Tissevert/hablo
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Merge branch 'main' into implement-static-pages

Browse source
This commit is contained in:
Tissevert 2020-05-30 12:28:48 +02:00
commit fc8e26a983
35 changed files with 1109 additions and 735 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
CHANGELOG.md
View file

@ -1,5 +1,10 @@
# Revision history for hablo # Revision history for hablo
## 1.0.3.0 -- 2019-12-21
* Fix OpenGraph cards displayed for links to hablo-generated pages posted on the Fediverse (should work elsewhere too but I don't care and have never tested)
* This fix alas requires to «anchor» the generated website at a given location by means of the new `--site-url` option. OpenGraph cards are just completely disabled if you prefer your website to remain portable.
## 1.0.2.0 -- 2019-08-27 ## 1.0.2.0 -- 2019-08-27
* Format for [conditional blocks](/Tissevert/hablo/wiki/Template-variables#metadata) changed to allow an internal simplification. This is transparent if you're creating a new blog or using the default wording but be sure to edit your wording if you're using a custom one : * Format for [conditional blocks](/Tissevert/hablo/wiki/Template-variables#metadata) changed to allow an internal simplification. This is transparent if you're creating a new blog or using the default wording but be sure to edit your wording if you're using a custom one :

4
doc/Architectural-choices.md
View file

@ -24,7 +24,7 @@ Pages include a banner, a navigation `<div>` with links to the various tags and
### Article pages ### Article pages
Ideally, the markdown files would be enough and there wouldn't be any HTML generated for articles. Unfortunately, in order to share direct links to articles, some HTML is necessary to reach the blog's interface, loading some JS, to handle the navigation and not only display a markdown file. The additional HTML also allows to generate [open-graph](http://ogp.me/) cards to make the links look nicer on [social media](#fediverse). Ideally, the markdown files would be enough and there wouldn't be any HTML generated for articles. Unfortunately, in order to share direct links to articles, some HTML is necessary to reach the blog's interface, loading some JS, to handle the navigation and not only display a markdown file. The additional HTML also allows to generate [Open Graph](http://ogp.me/) cards to make the links look nicer on [social media](#fediverse).
The article pages' content is the body of the markdown file wrapped in a HTML `<pre>` element and its title. The article pages' content is the body of the markdown file wrapped in a HTML `<pre>` element and its title.
@ -48,6 +48,6 @@ Hablo takes a stand against this. It aims at generating HTML files that are simp
## Fediverse ## Fediverse
Hablo is conceived from the start to interact with the [fediverse](https://fediverse.network/) and social media in general so all pages generated embed a set of basic [open-graph](http://ogp.me/) metadata in their header. This allows links posted on social media to appear in a nice box with a picture, the name of the blog and a short description. Hablo is conceived from the start to interact with the [fediverse](https://fediverse.network/) and social media in general. It can embed a set of basic [Open Graph](http://ogp.me/) metadata in the header of all generated pages if you [provide the URL](https://git.marvid.fr/Tissevert/hablo/wiki/Command-line#site-url) where your blog will be deployed to hablo. This allows links posted on social media to appear in a nice box with a picture, the name of the blog and a short description.
Also, being static, hablo doesn't handle dynamic things like comments directly. Instead, comments are [toots](https://git.marvid.fr/Tissevert/hablo/wiki/Customizing%20your%20blog#how-do-i-customize-the-templates-) listed on a fediverse instance. Also, being static, hablo doesn't handle dynamic things like comments directly. Instead, comments are [toots](https://git.marvid.fr/Tissevert/hablo/wiki/Customizing%20your%20blog#how-do-i-customize-the-templates-) listed on a fediverse instance.

36
doc/Command-line.md
View file

@ -48,13 +48,11 @@ hablo --banner /my/set/of/banner/turtles.html /path/to/your/blog
`-c, --card-image` `-c, --card-image`
By default, hablo will try to find the image to use for cards [automatically](https://git.marvid.fr/Tissevert/hablo/src/branch/master/src/Blog/Skin.hs#L36). It will look for a file with the [name](#name) of your blog and the extension `.ico`, `.gif`, `.jpeg`, `.jpg`, `.png` or `.svg` located at the root of the blog or in a directory called `image`, `images`, `pictures`, `skin` or `static`. By default, hablo will try to find the image to use for cards [automatically](https://git.marvid.fr/Tissevert/hablo/src/branch/main/src/Blog/Skin.hs#L36). It will look for a file with the [name](#name) of your blog and the extension `.ico`, `.gif`, `.jpeg`, `.jpg`, `.png` or `.svg` located at the root of the blog or in a directory called `image`, `images`, `pictures`, `skin` or `static`.
This option allows you to skip the auto-discover step or to use an image that wouldn't be found with the above method and directly tell hablo what file to use. This option allows you to skip the auto-discover step or to use an image that wouldn't be found with the above method and directly tell hablo what file to use. It is of course only relevant if you have [enabled](#site-url) Open Graph cards for your website by providing its deployment URL to hablo. Since it already knows the root URL of your website, this option expects only the local path to the image of course.
Note that not all cards generated for your blog will necessarily contain an image. If none of the expected path for card images exists and you don't provide one with this option, then pages won't embed an [open-graph](http://ogp.me/) picture in their card by default but articles with a [featured image](https://git.marvid.fr/Tissevert/hablo/wiki/Metadata#featured-image) will still do (and the image used for the card will be the featured image of the article). Note that not all cards generated for your blog will necessarily contain an image. If none of the expected path for card images exists and you don't provide one with this option, then pages won't embed an [Open Graph](http://ogp.me/) picture in their card by default but articles with a [featured image](https://git.marvid.fr/Tissevert/hablo/wiki/Metadata#featured-image) will still do (and the image used for the card will be the featured image of the article).
Card images in themselves are only relevant once your blog is deployed and accessed by a browser or linked to. Hablo only includes a link to them or not, so of course the value of this option must be a relative path within your blog's structure. If you put a file outside, your web server will of course return 404 errors whenever something will read the corresponding header and attempt to access it.
```bash ```bash
hablo --card-image skin/defaultCardImage.png hablo --card-image skin/defaultCardImage.png
@ -90,7 +88,7 @@ hablo --favicon skin/eyeOfTheTurtle.jpg
`-H, --head` `-H, --head`
The header section of the HTML pages includes several things such as the [open-graph](http://ogp.me/) metadata, the script inclusions for hablo's client code and for its [dependencies](https://git.marvid.fr/Tissevert/hablo/wiki/Deploying%20a%20hablo%20blog). The header section of the HTML pages includes several things such as the [Open Graph](http://ogp.me/) metadata, the script inclusions for hablo's client code and for its [dependencies](https://git.marvid.fr/Tissevert/hablo/wiki/Deploying%20a%20hablo%20blog).
Use the `--head` option to add some arbitrary HTML elements to the header of your pages. This is the way to use a CSS theme for your blog, as is shown in the [customization](https://git.marvid.fr/Tissevert/hablo/wiki/Customizing%20your%20blog#how-do-i-use-a-custom-skin-) how-to. Use the `--head` option to add some arbitrary HTML elements to the header of your pages. This is the way to use a CSS theme for your blog, as is shown in the [customization](https://git.marvid.fr/Tissevert/hablo/wiki/Customizing%20your%20blog#how-do-i-use-a-custom-skin-) how-to.
@ -98,7 +96,7 @@ Use the `--head` option to add some arbitrary HTML elements to the header of you
`-n, --name` `-n, --name`
Each blog has a name which is used in the default banner of your site and as the title of all pages (displayed in the tab's name and in the window name when your blog's tab is focused). Hablo infers it from the name of the directory containing it. It works on an absolute version the path it receives, so it won't suddenly think your blog is called `..` because you ran Each blog has a name which is used in the default banner of your site and as the title of all pages (displayed in the tab's name and in the window name when your blog's tab is focused). Hablo infers it from the name of the directory containing it. It works on an absolute version of the path it receives, so it won't suddenly think your blog is called `..` because you ran
```bash ```bash
hablo .. hablo ..
@ -112,6 +110,12 @@ You can use this option if you want to override this behaviour and provide a dif
hablo --name "Turtles/Paradize" hablo --name "Turtles/Paradize"
``` ```
## Open Graph cards
`-O, --open-graph-cards`
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
`-p, --pages` `-p, --pages`
@ -128,7 +132,7 @@ On the page that [lists](https://git.marvid.fr/Tissevert/hablo/wiki/Architectura
hablo --preview-articles 5 hablo --preview-articles 5
``` ```
will make all your short pages display 5 articles. will make all your short pages display 5 articles. This number of articles per short page is also used in the RSS feeds if you enable them with [`--rss`](#rss).
## Number of lines preview for articles ## Number of lines preview for articles
@ -146,6 +150,22 @@ Hablo uses [remarkable](https://github.com/jonschlinkert/remarkable) to render y
The file is read by hablo when the blog is generated and its content gets included into the client JS code so it can be located absolutely anywhere, even outside your blog's directory. The file is read by hablo when the blog is generated and its content gets included into the client JS code so it can be located absolutely anywhere, even outside your blog's directory.
## RSS
`-R, --rss`
Enables the generation of RSS feeds for each [list](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#page-types) of articles. The feed consists in an additional `rss.xml` file placed in the same directory as the `index.html` and `all.html` files generated for. The feeds only include the most recent articles exactly as the «short» versions of each list, which means that they are affected by the use of the [`--preview-articles`](#number-of-articles-previewed) option. When this option is enabled, hablo will also include links to the generated feeds in the list pages. Two [template variables](https://git.marvid.fr/Tissevert/hablo/wiki/Template%20variables#rsslinks) control respectively the content and the title of the link.
Note that this feature requires setting your site URL with [`--site-url`](#site-url).
## Site URL
`-u, --site-url`
All the default content generated by hablo is independent from any host because it doesn't use any full URL with a host name. Enabling [Open Graph cards](#open-graph-cards) or [RSS feeds](#rss) requires to know this information though, which is achieved by setting this option to the desired value.
Note that this is purely optional and you don't have to use this option if you don't care about Open Graph cards or RSS feeds. Setting it for no reason will trigger a warning.
## Wording ## Wording
`-w, --wording` `-w, --wording`

2
doc/Customizing-your-blog.md
View file

@ -104,4 +104,4 @@ Now, when you generate your blog, tell hablo to look for comments on the instanc
hablo --comments-at https://turtles.social hablo --comments-at https://turtles.social
``` ```
Be sure to clear the cache of your web browser before visiting your article again. A «comments» section now shows after your article, with possibly some comments if someone has already answered your post on the fediverse. Be sure to clear the cache of your web browser before visiting your article again. A «comments» section now shows after your article, with possibly some comments if someone has already answered your post on the fediverse. Also, please note that, as comments are purely handled by the fediverse so is the moderation : you should preferably use this feature on an instance where you have moderation rights and will be able to delete hateful comments or where you know the moderation team will be able to react appropriately.

6
doc/Metadata.md
View file

@ -41,11 +41,11 @@ comments: 101781535999718634
Hablo associates to each article the date when it was written or last edited to sort articles chronologically and to display it. Trying to [reuse](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#reuse) as much as possible, this date is by default the «last modified» Unix date of the file that contains the article. Hablo associates to each article the date when it was written or last edited to sort articles chronologically and to display it. Trying to [reuse](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#reuse) as much as possible, this date is by default the «last modified» Unix date of the file that contains the article.
You can override this behaviour by setting a `date` metadata. It can contain a date with an optional time (hour and minute) and a timezone, also optional. If you don't set a timezone the current one will be used. Note that this means that some of your article might seem to have their dates «moving» a bit, if for example you set the date for one of your article (but not the timezone), generate your blog, then travel to a place with a very different timezone, and generate your blog again. You can override this behaviour by setting a `date` metadata. It can contain a date with an optional time (hour and minute) and a timezone, also optional. If you don't set a timezone the current one will be used. Note that this means that some of your articles might seem to have their dates «moving» a bit, if for example you set the date for one of your article (but not the timezone), generate your blog, then travel to a place with a very different timezone, and generate your blog again.
### Featured image ### Featured image
Every article can contain as many pictures as you like, anywhere you like in it. But you can choose one of them (or even one that doesn't appear in your article) to appear in the [open-graph](http://ogp.me/) card of your article, so that it is displayed and «represents» your article when you paste links to it on social media. The exact name of the metadata is `featuredImage`, camel-case, and it expects the site-root relative link of the picture (so the path as seen from your blog by a client accessing it). Every article can contain as many pictures as you like, anywhere you like in it. But you can choose one of them (or even one that doesn't appear in your article) to appear in the [Open Graph](http://ogp.me/) card of your article if you've [enabled](https://git.marvid.fr/Tissevert/hablo/wiki/Command-line#open-graph-cards) them, so that it is displayed and «represents» your article when you paste links to it on social media. The exact name of the metadata is `featuredImage`, camel-case, and it expects the site-root relative link of the picture (so the path as seen from your blog by a client accessing it).
```YAML ```YAML
featuredImage: /media/turtles/olive-ridley.jpg featuredImage: /media/turtles/olive-ridley.jpg
@ -53,7 +53,7 @@ featuredImage: /media/turtles/olive-ridley.jpg
### Summary ### Summary
You can write a short description of your article and use it as the value of its `summary` metadata and this text will be used in the open-graph [description](http://ogp.me/#optional) of the card generated for the article. You can write a short description of your article and use it as the value of its `summary` metadata and this text will be used in the Open Graph [description](http://ogp.me/#optional) of the card generated for the article (like above for the featured image, if they're [enabled](https://git.marvid.fr/Tissevert/hablo/wiki/Command-line#open-graph-cards))
```YAML ```YAML
summary: This week, I'm gonna tell you everything about the olive ridley sea turtle ! summary: This week, I'm gonna tell you everything about the olive ridley sea turtle !

56
doc/Template-variables.md
View file

@ -4,33 +4,39 @@ Here is the full list of the available text template variables that you can cust
Variables are prefixed by a `$` and may be enclosed in brackets `{ }` to lift any ambiguity and separate the variable from the surrounding characters (exemple : does the template `the $nth` refers to a `nth` variable or is it the variable `n` followed by the literal characters `th` ? the first interpretation prevails, and if you want the second one you should write `the ${n}th`). Variables are prefixed by a `$` and may be enclosed in brackets `{ }` to lift any ambiguity and separate the variable from the surrounding characters (exemple : does the template `the $nth` refers to a `nth` variable or is it the variable `n` followed by the literal characters `th` ? the first interpretation prevails, and if you want the second one you should write `the ${n}th`).
Most of the templates are used «at [compile-time](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#static-and-lazy)» when the blog is generated and so errors, missing variables etc. are caught early but some like [metadata](#metadata) are only used client-side and hence need to be more resistant. If a variable present in a template is missing when the template is rendered, an `undefined` JS value is returned. All template variables are checked at «[compile-time](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#static-and-lazy)» when the blog is generated and so syntax errors, missing or unexpected variables etc. are caught early.
Now some contexts, especially article contexts may vary a bit so some templates like `metadata` need a way to «catch» those null values and keep up templating. For instance, an article may or may not have an author or tags. You could for instance decide that the base articles of your blog aren't signed because they obviously come from you or the organization that publish the blog but that when the blog publishes an article by a special guest it needs a special mention. To «harden» a template string against possible null values, just enclose the corresponding optional part between `${? ?}`. ## Conditional blocks
## allLink Now some contexts may vary a bit and sometimes «lack» a variable so some templates like `metadata` need a way to «catch» those possible null values and keep templating. You could for instance decide that most articles of your blog aren't signed because they obviously come from you or the organization that publishes the blog but that when the blog features an article by a special guest it needs a special mention and you would put the corresponding part using the `${author}` variable in a conditional block. The syntax to do so and «warn» the templating system of possible null values is to enclose the corresponding optional part inside `${? ?}` like so :
```
allPage = The articles{? about ${tag}?}
```
This will yield just `The articles` on the general pages without tags and `The articles about sea turtles` on the pages for the tag `sea turtles`. Note that conditional blocks are «flat», you can't nest one under another.
## Available variables
### allLink
The text used in the link to the [full](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#full-pages) page on the [latest](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#latest-pages) page of the same category. The text used in the link to the [full](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#full-pages) page on the [latest](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#latest-pages) page of the same category.
## allPage ### allPage
The `<h2>` title used on the [full page for all the articles](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#list-pages). The `<h2>` title used on the [full page for articles](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#list-pages).
## allTaggedPage It can use the variable named `$tag` : the name of the tag for the given page. Be careful that this variable will be null for the untagged «general» pages, so you want to escape it using the [conditional](#conditional-blocks) syntax described above if your template string does contain `${tag}`.
The template for the `<h2>` title used on the [full pages for all the articles tagged a given tag](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#list-pages). ### commentsLink
It of course expects one variable named `$tag` : the name of the tag for the given page.
## commentsLink
The text displayed after the comments as a link to the toot that opens the comments section inviting visitors to comment the post. The text displayed after the comments as a link to the toot that opens the comments section inviting visitors to comment the post.
## commentsSection ### commentsSection
The content of the `<h2>` element at the begining of the comments on the pages of articles that have comments enabled. The content of the `<h2>` element at the begining of the comments on the pages of articles that have comments enabled.
## dateFormat ### dateFormat
This isn't really a template per-se but impacts the way the dates are generated to use in the [metadata](#metadata) template. More precisely it contains the arguments passed to the [toLocaleDateString](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/toLocaleDateString) method. It can thus only consist in a locale name, but since `toLocaleDateString` also accepts an object as second argument, you can write the whole thing using JSON like this : This isn't really a template per-se but impacts the way the dates are generated to use in the [metadata](#metadata) template. More precisely it contains the arguments passed to the [toLocaleDateString](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/toLocaleDateString) method. It can thus only consist in a locale name, but since `toLocaleDateString` also accepts an object as second argument, you can write the whole thing using JSON like this :
@ -38,21 +44,17 @@ This isn't really a template per-se but impacts the way the dates are generated
dateFormat = ["en-AU", {"month":"long", "day":"2-digit"}] dateFormat = ["en-AU", {"month":"long", "day":"2-digit"}]
``` ```
## latestLink ### latestLink
The text used in the link to the [latest](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#latest-pages) page on the [full](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#full-pages) page of the same category. The text used in the link to the [latest](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#latest-pages) page on the [full](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#full-pages) page of the same category.
## latestPage ### latestPage
The `<h2>` title used on the [latest page for all the articles](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#list-pages). This page is the main page of your blog so this is more or less the first title that people see when they come to your blog. The `<h2>` title used on the [latest page for articles](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#list-pages). The latest page without tags is the «main» page of your blog so this is more or less the first title that people see when they come to your blog.
## latestTaggedPage Just like the [allPage](#allpage) above it makes use of the `$tag` variable, that will be null for the untagged «general» pages. Again, see the [conditional](#conditional-blocks) section above to handle this properly.
The template for the `<h2>` title used on the [latest pages for all the articles tagged a given tag](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#list-pages). ### metadata
It of course expects one variable named `$tag` : the name of the tag for the given page.
## metadata
The template of the text used to present the metadata associated to each article. This template is used both in the preview of an article on any page that lists it and on the article's page itself. It expects three possible variables The template of the text used to present the metadata associated to each article. This template is used both in the preview of an article on any page that lists it and on the article's page itself. It expects three possible variables
@ -68,7 +70,15 @@ metadata = {?by ${author} ?}on ${date}{? tagged ${tags}?}
If an article has an author, the rendered `metadata` string will start with «by <AUTHOR>», otherwise it will directly start with «on <SOME DATE>». Likewise all articles with tags will have their `metadata` end with « tagged » and then the list of comma-separated tags but if an article doesn't have tags, it will simply end after the date. If an article has an author, the rendered `metadata` string will start with «by <AUTHOR>», otherwise it will directly start with «on <SOME DATE>». Likewise all articles with tags will have their `metadata` end with « tagged » and then the list of comma-separated tags but if an article doesn't have tags, it will simply end after the date.
## tagsList ### rssLink
This template variable contains the text displayed in the link element pointing to the [RSS feed](https://git.marvid.fr/Tissevert/hablo/wiki/Command-line#rss) to each [list page](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#list-pages). This template is a constant and doesn't expect any templating variable.
### rssTitle
This template variable contains the title attribute of the link element pointing to the [RSS feed](https://git.marvid.fr/Tissevert/hablo/wiki/Command-line#rss) to each [list page](https://git.marvid.fr/Tissevert/hablo/wiki/Architectural%20choices#list-pages) that will be visible on mouse hover. The only templating variable it expects is `$tag` (which should be preferably [protected](#conditional-blocks) if you use it because `$tag` will be null on the main page containing a link to the general feed containing all the articles published on your blog).
### tagsList
The content of the `<h2>` element in the navigation `<div>` that lists all the tags of your blog. The content of the `<h2>` element in the navigation `<div>` that lists all the tags of your blog.

12
hablo.cabal
View file

@ -3,7 +3,7 @@ cabal-version: >= 1.10
-- For further documentation, see http://haskell.org/cabal/users-guide/ -- For further documentation, see http://haskell.org/cabal/users-guide/
name: hablo name: hablo
version: 1.0.2.0 version: 1.0.3.0
synopsis: A minimalist static blog generator synopsis: A minimalist static blog generator
description: description:
Hablo is a fediverse-oriented static blog generator for articles written Hablo is a fediverse-oriented static blog generator for articles written
@ -34,9 +34,13 @@ executable hablo
, ArticlesList , ArticlesList
, Blog , Blog
, Blog.Path , Blog.Path
, Blog.Template
, Blog.Skin , Blog.Skin
, Blog.URL
, Blog.Wording , Blog.Wording
, Dom , Collection
, DOM
, DOM.Card
, Files , Files
, HTML , HTML
, JS , JS
@ -44,6 +48,7 @@ executable hablo
, Page , Page
, Paths_hablo , Paths_hablo
, Pretty , Pretty
, RSS
-- other-extensions: -- other-extensions:
build-depends: aeson >= 1.4.0 && < 1.5 build-depends: aeson >= 1.4.0 && < 1.5
, base >= 4.9.1 && < 4.13 , base >= 4.9.1 && < 4.13
@ -53,11 +58,12 @@ executable hablo
, filepath >= 1.4.2 && < 1.5 , filepath >= 1.4.2 && < 1.5
, lucid >= 2.9.11 && < 2.10 , lucid >= 2.9.11 && < 2.10
, mtl >= 2.2.2 && < 2.3 , mtl >= 2.2.2 && < 2.3
, optparse-applicative >= 0.14.3 && < 0.15 , optparse-applicative >= 0.14.3 && < 0.16
, parsec >= 3.1.13 && < 3.2 , parsec >= 3.1.13 && < 3.2
, template >= 0.2.0 && < 0.3 , template >= 0.2.0 && < 0.3
, text >= 1.2.3 && < 1.3 , text >= 1.2.3 && < 1.3
, time >= 1.8.0 && < 1.9 , time >= 1.8.0 && < 1.9
, SJW >= 0.1.2 && < 0.2
, unix >= 2.7.2 && < 2.8 , unix >= 2.7.2 && < 2.8
ghc-options: -Wall -dynamic ghc-options: -Wall -dynamic
hs-source-dirs: src hs-source-dirs: src

8
share/defaultWording.conf
View file

@ -1,11 +1,11 @@
allLink = See all allLink = See all
allPage = All articles allPage = All articles{? tagged ${tag}?}
allTaggedPage = All articles tagged ${tag}
commentsLink = Comment on the fediverse commentsLink = Comment on the fediverse
commentsSection = Comments commentsSection = Comments
dateFormat = en-US dateFormat = en-US
latestLink = See only latest latestLink = See only latest
latestPage = Latest articles latestPage = Latest articles{? tagged ${tag}?}
latestTaggedPage = Latest articles tagged ${tag}
metadata = {?by ${author} ?}on ${date}{? tagged ${tags}?} metadata = {?by ${author} ?}on ${date}{? tagged ${tags}?}
rssLink = Subscribe
rssTitle = Follow all articles{? tagged ${tag}?}
tagsList = Tags tagsList = Tags

110
share/js/DomRenderer.js Normal file
View file

@ -0,0 +1,110 @@
import blog from Hablo.Config;
import Metadata;
import Remarkable;
import Template;
import * as Dom from UnitJS.Dom;
import {defined} from UnitJS.Fun;
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(Metadata.get(article.id));
var text = article.getElementsByTagName('pre')[0];
if(text != undefined) {
article.replaceChild(getDiv(text.innerText), text);
if(comments) {
Metadata.getComments(article.id)
.forEach(article.appendChild.bind(article));
}
} else {
console.log('No content found for this article');
}
}
function getDiv(markdown) {
var d= Dom.make('div', {
innerHTML: Remarkable.md.render(markdown)
});
var scripts = d.getElementsByTagName('script');
for(var i = 0; i < scripts.length; i++) {
var run = Dom.make('script',
{type: 'text/javascript', src: scripts[i].src, textContent: scripts[i].textContent}
);
scripts[i].parentNode.replaceChild(run, scripts[i]);
}
return d;
}
function 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 Dom.make('article', {}, [
Dom.make('header', {}, [
Dom.make('a', {href: url}, [
Dom.make('h1', {innerText: blog.articles[key].title})
]),
Metadata.get(key)
]),
div
].concat(limit != undefined ? [] : Metadata.getComments(key)));
}
function pageTitle(tag, all) {
return Template.render(all ? 'allPage' : 'latestPage', {tag: tag});
}
function otherUrl(tag, all) {
var path = [tag, all ? '' : 'all.html'];
return '/' + path.filter(defined).join('/');
}
function articlesList(tag, all) {
return function(articlePreviews) {
return [
Dom.make('h2', {innerText: pageTitle(tag, all)}),
Dom.make('ul', {}, articlesListLinks(tag, all)),
Dom.make('div', {class: 'articles'}, articlePreviews.filter(defined))
];
};
}
function articlesListLinks(tag, all) {
var links = [
Dom.make('a', {
innerText: all ? blog.wording.latestLink : blog.wording.allLink,
href: otherUrl(tag, all),
class: 'other'
})
];
if(blog.hasRSS) {
links.unshift(Dom.make('a', {
innerText: blog.wording.rssLink,
href: 'rss.xml',
class: 'RSS',
title: Template.render('rssTitle', {tag: tag})
}));
}
return links.map(function(e) {return Dom.make('li', {}, [e]);});
}

5
share/js/Main.js Normal file
View file

@ -0,0 +1,5 @@
import replaceMarkdown from DomRenderer;
import hijackLinks from Navigation;
replaceMarkdown();
hijackLinks();

159
share/js/Metadata.js Normal file
View file

@ -0,0 +1,159 @@
import blog from Hablo.Config;
import Template;
import * as Async from UnitJS.Async;
import * as Cache from UnitJS.Cache;
import * as Dom from UnitJS.Dom;
var comments = Cache.make(function(threadId) {
return Async.bind(
Async.parallel(
getJSON(url(threadId)),
getJSON(url(threadId) + '/context'),
),
Async.map(function(t) {
return [renderLink(t[0]), renderAnswers(t[1])];
})
);
});
return {
get: get,
getComments: getComments
};
function url(threadId) {
return blog.urls.comments + '/api/v1/statuses/' + threadId;
}
function getJSON(url) {
return Async.bind(
Async.http({method: 'GET', url: url}),
function(queryResult) {
if(queryResult.status == 200) {
try {
return Async.wrap(JSON.parse(queryResult.responseText));
} catch(e) {
return Async.fail('Server returned invalid JSON for ' + url);
}
} else {
return Async.fail('Could not load page ' + url);
}
}
);
}
function getComments(articleKey) {
var threadId = blog.articles[articleKey].metadata.comments;
if(blog.urls.comments != undefined && threadId != undefined) {
var ul = Dom.make('ul');
var div = emptySection(ul);
Async.run(
Async.bind(
comments.get(threadId), Async.map(populateComments(div, ul))
)
);
return [div];
} else {
return [];
}
}
function populateComments(div, ul) {
return function(apiResults) {
var post = apiResults[0], comments = apiResults[1];
div.appendChild(post);
comments.forEach(function(comment) {ul.appendChild(comment);});
};
}
function emptySection(ul) {
return Dom.make('div', {class: 'comments'}, [
Dom.make('h2', {innerText: blog.wording.commentsSection}),
ul
]);
}
function renderLink(post) {
return Dom.make('a', {
href: post.url,
innerText: blog.wording.commentsLink
});
}
function getContent(descendant) {
return descendant.content.replace(/:([^: ]+):/g, function(pattern, shortcode) {
var emoji = descendant.emojis.find(function(e) {return e.shortcode == shortcode;});
if(emoji) {
return [
'<img title=', shortcode, ' alt=', shortcode, ' src=', emoji.url, ' class="emoji"/>'
].join('"');
} else {
return pattern;
}
});
}
function renderAnswers(comments) {
return comments.descendants.map(function(descendant) {
return Dom.make('li', {}, [
Dom.make('a', {href: descendant.account.url}, [
Dom.make('img', {
src: descendant.account.avatar,
alt: descendant.account.username + "'s profile picture"
})
]),
Dom.make('div', {
class: "metadata",
innerHTML: Template.render('metadata', {
author: author(descendant.account.url, descendant.account.username),
date: date(descendant.created_at)
})
}),
Dom.make('div', {innerHTML: getContent(descendant)})
]);
});
}
function author(key, name) {
var authorUrl = key;
if(blog.articles[key] != undefined) {
authorUrl = blog.articles[key].metadata.author;
}
if(authorUrl) {
var author = name || authorUrl.replace(/.*\//, '');
return '<a href="' + authorUrl + '">' + author + '</a>';
}
}
function date(key) {
if(blog.articles[key] != undefined) {
var date = new Date(blog.articles[key].metadata.date * 1000);
} else {
var date = new Date(key);
}
var format = blog.wording.dateFormat;
if(format[0] != '[') {
if(format[0] != '"') {
format = '"' + format + '"';
}
format = '[' + format + ']';
}
return Date.prototype.toLocaleDateString.apply(date, JSON.parse(format));
}
function tags(key) {
var tags = blog.articles[key].tagged;
return tags.length < 1 ? null : tags.map(function(tag) {
return '<a class="tag" href="/' + tag + '">' + tag + '</a>';
}).join(', ');
}
function get(key) {
return Dom.make('div', {
class: "metadata",
innerHTML: Template.render('metadata', {
author: author(key),
date: date(key),
tags: tags(key)
})
});
}

118
share/js/Navigation.js Normal file
View file

@ -0,0 +1,118 @@
import {article, articlesList} 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 + ")"
);
}
}
);
});
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 Async.bind(
articles.get(key),
Async.map(
function(contents) {return [article(key, contents)];}
)
);
}
function preview(key) {
return Async.bind(
articles.get(key),
function(contents) {
return Async.wrap(
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(Fun.compare(reverseDate));
return ids.slice(0, all ? undefined : blog.skin.previewArticlesCount);
}
function getArticlesList(tag, all) {
return Async.bind(
Async.parallel.apply(null, articleIds(tag, all).map(preview)),
Async.map(articlesList(tag, all))
);
}
function show(contents) {
Async.run(
Async.bind(
contents,
Async.map(function (domElems) {
domElems = domElems.filter(Fun.defined);
var div = document.getElementById('contents');
Dom.clear(div);
for(var i = 0; i < domElems.length; i++) {
div.appendChild(domElems[i]);
}
hijackLinks(div);
})
)
);
}

8
share/js/Remarkable.js Normal file
View file

@ -0,0 +1,8 @@
import remarkableConfig from Hablo.Config;
var md = new Remarkable(remarkableConfig);
md.block.ruler.enable(['footnote']);
return {
md: md
};

35
share/js/Template.js Normal file
View file

@ -0,0 +1,35 @@
import blog from Hablo.Config;
return {
render: render
};
function render(template, environment) {
if(blog.wording[template] != undefined) {
var template = blog.wording[template];
}
template = template.replace(/{\?((?:[^?]|\?[^}])*)\?}/g, renderSub(environment));
var failed = [false];
var result = template.replace(
/([^$]|^)\$(?:{(\w+)}|(\w+)\b)/g,
substitute(environment, failed)
);
return failed[0] ? null : result;
}
function renderSub(environment) {
return function(_, sub) {
return render(sub, environment) || '';
};
}
function substitute(environment, failed) {
return function(_, before, bracketed, raw) {
var replaced = environment[bracketed || raw];
if(replaced != undefined) {
return before + replaced;
} else {
failed[0] = true;
}
}
}

94
share/js/domRenderer.js
View file

@ -1,94 +0,0 @@
function DomRenderer(modules) {
return {
article: article,
articlesList: articlesList,
replaceMarkdown: replaceMarkdown
};
function replaceMarkdown() {
var div = document.getElementById('contents');
if(div.children[0] && div.children[0].tagName.toLowerCase() == 'article') {
convertArticle(div.children[0], true);
} else {
var articles = div.getElementsByClassName('articles')[0];
if(articles != undefined) {
for(var i = 0; i < articles.children.length; i++) {
convertArticle(articles.children[i]);
}
} else {
console.log('No articles found for this page');
}
}
}
function convertArticle(article, comments) {
var header = article.getElementsByTagName('header')[0];
header.appendChild(modules.metadata.get(article.id));
var text = article.getElementsByTagName('pre')[0];
if(text != undefined) {
article.replaceChild(getDiv(text.innerText), text);
if(comments) {
modules.metadata.getComments(article.id)
.forEach(article.appendChild.bind(article));
}
} else {
console.log('No content found for this article');
}
}
function getDiv(markdown) {
var d= modules.dom.make('div', {
innerHTML: modules.md.render(markdown)
});
var scripts = d.getElementsByTagName('script');
for(var i = 0; i < scripts.length; i++) {
var run = modules.dom.make('script',
{type: 'text/javascript', src: scripts[i].src, textContent: scripts[i].textContent}
);
scripts[i].parentNode.replaceChild(run, scripts[i]);
}
return d;
}
function article(key, markdown, limit) {
var url = ["", blog.path.articlesPath, key + (limit != undefined ? '.html' : '.md')].join('/');
var lines = markdown.split(/\n/).slice(blog.articles[key].bodyOffset);
var div = getDiv(lines.slice(0, limit).join('\n'));
return modules.dom.make('article', {}, [
modules.dom.make('header', {}, [
modules.dom.make('a', {href: url}, [
modules.dom.make('h1', {innerText: blog.articles[key].title})
]),
modules.metadata.get(key)
]),
div
].concat(limit != undefined ? [] : modules.metadata.getComments(key)));
}
function pageTitle(tag, all) {
if(tag != undefined) {
var template = all ? 'allTaggedPage' : 'latestTaggedPage';
return modules.template.render(template, {tag: tag});
} else {
return blog.wording[all ? 'allPage' : 'latestPage'];
}
}
function otherUrl(tag, all) {
var path = [tag, all ? null : 'all.html'];
return '/' + path.filter(modules.fun.defined).join('/');
}
function articlesList(tag, all) {
return function(articlePreviews) {
return [
modules.dom.make('h2', {innerText: pageTitle(tag, all)}),
modules.dom.make('a', {
innerText: all ? blog.wording.latestLink : blog.wording.allLink,
href: otherUrl(tag, all)
}),
modules.dom.make('div', {class: 'articles'}, articlePreviews.filter(modules.fun.defined))
];
};
}
}

14
share/js/main.js
View file

@ -1,14 +0,0 @@
window.addEventListener('load', function() {
var async = unitJS.Async();
var cache = unitJS.Cache();
var dom = unitJS.Dom();
var fun = unitJS.Fun();
var md = new Remarkable(remarkableConfig);
md.block.ruler.enable(['footnote']);
var template = Template();
var metadata = Metadata({async: async, cache: cache, dom: dom, fun:fun, template: template});
var domRenderer = DomRenderer({dom: dom, fun: fun, md: md, metadata: metadata, template: template});
var navigation = Navigation({async: async, cache: cache, dom: dom, domRenderer: domRenderer, fun: fun, md: md});
domRenderer.replaceMarkdown();
navigation.hijackLinks();
});

155
share/js/metadata.js
View file

@ -1,155 +0,0 @@
function Metadata(modules) {
var comments = modules.cache.make(function(threadId) {
return modules.async.bind(
modules.async.parallel(
getJSON(url(threadId)),
getJSON(url(threadId) + '/context'),
),
modules.async.map(function(t) {
return [renderLink(t[0]), renderAnswers(t[1])];
})
);
});
return {
get: get,
getComments: getComments
};
function url(threadId) {
return blog.path.commentsAt + '/api/v1/statuses/' + threadId;
}
function getJSON(url) {
return modules.async.bind(
modules.async.http({method: 'GET', url: url}),
function(queryResult) {
if(queryResult.status == 200) {
try {
return modules.async.wrap(JSON.parse(queryResult.responseText));
} catch(e) {
return modules.async.fail('Server returned invalid JSON for ' + url);
}
} else {
return modules.async.fail('Could not load page ' + url);
}
}
);
}
function getComments(articleKey) {
var threadId = blog.articles[articleKey].metadata.comments;
if(blog.path.commentsAt != undefined && threadId != undefined) {
var ul = modules.dom.make('ul');
var div = emptySection(ul);
modules.async.run(
modules.async.bind(
comments.get(threadId), modules.async.map(populateComments(div, ul))
)
);
return [div];
} else {
return [];
}
}
function populateComments(div, ul) {
return function(apiResults) {
var post = apiResults[0], comments = apiResults[1];
div.appendChild(post);
comments.forEach(function(comment) {ul.appendChild(comment);});
};
}
function emptySection(ul) {
return modules.dom.make('div', {class: 'comments'}, [
modules.dom.make('h2', {innerText: blog.wording.commentsSection}),
ul
]);
}
function renderLink(post) {
return modules.dom.make('a', {
href: post.url,
innerText: blog.wording.commentsLink
});
}
function getContent(descendant) {
return descendant.content.replace(/:([^: ]+):/g, function(pattern, shortcode) {
var emoji = descendant.emojis.find(function(e) {return e.shortcode == shortcode;});
if(emoji) {
return [
'<img title=', shortcode, ' alt=', shortcode, ' src=', emoji.url, ' class="emoji"/>'
].join('"');
} else {
return pattern;
}
});
}
function renderAnswers(comments) {
return comments.descendants.map(function(descendant) {
return modules.dom.make('li', {}, [
modules.dom.make('a', {href: descendant.account.url}, [
modules.dom.make('img', {
src: descendant.account.avatar,
alt: descendant.account.username + "'s profile picture"
})
]),
modules.dom.make('div', {
class: "metadata",
innerHTML: modules.template.render('metadata', {
author: author(descendant.account.url, descendant.account.username),
date: date(descendant.created_at)
})
}),
modules.dom.make('div', {innerHTML: getContent(descendant)})
]);
});
}
function author(key, name) {
var authorUrl = key;
if(blog.articles[key] != undefined) {
authorUrl = blog.articles[key].metadata.author;
}
if(authorUrl) {
var author = name || authorUrl.replace(/.*\//, '');
return '<a href="' + authorUrl + '">' + author + '</a>';
}
}
function date(key) {
if(blog.articles[key] != undefined) {
var date = new Date(blog.articles[key].metadata.date * 1000);
} else {
var date = new Date(key);
}
var format = blog.wording.dateFormat;
if(format[0] != '[') {
if(format[0] != '"') {
format = '"' + format + '"';
}
format = '[' + format + ']';
}
return Date.prototype.toLocaleDateString.apply(date, JSON.parse(format));
}
function tags(key) {
var tags = blog.articles[key].tagged;
return tags.length < 1 ? null : tags.map(function(tag) {
return '<a class="tag" href="/' + tag + '">' + tag + '</a>';
}).join(', ');
}
function get(key) {
return modules.dom.make('div', {
class: "metadata",
innerHTML: modules.template.render('metadata', {
author: author(key),
date: date(key),
tags: tags(key)
})
});
}
}

117
share/js/navigation.js
View file

@ -1,117 +0,0 @@
function Navigation(modules) {
var articles = modules.cache.make(function(key) {
var url = ["", blog.path.articlesPath, key + '.md'].join('/');
return modules.async.bind(
modules.async.http({method: 'GET', url: url}),
function(queryResult) {
if(queryResult.status == 200) {
return modules.async.wrap(queryResult.responseText);
} else {
return modules.async.fail(
"Could not load article " + url + " (" + queryResult.status + " " + queryResult.statusText + ")"
);
}
}
);
});
window.addEventListener('popstate', function(e) {
if(e.state != undefined) {
navigate(e.state.url);
}
});
history.replaceState({url: window.location.pathname}, 'Blog - title', window.location.pathname);
return {
hijackLinks: hijackLinks
};
function hijackLinks(domElem) {
domElem = domElem || document;
var links = domElem.getElementsByTagName('a');
for(var i = 0; i < links.length; i++) {
var a = links[i];
var href = a.getAttribute("href");
if((href[0] == "/" && href.slice(-3) != ".md") || href[0] == "#") {
a.addEventListener('click', visit(a.getAttribute("href")));
}
}
}
function visit(url) {
return function(e) {
e.preventDefault();
if(url[0] == '#') {
window.location = url;
history.replaceState({url: window.location.pathname}, 'Blog - title', url);
} else {
navigate(url);
history.pushState({url: url}, 'Blog - title', url);
}
};
}
function navigate(url) {
var path = decodeURI(url).split("/").slice(1);
if(blog.tags[path[0]] != undefined) {
show(getArticlesList(path[0], path[1] == "all.html"));
} else if(path[0] == blog.path.articlesPath) {
show(getArticle(path[1].replace(/\.html$/, '')));
} else {
show(getArticlesList(null, path[0] == "all.html"));
}
}
function getArticle(key) {
return modules.async.bind(
articles.get(key),
modules.async.map(
function(contents) {return [modules.domRenderer.article(key, contents)];}
)
);
}
function preview(key) {
return modules.async.bind(
articles.get(key),
function(contents) {
return modules.async.wrap(
modules.domRenderer.article(
key,
contents,
blog.skin.previewLinesCount
)
);
}
);
}
function articleIds(tag, all) {
var ids = tag != undefined ? blog.tags[tag] : Object.keys(blog.articles);
var reverseDate = function (id) {return -blog.articles[id].metadata.date;};
ids.sort(modules.fun.compare(reverseDate));
return ids.slice(0, all ? undefined : blog.skin.previewArticlesCount);
}
function getArticlesList(tag, all) {
return modules.async.bind(
modules.async.parallel.apply(null, articleIds(tag, all).map(preview)),
modules.async.map(modules.domRenderer.articlesList(tag, all))
);
}
function show(contents) {
modules.async.run(
modules.async.bind(
contents,
modules.async.map(function (domElems) {
domElems = domElems.filter(modules.fun.defined);
var div = document.getElementById('contents');
modules.dom.clear(div);
for(var i = 0; i < domElems.length; i++) {
div.appendChild(domElems[i]);
}
hijackLinks(div);
})
)
);
}
}

35
share/js/template.js
View file

@ -1,35 +0,0 @@
function Template() {
return {
render: render
};
function render(template, environment) {
if(blog.wording[template] != undefined) {
var template = blog.wording[template];
}
template = template.replace(/{\?((?:[^?]|\?[^}])*)\?}/g, renderSub(environment));
var failed = [false];
var result = template.replace(
/([^$]|^)\$(?:{(\w+)}|(\w+)\b)/g,
substitute(environment, failed)
);
return failed[0] ? null : result;
}
function renderSub(environment) {
return function(_, sub) {
return render(sub, environment) || '';
};
}
function substitute(environment, failed) {
return function(_, before, bracketed, raw) {
var replaced = environment[bracketed || raw];
if(replaced != undefined) {
return before + replaced;
} else {
failed[0] = true;
}
}
}
}

15
src/Arguments.hs
View file

@ -6,7 +6,10 @@ module Arguments (
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Version (showVersion) import Data.Version (showVersion)
import Control.Applicative ((<|>), (<**>), optional) import Control.Applicative ((<|>), (<**>), optional)
import Options.Applicative (Parser, ReadM, argument, auto, eitherReader, execParser, flag', fullDesc, header, help, helper, info, long, metavar, short, str, value) import Options.Applicative (
Parser, ReadM, argument, auto, eitherReader, execParser, flag', fullDesc
, header, help, helper, info, long, metavar, short, str, switch, value
)
import qualified Options.Applicative as Optparse (option) import qualified Options.Applicative as Optparse (option)
import qualified Paths_hablo as Hablo (version) import qualified Paths_hablo as Hablo (version)
import System.FilePath (dropTrailingPathSeparator, isValid) import System.FilePath (dropTrailingPathSeparator, isValid)
@ -16,14 +19,17 @@ data Arguments = BlogConfig {
, articlesPath :: FilePath , articlesPath :: FilePath
, bannerPath :: Maybe FilePath , bannerPath :: Maybe FilePath
, cardImage :: Maybe FilePath , cardImage :: Maybe FilePath
, commentsAt :: Maybe String , commentsURL :: Maybe String
, favicon :: Maybe FilePath , favicon :: Maybe FilePath
, headPath :: Maybe FilePath , headPath :: Maybe FilePath
, name :: Maybe String , name :: Maybe String
, openGraphCards :: Bool
, pagesPath :: Maybe FilePath , pagesPath :: Maybe FilePath
, previewArticlesCount :: Int , previewArticlesCount :: Int
, previewLinesCount :: Int , previewLinesCount :: Int
, remarkableConfig :: Maybe FilePath , remarkableConfig :: Maybe FilePath
, rss :: Bool
, siteURL :: Maybe String
, wording :: Maybe FilePath , wording :: Maybe FilePath
} }
| Version | Version
@ -50,10 +56,11 @@ blogConfig = BlogConfig
) )
<*> option filePath 'b' "banner" "FILE" "path to the file to use for the blog's banner" <*> 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' "card-image" "FILE" "relative path to the image to use for the blog's card"
<*> option filePath 'C' "comments-at" "URL" "url of the instance where comments are stored" <*> option filePath 'C' "comments-url" "URL" "URL of the instance where comments are stored"
<*> option filePath 'f' "favicon" "FILE" "path to the image to use for the blog's favicon" <*> option filePath '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 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 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" <*> option filePath 'p' "pages"
"DIRECTORY" "relative path to the directory containing the pages within INPUT_DIR" "DIRECTORY" "relative path to the directory containing the pages within INPUT_DIR"
<*> Optparse.option auto ( <*> Optparse.option auto (
@ -72,6 +79,8 @@ blogConfig = BlogConfig
) )
<*> option filePath 'r' "remarkable-config" "FILE" <*> option filePath 'r' "remarkable-config" "FILE"
"path to a file containing a custom RemarkableJS configuration" "path to a file containing a custom RemarkableJS configuration"
<*> switch (short 'R' <> long "rss" <> help "enable RSS feeds generation")
<*> option filePath 'u' "site-url" "URL" "URL where the blog is published"
<*> option filePath 'w' "wording" "FILE" "path to the file containing the wording to use" <*> option filePath 'w' "wording" "FILE" "path to the file containing the wording to use"
version :: Parser Arguments version :: Parser Arguments

50
src/ArticlesList.hs
View file

@ -3,36 +3,46 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
module ArticlesList ( module ArticlesList (
ArticlesList(..) ArticlesList(..)
, otherUrl , description
, pageTitle , getArticles
, otherURL
, rssLinkTexts
) where ) where
import Article (Article) import Article (Article)
import Blog (Blog(..), get) import Blog (Blog(..), Renderer, Skin(..), template)
import Blog.Wording (render) import Collection (Collection(..))
import Control.Monad.Reader (MonadReader) import Control.Monad.Reader (MonadReader, asks)
import Data.Text (Text, pack) import Data.Text (Text, pack)
import Files (absoluteLink) import Files (absoluteLink)
import Pretty ((.$))
import System.FilePath.Posix ((</>)) import System.FilePath.Posix ((</>))
data ArticlesList = ArticlesList { data ArticlesList = ArticlesList {
tagged :: Maybe String full :: Bool
, full :: Bool , collection :: Collection
, featured :: [Article]
} }
otherUrl :: ArticlesList -> String getArticles :: MonadReader Blog m => ArticlesList -> m [Article]
otherUrl (ArticlesList {full, tagged}) = absoluteLink $ getArticles (ArticlesList {full, collection = Collection {featured}}) = do
(if full then id else (</> "all.html")) $ maybe "" id tagged limit <- take <$> (asks $skin.$previewArticlesCount)
return $ if full then featured else limit featured
pageTitle :: (MonadReader Blog m) => ArticlesList -> m Text otherURL :: ArticlesList -> String
pageTitle (ArticlesList {full, tagged}) = title (full, tagged) <$> Blog.get wording otherURL (ArticlesList {full, collection}) = absoluteLink $
(if full then id else (</> "all.html")) . maybe "" id $ tag collection
description :: Renderer m => ArticlesList -> m Text
description (ArticlesList {full, collection}) =
template page . environment $ tag collection
where where
title (True, Nothing) = render "allPage" [] page = if full then "allPage" else "latestPage"
title (True, Just tag) = render "allTaggedPage" [("tag", pack tag)] environment = maybe [] $ \value -> [("tag", pack value)]
title (False, Nothing) = render "latestPage" []
title (False, Just tag) = render "latestTaggedPage" [("tag", pack tag)]
rssLinkTexts :: Renderer m => ArticlesList -> m (Text, Text)
rssLinkTexts (ArticlesList {collection}) = do
text <- template "rssLink" []
title <- template "rssTitle" environment
return (text, title)
where
environment = maybe [] (\v -> [("tag", pack v)]) $ tag collection

29
src/Blog.hs
View file

@ -1,12 +1,15 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
module Blog ( module Blog (
Blog(..) Blog(..)
, Path(..) , Path(..)
, Renderer
, Skin(..) , Skin(..)
, URL(..)
, Wording , Wording
, build , build
, get , template
) where ) where
import Arguments (Arguments) import Arguments (Arguments)
@ -15,16 +18,22 @@ import Article (Article)
import qualified Article (at, getKey) import qualified Article (at, getKey)
import Blog.Path (Path(..)) import Blog.Path (Path(..))
import qualified Blog.Path as Path (build) import qualified Blog.Path as Path (build)
import Blog.Template (Environment, Templates, render)
import qualified Blog.Template as Template (build)
import Blog.Skin (Skin(..)) import Blog.Skin (Skin(..))
import qualified Blog.Skin as Skin (build) import qualified Blog.Skin as Skin (build)
import Blog.URL (URL(..))
import qualified Blog.URL as URL (build)
import Blog.Wording (Wording) import Blog.Wording (Wording)
import qualified Blog.Wording as Wording (build) import qualified Blog.Wording as Wording (build)
import Control.Monad ((>=>), filterM, foldM, forM) import Control.Monad ((>=>), filterM, foldM, forM)
import Control.Monad.Reader (MonadReader, ask) import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (MonadReader, asks)
import Data.Map (Map, insert, lookup) import Data.Map (Map, insert, lookup)
import qualified Data.Map as Map (empty, fromList) import qualified Data.Map as Map (empty, fromList)
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set (empty, null, singleton, union) import qualified Data.Set as Set (empty, null, singleton, union)
import Data.Text (Text)
import Files (File(..), absolute) import Files (File(..), absolute)
import qualified Files (find) import qualified Files (find)
import Page (Page) import Page (Page)
@ -39,16 +48,21 @@ type Parsed a = Either ParseError (String, a)
data Blog = Blog { data Blog = Blog {
articles :: Collection Article articles :: Collection Article
, hasRSS :: Bool
, name :: String , name :: String
, pages :: Collection Page , pages :: Collection Page
, path :: Path , path :: Path
, skin :: Skin , skin :: Skin
, tags :: Map String (Set String) , tags :: Map String (Set String)
, templates :: Templates
, urls :: URL
, wording :: Wording , wording :: Wording
} }
get :: MonadReader Blog m => (Blog -> a) -> m a type Renderer m = (MonadIO m, MonadReader Blog m)
get = (<$> ask)
template :: Renderer m => String -> Environment -> m Text
template key environment = asks templates >>= render key environment
keepOrWarn :: Collection a -> Parsed a -> IO (Collection a) keepOrWarn :: Collection a -> Parsed a -> IO (Collection a)
keepOrWarn accumulator (Left parseErrors) = keepOrWarn accumulator (Left parseErrors) =
@ -89,7 +103,10 @@ discover path = do
build :: Arguments -> IO Blog build :: Arguments -> IO Blog
build arguments = do build arguments = do
urls <- URL.build arguments
let hasRSS = maybe False (\_-> True) $ rss urls
wording <- Wording.build arguments wording <- Wording.build arguments
templates <- Template.build wording
root <- Files.absolute . Dir $ Arguments.sourceDir arguments root <- Files.absolute . Dir $ Arguments.sourceDir arguments
withCurrentDirectory root $ do withCurrentDirectory root $ do
path <- Path.build root arguments path <- Path.build root arguments
@ -97,4 +114,6 @@ build arguments = do
$ Arguments.name arguments $ Arguments.name arguments
skin <- Skin.build name arguments skin <- Skin.build name arguments
(articles, pages, tags) <- discover path (articles, pages, tags) <- discover path
return $ Blog {articles, name, pages, path, skin, tags, wording} return $ Blog {
articles, hasRSS, name, pages, path, skin, tags, templates, urls, wording
}

10
src/Blog/Path.hs
View file

@ -16,16 +16,14 @@ import System.Directory (doesDirectoryExist)
data Path = Path { data Path = Path {
articlesPath :: FilePath articlesPath :: FilePath
, commentsAt :: Maybe String
, pagesPath :: Maybe FilePath , pagesPath :: Maybe FilePath
, remarkableConfig :: Maybe FilePath , remarkableConfig :: Maybe FilePath
, root :: FilePath , root :: FilePath
} deriving Generic } deriving Generic
instance ToJSON Path where instance ToJSON Path where
toEncoding (Path {articlesPath, commentsAt, pagesPath}) = pairs ( toEncoding (Path {articlesPath, pagesPath}) = pairs (
"articlesPath" .= articlesPath "articlesPath" .= articlesPath
<> "commentsAt" .= commentsAt
<> "pagesPath" .= pagesPath <> "pagesPath" .= pagesPath
) )
@ -40,8 +38,4 @@ build root arguments = do
articlesPath <- filePath . Dir $ Arguments.articlesPath arguments articlesPath <- filePath . Dir $ Arguments.articlesPath arguments
pagesPath <- getPagesPath $ Arguments.pagesPath arguments pagesPath <- getPagesPath $ Arguments.pagesPath arguments
remarkableConfig <- mapM (filePath . File) $ Arguments.remarkableConfig arguments remarkableConfig <- mapM (filePath . File) $ Arguments.remarkableConfig arguments
return $ Path { return $ Path {articlesPath, pagesPath, remarkableConfig, root}
articlesPath, commentsAt, pagesPath, remarkableConfig, root
}
where
commentsAt = Arguments.commentsAt arguments

69
src/Blog/Template.hs Normal file
View file

@ -0,0 +1,69 @@
{-# LANGUAGE OverloadedStrings #-}
module Blog.Template (
Environment
, Templates(..)
, build
, render
) where
import Blog.Wording (Wording(..), variables)
import Control.Monad (foldM)
import Control.Monad.IO.Class (MonadIO(..))
import Data.List (intercalate)
import Data.Map (Map, (!))
import qualified Data.Map as Map (empty, insert, keys)
import Data.Text (Text, breakOn)
import qualified Data.Text as Text (concat, drop, null, unpack)
import Data.Text.Lazy (toStrict)
import Data.Text.Template (Template, renderA, showTemplate, templateSafe)
import System.Exit (die)
data TemplateChunk = Top Template | Sub Template
newtype HabloTemplate = HabloTemplate [TemplateChunk]
newtype Templates = Templates (Map String HabloTemplate)
type Environment = [(Text, Text)]
render :: MonadIO m => String -> Environment -> Templates -> m Text
render key environment (Templates templates) =
(Text.concat . fmap toStrict) <$> mapM renderChunk templateChunks
where
HabloTemplate templateChunks = templates ! key
renderer template = renderA template (flip lookup environment)
renderChunk (Top template) =
let err = "Could not template " ++ Text.unpack (showTemplate template) in
maybe (liftIO $ die err) return $ renderer template
renderChunk (Sub template) = return . maybe "" id $ renderer template
makeTemplate :: String -> Text -> IO Template
makeTemplate key templateText =
let testEnvironment = flip lookup [(s, "") | s <- availableVariables] in
case templateSafe templateText of
Left (row, col) -> die $ syntaxError (show row) (show col)
Right template ->
maybe (die badTemplate) (return . const template) (renderA template testEnvironment)
where
availableVariables = variables ! key
variablesMessage =
" (available variables: " ++ intercalate ", " (Text.unpack <$> availableVariables) ++ ")"
syntaxError row col =
"Syntax error in template for variable " ++ key ++ "at l." ++ row ++ ", c." ++ col
badTemplate = "Invalid template for variable " ++ key ++ variablesMessage
makeHabloTemplate :: String -> Map String Text -> IO HabloTemplate
makeHabloTemplate key wording = HabloTemplate <$> toHablo True (wording ! key)
where
toHablo _ "" = return []
toHablo atTop template = do
let (start, rest) = (Text.drop 2) <$> breakOn (delimiter atTop) template
push atTop start <*> toHablo (not atTop) rest
delimiter atTop = if atTop then "{?" else "?}"
push atTop t
| Text.null t = return id
| otherwise = (:) . (if atTop then Top else Sub) <$> makeTemplate key t
build :: Wording -> IO Templates
build (Wording wordingMap) =
Templates <$> foldM templateWording Map.empty (Map.keys variables)
where
templateWording templated key =
flip (Map.insert key) templated <$> makeHabloTemplate key wordingMap

45
src/Blog/URL.hs Normal file
View file

@ -0,0 +1,45 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Blog.URL (
URL(..)
, build
) where
import Arguments (Arguments)
import qualified Arguments as Arguments (Arguments(..))
import Data.Aeson (ToJSON(..), (.=), pairs)
import GHC.Generics (Generic)
import System.Exit (die)
import System.IO (hPutStrLn, stderr)
import Text.Printf (printf)
data URL = URL {
cards :: Maybe String
, comments :: Maybe String
, rss :: Maybe String
} deriving Generic
instance ToJSON URL where
toEncoding (URL {comments}) = pairs (
"comments" .= comments
)
build :: Arguments -> IO URL
build arguments = do
cards <- getSiteURL argOGCards "Open Graph cards"
rss <- getSiteURL argRSS "RSS feeds"
checksUsed (argOGCards || argRSS) siteURL
return $ URL {cards, comments, rss}
where
comments = Arguments.commentsURL arguments
siteURL = Arguments.siteURL arguments
argOGCards = Arguments.openGraphCards arguments
argRSS = Arguments.rss arguments
errorMsg :: String -> String
errorMsg = printf "Enabling %s requires setting the site url with --site-url"
getSiteURL False _ = return Nothing
getSiteURL True name = maybe (die $ errorMsg name) (return . Just) siteURL
checksUsed False (Just _) =
hPutStrLn stderr "Site url is set but not used, did you forget --open-graph-cards or --rss ?"
checksUsed _ _ = return ()

56
src/Blog/Wording.hs
View file

@ -1,22 +1,17 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Blog.Wording ( module Blog.Wording (
Wording(..) Wording(..)
, build , build
, render , variables
) where ) where
import Arguments (Arguments(..)) import Arguments (Arguments(..))
import Control.Monad (foldM) import Control.Monad (foldM)
import Data.Aeson (ToJSON(..)) import Data.Aeson (ToJSON(..))
import Data.List (intercalate) import Data.Map (Map)
import Data.Map (Map, (!)) import qualified Data.Map as Map (empty, fromList, keys, map, union)
import qualified Data.Map as Map (empty, fromList, insert, keys, map, union)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text (pack, unpack) import qualified Data.Text as Text (pack)
import Data.Text.Lazy (toStrict)
import Data.Text.Template (Template, renderA, showTemplate, templateSafe)
import qualified Data.Text.Template as Template (render)
import Paths_hablo (getDataFileName) import Paths_hablo (getDataFileName)
import Text.ParserCombinators.Parsec ( import Text.ParserCombinators.Parsec (
Parser Parser
@ -25,31 +20,26 @@ import Text.ParserCombinators.Parsec (
) )
import System.Exit (die) import System.Exit (die)
newtype Wording = Wording (Map String Template) newtype Wording = Wording (Map String Text)
variables :: Map String [Text] variables :: Map String [Text]
variables = Map.fromList [ variables = Map.fromList [
("allLink", []) ("allLink", [])
, ("allPage", []) , ("allPage", ["tag"])
, ("allTaggedPage", ["tag"])
, ("commentsLink", []) , ("commentsLink", [])
, ("commentsSection", []) , ("commentsSection", [])
, ("dateFormat", []) , ("dateFormat", [])
, ("latestLink", []) , ("latestLink", [])
, ("latestPage", []) , ("latestPage", ["tag"])
, ("latestTaggedPage", ["tag"])
, ("metadata", ["author", "date", "tags"]) , ("metadata", ["author", "date", "tags"])
, ("rssLink", [])
, ("rssTitle", ["tag"])
, ("tagsList", []) , ("tagsList", [])
] ]
instance ToJSON Wording where instance ToJSON Wording where
toJSON (Wording m) = toJSON (showTemplate <$> m) toJSON (Wording m) = toJSON m
toEncoding (Wording m) = toEncoding (showTemplate <$> m) toEncoding (Wording m) = toEncoding m
render :: String -> [(Text, Text)] -> Wording -> Text
render key env (Wording wMap) =
toStrict $ Template.render (wMap ! key) (Map.fromList env !)
addWording :: Map String Text -> FilePath -> IO (Map String Text) addWording :: Map String Text -> FilePath -> IO (Map String Text)
addWording currentWording wordingFile = do addWording currentWording wordingFile = do
@ -65,30 +55,12 @@ wordingP = Map.map Text.pack . Map.fromList <$>
restOfLine = many $ noneOf "\r\n" restOfLine = many $ noneOf "\r\n"
eol = try (string "\r\n") <|> string "\r" <|> string "\n" eol = try (string "\r\n") <|> string "\r" <|> string "\n"
skip = optional (char '#' *> restOfLine) *> eol skip = optional (char '#' *> restOfLine) *> eol
line = (,) <$> (choice (try . string <$> Map.keys variables) <* equal) <*> restOfLine varEqual = choice (try . string <$> Map.keys variables) <* equal
line = (,) <$> varEqual <*> restOfLine
equal = many (char ' ') *> char '=' *> many (char ' ') equal = many (char ' ') *> char '=' *> many (char ' ')
makeTemplate :: String -> Map String Text -> IO Template
makeTemplate key wording =
let templateText = wording ! key in
let testEnvironment = flip lookup [(s, "") | s <- availableVariables] in
case templateSafe templateText of
Left (row, col) -> die $ syntaxError (show row) (show col)
Right template ->
maybe (die badTemplate) (return . const template) (renderA template testEnvironment)
where
availableVariables = variables ! key
variablesMessage =
" (available variables: " ++ intercalate ", " (Text.unpack <$> availableVariables) ++ ")"
syntaxError row col =
"Syntax error in template for variable " ++ key ++ "at l." ++ row ++ ", c." ++ col
badTemplate = "Invalid template for variable " ++ key ++ variablesMessage
build :: Arguments -> IO Wording build :: Arguments -> IO Wording
build arguments = do build arguments = do
defaultWording <- getDataFileName "defaultWording.conf" defaultWording <- getDataFileName "defaultWording.conf"
let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording] let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording]
wordindMap <- foldM addWording Map.empty wordingFiles Wording <$> foldM addWording Map.empty wordingFiles
Wording <$> foldM (
\templated key -> flip (Map.insert key) templated <$> makeTemplate key wordindMap
) Map.empty (Map.keys variables)

53
src/Collection.hs Normal file
View file

@ -0,0 +1,53 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Collection (
Collection(..)
, getAll
, title
) where
import Article(Article(metadata))
import Blog (Blog(..), Path(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (MonadReader(..), ReaderT, asks)
import Data.List (sortOn)
import Data.Map ((!))
import qualified Data.Map as Map (elems, filterWithKey, toList)
import Data.Ord (Down(..))
import qualified Data.Set as Set (member)
import Pretty ((.$))
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>))
data Collection = Collection {
featured :: [Article]
, basePath :: FilePath
, tag :: Maybe String
}
build :: MonadIO m => [Article] -> Maybe String -> ReaderT Blog m Collection
build featured tag = do
root <- asks $path.$root
let basePath = maybe root (root </>) tag
liftIO $ createDirectoryIfMissing False basePath
return $ Collection {
featured = sortByDate featured, basePath, tag
}
where
sortByDate = sortOn (Down . (! "date") . metadata)
getAll :: ReaderT Blog IO [Collection]
getAll = do
Blog {articles, tags} <- ask
(:)
<$> (build (Map.elems articles) Nothing)
<*> (flip mapM (Map.toList tags) $
\(tag, tagged) -> build (getArticles tagged articles) $ Just tag
)
where
getArticles tagged =
Map.elems . Map.filterWithKey (\k _ -> Set.member k tagged)
title :: MonadReader Blog m => Collection -> m String
title (Collection {tag}) = do
asks $ (\name -> maybe name ((name ++ " - ") ++) tag) . name

105
src/DOM.hs Normal file
View file

@ -0,0 +1,105 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module DOM (
page
) where
import Article (Article(..))
import qualified Article (preview)
import ArticlesList (
ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
)
import Blog (Blog(..), Path(..), Skin(..), URL(..), template)
import Control.Monad.Reader (ReaderT, asks)
import qualified Data.Map as Map (keys)
import Data.Text (pack, empty)
import DOM.Card (HasCard)
import qualified DOM.Card as Card (make)
import Files (absoluteLink)
import Lucid (
HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_, h1_, h2_
, head_, header_, href_, li_, link_, id_, meta_, pre_, rel_, script_, src_
, title_, toHtml, toHtmlRaw, type_, ul_
)
import Prelude hiding (head, lookup)
import Pretty ((.$))
import System.FilePath.Posix ((</>), (<.>))
type HtmlGenerator = HtmlT (ReaderT Blog IO)
class HasCard a => Page a where
content :: a -> HtmlGenerator ()
instance Page Article where
content = article True
instance Page ArticlesList where
content al@(ArticlesList {full}) = do
preview <- Article.preview <$> (asks $skin.$previewLinesCount)
h2_ . toHtml =<< description al
ul_ $ do
asks hasRSS >>= rssLink
li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
div_ [class_ "articles"] (
mapM_ (article False . preview) =<< getArticles al
)
where
otherLink =
toHtml <$> template (if full then "latestLink" else "allLink") []
rssLink :: Bool -> HtmlGenerator ()
rssLink True = do
(text, title) <- rssLinkTexts al
li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text
rssLink False = return ()
article :: Bool -> Article -> HtmlGenerator ()
article raw (Article {key, body, Article.title}) = do
url <- absoluteLink . (</> key <.> extension) <$> (asks $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"
tag :: String -> HtmlGenerator ()
tag name = li_ (
a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name
)
defaultBanner :: HtmlGenerator ()
defaultBanner = do
div_ [id_ "header"] (
a_ [href_ "/"] (
h1_ . toHtml =<< asks name
)
)
faviconLink :: FilePath -> HtmlGenerator ()
faviconLink url = link_ [rel_ "shortcut icon", href_ $ pack url, type_ "image/x-icon"]
optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator ()
optional = maybe (return ())
page :: Page a => a -> HtmlGenerator ()
page aPage =
doctypehtml_ (do
head_ (do
meta_ [charset_ "utf-8"]
title_ . toHtml =<< asks name
script_ [src_ "/js/remarkable.min.js"] empty
script_ [src_ "/js/hablo.js"] empty
optional faviconLink =<< (asks $skin.$favicon)
optional (Card.make aPage) =<< (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
)
)

79
src/DOM/Card.hs Normal file
View file

@ -0,0 +1,79 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module DOM.Card (
Card(..)
, HasCard(..)
, make
) where
import qualified Article (Article(..))
import ArticlesList (ArticlesList(..))
import qualified ArticlesList (description)
import Blog (Blog(..), Renderer, Skin(..))
import Collection (Collection(..))
import qualified Collection (title)
import Control.Applicative ((<|>))
import Control.Monad.Reader (asks)
import qualified Data.Map as Map (lookup)
import Data.Text (Text, pack)
import Lucid (HtmlT, content_, meta_)
import Lucid.Base (makeAttribute)
import Pretty ((.$))
data Card = Card {
cardType :: Text
, description :: Text
, image :: Maybe String
, title :: String
, urlPath :: String
}
class HasCard a where
getCard :: Renderer m => a -> m Card
og :: Applicative m => Text -> Text -> HtmlT m ()
og attribute value =
meta_ [
makeAttribute "property" $ "og:" <> attribute
, content_ value
]
make :: (HasCard a, Renderer m) => a -> String -> HtmlT m ()
make element siteURL = do
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 "site_name" =<< (asks $name.$pack)
where
maybeImage = maybe (return ()) (og "image" . 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
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
}
where
file = '/' : (if full al then "all" else "index") ++ ".html"

117
src/Dom.hs
View file

@ -1,117 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Dom (
page
) where
import Article (Article(..))
import qualified Article (preview)
import ArticlesList (ArticlesList(..), otherUrl, pageTitle)
import Blog (Blog(..), Path(..), Skin(..))
import qualified Blog (get)
import Blog.Wording (render)
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
link = render (if full then "latestLink" else "allLink") []
otherLink = Blog.get $wording.$(link)
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.$(render "tagsList" []).$toHtml)
ul_ . mapM_ tag . Map.keys =<< Blog.get tags
)
div_ [id_ "contents"] $ content aPage
)
)

80
src/HTML.hs
View file

@ -6,79 +6,39 @@ module HTML (
import Article(Article(..)) import Article(Article(..))
import ArticlesList (ArticlesList(..)) import ArticlesList (ArticlesList(..))
import Blog (Blog(..), Path(..), Skin(..)) import Blog (Blog(..), Path(..))
import qualified Blog (get) import Collection (Collection(..))
import Control.Monad (forM) import qualified Collection (getAll)
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (MonadReader(..), ReaderT) import Control.Monad.Reader (ReaderT, asks)
import Data.List (sortOn) import qualified Data.Map as Map (elems)
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 qualified Data.Text.Lazy.IO as TextIO (writeFile)
import Dom (page) import DOM (page)
import Lucid import Lucid (renderTextT)
import Pretty ((.$)) import Pretty ((.$))
import System.Directory (createDirectoryIfMissing)
import System.FilePath.Posix ((</>), (<.>)) import System.FilePath.Posix ((</>), (<.>))
data Collection = Collection { articlesLists :: Collection -> [(FilePath, ArticlesList)]
articlesFeatured :: [Article] articlesLists collection@(Collection {basePath}) = [
, basePath :: FilePath (path full, ArticlesList {collection, full}) | full <- [False, True]
, 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 where
sortByDate = sortOn (Down . (! "date") . metadata) file bool = if bool then "all" else "index"
path bool = basePath </> file bool <.> "html"
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 :: [Article] -> ReaderT Blog IO ()
generateArticles = mapM_ $ \article -> do generateArticles = mapM_ $ \article -> do
baseDir <- (</>) <$> (Blog.get $path.$root) <*> (Blog.get $path.$articlesPath) baseDir <- (</>) <$> (asks $path.$root) <*> (asks $path.$articlesPath)
(renderTextT $ page article) (renderTextT $ page article)
>>= liftIO . TextIO.writeFile (baseDir </> key article <.> "html") >>= liftIO . TextIO.writeFile (baseDir </> key article <.> "html")
generateCollection :: Collection -> ReaderT Blog IO () generateCollection :: Collection -> ReaderT Blog IO ()
generateCollection (Collection {articlesFeatured = []}) = return () generateCollection (Collection {featured = []}) = return ()
generateCollection aCollection = do generateCollection collection =
liftIO . createDirectoryIfMissing False $ basePath aCollection flip mapM_ (articlesLists collection) $ \(filePath, articlesList) ->
articlesLists aCollection (renderTextT $ page articlesList) >>= liftIO . TextIO.writeFile filePath
>>= (mapM_ $ \(filePath, articlesList) ->
(renderTextT $ page articlesList)
>>= liftIO . TextIO.writeFile filePath
)
generate :: ReaderT Blog IO () generate :: ReaderT Blog IO ()
generate = do generate = do
Blog {articles, tags} <- ask asks articles >>= generateArticles . Map.elems
generateArticles $ Map.elems articles Collection.getAll >>= mapM_ generateCollection
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)

54
src/JS.hs
View file

@ -4,37 +4,53 @@ module JS (
) where ) where
import Blog (Blog(..), Path(..)) import Blog (Blog(..), Path(..))
import qualified Blog (get)
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (ReaderT) import Control.Monad.Reader (ReaderT, asks)
import Data.ByteString.Lazy (ByteString, concat, readFile, writeFile) import Data.ByteString.Lazy (
ByteString, concat, intercalate, fromStrict, readFile, writeFile
)
import Data.ByteString.Lazy.Char8 (pack) import Data.ByteString.Lazy.Char8 (pack)
import qualified Files (find) import Data.Text.Encoding (encodeUtf8)
import JSON (exportBlog) import JSON (exportBlog)
import Paths_hablo (getDataDir) import Paths_hablo (getDataDir)
import Pretty ((.$)) import Pretty ((.$))
import SJW (compile, source, sourceCode)
import System.Directory (createDirectoryIfMissing) import System.Directory (createDirectoryIfMissing)
import System.Exit (die)
import System.FilePath ((</>)) import System.FilePath ((</>))
import Prelude hiding (concat, readFile, writeFile) import Prelude hiding (concat, readFile, writeFile)
compile :: [ByteString] -> ByteString object :: [ByteString] -> ByteString
compile sources = concat (header:sources ++ [footer]) object sources = concat [header, intercalate ",\n" sources, footer]
where where
header = "(function() {\n" header = "return {\n"
footer = "})();" footer = "\n};"
var :: (String, ByteString) -> ByteString var :: (String, ByteString) -> ByteString
var (varName, content) = concat ["var ", pack varName, " = ", content, ";\n"] var (varName, content) = concat ["\t", pack varName, " : ", content]
generateConfig :: FilePath -> ReaderT Blog IO ()
generateConfig destinationDir = do
blogJSON <- exportBlog
remarkablePath <- asks $path.$remarkableConfig
liftIO $ do
remarkableJSON <- maybe (return "{html: true}") readFile remarkablePath
let jsVars = [("blog", blogJSON), ("remarkableConfig", remarkableJSON)]
writeFile configModule . object $ var <$> jsVars
where
configModule = destinationDir </> "Hablo" </> "Config.js"
generateMain :: FilePath -> IO ()
generateMain destinationDir = do
habloSources <- (</> "js") <$> getDataDir
result <- compile $ source [destinationDir, "unitJS", habloSources]
maybe (die "JS compilation failed\n") output =<< sourceCode result
where
output = writeFile (destinationDir </> "hablo.js") . fromStrict . encodeUtf8
generate :: ReaderT Blog IO () generate :: ReaderT Blog IO ()
generate = do generate = do
destinationDir <- (</> "js") <$> (Blog.get $path.$root) destinationDir <- asks $path.$root.$(</> "js")
blogJSON <- exportBlog liftIO . createDirectoryIfMissing True $ destinationDir </> "Hablo"
remarkablePath <- Blog.get $path.$remarkableConfig generateConfig destinationDir
liftIO $ do liftIO $ generateMain destinationDir
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 )

6
src/JSON.hs
View file

@ -6,7 +6,7 @@ module JSON (
import Article (Article) import Article (Article)
import qualified Article (Article(..)) import qualified Article (Article(..))
import Blog (Blog, Path, Skin, Wording) import Blog (Blog, Path, Skin, URL, Wording)
import qualified Blog (Blog(..)) import qualified Blog (Blog(..))
import Control.Monad.Reader (ReaderT, ask) import Control.Monad.Reader (ReaderT, ask)
import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions, encode) import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions, encode)
@ -28,9 +28,11 @@ instance ToJSON ArticleExport where
data BlogDB = BlogDB { data BlogDB = BlogDB {
articles :: Map String ArticleExport articles :: Map String ArticleExport
, hasRSS :: Bool
, path :: Path , path :: Path
, skin :: Skin , skin :: Skin
, tags :: Map String [String] , tags :: Map String [String]
, urls :: URL
, wording :: Wording , wording :: Wording
} deriving (Generic) } deriving (Generic)
@ -50,8 +52,10 @@ exportBlog = do
blog <- ask blog <- ask
return . encode $ BlogDB { return . encode $ BlogDB {
articles = mapWithKey (exportArticle blog) $ Blog.articles blog articles = mapWithKey (exportArticle blog) $ Blog.articles blog
, hasRSS = Blog.hasRSS blog
, path = Blog.path blog , path = Blog.path blog
, skin = Blog.skin blog , skin = Blog.skin blog
, tags = Set.elems <$> Blog.tags blog , tags = Set.elems <$> Blog.tags blog
, urls = Blog.urls blog
, wording = Blog.wording blog , wording = Blog.wording blog
} }

2
src/Main.hs
View file

@ -8,6 +8,7 @@ import Data.Version (showVersion)
import qualified HTML (generate) import qualified HTML (generate)
import qualified JS (generate) import qualified JS (generate)
import qualified Paths_hablo as Hablo (version) import qualified Paths_hablo as Hablo (version)
import qualified RSS (generate)
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
main :: IO () main :: IO ()
@ -18,4 +19,5 @@ main = do
config@(BlogConfig {}) -> Blog.build config >>= runReaderT (do config@(BlogConfig {}) -> Blog.build config >>= runReaderT (do
HTML.generate HTML.generate
JS.generate JS.generate
RSS.generate
) )

93
src/RSS.hs Normal file
View file

@ -0,0 +1,93 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module RSS (
generate
) where
import Article (Article(..))
import ArticlesList (ArticlesList(..), getArticles)
import qualified ArticlesList (description)
import Blog (Blog(..), Path(..), Renderer, URL(..))
import Collection (Collection(..), getAll)
import qualified Collection (title)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (MonadReader, ReaderT, asks)
import Data.Text (Text)
import Data.Map ((!))
import qualified Data.Text.Lazy.IO as TextIO (writeFile)
import Data.Time (defaultTimeLocale, formatTime, rfc822DateFormat)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Lucid (Attribute, HtmlT, Term, ToHtml(..), term, renderTextT)
import Lucid.Base (makeAttribute)
import Pretty ((.$))
import System.FilePath.Posix ((</>), (<.>))
prolog :: Monad m => HtmlT m ()
prolog = toHtmlRaw ("<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" :: String)
version_ :: Text -> Attribute
version_ = makeAttribute "version"
xmlns_content_ :: Text -> Attribute
xmlns_content_ = makeAttribute "xmlns:content"
xmlns_atom_ :: Text -> Attribute
xmlns_atom_ = makeAttribute "xmlns:atom"
rss_ :: Term arg result => arg -> result
rss_ = term "rss"
channel_ :: Term arg result => arg -> result
channel_ = term "channel"
title_ :: Term arg result => arg -> result
title_ = term "title"
link_ :: Term arg result => arg -> result
link_ = term "link"
description_ :: Term arg result => arg -> result
description_ = term "description"
item_ :: Term arg result => arg -> result
item_ = term "item"
pubDate_ :: Term arg result => arg -> result
pubDate_ = term "pubDate"
articleItem :: MonadReader Blog m => String -> Article -> HtmlT m ()
articleItem siteURL (Article {key, metadata, title}) =
item_ $ do
title_ $ toHtml title
link_ . toHtml =<< link <$> (asks $path.$articlesPath)
pubDate_ . toHtml . rfc822Date $ metadata ! "date"
where
link path = siteURL </> path </> key <.> "html"
rfc822Date =
formatTime defaultTimeLocale rfc822DateFormat
. posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)
feed :: Renderer m => String -> ArticlesList -> HtmlT m ()
feed siteURL al@(ArticlesList {collection}) = do
prolog
rss_ [version, content, atom] $ do
channel_ $ do
title_ . toHtml =<< Collection.title collection
link_ . toHtml $ siteURL </> maybe "" (++ "/") (tag collection)
description_ . toHtml =<< ArticlesList.description al
mapM_ (articleItem siteURL) =<< getArticles al
where
version = version_ "2.0"
content = xmlns_content_ "http://purl.org/rss/1.0/modules/content/"
atom = xmlns_atom_ "http://www.w3.org/2005/Atom"
generateCollection :: String -> Collection -> ReaderT Blog IO ()
generateCollection siteURL collection =
renderTextT (feed siteURL $ ArticlesList {full = False, collection})
>>= liftIO . TextIO.writeFile (basePath collection </> "rss" <.> "xml")
generate :: ReaderT Blog IO ()
generate = (asks $urls.$rss) >>= maybe (return ()) generateAll
where
generateAll siteURL = Collection.getAll >>= mapM_ (generateCollection siteURL)