From 3e223e71692edfd33033aace9b23b35a84e3dd52 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sun, 13 Dec 2020 20:09:23 +0100 Subject: [PATCH] Release 1.1.0.0 with RSS feeds and static pages --- CHANGELOG.md | 6 ++ README.md | 22 +++++ doc/Command-line.md | 20 +++- doc/Deploying-a-hablo-blog.md | 23 +---- doc/Generating-your-blog.md | 2 +- hablo.cabal | 69 ++++++++++--- share/defaultWording.conf | 3 + share/js/DomRenderer.js | 47 ++++++--- share/js/Navigation.js | 46 +++++---- src/Arguments.hs | 18 ++-- src/Article.hs | 91 +++-------------- src/Blog.hs | 56 ++++++----- src/Blog/Path.hs | 34 +++++-- src/Blog/Skin.hs | 5 +- src/Blog/Wording.hs | 3 + src/Collection.hs | 5 +- src/DOM.hs | 81 +++++++++------ src/DOM/Card.hs | 98 +++++++++++-------- src/Files.hs | 31 +++--- src/HTML.hs | 20 ++-- src/JS.hs | 4 +- src/JSON.hs | 66 +++++++------ src/Markdown.hs | 76 ++++++++++++++ src/Page.hs | 17 ++++ src/Pretty.hs | 12 ++- src/RSS.hs | 8 +- test/Mock/Arguments.hs | 86 ++++++++++++++++ test/Mock/Article.hs | 23 +++++ test/Mock/ArticlesList.hs | 22 +++++ test/Mock/Blog.hs | 39 ++++++++ test/Mock/Blog/Path.hs | 66 +++++++++++++ test/Mock/Blog/Skin.hs | 16 +++ test/Mock/Blog/Template.hs | 9 ++ test/Mock/Blog/URL.hs | 16 +++ test/Mock/Blog/Wording.hs | 25 +++++ test/Mock/Collection.hs | 28 ++++++ test/Mock/Markdown.hs | 33 +++++++ test/Structure.hs | 40 ++++++++ test/Structure/.placeHolder | 0 test/Structure/both/.placeHolder | 0 test/Structure/both/articles/.placeHolder | 0 .../both/customArticles/.placeHolder | 0 test/Structure/both/customPages/.placeHolder | 0 test/Structure/both/pages/.placeHolder | 0 test/Structure/custom/.placeHolder | 0 .../custom/customArticles/.placeHolder | 0 .../Structure/custom/customPages/.placeHolder | 0 test/Structure/defaultArticles/.placeHolder | 0 .../defaultArticles/articles/.placeHolder | 0 test/Structure/defaultPages/.placeHolder | 0 .../Structure/defaultPages/pages/.placeHolder | 0 test/Tests.hs | 14 +++ test/Utils.hs | 49 ++++++++++ test/XML/Card.hs | 11 +++ test/XML/Card/Component.hs | 89 +++++++++++++++++ test/XML/Card/Output.hs | 49 ++++++++++ test/XML/Card/Output/longMain.html | 1 + test/XML/Card/Output/longTesting.html | 1 + test/XML/Card/Output/noDescription.html | 1 + test/XML/Card/Output/noImage.html | 1 + test/XML/Card/Output/shortMain.html | 1 + test/XML/Card/Output/shortTesting.html | 1 + test/XML/Card/Output/simple.html | 1 + 63 files changed, 1155 insertions(+), 330 deletions(-) create mode 100644 src/Markdown.hs create mode 100644 src/Page.hs create mode 100644 test/Mock/Arguments.hs create mode 100644 test/Mock/Article.hs create mode 100644 test/Mock/ArticlesList.hs create mode 100644 test/Mock/Blog.hs create mode 100644 test/Mock/Blog/Path.hs create mode 100644 test/Mock/Blog/Skin.hs create mode 100644 test/Mock/Blog/Template.hs create mode 100644 test/Mock/Blog/URL.hs create mode 100644 test/Mock/Blog/Wording.hs create mode 100644 test/Mock/Collection.hs create mode 100644 test/Mock/Markdown.hs create mode 100644 test/Structure.hs create mode 100644 test/Structure/.placeHolder create mode 100644 test/Structure/both/.placeHolder create mode 100644 test/Structure/both/articles/.placeHolder create mode 100644 test/Structure/both/customArticles/.placeHolder create mode 100644 test/Structure/both/customPages/.placeHolder create mode 100644 test/Structure/both/pages/.placeHolder create mode 100644 test/Structure/custom/.placeHolder create mode 100644 test/Structure/custom/customArticles/.placeHolder create mode 100644 test/Structure/custom/customPages/.placeHolder create mode 100644 test/Structure/defaultArticles/.placeHolder create mode 100644 test/Structure/defaultArticles/articles/.placeHolder create mode 100644 test/Structure/defaultPages/.placeHolder create mode 100644 test/Structure/defaultPages/pages/.placeHolder create mode 100644 test/Tests.hs create mode 100644 test/Utils.hs create mode 100644 test/XML/Card.hs create mode 100644 test/XML/Card/Component.hs create mode 100644 test/XML/Card/Output.hs create mode 100644 test/XML/Card/Output/longMain.html create mode 100644 test/XML/Card/Output/longTesting.html create mode 100644 test/XML/Card/Output/noDescription.html create mode 100644 test/XML/Card/Output/noImage.html create mode 100644 test/XML/Card/Output/shortMain.html create mode 100644 test/XML/Card/Output/shortTesting.html create mode 100644 test/XML/Card/Output/simple.html diff --git a/CHANGELOG.md b/CHANGELOG.md index 52b472b..81375fb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for hablo +## 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) diff --git a/README.md b/README.md index 396eabd..82dd94b 100644 --- a/README.md +++ b/README.md @@ -20,6 +20,16 @@ cabal new-install hablo Alternatively, if you prefer to do things yourself you can do a +#### Simple install with nix + +Want to give hablo a quick try using nix ? + +```bash +nix-env -f 'https://git.marvid.fr/Tissevert/mynixpkgs/archive/main.tar.gz' -i hablo +``` + +Visit my [Nix packages](https://git.marvid.fr/Tissevert/mynixpkgs) for a more declarative setup. + #### Manual install from this repository Get a copy of this repository @@ -40,6 +50,18 @@ Install the result cabal new-install hablo ``` +### Dependencies + +Hablo requires [UnitJS](https://git.marvid.fr/Tissevert/UnitJS) which is handled by [SJW](https://git.marvid.fr/Tissevert/SJW). Make sure you have installed it regularly with `SJW`. If it isn't yet, the following commands should help you: + +```bash +cd /tmp +git clone https://git.marvid.fr/Tissevert/UnitJS.git +cd UnitJS +mkdir -p ~/.sjw +cp -r src/ ~/.sjw/unitJS +``` + ### Using hablo (tutorials) Wanna give it a try ? Start by [generating your blog](https://git.marvid.fr/Tissevert/hablo/wiki/Generating%20your%20blog) diff --git a/doc/Command-line.md b/doc/Command-line.md index 15d53c7..2c87923 100644 --- a/doc/Command-line.md +++ b/doc/Command-line.md @@ -32,6 +32,8 @@ hablo --articles turtles /path/to/your/blog See ? It was still `turtles` and not ~~`/path/to/your/blog/turtles`~~. +Also note that articles are partly optional : you can use hablo to generate a website with a fix content and no articles. In that case, just make sure no directory named `articles/` exists at the root of your website (see [pages](#pages-path)) and keep in mind that it should have static pages (hablo, just like other famous entities should not be invoked in vain and will exit in error suspecting something went wrong when invoked on an empty website with no articles and no pages, which to it means nothing to do). + ## Banner `-b, --banner` @@ -116,11 +118,25 @@ hablo --name "Turtles/Paradize" Enables Open Graph cards in pages to display a pretty preview of them instead of the raw URL in links posted to social media. Note that this feature requires setting your site URL with [`--site-url`](#site-url). -## Pages +## Pages path `-p, --pages` -This option doesn't work yet but hablo will support static pages in addition to articles in a future release. Like [articles](#article-path), they will be expected to be located in a sub-directory called `pages/` but this option will allow you to use an arbitrary path within your blog's structure. +In addition to «dynamic» lists of articles that grow over time, hablo supports «static» pages to allow you to publish relatively constant information related to your blog. Pages are expected to be located in a sub-directory called `pages/` but this option will allow you to use an arbitrary path within your blog's structure. + +So if for instance your blog is for a community of authors and a presentation of each of them is all you want to publish as «static» content, you could have this directory called «authors» and run `hablo` like this : + +```bash +hablo --pages authors +``` + +This option is very similar to the one for [articles](#articles-path). Like the articles path, the pages path is of course relative to the blog's root. Pages are also partly optional : you don't have to have static pages in your blog in which case you should just make sure no directory named `pages/` exists at the root of your website and you have articles (because like we said above hablo is highly suspicious of being invoked to perform no work and will suspect this is a mistake and report it as an error). + +Final tip : if you're using hablo to edit a static website with no articles, then you probably don't want to put your pages in a sub-directory but have them at the root of your website instead. This is possible, just remember that the current directory is called `.` in UNIX and run : + +```bash +hablo -p . +``` ## Number of articles previewed diff --git a/doc/Deploying-a-hablo-blog.md b/doc/Deploying-a-hablo-blog.md index c21f89a..3048d75 100644 --- a/doc/Deploying-a-hablo-blog.md +++ b/doc/Deploying-a-hablo-blog.md @@ -1,6 +1,6 @@ # Deployment -Since hablo generates static blogs, deployment is a fairly easy step. The only detail to pay attention to is the handling of dependencies. +Since hablo generates static blogs, deployment is a fairly easy step. The only detail to pay attention to is the handling of JS dependencies. We show here a simple local deployment of your blog assuming you use NGinx but this is fairly easy to transpose to your favourite web server. First let's create an NGinx configuration file for your blog. Let's put the following basic configuration @@ -29,30 +29,11 @@ sudo nginx -s reload Now let's install the dependencies. -## UnitJS - -Hablo requires [UnitJS](https://git.marvid.fr/Tissevert/UnitJS). Go to some temporary work directory, clone it and generate the packed JS module. - -```bash -cd /tmp -git clone https://git.marvid.fr/Tissevert/UnitJS.git -cd UnitJS -make -``` - -It's in `dist/unit.js`. Let's go back to your blog's directory and copy it. - -```bash -cd "/path/to/My perfect life is better than yours" -mkdir -p js -cp /tmp/UnitJS/dist/unit.js js -``` - ## Remarkable The markdown is converted to HTML in the client browser with the JS library [remarkable](https://github.com/jonschlinkert/remarkable). -We can simply download it in your `js` directory. +We can simply download it in the `js` subdirectory of your blog hablo created when you first invoked it. ```bash wget 'https://cdnjs.cloudflare.com/ajax/libs/remarkable/1.7.1/remarkable.min.js' -O js/remarkable.min.js diff --git a/doc/Generating-your-blog.md b/doc/Generating-your-blog.md index 6b3c179..db9b6d3 100644 --- a/doc/Generating-your-blog.md +++ b/doc/Generating-your-blog.md @@ -25,7 +25,7 @@ EOF Ok, ok, not everyone uses heredocs to write their articles. Personally I don't. You're writing a blog so you probably already have a favourite text editor; use it. The only thing I care about is, at this point, that you've created the file `Olive\ ridley\ sea\ turtle.md` in the `articles` directory with some markdown content in it. -Ready ? Good news, we're almost done. The only thing left is to tag your first article. With hablo articles don't have to be put in a single category but they can be tagged this and that to indicate that they are somehow linked to one topic or another (they don't have to, you can perfectly leave an article untagged but the tags directory itself must exist). Tags live in a subdirectory of `articles`. +Ready ? Good news, we're almost done. The only thing left is to tag your first article. With hablo articles don't have to be put in a single category but they can be tagged this and that to indicate that they are somehow linked to one topic or another (they don't have to, you can perfectly leave an article untagged). Tags live in a subdirectory of `articles`. ```bash mkdir -p articles/tags/Sea\ turtles diff --git a/hablo.cabal b/hablo.cabal index 34d3132..438aab6 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -3,16 +3,16 @@ cabal-version: >= 1.10 -- For further documentation, see http://haskell.org/cabal/users-guide/ name: hablo -version: 1.0.3.0 +version: 1.1.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. + 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,9 +27,8 @@ data-dir: share data-files: js/*.js defaultWording.conf -executable hablo - main-is: Main.hs - other-modules: Arguments +library + exposed-modules: Arguments , Article , ArticlesList , Blog @@ -45,25 +44,69 @@ executable hablo , HTML , JS , JSON + , Markdown + , Page , Paths_hablo , Pretty , RSS -- other-extensions: - build-depends: aeson >= 1.4.0 && < 1.5 - , base >= 4.9.1 && < 4.14 - , bytestring >= 0.10.8 && < 0.11 + build-depends: aeson >= 1.4.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 , mtl >= 2.2.2 && < 2.3 - , optparse-applicative >= 0.14.3 && < 0.16 + , optparse-applicative >= 0.14.3 && < 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.10 + , time >= 1.8.0 && < 1.12 , SJW >= 0.1.2 && < 0.2 , unix >= 2.7.2 && < 2.8 - ghc-options: -Wall -dynamic + ghc-options: -Wall hs-source-dirs: src default-language: Haskell2010 + +executable hablo + main-is: src/Main.hs + other-modules: Paths_hablo + -- other-extensions: + build-depends: base >= 4.9.1 && < 4.15 + , hablo + , mtl >= 2.2.2 && < 2.3 + ghc-options: -Wall + default-language: Haskell2010 + +test-suite tests + type: detailed-0.9 + test-module: Tests + other-modules: Mock.Arguments + , Mock.Article + , Mock.ArticlesList + , Mock.Blog + , Mock.Blog.Path + , Mock.Blog.Skin + , Mock.Blog.Template + , Mock.Blog.URL + , Mock.Blog.Wording + , Mock.Collection + , Mock.Markdown + , Structure + , Utils + , XML.Card + , XML.Card.Component + , XML.Card.Output + build-depends: base + , Cabal + , containers + , directory + , filepath + , hablo + , lucid + , mtl + , text + hs-source-dirs: test + ghc-options: -Wall + default-language: Haskell2010 diff --git a/share/defaultWording.conf b/share/defaultWording.conf index 21b431b..99dd6f4 100644 --- a/share/defaultWording.conf +++ b/share/defaultWording.conf @@ -1,11 +1,14 @@ allLink = See all allPage = All articles{? tagged ${tag}?} +articleDescription = A new article on ${name} commentsLink = Comment on the fediverse commentsSection = Comments dateFormat = en-US latestLink = See only latest latestPage = Latest articles{? tagged ${tag}?} metadata = {?by ${author} ?}on ${date}{? tagged ${tags}?} +pageDescription = Read on ${name} +pagesList = Pages rssLink = Subscribe rssTitle = Follow all articles{? tagged ${tag}?} tagsList = Tags diff --git a/share/js/DomRenderer.js b/share/js/DomRenderer.js index e9f9727..8b07ea6 100644 --- a/share/js/DomRenderer.js +++ b/share/js/DomRenderer.js @@ -6,20 +6,21 @@ import * as Dom from UnitJS.Dom; import {defined} from UnitJS.Fun; return { - article: article, articlesList: articlesList, + render: render, replaceMarkdown: replaceMarkdown }; function replaceMarkdown() { var div = document.getElementById('contents'); if(div.children[0] && div.children[0].tagName.toLowerCase() == 'article') { - convertArticle(div.children[0], true); + var contentType = window.location.pathname.slice(1).replace(/\/.*/, ''); + convertContent(contentType, 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]); + convertContent('article', articles.children[i]); } } else { console.log('No articles found for this page'); @@ -27,13 +28,15 @@ function replaceMarkdown() { } } -function convertArticle(article, comments) { +function convertContent(contentType, article, comments) { var header = article.getElementsByTagName('header')[0]; - header.appendChild(Metadata.get(article.id)); + if(contentType == 'article') { + header.appendChild(Metadata.get(article.id)); + } var text = article.getElementsByTagName('pre')[0]; if(text != undefined) { article.replaceChild(getDiv(text.innerText), text); - if(comments) { + if(contentType == 'article' && comments) { Metadata.getComments(article.id) .forEach(article.appendChild.bind(article)); } @@ -56,19 +59,33 @@ function getDiv(markdown) { 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); +function contentUrl(contentType, key, limit) { + var directory = blog.path[contentType + 'sPath']; + var extension = limit != undefined ? '.html' : '.md'; + return ["", directory, key + extension].join('/'); +} + +function commentsSection(contentType, key, limit) { + if(contentType != 'article' || limit != undefined) { + return []; + } else { + return Metadata.getComments(key); + } +} + +function render(contentType, key, markdown, limit) { + var url = contentUrl(contentType, key, limit); + var resource = blog[contentType + 's'][key]; + var lines = markdown.split(/\n/).slice(resource.bodyOffset); var div = getDiv(lines.slice(0, limit).join('\n')); return Dom.make('article', {}, [ Dom.make('header', {}, [ - Dom.make('a', {href: url}, [ - Dom.make('h1', {innerText: blog.articles[key].title}) - ]), - Metadata.get(key) - ]), + Dom.make('h1', {}, [ + Dom.make('a', {href: url, innerText: resource.title}) + ])].concat(contentType == 'article' ? Metadata.get(key) : []) + ), div - ].concat(limit != undefined ? [] : Metadata.getComments(key))); + ].concat(commentsSection(contentType, key, limit))); } function pageTitle(tag, all) { diff --git a/share/js/Navigation.js b/share/js/Navigation.js index 8309249..61bd13b 100644 --- a/share/js/Navigation.js +++ b/share/js/Navigation.js @@ -1,25 +1,29 @@ -import {article, articlesList} from DomRenderer; +import {articlesList, 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 articles = Cache.make(function(key) { - var url = ["", blog.path.articlesPath, 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 article " + url + " (" + queryResult.status + " " + queryResult.statusText + ")" - ); +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); @@ -60,27 +64,29 @@ function navigate(url) { 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$/, ''))); + show(getResource('article', path[1].replace(/\.html$/, ''))); + } else if(path[0] == blog.path.pagesPath) { + show(getResource('page', path[1].replace(/\.html$/, ''))); } else { show(getArticlesList(null, path[0] == "all.html")); } } -function getArticle(key) { +function getResource(contentType, key) { return Async.bind( - articles.get(key), + cache[contentType].get(key), Async.map( - function(contents) {return [article(key, contents)];} + function(contents) {return [render(contentType, key, contents)];} ) ); } function preview(key) { return Async.bind( - articles.get(key), + cache.article.get(key), function(contents) { return Async.wrap( - article(key, contents, blog.skin.previewLinesCount) + render('article', key, contents, blog.skin.previewLinesCount) ); } ); diff --git a/src/Arguments.hs b/src/Arguments.hs index 45b9bb6..a762abe 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -1,9 +1,12 @@ +{-# 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 ( @@ -16,7 +19,7 @@ import System.FilePath (dropTrailingPathSeparator, isValid) data Arguments = BlogConfig { sourceDir :: FilePath - , articlesPath :: FilePath + , articlesPath :: Maybe FilePath , bannerPath :: Maybe FilePath , cardImage :: Maybe FilePath , commentsURL :: Maybe String @@ -47,13 +50,8 @@ option readM aShort aLong aMetavar 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 '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-url" "URL" "URL of the instance where comments are stored" @@ -61,8 +59,8 @@ blogConfig = BlogConfig <*> 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" <*> 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" + <*> option filePath 'p' "pages" "DIRECTORY" + "relative path to the directory containing the pages within INPUT_DIR" <*> Optparse.option auto ( metavar "INTEGER" <> value 3 diff --git a/src/Article.hs b/src/Article.hs index 52d62a3..8dcd3ea 100644 --- a/src/Article.hs +++ b/src/Article.hs @@ -1,75 +1,23 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleContexts #-} module Article ( Article(..) , at - , getKey , preview ) where import Control.Applicative ((<|>)) -import Data.Map (Map) -import qualified Data.Map as Map (fromList, alter) +import qualified Data.Map as Map (alter) import Data.Time (defaultTimeLocale, getCurrentTimeZone, parseTimeM, timeZoneOffsetString) import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds) import Foreign.C.Types (CTime) -import System.FilePath (dropExtension, takeFileName) +import Markdown (Markdown(..), MarkdownContent(..), Metadata) +import qualified Markdown (at) import System.Posix.Files (getFileStatus, modificationTime) -import Text.ParserCombinators.Parsec ( - ParseError - , Parser - , () - , anyChar, char, count, endBy, eof, getPosition, many, many1, noneOf - , oneOf, option, parse, skipMany, sourceLine, string, try - ) +import Text.ParserCombinators.Parsec (ParseError) -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" - -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 @@ setDate tzOffset defaultDate = Map.alter timeStamp "date" 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 + fmap (makeArticle (setDate tzOffset fileDate)) <$> Markdown.at filePath -getKey :: FilePath -> String -getKey = dropExtension . takeFileName - -preview :: Int -> Article -> Article -preview linesCount article = article {body = take linesCount $ body article} +preview :: Int -> Article -> Markdown +preview linesCount (Article markdown@(Markdown {body})) = + markdown {body = take linesCount $ body} diff --git a/src/Blog.hs b/src/Blog.hs index 188e983..524514e 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -15,7 +15,7 @@ module Blog ( 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) @@ -34,22 +34,28 @@ import qualified Data.Map as Map (empty, fromList) import Data.Set (Set) import qualified Data.Set as Set (empty, null, singleton, union) import Data.Text (Text) -import Files (File(..), absolute) +import 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 @@ -60,41 +66,47 @@ type Renderer m = (MonadIO m, MonadReader Blog m) template :: Renderer m => String -> Environment -> m Text template key environment = asks templates >>= render key environment -keepOrWarn :: Map String Article -> Either ParseError (String, Article) -> IO (Map String Article) +keepOrWarn :: 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 @@ -102,13 +114,13 @@ build arguments = do let hasRSS = maybe False (\_-> True) $ rss urls wording <- Wording.build arguments templates <- Template.build wording - root <- Files.absolute . Dir $ Arguments.sourceDir arguments + 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 + (articles, pages, tags) <- discover path return $ Blog { - articles, hasRSS, name, path, skin, tags, templates, urls, wording + articles, hasRSS, name, pages, path, skin, tags, templates, urls, wording } diff --git a/src/Blog/Path.hs b/src/Blog/Path.hs index 2bffb48..ee60dad 100644 --- a/src/Blog/Path.hs +++ b/src/Blog/Path.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Blog.Path ( Path(..) , build @@ -8,17 +9,21 @@ module Blog.Path ( 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 + articlesPath :: Maybe FilePath , pagesPath :: Maybe FilePath , remarkableConfig :: Maybe FilePath , root :: FilePath - } deriving Generic + } deriving (Eq, Generic, Show) instance ToJSON Path where toEncoding (Path {articlesPath, pagesPath}) = pairs ( @@ -26,9 +31,22 @@ instance ToJSON Path where <> "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, 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 + pack Nothing Nothing _ = + throwError "No articles ? No pages ? Why did you wake me up ? I'm going back to sleep" + pack articlesPath pagesPath remarkableConfig = + return $ Path {articlesPath, pagesPath, remarkableConfig, root} + ignore = return Nothing diff --git a/src/Blog/Skin.hs b/src/Blog/Skin.hs index aa688c4..35370c8 100644 --- a/src/Blog/Skin.hs +++ b/src/Blog/Skin.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Blog.Skin ( Skin(..) , build @@ -11,7 +12,9 @@ import qualified Arguments (bannerPath, favicon, cardImage, headPath, previewArt 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 @@ instance ToJSON Skin where findImage :: String -> Maybe FilePath -> IO (Maybe FilePath) findImage _ (Just path) = return . Just $ absoluteLink path findImage name Nothing = - fmap absoluteLink . listToMaybe <$> filterM doesFileExist pathsToCheck + listToMaybe <$> filterM doesFileExist pathsToCheck where directories = [".", "image", "images", "pictures", "skin", "static"] extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"] diff --git a/src/Blog/Wording.hs b/src/Blog/Wording.hs index e393db8..3be9b38 100644 --- a/src/Blog/Wording.hs +++ b/src/Blog/Wording.hs @@ -26,12 +26,15 @@ 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", []) diff --git a/src/Collection.hs b/src/Collection.hs index 0a73798..03f0047 100644 --- a/src/Collection.hs +++ b/src/Collection.hs @@ -6,7 +6,7 @@ module Collection ( , title ) where -import Article(Article(metadata)) +import Article(Article) import Blog (Blog(..), Path(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT, asks) @@ -15,6 +15,7 @@ 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 (()) @@ -34,7 +35,7 @@ build featured tag = do featured = sortByDate featured, basePath, tag } where - sortByDate = sortOn (Down . (! "date") . metadata) + sortByDate = sortOn (Down . (! "date") . metadata . getMarkdown) getAll :: ReaderT Blog IO [Collection] getAll = do diff --git a/src/DOM.hs b/src/DOM.hs index a37dbe9..ef2fb31 100644 --- a/src/DOM.hs +++ b/src/DOM.hs @@ -1,18 +1,19 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module DOM ( - page + HasContent(..) + , htmlDocument ) where -import Article (Article(..)) +import Article (Article) import qualified Article (preview) import ArticlesList ( ArticlesList(..), description, getArticles, otherURL, rssLinkTexts ) -import Blog (Blog(..), Path(..), Skin(..), URL(..), template) +import Blog (Blog(..), Skin(..), URL(..), template) import Control.Monad.Reader (ReaderT, asks) -import qualified Data.Map as Map (keys) -import Data.Text (pack, empty) +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) @@ -21,19 +22,24 @@ import Lucid ( , 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 ((), (<.>)) +import System.FilePath.Posix ((<.>)) type HtmlGenerator = HtmlT (ReaderT Blog IO) -class HasCard a => Page a where +class HasCard a => HasContent a where content :: a -> HtmlGenerator () -instance Page Article where - content = article True +instance HasContent Article where + content = mDContent True . getMarkdown -instance Page ArticlesList where +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 @@ -41,7 +47,7 @@ instance Page ArticlesList where asks hasRSS >>= rssLink li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink div_ [class_ "articles"] ( - mapM_ (article False . preview) =<< getArticles al + mapM_ (mDContent False . preview) =<< getArticles al ) where otherLink = @@ -52,24 +58,25 @@ instance Page ArticlesList where li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text rssLink False = return () -article :: Bool -> Article -> HtmlGenerator () -article raw (Article {key, body, Article.title}) = do - url <- absoluteLink . ( key <.> extension) <$> (asks $path.$articlesPath) +mDContent :: Bool -> Markdown -> HtmlGenerator () +mDContent raw markdown@(Markdown {key, body}) = article_ [id_ $ pack key] (do - header_ (do - a_ [href_ $ pack url] . h1_ $ toHtml title - ) + header_ . h1_ $ mDLink raw markdown pre_ . toHtml $ unlines body ) - where extension = if raw then "md" else "html" + +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 = li_ ( - a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name - ) +tag name = + a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name defaultBanner :: HtmlGenerator () -defaultBanner = do +defaultBanner = div_ [id_ "header"] ( a_ [href_ "/"] ( h1_ . toHtml =<< asks name @@ -77,13 +84,25 @@ defaultBanner = do ) faviconLink :: FilePath -> HtmlGenerator () -faviconLink url = link_ [rel_ "shortcut icon", href_ $ pack url, type_ "image/x-icon"] +faviconLink url = link_ [ + rel_ "shortcut icon", href_ . pack $ absoluteLink url, type_ "image/x-icon" + ] optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator () optional = maybe (return ()) -page :: Page a => a -> HtmlGenerator () -page aPage = +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"] @@ -91,15 +110,15 @@ page aPage = script_ [src_ "/js/remarkable.min.js"] empty script_ [src_ "/js/hablo.js"] empty optional faviconLink =<< (asks $skin.$favicon) - optional (Card.make aPage) =<< (asks $urls.$cards) + optional (Card.make someContent) =<< (asks $urls.$cards) optional toHtmlRaw =<< (asks $skin.$head) ) body_ (do maybe defaultBanner toHtmlRaw =<< (asks $skin.$banner) - div_ [id_ "navigator"] (do - h2_ . toHtml =<< template "tagsList" [] - ul_ . mapM_ tag . Map.keys =<< asks tags - ) - div_ [id_ "contents"] $ content aPage + asks tags >>= navigationSection "tags" "tagsList" + (\(key, _) -> tag key) + asks pages >>= navigationSection "pages" "pagesList" + (\(_, page) -> mDLink False $ getMarkdown page) + div_ [id_ "contents"] $ content someContent ) ) diff --git a/src/DOM/Card.hs b/src/DOM/Card.hs index 55334cc..be7ccbe 100644 --- a/src/DOM/Card.hs +++ b/src/DOM/Card.hs @@ -2,15 +2,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module DOM.Card ( - Card(..) - , HasCard(..) + HasCard(..) , make ) where -import qualified Article (Article(..)) +import Article (Article(..)) import ArticlesList (ArticlesList(..)) import qualified ArticlesList (description) -import Blog (Blog(..), Renderer, Skin(..)) +import Blog (Blog(..), Renderer, Skin(..), template) import Collection (Collection(..)) import qualified Collection (title) import Control.Applicative ((<|>)) @@ -19,18 +18,18 @@ 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 ((.$)) - -data Card = Card { - cardType :: Text - , description :: Text - , image :: Maybe String - , title :: String - , urlPath :: String - } +import System.FilePath.Posix ((), (<.>)) class HasCard a where - getCard :: Renderer m => a -> m Card + 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 = @@ -41,39 +40,52 @@ og attribute value = make :: (HasCard a, Renderer m) => a -> String -> HtmlT m () make element siteURL = do - Card {cardType, description, image, title, urlPath} <- getCard element - og "url" . pack $ siteURL ++ urlPath - og "type" cardType - og "title" $ pack title - og "description" description - maybeImage =<< ((image <|>) <$> (asks $skin.$cardImage)) + 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" . pack . (siteURL++)) + maybeImage = maybe (return ()) (og "image" . sitePrefix) + sitePrefix = pack . (siteURL ) -instance HasCard Article.Article where - getCard (Article.Article {Article.title, Article.metadata}) = do - description <- pack <$> getDescription (Map.lookup "summary" metadata) - return $ Card { - cardType = "article" - , description - , image = (Map.lookup "featuredImage" metadata) - , DOM.Card.title - , urlPath = "/articles/" ++ title ++ ".html" - } - where - getDescription = maybe (asks $name.$("A new article on " <>)) return +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 - getCard al@(ArticlesList {collection}) = do - cardTitle <- Collection.title collection - description <- ArticlesList.description al - return $ Card { - cardType = "website" - , description - , image = Nothing - , DOM.Card.title = cardTitle - , urlPath = maybe "" ('/':) (tag collection) ++ file - } + 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" + file = (if full al then "all" else "index") <.> ".html" diff --git a/src/Files.hs b/src/Files.hs index d82ea89..b6bec82 100644 --- a/src/Files.hs +++ b/src/Files.hs @@ -1,35 +1,32 @@ module Files ( File(..) - , absolute , absoluteLink , filePath , find ) where -import System.Exit (die) -import System.Directory (doesDirectoryExist, doesFileExist, listDirectory, makeAbsolute) +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) import System.FilePath (()) data File = File FilePath | Dir FilePath -absolute :: File -> IO (FilePath) -absolute file = filePath file >>= makeAbsolute - absoluteLink :: FilePath -> FilePath absoluteLink ('.':path) = path absoluteLink path = "/" path -filePath :: File -> IO FilePath -filePath file = do - let (thePath, test, errorMessage) = - case file of - File path -> (path, doesFileExist, (++ ": no such file")) - Dir path -> (path, doesDirectoryExist, (++ ": no such directory")) - bool <- test thePath - if bool - then return thePath - else die $ errorMessage thePath +filePath :: File -> IO (Either String FilePath) +filePath = filePathAux + where + filePathAux (File path) = ifIO doesFileExist path Right (notExist . File) + filePathAux (Dir path) = ifIO doesDirectoryExist path Right (notExist . Dir) + ifIO predicate value whenTrue whenFalse = do + result <- predicate value + return $ if result then whenTrue value else whenFalse value + notExist (File path) = Left $ path ++ ": no such file" + notExist (Dir path) = Left $ path ++ ": no such directory" find :: FilePath -> IO [FilePath] find path = - fmap (path ) <$> listDirectory path + filePath (Dir path) >>= emptyIfMissing (fmap ((path ) <$>) . listDirectory) + where + emptyIfMissing = either (\_ -> return []) diff --git a/src/HTML.hs b/src/HTML.hs index 9818d13..8b684ca 100644 --- a/src/HTML.hs +++ b/src/HTML.hs @@ -4,7 +4,6 @@ module HTML ( generate ) where -import Article(Article(..)) import ArticlesList (ArticlesList(..)) import Blog (Blog(..), Path(..)) import Collection (Collection(..)) @@ -13,8 +12,9 @@ import Control.Monad.IO.Class (MonadIO(..)) 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 DOM (HasContent, htmlDocument) import Lucid (renderTextT) +import Markdown (Markdown(..), MarkdownContent(..)) import Pretty ((.$)) import System.FilePath.Posix ((), (<.>)) @@ -26,19 +26,21 @@ articlesLists collection@(Collection {basePath}) = [ file bool = if bool then "all" else "index" path bool = basePath file bool <.> "html" -generateArticles :: [Article] -> ReaderT Blog IO () -generateArticles = mapM_ $ \article -> do - baseDir <- () <$> (asks $path.$root) <*> (asks $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 {featured = []}) = return () generateCollection collection = flip mapM_ (articlesLists collection) $ \(filePath, articlesList) -> - (renderTextT $ page articlesList) >>= liftIO . TextIO.writeFile filePath + (renderTextT $ htmlDocument articlesList) + >>= liftIO . TextIO.writeFile filePath generate :: ReaderT Blog IO () generate = do - asks articles >>= generateArticles . Map.elems + asks articles >>= generateMarkdown . Map.elems Collection.getAll >>= mapM_ generateCollection + asks pages >>= generateMarkdown . Map.elems diff --git a/src/JS.hs b/src/JS.hs index 46d7a1a..757142d 100644 --- a/src/JS.hs +++ b/src/JS.hs @@ -3,6 +3,8 @@ module JS ( generate ) where +import Data.Aeson (encode) + import Blog (Blog(..), Path(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (ReaderT, asks) @@ -31,7 +33,7 @@ var (varName, content) = concat ["\t", pack varName, " : ", content] generateConfig :: FilePath -> ReaderT Blog IO () generateConfig destinationDir = do - blogJSON <- exportBlog + blogJSON <- asks (encode . exportBlog) remarkablePath <- asks $path.$remarkableConfig liftIO $ do remarkableJSON <- maybe (return "{html: true}") readFile remarkablePath diff --git a/src/JSON.hs b/src/JSON.hs index 3562455..34404de 100644 --- a/src/JSON.hs +++ b/src/JSON.hs @@ -4,58 +4,60 @@ module JSON ( exportBlog ) where -import Article (Article) -import qualified Article (Article(..)) 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 - , hasRSS = Blog.hasRSS blog - , path = Blog.path blog - , skin = Blog.skin blog - , tags = Set.elems <$> Blog.tags blog - , urls = Blog.urls blog - , wording = Blog.wording blog - } + where + tag key = Just . Map.keys . Map.filter (Set.member key) $ Blog.tags blog + getArticles = mapWithKey (exportMarkdown . tag) + getPages = mapWithKey (\_-> exportMarkdown Nothing) diff --git a/src/Markdown.hs b/src/Markdown.hs new file mode 100644 index 0000000..dc2c720 --- /dev/null +++ b/src/Markdown.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Markdown ( + Markdown(..) + , MarkdownContent(..) + , Metadata + , at + , getKey + ) where + +import Control.Applicative ((<|>)) +import Data.Map (Map) +import qualified Data.Map as Map (fromList) +import System.FilePath (dropExtension, takeFileName) +import Text.ParserCombinators.Parsec ( + ParseError, Parser + , () + , anyChar, char, count, endBy, eof, getPosition, many, many1, noneOf + , oneOf, option, parse, skipMany, sourceLine, sourceName, string, try + ) + +type Metadata = Map String String +data Markdown = Markdown { + key :: String + , path :: String + , title :: String + , metadata :: Metadata + , bodyOffset :: Int + , body :: [String] + } + +class MarkdownContent a where + getMarkdown :: a -> Markdown + +parser :: Parser Markdown +parser = do + (title, metadata) <- skipMany eol *> (headerP <|> reverseHeaderP) + bodyOffset <- skipMany eol *> (pred . sourceLine <$> getPosition) + body <- lines <$> many anyChar <* eof + inputFile <- sourceName <$> getPosition + let (key, path) = (getKey inputFile, dropExtension inputFile) + return $ Markdown {key, path, title, metadata, bodyOffset, body} + where + headerP = (,) <$> titleP <* many eol <*> metadataP + reverseHeaderP = flip (,) <$> metadataP <* many eol<*> titleP + +metadataP :: Parser Metadata +metadataP = Map.fromList <$> option [] ( + metaSectionSeparator *> many eol *> + (try keyVal) `endBy` (many1 eol) + <* metaSectionSeparator + ) "metadata section" + where + metaSectionSeparator = count 3 (oneOf "~-") *> eol + spaces = skipMany $ char ' ' + keyVal = (,) <$> (no ": \r\n" <* spaces <* char ':' <* spaces) <*> no "\r\n" + +titleP :: Parser String +titleP = try (singleLine <|> underlined) + where + singleLine = char '#' *> char ' ' *> no "\r\n" <* eol + underlined = + no "\r\n" <* eol + >>= \titleLine -> count (length titleLine) (oneOf "#=") *> eol *> return titleLine + "'#' or '=' to underline the title" + +eol :: Parser String +eol = try (string "\r\n") <|> string "\r" <|> string "\n" "newline" + +no :: String -> Parser String +no = many1 . noneOf + +getKey :: FilePath -> String +getKey = dropExtension . takeFileName + +at :: FilePath -> IO (Either ParseError Markdown) +at filePath = parse parser filePath <$> readFile filePath diff --git a/src/Page.hs b/src/Page.hs new file mode 100644 index 0000000..2e638b9 --- /dev/null +++ b/src/Page.hs @@ -0,0 +1,17 @@ +module Page ( + Page(..) + , at + ) where + +import Markdown (Markdown(..), MarkdownContent(..)) +import qualified Markdown as Markdown (at) +import Text.ParserCombinators.Parsec (ParseError) + +newtype Page = Page Markdown +instance MarkdownContent Page where + getMarkdown (Page markdown) = markdown + +at :: FilePath -> IO (Either ParseError (String, Page)) +at filePath = fmap makePage <$> Markdown.at filePath + where + makePage markdown = (key markdown, Page markdown) diff --git a/src/Pretty.hs b/src/Pretty.hs index f014ccf..584544a 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -1,6 +1,16 @@ module Pretty ( - (.$) + (.$) + , assertRight + , onRight ) where +import System.Exit (die) + (.$) :: (a -> b) -> (b -> c) -> (a -> c) (.$) f g = g . f + +onRight :: (a -> IO b) -> Either String a -> IO b +onRight = either die + +assertRight :: Either String a -> IO a +assertRight = onRight return diff --git a/src/RSS.hs b/src/RSS.hs index 73f8b79..e7382d4 100644 --- a/src/RSS.hs +++ b/src/RSS.hs @@ -8,7 +8,7 @@ module RSS ( import Article (Article(..)) import ArticlesList (ArticlesList(..), getArticles) import qualified ArticlesList (description) -import Blog (Blog(..), Path(..), Renderer, URL(..)) +import Blog (Blog(urls), Renderer, URL(..)) import Collection (Collection(..), getAll) import qualified Collection (title) import Control.Monad.IO.Class (MonadIO(..)) @@ -20,6 +20,7 @@ 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 ((), (<.>)) @@ -57,13 +58,12 @@ pubDate_ :: Term arg result => arg -> result pubDate_ = term "pubDate" articleItem :: MonadReader Blog m => String -> Article -> HtmlT m () -articleItem siteURL (Article {key, metadata, title}) = +articleItem siteURL (Article (Markdown {path, metadata, title})) = item_ $ do title_ $ toHtml title - link_ . toHtml =<< link <$> (asks $path.$articlesPath) + link_ $ toHtml (siteURL path <.> "html") pubDate_ . toHtml . rfc822Date $ metadata ! "date" where - link path = siteURL path key <.> "html" rfc822Date = formatTime defaultTimeLocale rfc822DateFormat . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int) diff --git a/test/Mock/Arguments.hs b/test/Mock/Arguments.hs new file mode 100644 index 0000000..e81a2a0 --- /dev/null +++ b/test/Mock/Arguments.hs @@ -0,0 +1,86 @@ +module Mock.Arguments ( + badCustomArticles + , badCustomPages + , bothCustom + , bothDefault + , customArticles + , customArticlesDefaultPages + , customPages + , customPagesDefaultArticles + , defaultArticles + , defaultPages + , emptyBlog + ) where + +import Arguments (Arguments(..)) +import Utils (testDataPath) + +defaultArticles :: Arguments +defaultArticles = BlogConfig { + sourceDir = testDataPath "Structure/defaultArticles" + , articlesPath = Nothing + , bannerPath = Nothing + , cardImage = Nothing + , commentsURL = Nothing + , favicon = Nothing + , headPath = Nothing + , name = Nothing + , openGraphCards = False + , pagesPath = Nothing + , previewArticlesCount = 3 + , previewLinesCount = 10 + , remarkableConfig = Nothing + , rss = False + , siteURL = Nothing + , wording = Nothing + } + +defaultPages :: Arguments +defaultPages = defaultArticles { + sourceDir = testDataPath "Structure/defaultPages" + } + +bothDefault :: Arguments +bothDefault = defaultArticles { + sourceDir = testDataPath "Structure/both" + } + +emptyBlog :: Arguments +emptyBlog = defaultArticles { + sourceDir = testDataPath "Structure/custom" + } + +customArticles :: Arguments +customArticles = emptyBlog { + articlesPath = Just "customArticles" + } + +customArticlesDefaultPages :: Arguments +customArticlesDefaultPages = bothDefault { + articlesPath = Just "customArticles" + } + +customPages :: Arguments +customPages = emptyBlog { + pagesPath = Just "customPages" + } + +customPagesDefaultArticles :: Arguments +customPagesDefaultArticles = bothDefault { + pagesPath = Just "customPages" + } + +bothCustom :: Arguments +bothCustom = customArticles { + pagesPath = Just "customPages" + } + +badCustomArticles :: Arguments +badCustomArticles = bothDefault { + articlesPath = Just "missingDirectory" + } + +badCustomPages :: Arguments +badCustomPages = bothDefault { + pagesPath = Just "missingDirectory" + } diff --git a/test/Mock/Article.hs b/test/Mock/Article.hs new file mode 100644 index 0000000..12f1cb1 --- /dev/null +++ b/test/Mock/Article.hs @@ -0,0 +1,23 @@ +module Mock.Article ( + noDescription + , noImage + , noMeta + , simple + ) where + +import Article (Article(..)) +import qualified Data.Map as Map (fromList) +import Markdown (Markdown(..)) +import Mock.Markdown (article) + +simple :: Article +simple = Article article + +noImage :: Article +noImage = Article $ article {metadata = Map.fromList [("summary", "It's a test")]} + +noDescription :: Article +noDescription = Article $ article {metadata = Map.fromList [("featuredImage", "test.png")]} + +noMeta :: Article +noMeta = Article $ article {metadata = Map.fromList []} diff --git a/test/Mock/ArticlesList.hs b/test/Mock/ArticlesList.hs new file mode 100644 index 0000000..a1a5d5c --- /dev/null +++ b/test/Mock/ArticlesList.hs @@ -0,0 +1,22 @@ +module Mock.ArticlesList ( + longMain + , longTesting + , shortMain + , shortTesting + ) where + +import ArticlesList (ArticlesList(..)) +import Mock.Collection (main, testing) +import Prelude hiding (all) + +shortMain :: IO ArticlesList +shortMain = ArticlesList False <$> main + +shortTesting :: IO ArticlesList +shortTesting = ArticlesList False <$> testing + +longMain :: IO ArticlesList +longMain = ArticlesList True <$> main + +longTesting :: IO ArticlesList +longTesting = ArticlesList True <$> testing diff --git a/test/Mock/Blog.hs b/test/Mock/Blog.hs new file mode 100644 index 0000000..fb182c0 --- /dev/null +++ b/test/Mock/Blog.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Mock.Blog ( + noCards + , noRSS + , simple + ) where + +import Blog (Blog(..)) +import qualified Data.Map as Map (fromList) +import qualified Data.Set as Set (fromList) +import qualified Mock.Article (simple) +import qualified Mock.Blog.Path (defaultArticles) +import qualified Mock.Blog.Skin (simple) +import qualified Mock.Blog.Template (simple) +import qualified Mock.Blog.URL (simple, noCards) +import qualified Mock.Blog.Wording (defaultWording) + +simple :: IO Blog +simple = + let wording = Mock.Blog.Wording.defaultWording in do + templates <- Mock.Blog.Template.simple + return $ Blog { + articles = Map.fromList [("test", Mock.Article.simple)] + , hasRSS = True + , name = "The Test Blog" + , pages = Map.fromList [] + , path = Mock.Blog.Path.defaultArticles + , skin = Mock.Blog.Skin.simple + , tags = Map.fromList [("testing", Set.fromList ["test"])] + , templates + , urls = Mock.Blog.URL.simple + , wording + } + +noCards :: IO Blog +noCards = (\b -> b {urls = Mock.Blog.URL.noCards}) <$> simple + +noRSS :: IO Blog +noRSS = (\b -> b {hasRSS = False}) <$> simple diff --git a/test/Mock/Blog/Path.hs b/test/Mock/Blog/Path.hs new file mode 100644 index 0000000..2feb078 --- /dev/null +++ b/test/Mock/Blog/Path.hs @@ -0,0 +1,66 @@ +module Mock.Blog.Path ( + bothCustom + , bothDefault + , customArticles + , customArticlesDefaultPages + , customPages + , customPagesDefaultArticles + , defaultArticles + , defaultPages + ) where + +import Blog.Path (Path(..)) + +defaultArticles :: Path +defaultArticles = Path { + articlesPath = Just "articles" + , pagesPath = Nothing + , remarkableConfig = Nothing + , root = "test/Structure/defaultArticles" + } + +defaultPages :: Path +defaultPages = Path { + articlesPath = Nothing + , pagesPath = Just "pages" + , remarkableConfig = Nothing + , root = "test/Structure/defaultPages" + } + +bothDefault :: Path +bothDefault = Path { + articlesPath = Just "articles" + , pagesPath = Just "pages" + , remarkableConfig = Nothing + , root = "test/Structure/both" + } + +customArticles :: Path +customArticles = Path { + articlesPath = Just "customArticles" + , pagesPath = Nothing + , remarkableConfig = Nothing + , root = "test/Structure/custom" + } + +bothCustom :: Path +bothCustom = customArticles { + pagesPath = Just "customPages" + } + +customPages :: Path +customPages = bothCustom { + articlesPath = Nothing + } + +customArticlesDefaultPages :: Path +customArticlesDefaultPages = bothDefault { + articlesPath = Just "customArticles" + , pagesPath = Just "pages" + } + +customPagesDefaultArticles :: Path +customPagesDefaultArticles = customArticlesDefaultPages { + articlesPath = Just "articles" + , pagesPath = Just "customPages" + } diff --git a/test/Mock/Blog/Skin.hs b/test/Mock/Blog/Skin.hs new file mode 100644 index 0000000..3259a5a --- /dev/null +++ b/test/Mock/Blog/Skin.hs @@ -0,0 +1,16 @@ +module Mock.Blog.Skin ( + simple + ) where + +import Blog.Skin (Skin(..)) +import Prelude hiding (head) + +simple :: Skin +simple = Skin { + banner = Nothing + , cardImage = Nothing + , favicon = Nothing + , head = Nothing + , previewArticlesCount = 3 + , previewLinesCount = 10 + } diff --git a/test/Mock/Blog/Template.hs b/test/Mock/Blog/Template.hs new file mode 100644 index 0000000..bba3d39 --- /dev/null +++ b/test/Mock/Blog/Template.hs @@ -0,0 +1,9 @@ +module Mock.Blog.Template ( + simple + ) where + +import Blog.Template (Templates, build) +import Mock.Blog.Wording (defaultWording) + +simple :: IO Templates +simple = build Mock.Blog.Wording.defaultWording diff --git a/test/Mock/Blog/URL.hs b/test/Mock/Blog/URL.hs new file mode 100644 index 0000000..5d14fa4 --- /dev/null +++ b/test/Mock/Blog/URL.hs @@ -0,0 +1,16 @@ +module Mock.Blog.URL ( + noCards + , simple + ) where + +import Blog.URL (URL(..)) + +simple :: URL +simple = URL { + cards = Just "https://test.net" + , comments = Nothing + , rss = Nothing + } + +noCards :: URL +noCards = simple {cards = Nothing} diff --git a/test/Mock/Blog/Wording.hs b/test/Mock/Blog/Wording.hs new file mode 100644 index 0000000..7b7df50 --- /dev/null +++ b/test/Mock/Blog/Wording.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +module Mock.Blog.Wording ( + defaultWording + ) where + +import Blog.Wording (Wording(..)) +import qualified Data.Map as Map (fromList) + +defaultWording :: Wording +defaultWording = Wording $ Map.fromList [ + ("allLink", "See all") + , ("allPage", "All articles{? tagged ${tag}?}") + , ("articleDescription", "A new article on ${name}") + , ("commentsLink", "Comment on the fediverse") + , ("commentsSection", "Comments") + , ("dateFormat", "en-US") + , ("latestLink", "See only latest") + , ("latestPage", "Latest articles{? tagged ${tag}?}") + , ("metadata", "{?by ${author} ?}on ${date}{? tagged ${tags}?}") + , ("pageDescription", "Read on ${name}") + , ("pagesList", "Pages") + , ("rssLink", "Subscribe") + , ("rssTitle", "Follow all articles{? tagged ${tag}?}") + , ("tagsList", "Tags") + ] diff --git a/test/Mock/Collection.hs b/test/Mock/Collection.hs new file mode 100644 index 0000000..68c1dfd --- /dev/null +++ b/test/Mock/Collection.hs @@ -0,0 +1,28 @@ +module Mock.Collection ( + main + , testing + ) where + +import Blog (Blog(..), Path(..)) +import Collection (Collection(..)) +import Data.Map as Map (elems) +import qualified Mock.Blog (simple) +import System.FilePath (()) + +main :: IO Collection +main = do + blog <- Mock.Blog.simple + return $ Collection { + featured = Map.elems $ articles blog + , basePath = root $ path blog + , tag = Nothing + } + +testing :: IO Collection +testing = do + blog <- Mock.Blog.simple + return $ Collection { + featured = Map.elems $ articles blog + , basePath = root (path blog) "testing" + , tag = Just "testing" + } diff --git a/test/Mock/Markdown.hs b/test/Mock/Markdown.hs new file mode 100644 index 0000000..b745a66 --- /dev/null +++ b/test/Mock/Markdown.hs @@ -0,0 +1,33 @@ +module Mock.Markdown ( + article + , page + ) where + +import qualified Data.Map as Map (fromList) +import Markdown (Markdown(..)) + +article :: Markdown +article = Markdown { + key = "test" + , path = "articles/test" + , Markdown.title = "Some test" + , metadata = Map.fromList [ + ("summary", "It's a test") + , ("featuredImage", "test.png") + ] + , bodyOffset = 3 + , body = [] + } + +page :: Markdown +page = Markdown { + key = "test" + , path = "pages/test" + , Markdown.title = "A test page" + , metadata = Map.fromList [ + ("summary", "Tests are useful") + , ("featuredImage", "test.png") + ] + , bodyOffset = 3 + , body = [] + } diff --git a/test/Structure.hs b/test/Structure.hs new file mode 100644 index 0000000..1d77af4 --- /dev/null +++ b/test/Structure.hs @@ -0,0 +1,40 @@ +module Structure ( + test + ) where + +import Arguments (Arguments(..)) +import Blog (Path) +import qualified Blog.Path as Path (build) +import Distribution.TestSuite +import qualified Mock.Arguments as Arguments +import qualified Mock.Blog.Path as Path +import System.Directory (withCurrentDirectory) +import Utils (simpleTest, tag) + +checkPath :: Arguments -> Maybe Path -> IO Progress +checkPath input expected = do + withCurrentDirectory root $ do + actual <- either (\_ -> Nothing) Just <$> Path.build root input + return . Finished $ + if actual == expected + then Pass + else Fail $ "Expected " ++ show expected ++ " but got " ++ show actual + where + root = sourceDir input + +test :: Test +test = tag "structure" . testGroup "Blog structure" $ simpleTest <$> [ + ("empty structure", checkPath Arguments.emptyBlog Nothing) + , ("default articles", checkPath Arguments.defaultArticles $ Just Path.defaultArticles) + , ("default pages", checkPath Arguments.defaultPages $ Just Path.defaultPages) + , ("both default", checkPath Arguments.bothDefault $ Just Path.bothDefault) + , ("custom articles", checkPath Arguments.customArticles $ Just Path.customArticles) + , ("custom pages", checkPath Arguments.customPages $ Just Path.customPages) + , ("both custom", checkPath Arguments.bothCustom $ Just Path.bothCustom) + , ("custom articles, default pages" + , checkPath Arguments.customArticlesDefaultPages $ Just Path.customArticlesDefaultPages) + , ("custom pages, default articles" + , checkPath Arguments.customPagesDefaultArticles $ Just Path.customPagesDefaultArticles) + , ("bad custom articles", checkPath Arguments.badCustomArticles $ Nothing) + , ("bad custom pages", checkPath Arguments.badCustomPages $ Nothing) + ] diff --git a/test/Structure/.placeHolder b/test/Structure/.placeHolder new file mode 100644 index 0000000..e69de29 diff --git a/test/Structure/both/.placeHolder b/test/Structure/both/.placeHolder new file mode 100644 index 0000000..e69de29 diff --git a/test/Structure/both/articles/.placeHolder b/test/Structure/both/articles/.placeHolder new file mode 100644 index 0000000..e69de29 diff --git a/test/Structure/both/customArticles/.placeHolder b/test/Structure/both/customArticles/.placeHolder new file mode 100644 index 0000000..e69de29 diff --git a/test/Structure/both/customPages/.placeHolder b/test/Structure/both/customPages/.placeHolder new file mode 100644 index 0000000..e69de29 diff --git a/test/Structure/both/pages/.placeHolder b/test/Structure/both/pages/.placeHolder new file mode 100644 index 0000000..e69de29 diff --git a/test/Structure/custom/.placeHolder b/test/Structure/custom/.placeHolder new file mode 100644 index 0000000..e69de29 diff --git a/test/Structure/custom/customArticles/.placeHolder b/test/Structure/custom/customArticles/.placeHolder new file mode 100644 index 0000000..e69de29 diff --git a/test/Structure/custom/customPages/.placeHolder b/test/Structure/custom/customPages/.placeHolder new file mode 100644 index 0000000..e69de29 diff --git a/test/Structure/defaultArticles/.placeHolder b/test/Structure/defaultArticles/.placeHolder new file mode 100644 index 0000000..e69de29 diff --git a/test/Structure/defaultArticles/articles/.placeHolder b/test/Structure/defaultArticles/articles/.placeHolder new file mode 100644 index 0000000..e69de29 diff --git a/test/Structure/defaultPages/.placeHolder b/test/Structure/defaultPages/.placeHolder new file mode 100644 index 0000000..e69de29 diff --git a/test/Structure/defaultPages/pages/.placeHolder b/test/Structure/defaultPages/pages/.placeHolder new file mode 100644 index 0000000..e69de29 diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 index 0000000..1be31f5 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,14 @@ +module Tests ( + tests + ) where + +import Distribution.TestSuite +import qualified Structure (test) +import Utils (tag) +import qualified XML.Card (test) + +tests :: IO [Test] +tests = return $ tag "xml" <$> [ + XML.Card.test + , Structure.test + ] diff --git a/test/Utils.hs b/test/Utils.hs new file mode 100644 index 0000000..a4b2a9f --- /dev/null +++ b/test/Utils.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Utils ( + assertAll + , assertEqual + , simpleTest + , tag + , testDataPath + ) where + +import Distribution.TestSuite +import System.FilePath (()) +import Text.Printf (printf) + +tagInstance :: String -> TestInstance -> TestInstance +tagInstance tagName testInstance = testInstance { + tags = tagName : (tags testInstance) + } + +tag :: String -> Test -> Test +tag tagName (Test testInstance) = Test (tagInstance tagName testInstance) +tag tagName group = group {groupTests = tag tagName <$> groupTests group} + +simpleTest :: (String, IO Progress) -> Test +simpleTest (name, run) = Test testInstance + where + testInstance = TestInstance { + run + , name + , tags = [] + , options = [] + , setOption = \_ _ -> Right testInstance + } + +wrong :: Show a => String -> a -> a -> IO Progress +wrong message expected actual = return . Finished . Fail $ + printf "%s: %s vs. %s" message (show expected) (show actual) + +assertAll :: [(Bool, IO Progress, String)] -> IO Progress +assertAll = foldr assert (return $ Finished Pass) + where + assert (bool, badIssue, checkMessage) next = + if bool then return $ Progress checkMessage next else badIssue + +assertEqual :: (Show a, Eq a) => String -> a -> a -> (Bool, IO Progress, String) +assertEqual what a b = + (a == b, wrong (what ++ " do not match !") a b, what ++ " ok") + +testDataPath :: FilePath -> FilePath +testDataPath = ("test" ) diff --git a/test/XML/Card.hs b/test/XML/Card.hs new file mode 100644 index 0000000..315ade7 --- /dev/null +++ b/test/XML/Card.hs @@ -0,0 +1,11 @@ +module XML.Card ( + test + ) where + +import Distribution.TestSuite +import Utils (tag) +import qualified XML.Card.Component as Component (test) +import qualified XML.Card.Output as Output (test) + +test :: Test +test = tag "card" $ testGroup "Cards" [Component.test, Output.test] diff --git a/test/XML/Card/Component.hs b/test/XML/Card/Component.hs new file mode 100644 index 0000000..db5a4bc --- /dev/null +++ b/test/XML/Card/Component.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +module XML.Card.Component ( + test + ) where + +import Blog (Blog) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader (runReaderT) +import Data.Text (Text) +import Distribution.TestSuite +import DOM.Card (HasCard(..)) +import Mock.Blog as Blog (simple) +import Mock.Article as Article (noDescription, noImage, simple) +import Mock.ArticlesList as ArticlesList ( + longMain, longTesting, shortMain, shortTesting + ) +import Utils (assertAll, assertEqual, simpleTest, tag) + +check :: HasCard a => IO Blog -> a -> (Text, Text, Maybe String, String, String) -> IO Progress +check getBlog input (expectedCT, expectedD, expectedI, expectedT, expectedU) = + getBlog >>= runReaderT ( + sequence [ + assertEqual "card types" expectedCT <$> cardType input + , assertEqual "descriptions" expectedD <$> description input + , assertEqual "images" expectedI <$> image input + , assertEqual "titles" expectedT <$> title input + , assertEqual "urls" expectedU <$> urlPath input + ] >>= liftIO . assertAll + ) + +articleCard :: Test +articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [ + ("simple article components", check Blog.simple Article.simple ( + "article" + , "It's a test" + , Just "test.png" + , "Some test" + , "articles/test.html" + )) + , ("article components without description", check Blog.simple Article.noDescription ( + "article" + , "A new article on The Test Blog" + , Just "test.png" + , "Some test" + , "articles/test.html" + )) + , ("article components without image", check Blog.simple Article.noImage ( + "article" + , "It's a test" + , Nothing + , "Some test" + , "articles/test.html" + )) + ] + +articlesListCard :: Test +articlesListCard = tag "articlesList" . testGroup "Articles list cards" $ simpleTest <$> [ + ("short untagged page component", ArticlesList.shortMain >>= (flip (check Blog.simple) ( + "website" + , "Latest articles" + , Nothing + , "The Test Blog" + , "index.html" + ))) + , ("long untagged page component", ArticlesList.longMain >>= (flip (check Blog.simple) ( + "website" + , "All articles" + , Nothing + , "The Test Blog" + , "all.html" + ))) + , ("short tagged page component", ArticlesList.shortTesting >>= (flip (check Blog.simple) ( + "website" + , "Latest articles tagged testing" + , Nothing + , "The Test Blog - testing" + , "testing/index.html" + ))) + , ("long tagged page component", ArticlesList.longTesting >>= (flip (check Blog.simple) ( + "website" + , "All articles tagged testing" + , Nothing + , "The Test Blog - testing" + , "testing/all.html" + ))) + ] + +test :: Test +test = tag "component" $ testGroup "Cards components" [articleCard, articlesListCard] diff --git a/test/XML/Card/Output.hs b/test/XML/Card/Output.hs new file mode 100644 index 0000000..c3fb71a --- /dev/null +++ b/test/XML/Card/Output.hs @@ -0,0 +1,49 @@ +module XML.Card.Output ( + test + ) where + +import Blog (Blog(..), URL(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader (asks, runReaderT) +import qualified Data.Text.Lazy.IO as Lazy (readFile) +import Distribution.TestSuite +import DOM.Card (HasCard(..), make) +import Lucid (renderTextT) +import Mock.Blog as Blog (noCards, simple) +import Mock.Article as Article (noDescription, noImage, simple) +import Mock.ArticlesList as ArticlesList ( + longMain, longTesting, shortMain, shortTesting + ) +import Pretty ((.$)) +import System.FilePath (()) +import Utils (assertAll, assertEqual, simpleTest, tag, testDataPath) + +check :: HasCard a => IO Blog -> a -> FilePath -> IO Progress +check getBlog input expectedFile = + getBlog >>= runReaderT (do + actual <- renderTextT $ maybe (return ()) (DOM.Card.make input) =<< (asks $urls.$cards) + expected <- liftIO . Lazy.readFile $ testDataPath "XML/Card/Output" expectedFile + liftIO $ assertAll [ + assertEqual "card HTML output" expected actual + ] + ) + +articleCard :: Test +articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [ + ("simple article output", check Blog.simple Article.simple "simple.html") + , ("article output without description", check Blog.simple Article.noDescription "noDescription.html") + , ("article output without image", check Blog.simple Article.noImage "noImage.html") + , ("no card article output", check Blog.noCards Article.simple "/dev/null") + ] + +articlesListCard :: Test +articlesListCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [ + ("short untagged page output", ArticlesList.shortMain >>= flip (check Blog.simple) "shortMain.html") + , ("long untagged page output", ArticlesList.longMain >>= flip (check Blog.simple) "longMain.html") + , ("short tagged page output", ArticlesList.shortTesting >>= flip (check Blog.simple) "shortTesting.html") + , ("long tagged page output", ArticlesList.longTesting >>= flip (check Blog.simple) "longTesting.html") + , ("no card articlesList output", ArticlesList.shortMain >>= flip (check Blog.noCards) "/dev/null") + ] + +test :: Test +test = tag "output" $ testGroup "Cards outputs" [articleCard, articlesListCard] diff --git a/test/XML/Card/Output/longMain.html b/test/XML/Card/Output/longMain.html new file mode 100644 index 0000000..4c130b3 --- /dev/null +++ b/test/XML/Card/Output/longMain.html @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/test/XML/Card/Output/longTesting.html b/test/XML/Card/Output/longTesting.html new file mode 100644 index 0000000..90cdb49 --- /dev/null +++ b/test/XML/Card/Output/longTesting.html @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/test/XML/Card/Output/noDescription.html b/test/XML/Card/Output/noDescription.html new file mode 100644 index 0000000..2568e41 --- /dev/null +++ b/test/XML/Card/Output/noDescription.html @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/test/XML/Card/Output/noImage.html b/test/XML/Card/Output/noImage.html new file mode 100644 index 0000000..920bac5 --- /dev/null +++ b/test/XML/Card/Output/noImage.html @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/test/XML/Card/Output/shortMain.html b/test/XML/Card/Output/shortMain.html new file mode 100644 index 0000000..2442979 --- /dev/null +++ b/test/XML/Card/Output/shortMain.html @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/test/XML/Card/Output/shortTesting.html b/test/XML/Card/Output/shortTesting.html new file mode 100644 index 0000000..95c3cc5 --- /dev/null +++ b/test/XML/Card/Output/shortTesting.html @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/test/XML/Card/Output/simple.html b/test/XML/Card/Output/simple.html new file mode 100644 index 0000000..8477739 --- /dev/null +++ b/test/XML/Card/Output/simple.html @@ -0,0 +1 @@ + \ No newline at end of file