diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for hablo
+
+## 1.0.0.0 -- 2019-04-19
+
+* First version. Finally released by an unexpecting developer
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2019, Tissevert
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Tissevert nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/hablo.cabal b/hablo.cabal
new file mode 100644
--- /dev/null
+++ b/hablo.cabal
@@ -0,0 +1,63 @@
+cabal-version: >= 1.10
+-- Initial package description 'hablo.cabal' generated by 'cabal init'.
+-- For further documentation, see http://haskell.org/cabal/users-guide/
+
+name: hablo
+version: 1.0.0.0
+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.
+homepage: https://git.marvid.fr/Tissevert/hablo
+-- bug-reports:
+license: BSD3
+license-file: LICENSE
+author: Tissevert
+maintainer: tissevert+devel@marvid.fr
+-- copyright:
+category: Web
+extra-source-files: CHANGELOG.md
+build-type: Simple
+data-dir: share
+data-files: js/*.js
+ defaultWording.conf
+
+executable hablo
+ main-is: Main.hs
+ other-modules: Arguments
+ , Article
+ , ArticlesList
+ , Blog
+ , Blog.Path
+ , Blog.Skin
+ , Blog.Wording
+ , Dom
+ , Files
+ , HTML
+ , JS
+ , JSON
+ , Paths_hablo
+ , Pretty
+ -- 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
+ , filepath >= 1.4.2 && < 1.5
+ , lucid >= 2.9.11 && < 2.10
+ , mtl >= 2.2.2 && < 2.3
+ , optparse-applicative >= 0.14.3 && < 0.15
+ , parsec >= 3.1.13 && < 3.2
+ , template >= 0.2.0 && < 0.3
+ , text >= 1.2.3 && < 1.3
+ , time >= 1.8.0 && < 1.9
+ , unix >= 2.7.2 && < 2.8
+ ghc-options: -Wall -dynamic
+ hs-source-dirs: src
+ default-language: Haskell2010
diff --git a/share/defaultWording.conf b/share/defaultWording.conf
new file mode 100644
--- /dev/null
+++ b/share/defaultWording.conf
@@ -0,0 +1,11 @@
+allLink = See all
+allPage = All articles
+allTaggedPage = All articles tagged ${tag}
+commentsLink = Comment on the fediverse
+commentsSection = Comments
+dateFormat = en-US
+latestLink = See only latest
+latestPage = Latest articles
+latestTaggedPage = Latest articles tagged ${tag}
+metadata = ${?by ${author} ?}on ${date}${? tagged ${tags}?}
+tagsList = Tags
diff --git a/share/js/domRenderer.js b/share/js/domRenderer.js
new file mode 100644
--- /dev/null
+++ b/share/js/domRenderer.js
@@ -0,0 +1,94 @@
+function DomRenderer(modules) {
+ return {
+ article: article,
+ articlesList: articlesList,
+ replaceMarkdown: replaceMarkdown
+ };
+
+ function replaceMarkdown() {
+ var div = document.getElementById('contents');
+ if(div.children[0] && div.children[0].tagName.toLowerCase() == 'article') {
+ convertArticle(div.children[0], true);
+ } else {
+ var articles = div.getElementsByClassName('articles')[0];
+ if(articles != undefined) {
+ for(var i = 0; i < articles.children.length; i++) {
+ convertArticle(articles.children[i]);
+ }
+ } else {
+ console.log('No articles found for this page');
+ }
+ }
+ }
+
+ function convertArticle(article, comments) {
+ var header = article.getElementsByTagName('header')[0];
+ header.appendChild(modules.metadata.get(article.id));
+ var text = article.getElementsByTagName('pre')[0];
+ if(text != undefined) {
+ article.replaceChild(getDiv(text.innerText), text);
+ if(comments) {
+ modules.metadata.getComments(article.id)
+ .forEach(article.appendChild.bind(article));
+ }
+ } else {
+ console.log('No content found for this article');
+ }
+ }
+
+ function getDiv(markdown) {
+ var d= modules.dom.make('div', {
+ innerHTML: modules.md.render(markdown)
+ });
+ var scripts = d.getElementsByTagName('script');
+ for(var i = 0; i < scripts.length; i++) {
+ var run = modules.dom.make('script',
+ {type: 'text/javascript', src: scripts[i].src, textContent: scripts[i].textContent}
+ );
+ scripts[i].parentNode.replaceChild(run, scripts[i]);
+ }
+ return d;
+ }
+
+ function article(key, markdown, limit) {
+ var url = ["", blog.path.articlesPath, key + (limit != undefined ? '.html' : '.md')].join('/');
+ var lines = markdown.split(/\n/).slice(blog.articles[key].bodyOffset);
+ var div = getDiv(lines.slice(0, limit).join('\n'));
+ return modules.dom.make('article', {}, [
+ modules.dom.make('header', {}, [
+ modules.dom.make('a', {href: url}, [
+ modules.dom.make('h1', {innerText: blog.articles[key].title})
+ ]),
+ modules.metadata.get(key)
+ ]),
+ div
+ ].concat(limit != undefined ? [] : modules.metadata.getComments(key)));
+ }
+
+ function pageTitle(tag, all) {
+ if(tag != undefined) {
+ var template = all ? 'allTaggedPage' : 'latestTaggedPage';
+ return modules.template.render(template, {tag: tag});
+ } else {
+ return blog.wording[all ? 'allPage' : 'latestPage'];
+ }
+ }
+
+ function otherUrl(tag, all) {
+ var path = [tag, all ? null : 'all.html'];
+ return '/' + path.filter(modules.fun.defined).join('/');
+ }
+
+ function articlesList(tag, all) {
+ return function(articlePreviews) {
+ return [
+ modules.dom.make('h2', {innerText: pageTitle(tag, all)}),
+ modules.dom.make('a', {
+ innerText: all ? blog.wording.latestLink : blog.wording.allLink,
+ href: otherUrl(tag, all)
+ }),
+ modules.dom.make('div', {class: 'articles'}, articlePreviews.filter(modules.fun.defined))
+ ];
+ };
+ }
+}
diff --git a/share/js/main.js b/share/js/main.js
new file mode 100644
--- /dev/null
+++ b/share/js/main.js
@@ -0,0 +1,14 @@
+window.addEventListener('load', function() {
+ var async = unitJS.Async();
+ var cache = unitJS.Cache();
+ var dom = unitJS.Dom();
+ var fun = unitJS.Fun();
+ var md = new Remarkable(remarkableConfig);
+ md.block.ruler.enable(['footnote']);
+ var template = Template();
+ var metadata = Metadata({async: async, cache: cache, dom: dom, fun:fun, template: template});
+ var domRenderer = DomRenderer({dom: dom, fun: fun, md: md, metadata: metadata, template: template});
+ var navigation = Navigation({async: async, cache: cache, dom: dom, domRenderer: domRenderer, fun: fun, md: md});
+ domRenderer.replaceMarkdown();
+ navigation.hijackLinks();
+});
diff --git a/share/js/metadata.js b/share/js/metadata.js
new file mode 100644
--- /dev/null
+++ b/share/js/metadata.js
@@ -0,0 +1,155 @@
+function Metadata(modules) {
+ var comments = modules.cache.make(function(threadId) {
+ return modules.async.bind(
+ modules.async.parallel(
+ getJSON(url(threadId)),
+ getJSON(url(threadId) + '/context'),
+ ),
+ modules.async.map(function(t) {
+ return [renderLink(t[0]), renderAnswers(t[1])];
+ })
+ );
+ });
+ return {
+ get: get,
+ getComments: getComments
+ };
+
+ function url(threadId) {
+ return blog.path.commentsAt + '/api/v1/statuses/' + threadId;
+ }
+
+ function getJSON(url) {
+ return modules.async.bind(
+ modules.async.http({method: 'GET', url: url}),
+ function(queryResult) {
+ if(queryResult.status == 200) {
+ try {
+ return modules.async.wrap(JSON.parse(queryResult.responseText));
+ } catch(e) {
+ return modules.async.fail('Server returned invalid JSON for ' + url);
+ }
+ } else {
+ return modules.async.fail('Could not load page ' + url);
+ }
+ }
+ );
+ }
+
+ function getComments(articleKey) {
+ var threadId = blog.articles[articleKey].metadata.comments;
+ if(blog.path.commentsAt != undefined && threadId != undefined) {
+ var ul = modules.dom.make('ul');
+ var div = emptySection(ul);
+ modules.async.run(
+ modules.async.bind(
+ comments.get(threadId), modules.async.map(populateComments(div, ul))
+ )
+ );
+ return [div];
+ } else {
+ return [];
+ }
+ }
+
+ function populateComments(div, ul) {
+ return function(apiResults) {
+ var post = apiResults[0], comments = apiResults[1];
+ div.appendChild(post);
+ comments.forEach(function(comment) {ul.appendChild(comment);});
+ };
+ }
+
+ function emptySection(ul) {
+ return modules.dom.make('div', {class: 'comments'}, [
+ modules.dom.make('h2', {innerText: blog.wording.commentsSection}),
+ ul
+ ]);
+ }
+
+ function renderLink(post) {
+ return modules.dom.make('a', {
+ href: post.url,
+ innerText: blog.wording.commentsLink
+ });
+ }
+
+ function getContent(descendant) {
+ return descendant.content.replace(/:([^: ]+):/g, function(pattern, shortcode) {
+ var emoji = descendant.emojis.find(function(e) {return e.shortcode == shortcode;});
+ if(emoji) {
+ return [
+ '
'
+ ].join('"');
+ } else {
+ return pattern;
+ }
+ });
+ }
+
+ function renderAnswers(comments) {
+ return comments.descendants.map(function(descendant) {
+ return modules.dom.make('li', {}, [
+ modules.dom.make('a', {href: descendant.account.url}, [
+ modules.dom.make('img', {
+ src: descendant.account.avatar,
+ alt: descendant.account.username + "'s profile picture"
+ })
+ ]),
+ modules.dom.make('div', {
+ class: "metadata",
+ innerHTML: modules.template.render('metadata', {
+ author: author(descendant.account.url, descendant.account.username),
+ date: date(descendant.created_at)
+ })
+ }),
+ modules.dom.make('div', {innerHTML: getContent(descendant)})
+ ]);
+ });
+ }
+
+ function author(key, name) {
+ var authorUrl = key;
+ if(blog.articles[key] != undefined) {
+ authorUrl = blog.articles[key].metadata.author;
+ }
+ if(authorUrl) {
+ var author = name || authorUrl.replace(/.*\//, '');
+ return '' + author + '';
+ }
+ }
+
+ function date(key) {
+ if(blog.articles[key] != undefined) {
+ var date = new Date(blog.articles[key].metadata.date * 1000);
+ } else {
+ var date = new Date(key);
+ }
+ var format = blog.wording.dateFormat;
+ if(format[0] != '[') {
+ if(format[0] != '"') {
+ format = '"' + format + '"';
+ }
+ format = '[' + format + ']';
+ }
+ return Date.prototype.toLocaleDateString.apply(date, JSON.parse(format));
+ }
+
+ function tags(key) {
+ var tags = blog.articles[key].tagged;
+ return tags.length < 1 ? null : tags.map(function(tag) {
+ return '' + tag + '';
+ }).join(', ');
+ }
+
+ function get(key) {
+ return modules.dom.make('div', {
+ class: "metadata",
+ innerHTML: modules.template.render('metadata', {
+ author: author(key),
+ date: date(key),
+ tags: tags(key)
+ })
+ });
+ }
+}
diff --git a/share/js/navigation.js b/share/js/navigation.js
new file mode 100644
--- /dev/null
+++ b/share/js/navigation.js
@@ -0,0 +1,117 @@
+function Navigation(modules) {
+ var articles = modules.cache.make(function(key) {
+ var url = ["", blog.path.articlesPath, key + '.md'].join('/');
+ return modules.async.bind(
+ modules.async.http({method: 'GET', url: url}),
+ function(queryResult) {
+ if(queryResult.status == 200) {
+ return modules.async.wrap(queryResult.responseText);
+ } else {
+ return modules.async.fail(
+ "Could not load article " + url + " (" + queryResult.status + " " + queryResult.statusText + ")"
+ );
+ }
+ }
+ );
+ });
+ window.addEventListener('popstate', function(e) {
+ if(e.state != undefined) {
+ navigate(e.state.url);
+ }
+ });
+ history.replaceState({url: window.location.pathname}, 'Blog - title', window.location.pathname);
+ return {
+ hijackLinks: hijackLinks
+ };
+
+ function hijackLinks(domElem) {
+ domElem = domElem || document;
+ var links = domElem.getElementsByTagName('a');
+ for(var i = 0; i < links.length; i++) {
+ var a = links[i];
+ var href = a.getAttribute("href");
+ if((href[0] == "/" && href.slice(-3) != ".md") || href[0] == "#") {
+ a.addEventListener('click', visit(a.getAttribute("href")));
+ }
+ }
+ }
+
+ function visit(url) {
+ return function(e) {
+ e.preventDefault();
+ if(url[0] == '#') {
+ window.location = url;
+ history.replaceState({url: window.location.pathname}, 'Blog - title', url);
+ } else {
+ navigate(url);
+ history.pushState({url: url}, 'Blog - title', url);
+ }
+ };
+ }
+
+ function navigate(url) {
+ var path = decodeURI(url).split("/").slice(1);
+ if(blog.tags[path[0]] != undefined) {
+ show(getArticlesList(path[0], path[1] == "all.html"));
+ } else if(path[0] == blog.path.articlesPath) {
+ show(getArticle(path[1].replace(/\.html$/, '')));
+ } else {
+ show(getArticlesList(null, path[0] == "all.html"));
+ }
+ }
+
+ function getArticle(key) {
+ return modules.async.bind(
+ articles.get(key),
+ modules.async.map(
+ function(contents) {return [modules.domRenderer.article(key, contents)];}
+ )
+ );
+ }
+
+ function preview(key) {
+ return modules.async.bind(
+ articles.get(key),
+ function(contents) {
+ return modules.async.wrap(
+ modules.domRenderer.article(
+ key,
+ contents,
+ blog.skin.previewLinesCount
+ )
+ );
+ }
+ );
+ }
+
+ function articleIds(tag, all) {
+ var ids = tag != undefined ? blog.tags[tag] : Object.keys(blog.articles);
+ var reverseDate = function (id) {return -blog.articles[id].metadata.date;};
+ ids.sort(modules.fun.compare(reverseDate));
+ return ids.slice(0, all ? undefined : blog.skin.previewArticlesCount);
+ }
+
+ function getArticlesList(tag, all) {
+ return modules.async.bind(
+ modules.async.parallel.apply(null, articleIds(tag, all).map(preview)),
+ modules.async.map(modules.domRenderer.articlesList(tag, all))
+ );
+ }
+
+ function show(contents) {
+ modules.async.run(
+ modules.async.bind(
+ contents,
+ modules.async.map(function (domElems) {
+ domElems = domElems.filter(modules.fun.defined);
+ var div = document.getElementById('contents');
+ modules.dom.clear(div);
+ for(var i = 0; i < domElems.length; i++) {
+ div.appendChild(domElems[i]);
+ }
+ hijackLinks(div);
+ })
+ )
+ );
+ }
+}
diff --git a/share/js/template.js b/share/js/template.js
new file mode 100644
--- /dev/null
+++ b/share/js/template.js
@@ -0,0 +1,35 @@
+function Template() {
+ return {
+ render: render
+ };
+
+ function render(template, environment) {
+ if(blog.wording[template] != undefined) {
+ var template = blog.wording[template];
+ }
+ template = template.replace(/\${\?((?:[^?]|\?[^}])*)\?}/g, renderSub(environment));
+ var failed = [false];
+ var result = template.replace(
+ /([^$]|^)\$(?:{(\w+)}|(\w+)\b)/g,
+ substitute(environment, failed)
+ );
+ return failed[0] ? null : result;
+ }
+
+ function renderSub(environment) {
+ return function(_, sub) {
+ return render(sub, environment) || '';
+ };
+ }
+
+ function substitute(environment, failed) {
+ return function(_, before, bracketed, raw) {
+ var replaced = environment[bracketed || raw];
+ if(replaced != undefined) {
+ return before + replaced;
+ } else {
+ failed[0] = true;
+ }
+ }
+ }
+}
diff --git a/src/Arguments.hs b/src/Arguments.hs
new file mode 100644
--- /dev/null
+++ b/src/Arguments.hs
@@ -0,0 +1,98 @@
+module Arguments (
+ Arguments(..)
+ , get
+ ) where
+
+import Data.Monoid ((<>))
+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 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
+ , bannerPath :: Maybe FilePath
+ , cardImage :: Maybe FilePath
+ , commentsAt :: Maybe String
+ , favicon :: Maybe FilePath
+ , headPath :: Maybe FilePath
+ , name :: Maybe String
+ , pagesPath :: Maybe FilePath
+ , previewArticlesCount :: Int
+ , previewLinesCount :: Int
+ , remarkableConfig :: Maybe FilePath
+ , wording :: Maybe FilePath
+ }
+ | Version
+
+option :: ReadM a -> Char -> String -> String -> String -> Parser (Maybe a)
+option readM aShort aLong aMetavar aHelpMessage =
+ Optparse.option (optional readM) (
+ metavar aMetavar
+ <> value Nothing
+ <> short aShort
+ <> long aLong
+ <> help aHelpMessage
+ )
+
+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 '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 '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"
+ <*> Optparse.option auto (
+ metavar "INTEGER"
+ <> value 3
+ <> short 'A'
+ <> long "preview-articles"
+ <> help "number of articles listed on the page of each category"
+ )
+ <*> Optparse.option auto (
+ metavar "INTEGER"
+ <> value 10
+ <> short 'L'
+ <> long "preview-lines"
+ <> help "number of lines to display in articles preview"
+ )
+ <*> option filePath 'r' "remarkable-config" "FILE"
+ "path to a file containing a custom RemarkableJS configuration"
+ <*> option filePath 'w' "wording" "FILE" "path to the file containing the wording to use"
+
+version :: Parser Arguments
+version = flag' Version (
+ long "version"
+ <> short 'v'
+ <> help "print the version number"
+ )
+
+arguments :: Parser Arguments
+arguments = blogConfig <|> version
+
+filePath :: ReadM FilePath
+filePath = eitherReader $ \path ->
+ if isValid path
+ then Right $ dropTrailingPathSeparator path
+ else Left "This string doesn't represent a valid path"
+
+get :: IO Arguments
+get = do
+ execParser $
+ info
+ (arguments <**> helper)
+ (fullDesc <> header ("Hablo v" ++ showVersion Hablo.version))
diff --git a/src/Article.hs b/src/Article.hs
new file mode 100644
--- /dev/null
+++ b/src/Article.hs
@@ -0,0 +1,103 @@
+{-# 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 Data.Time (defaultTimeLocale, getCurrentTimeZone, parseTimeM, timeZoneOffsetString)
+import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
+import Foreign.C.Types (CTime)
+import System.FilePath (dropExtension, takeFileName)
+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]
+ }
+
+articleP :: Parser (String, Metadata, Int, [String])
+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
+ )
+ 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
+
+eol :: Parser String
+eol = try (string "\r\n") <|> string "\r" <|> string "\n"
+
+no :: String -> Parser String
+no = many1 . noneOf
+
+setDate :: String -> CTime -> Metadata -> Metadata
+setDate tzOffset defaultDate = Map.alter timeStamp "date"
+ where
+ formats = ("%Y-%m-%d" ++) . (++ " %z") <$> ["", " %H:%M"]
+ epoch = show . (truncate :: POSIXTime -> Integer) . utcTimeToPOSIXSeconds
+ timeStamp Nothing = Just $ show defaultDate
+ timeStamp (Just date) =
+ let dates = [date, date ++ " " ++ tzOffset] in
+ let parsedTimes = parseTimeM True defaultTimeLocale <$> formats <*> dates in
+ foldr (<|>) (timeStamp Nothing) (fmap epoch <$> parsedTimes)
+
+at :: FilePath -> IO (Either ParseError (String, Article))
+at filePath = do
+ tzOffset <- timeZoneOffsetString <$> getCurrentTimeZone
+ fileDate <- modificationTime <$> getFileStatus filePath
+ let build = makeArticle (setDate tzOffset fileDate)
+ fmap build . parse articleP filePath <$> readFile filePath
+ where
+ makeArticle metaFilter (title, metadata, bodyOffset, body) = (
+ getKey filePath
+ , Article {
+ key = getKey filePath
+ , title
+ , metadata = metaFilter metadata
+ , bodyOffset
+ , body
+ }
+ )
+
+getKey :: FilePath -> String
+getKey = dropExtension . takeFileName
+
+preview :: Int -> Article -> Article
+preview linesCount article = article {body = take linesCount $ body article}
diff --git a/src/ArticlesList.hs b/src/ArticlesList.hs
new file mode 100644
--- /dev/null
+++ b/src/ArticlesList.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+module ArticlesList (
+ ArticlesList(..)
+ , otherUrl
+ , pageTitle
+ ) where
+
+import Article (Article)
+import Blog (Blog(..), Wording(..), get)
+import Control.Monad.Reader (MonadReader)
+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]
+ }
+
+otherUrl :: ArticlesList -> String
+otherUrl (ArticlesList {full, tagged}) = absoluteLink $
+ (if full then id else ( "all.html")) $ maybe "" id tagged
+
+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
+ where
+ tag :: String -> Text -> Text
+ tag t = \"tag" -> pack t
diff --git a/src/Blog.hs b/src/Blog.hs
new file mode 100644
--- /dev/null
+++ b/src/Blog.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Blog (
+ Blog(..)
+ , Path(..)
+ , Skin(..)
+ , Wording(..)
+ , build
+ , get
+ ) where
+
+import Arguments (Arguments)
+import qualified Arguments (name, sourceDir)
+import Article (Article)
+import qualified Article (at, getKey)
+import Blog.Path (Path(..))
+import qualified Blog.Path as Path (build)
+import Blog.Skin (Skin(..))
+import qualified Blog.Skin as Skin (build)
+import Blog.Wording (Wording(..))
+import qualified Blog.Wording as Wording (build)
+import Control.Monad ((>=>), filterM, forM)
+import Control.Monad.Reader (MonadReader, ask)
+import Data.Either (rights)
+import Data.Map (Map, lookup)
+import qualified Data.Map as Map (fromList)
+import Data.Set (Set)
+import qualified Data.Set as Set (empty, null, singleton, union)
+import Files (File(..), absolute)
+import qualified Files (find)
+import Prelude hiding (lookup)
+import System.Directory (doesFileExist, withCurrentDirectory)
+import System.FilePath ((), dropTrailingPathSeparator, takeExtension, takeFileName)
+
+type Collection = Map String Article
+
+data Blog = Blog {
+ articles :: Collection
+ , name :: String
+ , path :: Path
+ , skin :: Skin
+ , tags :: Map String (Set String)
+ , wording :: Wording
+ }
+
+get :: MonadReader Blog m => (Blog -> a) -> m a
+get = (<$> ask)
+
+findArticles :: FilePath -> IO (Map String Article)
+findArticles =
+ Files.find
+ >=> filterM isMarkDownFile
+ >=> mapM Article.at
+ >=> return . Map.fromList . rights
+ where
+ isMarkDownFile path = do
+ let correctExtension = takeExtension path == ".md"
+ (correctExtension &&) <$> doesFileExist path
+
+tagged :: Collection -> 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
+ 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 = do
+ articles <- findArticles $ articlesPath path
+ tags <- Map.fromList . filter (not . Set.null . snd)
+ <$> (Files.find (articlesPath path "tags") >>= mapM (articles `tagged`))
+ return (articles, tags)
+
+build :: Arguments -> IO Blog
+build arguments = do
+ wording <- Wording.build arguments
+ root <- Files.absolute . Dir $ Arguments.sourceDir arguments
+ withCurrentDirectory root $ do
+ path <- Path.build root arguments
+ let name = maybe (takeFileName $ dropTrailingPathSeparator root) id
+ $ Arguments.name arguments
+ skin <- Skin.build name arguments
+ (articles, tags) <- discover path
+ return $ Blog {articles, name, path, skin, tags, wording}
diff --git a/src/Blog/Path.hs b/src/Blog/Path.hs
new file mode 100644
--- /dev/null
+++ b/src/Blog/Path.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Blog.Path (
+ Path(..)
+ , build
+ ) where
+
+import Arguments (Arguments)
+import qualified Arguments as Arguments (Arguments(..))
+import Data.Aeson (ToJSON(..), (.=), pairs)
+import Data.Monoid ((<>))
+import Files (File(..), filePath)
+import GHC.Generics (Generic)
+
+data Path = Path {
+ articlesPath :: FilePath
+ , commentsAt :: Maybe String
+ , pagesPath :: Maybe FilePath
+ , remarkableConfig :: Maybe FilePath
+ , root :: FilePath
+ } deriving Generic
+
+instance ToJSON Path where
+ toEncoding (Path {articlesPath, commentsAt, 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
+ }
+ where
+ commentsAt = Arguments.commentsAt arguments
diff --git a/src/Blog/Skin.hs b/src/Blog/Skin.hs
new file mode 100644
--- /dev/null
+++ b/src/Blog/Skin.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Blog.Skin (
+ Skin(..)
+ , build
+ ) where
+
+import Arguments (Arguments)
+import qualified Arguments (bannerPath, favicon, cardImage, headPath, previewArticlesCount, previewLinesCount)
+import Control.Monad (filterM)
+import Data.Aeson (ToJSON(..), (.=), pairs)
+import Data.Maybe (listToMaybe)
+import Data.Monoid ((<>))
+import Files (absoluteLink)
+import GHC.Generics (Generic)
+import Prelude hiding (head)
+import System.Directory (doesFileExist)
+import System.FilePath ((), (<.>))
+
+data Skin = Skin {
+ banner :: Maybe String
+ , cardImage :: Maybe FilePath
+ , favicon :: Maybe FilePath
+ , head :: Maybe String
+ , previewArticlesCount :: Int
+ , previewLinesCount :: Int
+ } deriving Generic
+
+instance ToJSON Skin where
+ toEncoding (Skin {previewArticlesCount, previewLinesCount}) = pairs (
+ "previewArticlesCount" .= previewArticlesCount
+ <> "previewLinesCount" .= previewLinesCount
+ )
+
+findImage :: String -> Maybe FilePath -> IO (Maybe FilePath)
+findImage _ (Just path) = return . Just $ absoluteLink path
+findImage name Nothing =
+ fmap absoluteLink . listToMaybe <$> filterM doesFileExist pathsToCheck
+ where
+ directories = [".", "image", "images", "pictures", "skin", "static"]
+ extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"]
+ pathsToCheck = [ dir name <.> ext | dir <- directories, ext <- extensions ]
+
+build :: String -> Arguments -> IO Skin
+build blogName arguments = do
+ banner <- mapM readFile $ Arguments.bannerPath arguments
+ cardImage <- findImage blogName $ Arguments.cardImage arguments
+ favicon <- findImage "favicon" $ Arguments.favicon arguments
+ head <- mapM readFile $ Arguments.headPath arguments
+ return $ Skin {
+ banner
+ , cardImage
+ , favicon
+ , head
+ , previewArticlesCount = Arguments.previewArticlesCount arguments
+ , previewLinesCount = Arguments.previewLinesCount arguments
+ }
diff --git a/src/Blog/Wording.hs b/src/Blog/Wording.hs
new file mode 100644
--- /dev/null
+++ b/src/Blog/Wording.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Blog.Wording (
+ Wording(..)
+ , build
+ ) 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.Text (Text)
+import qualified Data.Text as Text (pack, unpack)
+import Data.Text.Template (Template, renderA, showTemplate, templateSafe)
+import Paths_hablo (getDataFileName)
+import Text.ParserCombinators.Parsec (
+ Parser
+ , (<|>)
+ , char, choice, endBy, eof, many, many1, noneOf, optional, parse, string, try
+ )
+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"
+ ]
+
+values :: [Wording -> Text]
+values = [
+ allLink, allPage, showTemplate . allTaggedPage, commentsLink, commentsSection
+ , dateFormat, latestLink, latestPage, showTemplate . latestTaggedPage
+ , metadata, 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
+
+addWording :: Map String Text -> FilePath -> IO (Map String Text)
+addWording currentWording wordingFile = do
+ parsed <- parse wordingP wordingFile <$> readFile wordingFile
+ case parsed of
+ Left errorMessage -> die $ show errorMessage
+ Right newWording -> return $ Map.union currentWording newWording
+
+wordingP :: Parser (Map String Text)
+wordingP = Map.map Text.pack . Map.fromList <$>
+ (many skip *> line `endBy` (many1 skip) <* eof)
+ where
+ 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
+ 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"
+ }
diff --git a/src/Dom.hs b/src/Dom.hs
new file mode 100644
--- /dev/null
+++ b/src/Dom.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Dom (
+ page
+ ) where
+
+import Article (Article(..))
+import qualified Article (preview)
+import ArticlesList (ArticlesList(..), otherUrl, pageTitle)
+import Blog (Blog(..), Path(..), Skin(..), Wording(..))
+import qualified Blog (get)
+import Control.Applicative ((<|>))
+import Control.Monad.Reader (ReaderT)
+import qualified Data.Map as Map (keys, lookup)
+import Data.Monoid ((<>))
+import Data.Text (Text, pack, empty)
+import Files (absoluteLink)
+import Lucid
+import Lucid.Base (makeAttribute)
+import Prelude hiding (head, lookup)
+import Pretty ((.$))
+import System.FilePath.Posix ((), (<.>))
+
+type HtmlGenerator = HtmlT (ReaderT Blog IO)
+
+class Page a where
+ card :: a -> HtmlGenerator ()
+ content :: a -> HtmlGenerator ()
+
+instance Page Article where
+ card (Article {title, Article.metadata}) = do
+ description <- getDescription (Map.lookup "summary" metadata)
+ makeCard title (pack description) (Map.lookup "featuredImage" metadata)
+ where
+ getDescription = maybe (Blog.get $name.$("A new article on " <>)) return
+
+ content = article True
+
+instance Page ArticlesList where
+ card al = do
+ cardTitle <- getTitle <$> Blog.get name
+ description <- pageTitle al
+ makeCard cardTitle description Nothing
+ where
+ getTitle name = maybe name ((name ++ " - ") ++) $ tagged al
+
+ content al@(ArticlesList {featured, full}) = do
+ preview <- Article.preview <$> (Blog.get $skin.$previewLinesCount)
+ h2_ . toHtml =<< pageTitle al
+ a_ [href_ . pack $ otherUrl al] . toHtml =<< otherLink
+ div_ [class_ "articles"] (
+ mapM_ (article False . preview) featured
+ )
+ where
+ otherLink = Blog.get $wording.$(if full then latestLink else allLink)
+
+article :: Bool -> Article -> HtmlGenerator ()
+article raw (Article {key, body, title}) = do
+ url <- absoluteLink . ( key <.> extension) <$> (Blog.get $path.$articlesPath)
+ article_ [id_ $ pack key] (do
+ header_ (do
+ a_ [href_ . pack $ url] . h1_ $ toHtml title
+ )
+ pre_ . toHtml $ unlines body
+ )
+ where extension = if raw then "md" else "html"
+
+makeCard :: String -> Text -> Maybe String -> HtmlGenerator ()
+makeCard title description image = do
+ og "title" $ pack title
+ og "description" description
+ maybeImage =<< ((image <|>) <$> (Blog.get $skin.$cardImage))
+ og "site_name" =<< (Blog.get $name.$pack)
+ where
+ og attribute value = meta_ [makeAttribute "property" $ "og:" <> attribute , content_ value]
+ maybeImage = maybe (return ()) (og "image" . pack)
+
+tag :: String -> HtmlGenerator ()
+tag tagName = li_ (
+ a_ [href_ . pack $ absoluteLink tagName, class_ "tag"] $ toHtml tagName
+ )
+
+defaultBanner :: HtmlGenerator ()
+defaultBanner = do
+ div_ [id_ "header"] (
+ a_ [href_ "/"] (
+ h1_ . toHtml =<< Blog.get name
+ )
+ )
+
+faviconLink :: FilePath -> HtmlGenerator ()
+faviconLink url = link_ [rel_ "shortcut icon", href_ $ pack url, type_ "image/x-icon"]
+
+page :: Page a => a -> HtmlGenerator ()
+page aPage =
+ doctypehtml_ (do
+ head_ (do
+ meta_ [charset_ "utf-8"]
+ title_ . toHtml =<< Blog.get name
+ script_ [src_ "/js/unit.js"] empty
+ script_ [src_ "/js/remarkable.min.js"] empty
+ script_ [src_ "/js/hablo.js"] empty
+ maybe (toHtml empty) faviconLink =<< (Blog.get $skin.$favicon)
+ card aPage
+ (Blog.get $skin.$head) >>= maybe (toHtml empty) toHtmlRaw
+ )
+ body_ (do
+ maybe defaultBanner toHtmlRaw =<< (Blog.get $skin.$banner)
+ div_ [id_ "navigator"] (do
+ h2_ =<< (Blog.get $wording.$tagsList.$toHtml)
+ ul_ . mapM_ tag . Map.keys =<< Blog.get tags
+ )
+ div_ [id_ "contents"] $ content aPage
+ )
+ )
diff --git a/src/Files.hs b/src/Files.hs
new file mode 100644
--- /dev/null
+++ b/src/Files.hs
@@ -0,0 +1,35 @@
+module Files (
+ File(..)
+ , absolute
+ , absoluteLink
+ , filePath
+ , find
+ ) where
+
+import System.Exit (die)
+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory, makeAbsolute)
+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
+
+find :: FilePath -> IO [FilePath]
+find path =
+ fmap (path ) <$> listDirectory path
diff --git a/src/HTML.hs b/src/HTML.hs
new file mode 100644
--- /dev/null
+++ b/src/HTML.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+module HTML (
+ generate
+ ) where
+
+import Article(Article(..))
+import ArticlesList (ArticlesList(..))
+import Blog (Blog(..), Path(..), Skin(..))
+import qualified Blog (get)
+import Control.Monad (forM)
+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 qualified Data.Text.Lazy.IO as TextIO (writeFile)
+import Dom (page)
+import Lucid
+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
+ }
+ 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
+ })
+ ]
+
+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")
+
+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
+ )
+
+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)
diff --git a/src/JS.hs b/src/JS.hs
new file mode 100644
--- /dev/null
+++ b/src/JS.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+module JS (
+ generate
+ ) where
+
+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 Data.ByteString.Lazy.Char8 (pack)
+import qualified Files (find)
+import JSON (exportBlog)
+import Paths_hablo (getDataDir)
+import Pretty ((.$))
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath (())
+import Prelude hiding (concat, readFile, writeFile)
+
+compile :: [ByteString] -> ByteString
+compile sources = concat (header:sources ++ [footer])
+ where
+ header = "(function() {\n"
+ footer = "})();"
+
+var :: (String, ByteString) -> ByteString
+var (varName, content) = concat ["var ", pack varName, " = ", content, ";\n"]
+
+generate :: ReaderT Blog IO ()
+generate = do
+ destinationDir <- ( "js") <$> (Blog.get $path.$root)
+ blogJSON <- exportBlog
+ remarkablePath <- Blog.get $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 )
diff --git a/src/JSON.hs b/src/JSON.hs
new file mode 100644
--- /dev/null
+++ b/src/JSON.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+module JSON (
+ exportBlog
+ ) where
+
+import Article (Article)
+import qualified Article (Article(..))
+import Blog (Blog, Path, Skin, 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.Map (Map, mapWithKey)
+import qualified Data.Map as Map (filter, keys)
+import qualified Data.Set as Set (elems, member)
+import GHC.Generics
+
+data ArticleExport = ArticleExport {
+ title :: String
+ , bodyOffset :: Int
+ , metadata :: Map String String
+ , tagged :: [String]
+ } deriving (Generic)
+
+instance ToJSON ArticleExport where
+ toEncoding = genericToEncoding defaultOptions
+
+data BlogDB = BlogDB {
+ articles :: Map String ArticleExport
+ , path :: Path
+ , skin :: Skin
+ , tags :: Map String [String]
+ , wording :: Wording
+ } deriving (Generic)
+
+instance ToJSON BlogDB 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 :: 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
+ }
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,21 @@
+module Main where
+
+import Arguments (Arguments(..))
+import qualified Arguments (get)
+import qualified Blog (build)
+import Control.Monad.Reader (runReaderT)
+import Data.Version (showVersion)
+import qualified HTML (generate)
+import qualified JS (generate)
+import qualified Paths_hablo as Hablo (version)
+import System.Exit (exitSuccess)
+
+main :: IO ()
+main = do
+ arguments <- Arguments.get
+ case arguments of
+ Version -> (putStrLn $ showVersion Hablo.version) >> exitSuccess
+ config@(BlogConfig {}) -> Blog.build config >>= runReaderT (do
+ HTML.generate
+ JS.generate
+ )
diff --git a/src/Pretty.hs b/src/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/src/Pretty.hs
@@ -0,0 +1,6 @@
+module Pretty (
+ (.$)
+ ) where
+
+(.$) :: (a -> b) -> (b -> c) -> (a -> c)
+(.$) f g = g . f