hablo (empty) → 1.0.0.0
raw patch · 24 files changed
+1420/−0 lines, 24 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, containers, directory, filepath, lucid, mtl, optparse-applicative, parsec, template, text, time, unix
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- hablo.cabal +63/−0
- share/defaultWording.conf +11/−0
- share/js/domRenderer.js +94/−0
- share/js/main.js +14/−0
- share/js/metadata.js +155/−0
- share/js/navigation.js +117/−0
- share/js/template.js +35/−0
- src/Arguments.hs +98/−0
- src/Article.hs +103/−0
- src/ArticlesList.hs +37/−0
- src/Blog.hs +88/−0
- src/Blog/Path.hs +40/−0
- src/Blog/Skin.hs +58/−0
- src/Blog/Wording.hs +112/−0
- src/Dom.hs +115/−0
- src/Files.hs +35/−0
- src/HTML.hs +84/−0
- src/JS.hs +40/−0
- src/JSON.hs +57/−0
- src/Main.hs +21/−0
- src/Pretty.hs +6/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for hablo++## 1.0.0.0 -- 2019-04-19++* First version. Finally released by an unexpecting developer
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hablo.cabal view
@@ -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
@@ -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
@@ -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))+ ];+ };+ }+}
@@ -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();+});
@@ -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 [+ '<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)+ })+ });+ }+}
@@ -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);+ })+ )+ );+ }+}
@@ -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;+ }+ }+ }+}
+ src/Arguments.hs view
@@ -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))
+ src/Article.hs view
@@ -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}
+ src/ArticlesList.hs view
@@ -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
+ src/Blog.hs view
@@ -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}
+ src/Blog/Path.hs view
@@ -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
+ src/Blog/Skin.hs view
@@ -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+ }
+ src/Blog/Wording.hs view
@@ -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"+ }
+ src/Dom.hs view
@@ -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+ )+ )
+ src/Files.hs view
@@ -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
+ src/HTML.hs view
@@ -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)
+ src/JS.hs view
@@ -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 )
+ src/JSON.hs view
@@ -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+ }
+ src/Main.hs view
@@ -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+ )
+ src/Pretty.hs view
@@ -0,0 +1,6 @@+module Pretty (+ (.$)+ ) where++(.$) :: (a -> b) -> (b -> c) -> (a -> c)+(.$) f g = g . f