Upgrade to the unreleased version of YOCaml 2

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

3
.gitignore vendored Normal file
View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -1,7 +1,7 @@
--- ---
date: 2024-04-16 date: 2024-04-16
article.title: Speeding up MirageVPN and use it in the wild title: Speeding up MirageVPN and use it in the wild
article.description: description:
Performance engineering of MirageVPN, speeding it up by a factor of 25. Performance engineering of MirageVPN, speeding it up by a factor of 25.
tags: tags:
- OCaml - OCaml
@ -19,7 +19,6 @@ coauthors:
name: Reynir Björnsson name: Reynir Björnsson
email: reynir@reynir.dk email: reynir@reynir.dk
link: https://reyn.ir/ 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). 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).

View file

@ -1,7 +1,7 @@
--- ---
date: 2024-06-17 date: 2024-06-17
article.title: MirageVPN server title: MirageVPN server
article.description: description:
Announcement of our MirageVPN server. Announcement of our MirageVPN server.
tags: tags:
- OCaml - OCaml
@ -18,7 +18,6 @@ coauthors:
name: Reynir Björnsson name: Reynir Björnsson
email: reynir@reynir.dk email: reynir@reynir.dk
link: https://reyn.ir/ 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. 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.

View file

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

View file

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

View file

@ -1,7 +1,7 @@
--- ---
date: 2024-02-13 date: 2024-02-13
article.title: Speeding elliptic curve cryptography title: Speeding elliptic curve cryptography
article.description: description:
How we improved the performance of elliptic curves by only modifying the underlying byte array How we improved the performance of elliptic curves by only modifying the underlying byte array
tags: tags:
- OCaml - OCaml

View file

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

View file

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

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

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

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

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))

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)

View file

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

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"
;;

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

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

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

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)
;;

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

View file

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

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

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

View file

@ -1,6 +1,7 @@
#!/bin/sh #!/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 \ -r git@git.robur.coop:robur/blog.robur.coop.git#gh-pages \
--host https://blog.robur.coop \
--name "The Robur team" \ --name "The Robur team" \
--email team@robur.coop --email team@robur.coop