hablo 1.0.1.0 → 1.1.0.1
raw patch · 53 files changed
+2059/−907 lines, 53 filesdep +Cabaldep +SJWdep +hablodep ~aesondep ~basedep ~bytestring
Dependencies added: Cabal, SJW, hablo
Dependency ranges changed: aeson, base, bytestring, containers, directory, filepath, lucid, mtl, optparse-applicative, text, time
Files
- CHANGELOG.md +22/−0
- hablo.cabal +66/−17
- share/defaultWording.conf +8/−5
- share/js/DomRenderer.js +143/−0
- share/js/Main.js +5/−0
- share/js/Metadata.js +159/−0
- share/js/Navigation.js +121/−0
- share/js/Remarkable.js +8/−0
- share/js/Template.js +35/−0
- share/js/domRenderer.js +0/−94
- share/js/main.js +0/−14
- share/js/metadata.js +0/−155
- share/js/navigation.js +0/−117
- share/js/template.js +0/−35
- src/Arguments.hs +20/−13
- src/Article.hs +14/−77
- src/ArticlesList.hs +30/−19
- src/Blog.hs +59/−28
- src/Blog/Path.hs +26/−14
- src/Blog/Skin.hs +4/−1
- src/Blog/Template.hs +69/−0
- src/Blog/URL.hs +45/−0
- src/Blog/Wording.hs +27/−70
- src/Collection.hs +54/−0
- src/DOM.hs +124/−0
- src/DOM/Card.hs +91/−0
- src/Dom.hs +0/−115
- src/Files.hs +14/−17
- src/HTML.hs +27/−65
- src/JS.hs +37/−19
- src/JSON.hs +37/−31
- src/Main.hs +2/−0
- src/Markdown.hs +76/−0
- src/Page.hs +17/−0
- src/Pretty.hs +11/−1
- src/RSS.hs +93/−0
- test/Mock/Arguments.hs +86/−0
- test/Mock/Article.hs +23/−0
- test/Mock/ArticlesList.hs +22/−0
- test/Mock/Blog.hs +39/−0
- test/Mock/Blog/Path.hs +66/−0
- test/Mock/Blog/Skin.hs +16/−0
- test/Mock/Blog/Template.hs +9/−0
- test/Mock/Blog/URL.hs +16/−0
- test/Mock/Blog/Wording.hs +25/−0
- test/Mock/Collection.hs +28/−0
- test/Mock/Markdown.hs +33/−0
- test/Structure.hs +40/−0
- test/Tests.hs +14/−0
- test/Utils.hs +49/−0
- test/XML/Card.hs +11/−0
- test/XML/Card/Component.hs +89/−0
- test/XML/Card/Output.hs +49/−0
CHANGELOG.md view
@@ -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
hablo.cabal view
@@ -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
@@ -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
@@ -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]);});+}
@@ -0,0 +1,5 @@+import replaceMarkdown from DomRenderer;+import hijackLinks from Navigation;++replaceMarkdown();+hijackLinks();
@@ -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 [+ '<img title=', shortcode, ' alt=', shortcode, ' src=', emoji.url, ' class="emoji"/>'+ ].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 '<a href="' + authorUrl + '">' + author + '</a>';+ }+}++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 '<a class="tag" href="/' + tag + '">' + tag + '</a>';+ }).join(', ');+}++function get(key) {+ return Dom.make('div', {+ class: "metadata",+ innerHTML: Template.render('metadata', {+ author: author(key),+ date: date(key),+ tags: tags(key)+ })+ });+}
@@ -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);+ })+ )+ );+}
@@ -0,0 +1,8 @@+import remarkableConfig from Hablo.Config;++var md = new Remarkable(remarkableConfig);+md.block.ruler.enable(['footnote']);++return {+ md: md+};
@@ -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;+ }+ }+}
@@ -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))- ];- };- }-}
@@ -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();-});
@@ -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 [- '<img title=', shortcode, ' alt=', shortcode, ' src=', emoji.url, ' class="emoji"/>'- ].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 '<a href="' + authorUrl + '">' + author + '</a>';- }- }-- 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 '<a class="tag" href="/' + tag + '">' + tag + '</a>';- }).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)- })- });- }-}
@@ -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);- })- )- );- }-}
@@ -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;- }- }- }-}
src/Arguments.hs view
@@ -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
src/Article.hs view
@@ -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}
src/ArticlesList.hs view
@@ -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
src/Blog.hs view
@@ -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+ }
src/Blog/Path.hs view
@@ -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
src/Blog/Skin.hs view
@@ -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"]
+ src/Blog/Template.hs view
@@ -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
+ src/Blog/URL.hs view
@@ -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 ()
src/Blog/Wording.hs view
@@ -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
+ src/Collection.hs view
@@ -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
+ src/DOM.hs view
@@ -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+ )+ )
+ src/DOM/Card.hs view
@@ -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"
− src/Dom.hs
@@ -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- )- )
src/Files.hs view
@@ -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 [])
src/HTML.hs view
@@ -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
src/JS.hs view
@@ -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
src/JSON.hs view
@@ -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)
src/Main.hs view
@@ -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 )
+ src/Markdown.hs view
@@ -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
+ src/Page.hs view
@@ -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)
src/Pretty.hs view
@@ -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
+ src/RSS.hs view
@@ -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 ("<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" :: String)++version_ :: Text -> Attribute+version_ = makeAttribute "version"++xmlns_content_ :: Text -> Attribute+xmlns_content_ = makeAttribute "xmlns:content"++xmlns_atom_ :: Text -> Attribute+xmlns_atom_ = makeAttribute "xmlns:atom"++rss_ :: Term arg result => arg -> result+rss_ = term "rss"++channel_ :: Term arg result => arg -> result+channel_ = term "channel"++title_ :: Term arg result => arg -> result+title_ = term "title"++link_ :: Term arg result => arg -> result+link_ = term "link"++description_ :: Term arg result => arg -> result+description_ = term "description"++item_ :: Term arg result => arg -> result+item_ = term "item"++pubDate_ :: Term arg result => arg -> result+pubDate_ = term "pubDate"++articleItem :: 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)
+ test/Mock/Arguments.hs view
@@ -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"+ }
+ test/Mock/Article.hs view
@@ -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 []}
+ test/Mock/ArticlesList.hs view
@@ -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
+ test/Mock/Blog.hs view
@@ -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
+ test/Mock/Blog/Path.hs view
@@ -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"+ }
+ test/Mock/Blog/Skin.hs view
@@ -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+ }
+ test/Mock/Blog/Template.hs view
@@ -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
+ test/Mock/Blog/URL.hs view
@@ -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}
+ test/Mock/Blog/Wording.hs view
@@ -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")+ ]
+ test/Mock/Collection.hs view
@@ -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"+ }
+ test/Mock/Markdown.hs view
@@ -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 = []+ }
+ test/Structure.hs view
@@ -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)+ ]
+ test/Tests.hs view
@@ -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+ ]
+ test/Utils.hs view
@@ -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" </>)
+ test/XML/Card.hs view
@@ -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]
+ test/XML/Card/Component.hs view
@@ -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]
+ test/XML/Card/Output.hs view
@@ -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]