reynir/blog.robur.coop
1
0
Fork 0
forked from robur/blog.robur.coop
Code Pull requests Activity

Upgrade to the unreleased version of YOCaml 2

Browse source
This commit is contained in:
Calascibetta Romain 2024-09-30 20:39:49 +02:00
parent aa6bcc5277
commit 6b343af91c
35 changed files with 822 additions and 971 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
.gitignore vendored Normal file
View file

@ -0,0 +1,3 @@
_build/
_site/
_cache

13
README.md
View file

@ -10,25 +10,26 @@ $ git clone git@git.robur.coop:robur/blog.robur.coop
$ cd blog.robur.coop/
$ opam pin add -yn .
$ opam install --deps-only blogger
$ dune exec src/blogger.exe -- watch
$ dune exec src/watch.exe --
```
A little server run on `http://localhost:8888`.
A little server run on `http://localhost:8000`.
The user can add an article into the `articles/` directory. The format is easy.
A simple header which starts with `---` and finish with `---`. Inside, you have
a YAML description of the article where some fields are required:
- `date`
- `article.title`
- `article.description`
- `title`
- `description`
- `tags`
You can specify an `author` (with its `name`, `email` and `link`) or not. By
default, we use `team@robur.coop`. If everything looks good, you can generate
via the `blogger.exe` tool the generated website via:
```shell-session
$ dune exec src/blogger.exe -- push \
-r git@git.robur.coop:robur/blog.robur.coop.git#gh-pages
$ dune exec src/push.exe -- push \
-r git@git.robur.coop:robur/blog.robur.coop.git#gh-pages \
--host https://blog.robur.coop
[--name "The Robur team"] \
[--email team@robur.coop]
```

4
articles/2024-02-03-python-str-repr.md
View file

@ -1,7 +1,7 @@
---
date: 2024-02-03
article.title: Python's `str.__repr__()`
article.description: Reimplementing Python string escaping in OCaml
title: Python's `str.__repr__()`
description: Reimplementing Python string escaping in OCaml
tags:
- OCaml
- Python

4
articles/2024-08-21-OpenVPN-and-MirageVPN.markdown → articles/2024-08-21-OpenVPN-and-MirageVPN.md
View file

@ -1,7 +1,7 @@
---
date: 2024-08-21
article.title: MirageVPN and OpenVPN
article.description: Discoveries made implementing MirageVPN, a OpenVPN-compatible VPN library
title: MirageVPN and OpenVPN
description: Discoveries made implementing MirageVPN, a OpenVPN-compatible VPN library
tags:
- MirageVPN
- OpenVPN

4
articles/gptar.md
View file

@ -1,7 +1,7 @@
---
date: 2024-02-21
article.title: GPTar
article.description: Hybrid GUID partition table and tar archive
title: GPTar
description: Hybrid GUID partition table and tar archive
tags:
- OCaml
- gpt

8
articles/lwt_pause.md
View file

@ -1,7 +1,7 @@
---
date: 2024-02-11
article.title: Cooperation and Lwt.pause
article.description:
title: Cooperation and Lwt.pause
description:
A disgression about Lwt and Miou
tags:
- OCaml
@ -9,6 +9,10 @@ tags:
- Community
- Unikernel
- Git
author:
name: Romain Calascibetta
email: romain.calascibetta@gmail.com
link: https://blog.osau.re/
breaks: false
---

4
articles/miragevpn-ncp.md
View file

@ -1,7 +1,7 @@
---
date: 2023-11-20
article.title: MirageVPN updated (AEAD, NCP)
article.description:
title: MirageVPN updated (AEAD, NCP)
description:
How we resurrected MirageVPN from its bitrot state
tags:
- OCaml

5
articles/miragevpn-performance.md
View file

@ -1,7 +1,7 @@
---
date: 2024-04-16
article.title: Speeding up MirageVPN and use it in the wild
article.description:
title: Speeding up MirageVPN and use it in the wild
description:
Performance engineering of MirageVPN, speeding it up by a factor of 25.
tags:
- OCaml
@ -19,7 +19,6 @@ coauthors:
name: Reynir Björnsson
email: reynir@reynir.dk
link: https://reyn.ir/
contribution: What is this field used for?
---
As we were busy continuing to work on [MirageVPN](https://github.com/robur-coop/miragevpn), we got in touch with [eduVPN](https://eduvpn.org), who are interested about deploying MirageVPN. We got example configuration from their side, and [fixed](https://github.com/robur-coop/miragevpn/pull/201) [some](https://github.com/robur-coop/miragevpn/pull/168) [issues](https://github.com/robur-coop/miragevpn/pull/202), and also implemented [tls-crypt](https://github.com/robur-coop/miragevpn/pull/169) - which was straightforward since we earlier spend time to implement [tls-crypt-v2](https://blog.robur.coop/articles/miragevpn.html).

7
articles/miragevpn-server.md
View file

@ -1,7 +1,7 @@
---
date: 2024-06-17
article.title: MirageVPN server
article.description:
title: MirageVPN server
description:
Announcement of our MirageVPN server.
tags:
- OCaml
@ -18,7 +18,6 @@ coauthors:
name: Reynir Björnsson
email: reynir@reynir.dk
link: https://reyn.ir/
contribution: What is this field used for?
---
It is a great pleasure to finally announce that we have finished a server implementation for MirageVPN (OpenVPN™-compatible). This allows to setup a very robust VPN network on both the client and the server side.
@ -37,4 +36,4 @@ The overall progress was tracked in [this issue](https://github.com/robur-coop/m
Please move along to our handbook with the [chapter on MirageVPN server](https://robur-coop.github.io/miragevpn-handbook/miragevpn_server.html).
If you encounter any issues, please open an issue at [the repository](https://github.com/robur-coop/miragevpn).
If you encounter any issues, please open an issue at [the repository](https://github.com/robur-coop/miragevpn).

4
articles/miragevpn.md
View file

@ -1,7 +1,7 @@
---
date: 2023-11-14
article.title: MirageVPN & tls-crypt-v2
article.description:
title: MirageVPN & tls-crypt-v2
description:
How we implementated tls-crypt-v2 for miragevpn
tags:
- OCaml

4
articles/qubes-miragevpn.md
View file

@ -1,7 +1,7 @@
---
date: 2024-06-24
article.title: qubes-miragevpn, a MirageVPN client for QubesOS
article.description: A new OpenVPN client for QubesOS
title: qubes-miragevpn, a MirageVPN client for QubesOS
description: A new OpenVPN client for QubesOS
tags:
- OCaml
- vpn

6
articles/speeding-ec-string.md
View file

@ -1,7 +1,7 @@
---
date: 2024-02-13
article.title: Speeding elliptic curve cryptography
article.description:
title: Speeding elliptic curve cryptography
description:
How we improved the performance of elliptic curves by only modifying the underlying byte array
tags:
- OCaml
@ -95,4 +95,4 @@ Remove all cstruct, everywhere, apart from in mirage-block-xen and mirage-net-xe
Our MirageOS work is only partially funded, we cross-fund our work by commercial contracts and public (EU) funding. We are part of a non-profit company, you can make a (tax-deducable - at least in the EU) [donation](https://aenderwerk.de/donate/) (select "DONATION robur" in the dropdown menu).
We're keen to get MirageOS deployed in production - if you would like to do that, don't hesitate to reach out to us via eMail team at robur.coop
We're keen to get MirageOS deployed in production - if you would like to do that, don't hesitate to reach out to us via eMail team at robur.coop

4
articles/tar-release.md
View file

@ -1,7 +1,7 @@
---
date: 2024-08-15
article.title: The new Tar release, a retrospective
article.description: A little retrospective to the new Tar release and changes
title: The new Tar release, a retrospective
description: A little retrospective to the new Tar release and changes
tags:
- OCaml
- Cstruct

638
bin/blog.ml Normal file
View file

@ -0,0 +1,638 @@
open Yocaml
let is_empty_list = function [] -> true | _ -> false
module Date = struct
type month =
| Jan
| Feb
| Mar
| Apr
| May
| Jun
| Jul
| Aug
| Sep
| Oct
| Nov
| Dec
type day_of_week = Mon | Tue | Wed | Thu | Fri | Sat | Sun
type year = int
type day = int
type hour = int
type min = int
type sec = int
type t = {
year : year
; month : month
; day : day
; hour : hour
; min : min
; sec : sec
}
let invalid_int x message =
Data.Validation.fail_with ~given:(string_of_int x) message
let month_from_int x =
if x > 0 && x <= 12 then
Result.ok
[| Jan; Feb; Mar; Apr; May; Jun; Jul; Aug; Sep; Oct; Nov; Dec |].(x - 1)
else invalid_int x "Invalid month value"
let year_from_int x =
if x >= 0 then Result.ok x else invalid_int x "Invalid year value"
let is_leap year =
if year mod 100 = 0 then year mod 400 = 0 else year mod 4 = 0
let days_in_month year month =
match month with
| Jan | Mar | May | Jul | Aug | Oct | Dec -> 31
| Feb -> if is_leap year then 29 else 28
| _ -> 30
let day_from_int year month x =
let dim = days_in_month year month in
if x >= 1 && x <= dim then Result.ok x
else invalid_int x "Invalid day value"
let hour_from_int x =
if x >= 0 && x < 24 then Result.ok x else invalid_int x "Invalid hour value"
let min_from_int x =
if x >= 0 && x < 60 then Result.ok x else invalid_int x "Invalid min value"
let sec_from_int x =
if x >= 0 && x < 60 then Result.ok x else invalid_int x "Invalid sec value"
let ( let* ) = Result.bind
let make ?(time = (0, 0, 0)) ~year ~month ~day () =
let hour, min, sec = time in
let* year = year_from_int year in
let* month = month_from_int month in
let* day = day_from_int year month day in
let* hour = hour_from_int hour in
let* min = min_from_int min in
let* sec = sec_from_int sec in
Result.ok { year; month; day; hour; min; sec }
let validate_from_datetime_str str =
let str = String.trim str in
match
Scanf.sscanf_opt str "%04d%c%02d%c%02d%c%02d%c%02d%c%02d"
(fun year _ month _ day _ hour _ min _ sec ->
((hour, min, sec), year, month, day))
with
| None -> Data.Validation.fail_with ~given:str "Invalid date format"
| Some (time, year, month, day) -> make ~time ~year ~month ~day ()
let validate_from_date_str str =
let str = String.trim str in
match
Scanf.sscanf_opt str "%04d%c%02d%c%02d" (fun year _ month _ day ->
(year, month, day))
with
| None -> Data.Validation.fail_with ~given:str "Invalid date format"
| Some (year, month, day) -> make ~year ~month ~day ()
let validate =
let open Data.Validation in
string & (validate_from_datetime_str / validate_from_date_str)
let month_to_int = function
| Jan -> 1
| Feb -> 2
| Mar -> 3
| Apr -> 4
| May -> 5
| Jun -> 6
| Jul -> 7
| Aug -> 8
| Sep -> 9
| Oct -> 10
| Nov -> 11
| Dec -> 12
let dow_to_int = function
| Mon -> 0
| Tue -> 1
| Wed -> 2
| Thu -> 3
| Fri -> 4
| Sat -> 5
| Sun -> 6
let compare_date a b =
let cmp = Int.compare a.year b.year in
if Int.equal cmp 0 then
let cmp = Int.compare (month_to_int a.month) (month_to_int b.month) in
if Int.equal cmp 0 then Int.compare a.day b.day else cmp
else cmp
let compare_time a b =
let cmp = Int.compare a.hour b.hour in
if Int.equal cmp 0 then
let cmp = Int.compare a.min b.min in
if Int.equal cmp 0 then Int.compare a.sec b.sec else cmp
else cmp
let compare a b =
let cmp = compare_date a b in
if Int.equal cmp 0 then compare_time a b else cmp
let pp_date ppf { year; month; day; _ } =
Format.fprintf ppf "%04d-%02d-%02d" year (month_to_int month) day
let month_value = function
| Jan -> 0
| Feb -> 3
| Mar -> 3
| Apr -> 6
| May -> 1
| Jun -> 4
| Jul -> 6
| Aug -> 2
| Sep -> 5
| Oct -> 0
| Nov -> 3
| Dec -> 5
let day_of_week { year; month; day; _ } =
let yy = year mod 100 in
let cc = (year - yy) / 100 in
let c_code = [| 6; 4; 2; 0 |].(cc mod 4) in
let y_code = (yy + (yy / 4)) mod 7 in
let m_code =
let v = month_value month in
if is_leap year && (month = Jan || month = Feb) then v - 1 else v
in
let index = (c_code + y_code + m_code + day) mod 7 in
[| Sun; Mon; Tue; Wed; Thu; Fri; Sat |].(index)
let normalize ({ year; month; day; hour; min; sec } as dt) =
let day_of_week = day_of_week dt in
let open Data in
record
[
("year", int year); ("month", int (month_to_int month)); ("day", int day)
; ("hour", int hour); ("min", int min); ("sec", int sec)
; ("day_of_week", int (dow_to_int day_of_week))
; ("human", string (Format.asprintf "%a" pp_date dt))
]
let to_archetype_date_time { year; month; day; hour; min; sec } =
let time = (hour, min, sec) in
let month = month_to_int month in
Result.get_ok (Archetype.Datetime.make ~time ~year ~month ~day ())
end
module Page = struct
let entity_name = "Page"
class type t = object ('self)
method title : string option
method charset : string option
method description : string option
method tags : string list
method with_host : string -> 'self
method get_host : string option
end
class page ?title ?description ?charset ?(tags = []) () =
object (_ : #t)
method title = title
method charset = charset
method description = description
method tags = tags
val host = None
method with_host v = {< host = Some v >}
method get_host = host
end
let neutral = Result.ok @@ new page ()
let validate fields =
let open Data.Validation in
let+ title = optional fields "title" string
and+ description = optional fields "description" string
and+ charset = optional fields "charset" string
and+ tags = optional_or fields ~default:[] "tags" (list_of string) in
new page ?title ?description ?charset ~tags ()
let validate =
let open Data.Validation in
record validate
end
module Author = struct
class type t = object
method name : string
method link : string
method email : string
method avatar : string option
end
let gravatar email =
let tk = String.(lowercase_ascii (trim email)) in
let hs = Digest.(to_hex (string tk)) in
"https://www.gravatar.com/avatar/" ^ hs
class author ~name ~link ~email ?(avatar = gravatar email) () =
object (_ : #t)
method name = name
method link = link
method email = email
method avatar = Some avatar
end
let validate fields =
let open Data.Validation in
let+ name = required fields "name" string
and+ link = required fields "link" string
and+ email = required fields "email" string
and+ avatar = optional fields "avatar" string in
match avatar with
| None -> new author ~name ~link ~email ()
| Some avatar -> new author ~name ~link ~email ~avatar ()
let validate =
let open Data.Validation in
record validate
let normalize obj =
let open Data in
record
[
("name", string obj#name); ("link", string obj#link)
; ("email", string obj#email); ("avatar", option string obj#avatar)
]
end
let robur_coop =
new Author.author
~name:"The Robur Team" ~link:"https://robur.coop/"
~email:"team@robur.coop" ()
module Article = struct
let entity_name = "Article"
class type t = object ('self)
method title : string
method description : string
method charset : string option
method tags : string list
method date : Date.t
method author : Author.t
method co_authors : Author.t list
method with_host : string -> 'self
method get_host : string option
end
class article ~title ~description ?charset ?(tags = []) ~date ~author
?(co_authors = []) () =
object (_ : #t)
method title = title
method description = description
method charset = charset
method tags = tags
method date = date
method author = author
method co_authors = co_authors
val host = None
method with_host v = {< host = Some v >}
method get_host = host
end
let title p = p#title
let description p = p#description
let tags p = p#tags
let date p = p#date
let neutral =
Data.Validation.fail_with ~given:"null" "Cannot be null"
|> Result.map_error (fun error ->
Required.Validation_error { entity = entity_name; error })
let validate fields =
let open Data.Validation in
let+ title = required fields "title" string
and+ description = required fields "description" string
and+ charset = optional fields "charset" string
and+ tags = optional_or fields ~default:[] "tags" (list_of string)
and+ date = required fields "date" Date.validate
and+ author =
optional_or fields ~default:robur_coop "author" Author.validate
and+ co_authors =
optional_or fields ~default:[] "co-authors" (list_of Author.validate)
in
new article ~title ~description ?charset ~tags ~date ~author ~co_authors ()
let validate =
let open Data.Validation in
record validate
let normalize obj =
Data.
[
("title", string obj#title); ("description", string obj#description)
; ("date", Date.normalize obj#date); ("charset", option string obj#charset)
; ("tags", list_of string obj#tags)
; ("author", Author.normalize obj#author)
; ("co-authors", list_of Author.normalize obj#co_authors)
; ("host", option string obj#get_host)
]
end
module Articles = struct
class type t = object ('self)
method title : string option
method description : string option
method articles : (Path.t * Article.t) list
method with_host : string -> 'self
method get_host : string option
end
class articles ?title ?description articles =
object (_ : #t)
method title = title
method description = description
method articles = articles
val host = None
method with_host v = {< host = Some v >}
method get_host = host
end
let sort_by_date ?(increasing = false) articles =
List.sort
(fun (_, articleA) (_, articleB) ->
let r = Date.compare articleA#date articleB#date in
if increasing then r else ~-r)
articles
let fetch (module P : Required.DATA_PROVIDER) ?increasing
?(filter = fun x -> x) ?(on = `Source) ~where ~compute_link path =
Task.from_effect begin fun () ->
let open Eff in
let* files = read_directory ~on ~only:`Files ~where path in
let+ articles =
List.traverse
(fun file ->
let url = compute_link file in
let+ metadata, _content =
Eff.read_file_with_metadata (module P) (module Article) ~on file
in
(url, metadata))
files
in
articles |> sort_by_date ?increasing |> filter end
let compute_index (module P : Required.DATA_PROVIDER) ?increasing
?(filter = fun x -> x) ?(on = `Source) ~where ~compute_link path =
let open Task in
(fun x -> (x, ()))
|>> second
(fetch (module P) ?increasing ~filter ~on ~where ~compute_link path)
>>> lift (fun (v, articles) ->
new articles ?title:v#title ?description:v#description articles)
let normalize (ident, article) =
let open Data in
record (("url", string @@ Path.to_string ident) :: Article.normalize article)
let normalize obj =
let open Data in
[
("articles", list_of normalize obj#articles)
; ("has_articles", bool @@ is_empty_list obj#articles)
; ("title", option string obj#title)
; ("description", option string obj#description)
; ("host", option string obj#get_host)
]
end
module Make_with_target (S : sig
val source : Path.t
val target : Path.t
end) =
struct
let source_root = S.source
module Source = struct
let css = Path.(source_root / "css")
let js = Path.(source_root / "js")
let images = Path.(source_root / "images")
let articles = Path.(source_root / "articles")
let index = Path.(source_root / "pages" / "index.md")
let templates = Path.(source_root / "templates")
let template file = Path.(templates / file)
let binary = Path.rel [ Sys.argv.(0) ]
let cache = Path.(source_root / "_cache")
end
module Target = struct
let target_root = S.target
let pages = target_root
let articles = Path.(target_root / "articles")
let rss1 = Path.(target_root / "rss1.xml")
let rss2 = Path.(target_root / "feed.xml")
let atom = Path.(target_root / "atom.xml")
let as_html into file =
file |> Path.move ~into |> Path.change_extension "html"
end
let target = Target.target_root
let process_css_files =
Action.copy_directory ~into:Target.target_root Source.css
let process_js_files =
Action.copy_directory ~into:Target.target_root Source.js
let process_images_files =
Action.copy_directory ~into:Target.target_root Source.images
let process_article ~host file =
let file_target = Target.(as_html articles file) in
let open Task in
Action.write_static_file file_target
begin
Pipeline.track_file Source.binary
>>> Yocaml_yaml.Pipeline.read_file_with_metadata (module Article) file
>>* (fun (obj, str) -> Eff.return (obj#with_host host, str))
>>> Yocaml_cmarkit.content_to_html ()
>>> Yocaml_jingoo.Pipeline.as_template
(module Article)
(Source.template "article.html")
>>> Yocaml_jingoo.Pipeline.as_template
(module Article)
(Source.template "layout.html")
>>> drop_first ()
end
let process_articles ~host =
Action.batch ~only:`Files ~where:(Path.has_extension "md") Source.articles
(process_article ~host)
let process_index ~host =
let file = Source.index in
let file_target = Target.(as_html pages file) in
let open Task in
let compute_index =
Articles.compute_index
(module Yocaml_yaml)
~where:(Path.has_extension "md")
~compute_link:(Target.as_html @@ Path.abs [ "articles" ])
Source.articles
in
Action.write_static_file file_target
begin
Pipeline.track_files [ Source.binary; Source.articles ]
>>> Yocaml_yaml.Pipeline.read_file_with_metadata (module Page) file
>>> Yocaml_cmarkit.content_to_html ()
>>> first compute_index
>>* (fun (obj, str) -> Eff.return (obj#with_host host, str))
>>> Yocaml_jingoo.Pipeline.as_template ~strict:true
(module Articles)
(Source.template "index.html")
>>> Yocaml_jingoo.Pipeline.as_template ~strict:true
(module Articles)
(Source.template "layout.html")
>>> drop_first ()
end
let feed_title = "The Robur's blog"
let site_url = "https://blog.robur.coop/"
let feed_description = "The Robur cooperative blog"
let fetch_articles =
let open Task in
Pipeline.track_files [ Source.binary; Source.articles ]
>>> Articles.fetch
(module Yocaml_yaml)
~where:(Path.has_extension "md")
~compute_link:(Target.as_html @@ Path.abs [ "articles" ])
Source.articles
let rss1 =
let from_articles ~title ~site_url ~description ~feed_url () =
let open Yocaml_syndication in
Rss1.from ~title ~url:feed_url ~link:site_url ~description
@@ fun (path, article) ->
let title = Article.title article in
let link = site_url ^ Yocaml.Path.to_string path in
let description = Article.description article in
Rss1.item ~title ~link ~description
in
let open Task in
Action.write_static_file Target.rss1
begin
fetch_articles
>>> from_articles ~title:feed_title ~site_url
~description:feed_description
~feed_url:"https://blog.robur.coop/rss1.xml" ()
end
let rss2 =
let open Task in
let from_articles ~title ~site_url ~description ~feed_url () =
let open Yocaml_syndication in
lift
begin
fun articles ->
let last_build_date =
List.fold_left
begin
fun acc (_, elt) ->
let v = Date.to_archetype_date_time (Article.date elt) in
match acc with
| None -> Some v
| Some a ->
if Archetype.Datetime.compare a v > 0 then Some a
else Some v
end
None articles
|> Option.map Datetime.make
in
let feed =
Rss2.feed ?last_build_date ~title ~link:site_url ~url:feed_url
~description
begin
fun (path, article) ->
let title = Article.title article in
let link = site_url ^ Path.to_string path in
let guid = Rss2.guid_from_link in
let description = Article.description article in
let pub_date =
Datetime.make
(Date.to_archetype_date_time (Article.date article))
in
Rss2.item ~title ~link ~guid ~description ~pub_date ()
end
articles
in
Xml.to_string feed
end
in
Action.write_static_file Target.rss2
begin
fetch_articles
>>> from_articles ~title:feed_title ~site_url
~description:feed_description
~feed_url:"https://blog.robur.coop/feed.xml" ()
end
let atom =
let open Task in
let open Yocaml_syndication in
let authors = Yocaml.Nel.singleton @@ Person.make "The Robur Team" in
let from_articles ?(updated = Atom.updated_from_entries ()) ?(links = [])
?id ~site_url ~authors ~title ~feed_url () =
let id = Option.value ~default:feed_url id in
let feed_url = Atom.self feed_url in
let base_url = Atom.link site_url in
let links = base_url :: feed_url :: links in
Atom.from ~links ~updated ~title ~authors ~id
begin
fun (path, article) ->
let title = Article.title article in
let content_url = site_url ^ Yocaml.Path.to_string path in
let updated =
Datetime.make (Date.to_archetype_date_time (Article.date article))
in
let categories = List.map Category.make (Article.tags article) in
let summary = Atom.text (Article.description article) in
let links = [ Atom.alternate content_url ~title ] in
Atom.entry ~links ~categories ~summary ~updated ~id:content_url
~title:(Atom.text title) ()
end
in
Action.write_static_file Target.atom
begin
fetch_articles
>>> from_articles ~site_url ~authors ~title:(Atom.text feed_title)
~feed_url:"https://blog.robur.coop/atom.xml" ()
end
let process_all ~host =
let open Eff in
Action.restore_cache ~on:`Source Source.cache
>>= process_css_files >>= process_js_files >>= process_images_files
>>= process_articles ~host >>= process_index ~host >>= rss1 >>= rss2 >>= atom
>>= Action.store_cache ~on:`Source Source.cache
end
module Make (S : sig
val source : Path.t
end) =
Make_with_target (struct
include S
let target = Path.(source / "_site")
end)

14
bin/blog.mli Normal file
View file

@ -0,0 +1,14 @@
module Make_with_target (_ : sig
val source : Yocaml.Path.t
val target : Yocaml.Path.t
end) : sig
val target : Yocaml.Path.t
val process_all : host:string -> unit Yocaml.Eff.t
end
module Make (_ : sig
val source : Yocaml.Path.t
end) : sig
val target : Yocaml.Path.t
val process_all : host:string -> unit Yocaml.Eff.t
end

23
bin/dune Normal file
View file

@ -0,0 +1,23 @@
(executable
(name watch)
(libraries
yocaml
yocaml_syndication
yocaml_yaml
yocaml_jingoo
yocaml_cmarkit
yocaml_unix))
(executable
(name push)
(libraries
fmt.tty
logs.fmt
git-unix
yocaml
yocaml_git
yocaml_syndication
yocaml_yaml
yocaml_jingoo
yocaml_cmarkit
yocaml_unix))

60
bin/push.ml Normal file
View file

@ -0,0 +1,60 @@
let reporter ppf =
let report src level ~over k msgf =
let k _ =
over ();
k ()
in
let with_metadata header _tags k ppf fmt =
Format.kfprintf k ppf
("%a[%a]: " ^^ fmt ^^ "\n%!")
Logs_fmt.pp_header (level, header)
Fmt.(styled `Magenta string)
(Logs.Src.name src)
in
msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt
in
{ Logs.report }
let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ()
let () = Logs.set_reporter (reporter Fmt.stdout)
(* let () = Logs.set_level ~all:true (Some Logs.Debug) *)
let author = ref "The Robur Team"
let email = ref "team@robur.coop"
let message = ref "Pushed by YOCaml 2"
let remote = ref "git@git.robur.coop:robur/blog.robur.coop.git#gh-pages"
let host = ref "https://blog.robur.coop"
module Source = Yocaml_git.From_identity (Yocaml_unix.Runtime)
let usage =
Fmt.str
"%s [--message <message>] [--author <author>] [--email <email>] -r \
<repository>"
Sys.argv.(0)
let specification =
[
("--message", Arg.Set_string message, "The commit message")
; ("--email", Arg.Set_string email, "The email used to craft the commit")
; ("-r", Arg.Set_string remote, "The Git repository")
; ("--author", Arg.Set_string author, "The Git commit author")
; ("--host", Arg.Set_string host, "The host where the blog is available")
]
let () =
Arg.parse specification ignore usage;
let author = !author
and email = !email
and message = !message
and remote = !remote in
let module Blog = Blog.Make_with_target (struct
let source = Yocaml.Path.rel []
let target = Yocaml.Path.rel []
end) in
Yocaml_git.run
(module Source)
(module Pclock)
~context:`SSH ~author ~email ~message ~remote
(fun () -> Blog.process_all ~host:!host)
|> Lwt_main.run
|> Result.iter_error (fun (`Msg err) -> invalid_arg err)

15
bin/watch.ml Normal file
View file

@ -0,0 +1,15 @@
let port = ref 8000
let usage = Fmt.str "%s [--port <port>]" Sys.argv.(0)
let specification =
[ ("--port", Arg.Set_int port, "The port where we serve the website") ]
module Dest = Blog.Make (struct
let source = Yocaml.Path.rel []
end)
let () =
Arg.parse specification ignore usage;
let host = Fmt.str "http://localhost:%d" !port in
Yocaml_unix.serve ~level:`Info ~target:Dest.target ~port:!port
@@ fun () -> Dest.process_all ~host

18
blogger.opam
View file

@ -5,7 +5,7 @@ maintainer: "romain.calascibetta@gmail.com"
authors: [ "The XHTMLBoy <xhtmlboi@gmail.com>" ]
build: [
[ "dune" "subst" ]
[ "dune" "subst" ] {dev}
[ "dune" "build" "-p" name "-j" jobs ]
[ "dune" "runtest" "-p" name ] {with-test}
[ "dune" "build" "@doc" "-p" name ] {with-doc}
@ -18,7 +18,7 @@ dev-repo: "git://github.com/dinosaure/blogger.git"
bug-reports: "https://github.com/dinosaure/blogger/issues"
depends: [
"ocaml" { >= "4.11.1" }
"ocaml" { >= "5.1.0" }
"dune" { >= "2.8" }
"preface" { >= "0.1.0" }
"logs" {>= "0.7.0" }
@ -27,7 +27,19 @@ depends: [
"yocaml"
"yocaml_unix"
"yocaml_yaml"
"yocaml_cmark"
"yocaml_cmarkit"
"yocaml_git"
"yocaml_jingoo"
"yocaml_syndication"
]
pin-depends: [
["yocaml.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
["yocaml_runtime.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
["yocaml_unix.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
["yocaml_yaml.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
["yocaml_cmarkit.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
["yocaml_git.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
["yocaml_jingoo.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
["yocaml_syndication.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
]

332
src/blogger.ml
View file

@ -1,332 +0,0 @@
let caller = Sys.argv.(0)
let version = "%%VERSION%%"
let default_port = 8888
let default_target = Fpath.v "_site"
let program ~target =
let open Yocaml in
let* () = Task.move_javascript target in
let* () = Task.move_css target in
let* () = Task.move_images target in
let* () = Task.process_articles target in
let* () = Task.generate_feed target in
let* () = Task.generate_tags target in
Task.generate_index target
let local_build _quiet target =
Yocaml_unix.execute (program ~target:(Fpath.to_string target))
module SSH = struct
open Lwt.Infix
type error = Unix.error * string * string
type write_error = [ `Closed | `Error of Unix.error * string * string ]
let pp_error ppf (err, f, v) =
Fmt.pf ppf "%s(%s): %s" f v (Unix.error_message err)
let pp_write_error ppf = function
| `Closed -> Fmt.pf ppf "Connection closed by peer"
| `Error (err, f, v) -> Fmt.pf ppf "%s(%s): %s" f v (Unix.error_message err)
type flow = { ic : in_channel; oc : out_channel }
type endpoint = {
user : string;
path : string;
host : Unix.inet_addr;
port : int;
capabilities : [ `Rd | `Wr ];
}
let pp_inet_addr ppf inet_addr =
Fmt.string ppf (Unix.string_of_inet_addr inet_addr)
let connect { user; path; host; port; capabilities } =
let edn = Fmt.str "%s@%a" user pp_inet_addr host in
let cmd =
match capabilities with
| `Wr -> Fmt.str {sh|git-receive-pack '%s'|sh} path
| `Rd -> Fmt.str {sh|git-upload-pack '%s'|sh} path
in
let cmd = Fmt.str "ssh -p %d %s %a" port edn Fmt.(quote string) cmd in
try
let ic, oc = Unix.open_process cmd in
Lwt.return_ok { ic; oc }
with Unix.Unix_error (err, f, v) -> Lwt.return_error (`Error (err, f, v))
let read t =
let tmp = Bytes.create 0x1000 in
try
let len = input t.ic tmp 0 0x1000 in
if len = 0 then Lwt.return_ok `Eof
else Lwt.return_ok (`Data (Cstruct.of_bytes tmp ~off:0 ~len))
with Unix.Unix_error (err, f, v) -> Lwt.return_error (err, f, v)
let write t cs =
let str = Cstruct.to_string cs in
try
output_string t.oc str;
flush t.oc;
Lwt.return_ok ()
with Unix.Unix_error (err, f, v) -> Lwt.return_error (`Error (err, f, v))
let writev t css =
let rec go t = function
| [] -> Lwt.return_ok ()
| x :: r -> (
write t x >>= function
| Ok () -> go t r
| Error _ as err -> Lwt.return err)
in
go t css
let close t =
close_in t.ic;
close_out t.oc;
Lwt.return_unit
let shutdown t mode =
match mode with
| `read -> close_in t.ic ; Lwt.return_unit
| `write -> close_out t.oc ; Lwt.return_unit
| `read_write -> close t
end
let ssh_edn, ssh_protocol = Mimic.register ~name:"ssh" (module SSH)
let unix_ctx_with_ssh () =
let open Lwt.Infix in
Git_unix.ctx (Happy_eyeballs_lwt.create ()) >|= fun ctx ->
let open Mimic in
let k0 scheme user path host port capabilities =
match (scheme, Unix.gethostbyname host) with
| `SSH, { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 ->
Lwt.return_some
{ SSH.user; path; host = h_addr_list.(0); port; capabilities }
| _ -> Lwt.return_none
in
ctx
|> Mimic.fold Smart_git.git_transmission
Fun.[ req Smart_git.git_scheme ]
~k:(function `SSH -> Lwt.return_some `Exec | _ -> Lwt.return_none)
|> Mimic.fold ssh_edn
Fun.
[
req Smart_git.git_scheme;
req Smart_git.git_ssh_user;
req Smart_git.git_path;
req Smart_git.git_hostname;
dft Smart_git.git_port 22;
req Smart_git.git_capabilities;
]
~k:k0
let run_git_config key = function
| Some value -> Some value
| None -> (
let open Bos in
let value = OS.Cmd.run_out Cmd.(v "git" % "config" % "--global" % key) in
match OS.Cmd.out_string value with
| Ok (value, _) -> Some value
| Error _ -> None)
let run_git_rev_parse default =
let open Bos in
let value = OS.Cmd.run_out
Cmd.(v "git" % "describe" % "--always" % "--dirty"
% "--exclude=*" % "--abbrev=0")
in
match OS.Cmd.out_string value with
| Ok (value, (_, `Exited 0)) -> value
| Ok (value, (run_info, _)) ->
Logs.warn (fun m -> m "Failed to get commit id: %a: %s"
Cmd.pp (OS.Cmd.run_info_cmd run_info)
value);
default
| Error `Msg e ->
Logs.warn (fun m -> m "Failed to get commit id: %s" e);
default
let get_name_and_email name email =
let name = run_git_config "user.name" name in
let email = run_git_config "user.email" email in
(name, email)
let name_and_email =
let name_arg =
let doc = "Name of the committer." in
Cmdliner.Arg.(value & opt (some string) None & info [ "name" ] ~doc)
in
let email_arg =
let doc = "Email of the committer." in
Cmdliner.Arg.(value & opt (some string) None & info [ "email" ] ~doc)
in
Cmdliner.Term.(const get_name_and_email $ name_arg $ email_arg)
let build_and_push _quiet remote (author, email) hook =
let fiber () =
let open Lwt.Syntax in
let commit_id = run_git_rev_parse "an unknown state" in
let comment = Printf.sprintf "Built from %s" commit_id in
let* ctx = unix_ctx_with_ssh () in
let* res =
Yocaml_git.execute
(module Yocaml_unix)
(module Pclock)
~ctx ?author ?email ~comment remote (program ~target:"")
in
match res with
| Error (`Msg err) -> Fmt.failwith "build-and-push: %s." err
| Ok () -> (
match hook with
| None -> Lwt.return_unit
| Some hook -> (
let open Lwt.Infix in
Http_lwt_client.request ~config:(`HTTP_1_1 Httpaf.Config.default)
~meth:`GET (Uri.to_string hook)
(fun _ () _ -> Lwt.return_unit)
()
>>= function
| Ok (_response, ()) -> Lwt.return_unit
| Error (`Msg err) -> failwith err))
in
Lwt_main.run (fiber ())
let watch quiet target potential_port =
let port = Option.value ~default:default_port potential_port in
let () = local_build quiet target in
let target = Fpath.to_string target in
let server = Yocaml_unix.serve ~filepath:target ~port (program ~target) in
Lwt_main.run server
let common_options = "COMMON OPTIONS"
let verbosity =
let open Cmdliner in
let env = Cmd.Env.info "BLOGGER_LOGS" in
Logs_cli.level ~docs:common_options ~env ()
let renderer =
let open Cmdliner in
let env = Cmd.Env.info "BLOGGER_FMT" in
Fmt_cli.style_renderer ~docs:common_options ~env ()
let utf_8 =
let open Cmdliner in
let doc = "Allow binaries to emit UTF-8 characters." in
let env = Cmd.Env.info "BLOGGER_UTF_8" in
Arg.(value & opt bool true & info [ "with-utf-8" ] ~doc ~env)
let reporter ppf =
let report src level ~over k msgf =
let k _ =
over ();
k ()
in
let with_metadata header _tags k ppf fmt =
Fmt.kpf k ppf
("%a[%a]: " ^^ fmt ^^ "\n%!")
Logs_fmt.pp_header (level, header)
Fmt.(styled `Magenta string)
(Logs.Src.name src)
in
msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt
in
{ Logs.report }
let setup_logs utf_8 style_renderer level =
Fmt_tty.setup_std_outputs ~utf_8 ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (reporter Fmt.stderr);
Option.is_none level
let setup_logs = Cmdliner.Term.(const setup_logs $ utf_8 $ renderer $ verbosity)
let man =
let open Cmdliner in
[ `S Manpage.s_authors; `P "blog.robur.coop" ]
let build_cmd =
let open Cmdliner in
let doc = Format.asprintf "Build the blog into the specified directory" in
let exits = Cmd.Exit.defaults in
let info = Cmd.info "build" ~version ~doc ~exits ~man in
let path_arg =
let doc =
Format.asprintf "Specify where we build the website (default: %a)"
Fpath.pp default_target
in
let arg = Arg.info ~doc [ "destination" ] in
Arg.(value & opt (conv (Fpath.of_string, Fpath.pp)) default_target & arg)
in
Cmd.v info Term.(const local_build $ setup_logs $ path_arg)
let watch_cmd =
let open Cmdliner in
let doc =
Format.asprintf
"Serve from the specified directory as an HTTP server and rebuild \
website on demand"
in
let exits = Cmd.Exit.defaults in
let path_arg =
let doc =
Format.asprintf "Specify where we build the website (default: %a)"
Fpath.pp default_target
in
let arg = Arg.info ~doc [ "destination" ] in
Arg.(value & opt (conv (Fpath.of_string, Fpath.pp)) default_target & arg)
in
let port_arg =
let doc = Format.asprintf "The port (default: %d)" default_port in
let arg = Arg.info ~doc [ "port"; "P"; "p" ] in
Arg.(value & opt (some int) None & arg)
in
let info = Cmd.info "watch" ~version ~doc ~exits ~man in
Cmd.v info Term.(const watch $ setup_logs $ path_arg $ port_arg)
let push_cmd =
let open Cmdliner in
let doc =
Format.asprintf
"Push the blog (from the specified directory) into a Git repository"
in
let exits = Cmd.Exit.defaults in
let remote_arg =
let remote =
let parser str =
match Smart_git.Endpoint.of_string str with
| Ok _ -> Ok str
| Error _ as err -> err
in
Arg.conv (parser, Fmt.string)
in
let doc = "The remote Git repository" in
let arg = Arg.info ~doc [ "r"; "remote" ] in
Arg.(required & opt (some remote) None & arg)
in
let hook_arg =
let doc = "The URL of the hook to update the unikernel" in
let arg = Arg.info ~doc [ "h"; "hook" ] in
let of_string str =
match Uri.of_string str with
| v -> Ok v
| exception _ -> Rresult.R.error_msgf "Invalid URI: %s" str
in
Arg.(value & opt (some (conv (of_string, Uri.pp))) None & arg)
in
let info = Cmd.info "push" ~version ~doc ~exits ~man in
Cmd.v info
Term.(
const build_and_push $ setup_logs $ remote_arg $ name_and_email $ hook_arg)
let cmd =
let open Cmdliner in
let sdocs = Manpage.s_common_options in
let doc = "Build, push or serve my personal website" in
let default_info = Cmd.info caller ~version ~doc ~sdocs ~man in
let default = Term.(ret (const (`Help (`Pager, None)))) in
Cmd.group ~default default_info [ build_cmd; watch_cmd; push_cmd ]
let () = exit @@ Cmdliner.Cmd.eval cmd

64
src/collection.ml
View file

@ -1,64 +0,0 @@
open Yocaml
let get_article (module V : Metadata.VALIDABLE) article_file =
let arr =
Build.read_file_with_metadata
(module V)
(module Model.Article)
article_file
in
let deps = Build.get_dependencies arr in
let task = Build.get_task arr in
let+ meta, _ = task () in
deps, (meta, Model.article_path article_file)
;;
let get_articles (module V : Metadata.VALIDABLE) path =
let* files = read_child_files path File.is_markdown in
let+ articles = Traverse.traverse (get_article (module V)) files in
let deps, effects = List.split articles in
Deps.Monoid.reduce deps, effects
;;
module Articles = struct
type t = (Model.Article.t * Filepath.t) list
let get_all (module V : Metadata.VALIDABLE) ?(decreasing = true) path =
let+ deps, articles = get_articles (module V) path in
let sorted_article = Model.Articles.sort ~decreasing articles in
Build.make deps (fun x -> return (x, sorted_article))
;;
end
module Tags = struct
module M = Map.Make (String)
let by_quantity ?(decreasing = true) (_, a) (_, b) =
let r = Int.compare $ List.length a $ List.length b in
if decreasing then ~-r else r
;;
let group metas =
List.fold_left
(fun accumulator (article, path) ->
List.fold_left
(fun map tag ->
match M.find_opt tag map with
| Some articles -> M.add tag ((article, path) :: articles) map
| None -> M.add tag [ article, path ] map)
accumulator
(Model.Article.tags article))
M.empty
metas
|> M.map
(List.sort (fun (a, _) (b, _) -> Model.Article.compare_by_date a b))
|> M.to_seq
|> List.of_seq
|> List.sort by_quantity
;;
let compute (module V : Metadata.VALIDABLE) path =
let+ deps, articles = get_articles (module V) path in
deps, group articles
;;
end

18
src/collection.mli
View file

@ -1,18 +0,0 @@
open Yocaml
module Articles : sig
type t = (Model.Article.t * Filepath.t) list
val get_all
: (module Metadata.VALIDABLE)
-> ?decreasing:bool
-> Filepath.t
-> ('a, 'a * t) Build.t Effect.t
end
module Tags : sig
val compute
: (module Metadata.VALIDABLE)
-> Filepath.t
-> (Deps.t * (string * (Model.Article.t * string) list) list) Effect.t
end

21
src/dune
View file

@ -1,21 +0,0 @@
(executable
(name blogger)
(libraries
logs
logs.fmt
logs.cli
fmt
fmt.tty
fmt.cli
cmdliner
preface
mirage-clock-unix
http-lwt-client
git-unix
cmarkit
yocaml
yocaml_yaml
yocaml_cmark
yocaml_unix
yocaml_git
yocaml_jingoo))

15
src/feed.ml
View file

@ -1,15 +0,0 @@
open Yocaml
let domain = "https://blog.robur.coop"
let feed_url = into domain "feed.xml"
let articles_to_items articles =
List.map
(fun (article, url) -> Model.Article.to_rss_item (into domain url) article)
articles
let make ((), articles) =
Yocaml.Rss.Channel.make ~title:"Robur's blog" ~link:domain ~feed_link:feed_url
~description:"The Robur cooperative blog" ~generator:"yocaml"
~webmaster:"team@robur.coop"
(articles_to_items articles)

1
src/feed.mli
View file

@ -1 +0,0 @@
val make : unit * Collection.Articles.t -> Yocaml.Rss.Channel.t

18
src/file.ml
View file

@ -1,18 +0,0 @@
open Yocaml
let is_css = with_extension "css"
let is_javascript = with_extension "js"
let is_image =
let open Preface.Predicate in
with_extension "png"
|| with_extension "svg"
|| with_extension "jpg"
|| with_extension "jpeg"
|| with_extension "gif"
;;
let is_markdown =
let open Preface.Predicate in
with_extension "md" || with_extension "markdown"
;;

6
src/file.mli
View file

@ -1,6 +0,0 @@
open Yocaml
val is_css : Filepath.t -> bool
val is_javascript : Filepath.t -> bool
val is_image : Filepath.t -> bool
val is_markdown : Filepath.t -> bool

256
src/model.ml
View file

@ -1,256 +0,0 @@
open Yocaml
let article_path file =
let filename = basename $ replace_extension file "html" in
filename |> into "articles"
let tag_path tag = add_extension tag "html" |> into "tags"
module Author = struct
type t = {
name : string;
link : string;
email : string;
avatar : string option;
}
let equal a b =
String.equal a.name b.name && String.equal a.link b.link
&& String.equal a.email b.email
&& Option.equal String.equal a.avatar b.avatar
let make name link email avatar = { name; link; email; avatar }
let from (type a) (module V : Metadata.VALIDABLE with type t = a) obj =
V.object_and
(fun assoc ->
let open Validate.Applicative in
make
<$> V.(required_assoc string) "name" assoc
<*> V.(required_assoc string) "link" assoc
<*> V.(required_assoc string) "email" assoc
<*> V.(optional_assoc string) "avatar" assoc)
obj
let default_user =
make "robur" "https://blog.robur.coop/" "team@robur.coop" None
let gravatar email =
let tk = String.(lowercase_ascii $ trim email) in
let hs = Digest.(to_hex $ string tk) in
"https://www.gravatar.com/avatar/" ^ hs
let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
{ name; link; email; avatar } =
let avatar = match avatar with Some uri -> uri | None -> gravatar email in
D.
[
("name", string name);
("link", string link);
("email", string email);
("avatar", string avatar);
]
end
module Co_author = struct
type t = { author : Author.t; contribution : string }
let make author contribution = { author; contribution }
let from (type a) (module V : Metadata.VALIDABLE with type t = a) obj =
V.object_and
(fun assoc ->
let open Validate.Applicative in
make
<$> V.(required_assoc (Author.from (module V))) "author" assoc
<*> V.(required_assoc string) "contribution" assoc)
obj
let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
{ author; contribution } =
D.
[
("author", object_ $ Author.inject (module D) author);
("contribution", string contribution);
]
end
module Article = struct
type t = {
article_title : string;
article_description : string;
tags : string list;
date : Date.t;
title : string option;
description : string option;
author : Author.t;
co_authors : Co_author.t list;
invited_article : bool;
}
let date { date; _ } = date
let tags { tags; _ } = tags
let escape_string str =
let renderer = Cmarkit_renderer.make () in
let buffer = Buffer.create (String.length str) in
let ctx = Cmarkit_renderer.Context.make renderer buffer in
Cmarkit_html.html_escaped_string ctx str;
Buffer.contents buffer
let to_rss_item url article =
let title = escape_string article.article_title in
let description = escape_string article.article_description in
Rss.(
Item.make ~title ~link:url ~pub_date:article.date ~description
~guid:(Guid.link url) ())
let make article_title article_description tags date title description author
co_authors =
let author = Option.value ~default:Author.default_user author in
let invited_article = not (Author.equal author Author.default_user) in
{
article_title;
article_description;
tags = List.map String.lowercase_ascii tags;
date;
title;
description;
author;
co_authors;
invited_article;
}
let from_string (module V : Metadata.VALIDABLE) = function
| None -> Validate.error $ Error.Required_metadata [ "Article" ]
| Some str ->
let open Validate.Monad in
V.from_string str
>>= V.object_and (fun assoc ->
let open Validate.Applicative in
make
<$> V.(required_assoc string) "article.title" assoc
<*> V.(required_assoc string) "article.description" assoc
<*> V.(optional_assoc_or ~default:[] (list_of string))
"tags" assoc
<*> V.required_assoc
(Metadata.Date.from (module V))
"date" assoc
<*> V.(optional_assoc string) "title" assoc
<*> V.(optional_assoc string) "description" assoc
<*> V.(optional_assoc (Author.from (module V))) "author" assoc
<*> V.(
optional_assoc_or ~default:[]
(list_of (Co_author.from (module V)))
"coauthors" assoc))
let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
{
article_title;
article_description;
tags;
date;
title;
description;
author;
co_authors;
invited_article;
} =
let co_authors =
List.map (fun c -> D.object_ $ Co_author.inject (module D) c) co_authors
in
let has_co_authors = match co_authors with [] -> false | _ -> true in
D.
[
("root", string "..");
( "metadata",
object_
[
("title", string article_title);
("description", string article_description);
] );
("tags", list (List.map string tags));
("date", object_ $ Metadata.Date.inject (module D) date);
("author", object_ $ Author.inject (module D) author);
("coauthors", list co_authors);
("invited", boolean invited_article);
("has_coauthors", boolean has_co_authors);
]
@ Metadata.Page.inject (module D) (Metadata.Page.make title description)
let compare_by_date a b = Date.compare a.date b.date
end
module Articles = struct
type t = {
articles : (Article.t * string) list;
title : string option;
description : string option;
}
let make ?title ?description articles = { articles; title; description }
let title p = p.title
let description p = p.description
let articles p = p.articles
let set_articles new_articles p = { p with articles = new_articles }
let set_title new_title p = { p with title = new_title }
let set_description new_desc p = { p with description = new_desc }
let sort ?(decreasing = true) articles =
List.sort
(fun (a, _) (b, _) ->
let a_date = Article.date a and b_date = Article.date b in
let r = Date.compare a_date b_date in
if decreasing then ~-r else r)
articles
let sort_articles_by_date ?(decreasing = true) p =
{ p with articles = sort ~decreasing p.articles }
let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
{ articles; title; description } =
( "articles",
D.list
(List.map
(fun (article, url) ->
D.object_
(("url", D.string url) :: Article.inject (module D) article))
articles) )
:: ("root", D.string ".")
:: (Metadata.Page.inject (module D) $ Metadata.Page.make title description)
end
let article_object (type a) (module D : Key_value.DESCRIBABLE with type t = a)
(article, url) =
D.object_ (("url", D.string url) :: Article.inject (module D) article)
module Tag = struct
type t = {
tag : string;
tags : (string * int) list;
articles : (Article.t * string) list;
title : string option;
description : string option;
}
let make ?title ?description tag articles tags =
{ tag; tags; articles = Articles.sort articles; title; description }
let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
{ tag; tags; articles; title; description } =
("tag", D.string tag)
:: ("root", D.string "..")
:: ("articles", D.list (List.map (article_object (module D)) articles))
:: ( "tags",
D.list
(List.map
(fun (tag, n) ->
D.object_
[
("name", D.string tag);
("link", D.string (tag_path tag));
("number", D.integer n);
])
tags) )
:: (Metadata.Page.inject (module D) $ Metadata.Page.make title description)
end

55
src/model.mli
View file

@ -1,55 +0,0 @@
open Yocaml
val article_path : Filepath.t -> Filepath.t
val tag_path : string -> Filepath.t
module Article : sig
type t
val date : t -> Date.t
val tags : t -> string list
val to_rss_item : string -> t -> Rss.Item.t
val compare_by_date : t -> t -> int
include Metadata.INJECTABLE with type t := t
include Metadata.READABLE with type t := t
end
module Tag : sig
type t
val make
: ?title:string
-> ?description:string
-> string
-> (Article.t * string) list
-> (string * int) list
-> t
include Metadata.INJECTABLE with type t := t
end
module Articles : sig
type t
val make
: ?title:string
-> ?description:string
-> (Article.t * string) list
-> t
val sort
: ?decreasing:bool
-> (Article.t * string) list
-> (Article.t * string) list
val sort_articles_by_date : ?decreasing:bool -> t -> t
val articles : t -> (Article.t * string) list
val title : t -> string option
val description : t -> string option
val set_title : string option -> t -> t
val set_description : string option -> t -> t
val set_articles : (Article.t * string) list -> t -> t
include Metadata.INJECTABLE with type t := t
end

108
src/task.ml
View file

@ -1,108 +0,0 @@
open Yocaml
module Metaformat = Yocaml_yaml
module Markup = Yocaml_cmark
module Template = Yocaml_jingoo
let css_target target = "css" |> into target
let javascript_target target = "js" |> into target
let images_target target = "images" |> into target
let template file = add_extension file "html" |> into "templates"
let article_template = template "article"
let layout_template = template "layout"
let list_template = template "list_articles"
let article_target file target = Model.article_path file |> into target
let binary_update = Build.watch Sys.argv.(0)
let index_html target = "index.html" |> into target
let index_md = "index.md" |> into "pages"
let rss_feed target = "feed.xml" |> into target
let tag_file tag target = Model.tag_path tag |> into target
let tag_template = template "tag"
let move_css target =
process_files
[ "css" ]
File.is_css
(Build.copy_file ~into:(css_target target))
;;
let move_javascript target =
process_files
[ "js" ]
File.is_javascript
(Build.copy_file ~into:(javascript_target target))
;;
let move_images target =
process_files
[ "images" ]
File.is_image
(Build.copy_file ~into:(images_target target))
;;
let process_articles target =
process_files [ "articles" ] File.is_markdown (fun article_file ->
let open Build in
create_file
(article_target article_file target)
(binary_update
>>> Metaformat.read_file_with_metadata
(module Model.Article)
article_file
>>> Markup.content_to_html ~strict:false ()
>>> Template.apply_as_template (module Model.Article) article_template
>>> Template.apply_as_template (module Model.Article) layout_template
>>^ Stdlib.snd))
;;
let merge_with_page ((meta, content), articles) =
let title = Metadata.Page.title meta in
let description = Metadata.Page.description meta in
Model.Articles.make ?title ?description articles, content
;;
let generate_feed target =
let open Build in
let* articles_arrow =
Collection.Articles.get_all (module Metaformat) "articles"
in
create_file
(rss_feed target)
(binary_update >>> articles_arrow >>^ Feed.make >>^ Rss.Channel.to_rss)
;;
let generate_tags target =
let* deps, tags = Collection.Tags.compute (module Metaformat) "articles" in
let tags_string = List.map (fun (i, s) -> i, List.length s) tags in
let mk_meta tag articles () = Model.Tag.make tag articles tags_string, "" in
List.fold_left
(fun program (tag, articles) ->
let open Build in
program
>> create_file
(tag_file tag target)
(init deps
>>> binary_update
>>^ mk_meta tag articles
>>> Template.apply_as_template (module Model.Tag) tag_template
>>> Template.apply_as_template (module Model.Tag) layout_template
>>^ Stdlib.snd))
(return ())
tags
;;
let generate_index target =
let open Build in
let* articles_arrow =
Collection.Articles.get_all (module Metaformat) "articles"
in
create_file
(index_html target)
(binary_update
>>> Metaformat.read_file_with_metadata (module Metadata.Page) index_md
>>> Markup.content_to_html ~strict:false ()
>>> articles_arrow
>>^ merge_with_page
>>> Template.apply_as_template (module Model.Articles) list_template
>>> Template.apply_as_template (module Model.Articles) layout_template
>>^ Stdlib.snd)
;;

7
src/task.mli
View file

@ -1,7 +0,0 @@
val move_css : string -> unit Yocaml.Effect.t
val move_images : string -> unit Yocaml.Effect.t
val move_javascript : string -> unit Yocaml.Effect.t
val process_articles : string -> unit Yocaml.Effect.t
val generate_feed : string -> unit Yocaml.Effect.t
val generate_index : string -> unit Yocaml.Effect.t
val generate_tags : string -> unit Yocaml.Effect.t

8
templates/article.html
View file

@ -1,13 +1,13 @@
<a href="/index.html">Back to index</a>
<a href="{{ host }}/index.html">Back to index</a>
<article>
<h1>{{ metadata.title }}</h1>
<h1>{{ title }}</h1>
<ul class="tags-list">
{%- for tag in tags -%}
<li><a href="/tags/{{ tag }}.html">{{ tag }}</a></li>
<li>{{ tag }}</li>
{%- endfor -%}
</ul>
{%- autoescape false -%}
{{ body }}
{{ yocaml_body }}
{% endautoescape -%}
</article>

12
templates/list_articles.html → templates/index.html
View file

@ -1,7 +1,7 @@
<a class="small-button rss" href="./feed.xml">RSS</a>
<a class="small-button rss" href="{{ host }}/feed.xml">RSS</a>
{%- autoescape false -%}
{{ body }}
{{ yocaml_body }}
{% endautoescape -%}
<h3>Essays and ramblings</h3>
@ -20,13 +20,13 @@
{%- endfor -%}
</div>
<div class="content">
<span class="date">{{ article.date.canonical }}</span>
<a href="{{ article.url }}">{{ article.metadata.title }}</a><br />
<p>{{ article.metadata.description }}</p>
<span class="date">{{ article.date.human }}</span>
<a href="{{ host }}{{ article.url }}">{{ article.title }}</a><br />
<p>{{ article.description }}</p>
<div class="bottom">
<ul class="tags-list">
{%- for tag in article.tags -%}
<li><a href="/tags/{{ tag }}.html">{{ tag }}</a></li>
<li>{{ tag }}</li>
{%- endfor -%}
</ul>
</div>

31
templates/layout.html
View file

@ -1,20 +1,3 @@
{%- if metadata.title -%}
{%- set dash = " - " -%}
{%- set page_title = metadata.title -%}
{%- elseif title -%}
{%- set dash = " - " -%}
{%- set page_title = title -%}
{%- else -%}
{%- set dash = "" -%}
{%- set page_title = "" -%}
{%- endif %}
{% if metadata.description -%}
{%- set page_description = metadata.description -%}
{%- elseif description -%}
{%- set page_description = description -%}
{%- else -%}
{%- set page_description = "blog.robur.coop" -%}
{%- endif -%}
<!doctype html>
<html lang="en">
<head>
@ -22,13 +5,13 @@
<meta http-equiv="x-ua-compatible" content="ie=edge">
<meta name="viewport" content="width=device-width, initial-scale=1">
<title>
Robur's blog{{ dash }}{{ page_title }}
Robur's blog{{ dash }}{{ title }}
</title>
<meta name="description" content="{{ page_description }}">
<link type="text/css" rel="stylesheet" href="{{ root }}/css/hl.css">
<link type="text/css" rel="stylesheet" href="{{ root }}/css/style.css">
<script src="{{ root }}/js/hl.js"></script>
<link rel="alternate" type="application/rss+xml" href="{{ root }}/feed.xml" title="blog.robur.coop">
<meta name="description" content="{{ description }}">
<link type="text/css" rel="stylesheet" href="{{ host }}/css/hl.css">
<link type="text/css" rel="stylesheet" href="{{ host }}/css/style.css">
<script src="{{ host }}/js/hl.js"></script>
<link rel="alternate" type="application/rss+xml" href="{{ host }}/feed.xml" title="blog.robur.coop">
</head>
<body>
<header>
@ -39,7 +22,7 @@
</header>
<main>
{%- autoescape false -%}
{{ body }}
{{ yocaml_body }}
{% endautoescape -%}
</main>
<footer>

3
update.sh
View file

@ -1,6 +1,7 @@
#!/bin/sh
opam exec -- dune exec src/blogger.exe -- push \
opam exec -- dune exec src/push.exe --
-r git@git.robur.coop:robur/blog.robur.coop.git#gh-pages \
--host https://blog.robur.coop \
--name "The Robur team" \
--email team@robur.coop