Merge pull request 'Upgrade to the unreleased version of YOCaml 2' (#2) from yocaml2 into main

Reviewed-on: robur/blog.robur.coop#2
Reviewed-by: Reynir Björnsson <reynir@reynir.dk>

.gitignore

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

README.md

@@ -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]
 ```

articles/2024-02-03-python-str-repr.md

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

articles/2024-08-21-OpenVPN-and-MirageVPN.md

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

articles/gptar.md

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

articles/lwt_pause.md

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

articles/miragevpn-ncp.md

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

articles/miragevpn-performance.md

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

articles/miragevpn-server.md

@@ -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.

articles/miragevpn.md

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

articles/qubes-miragevpn.md

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

articles/speeding-ec-string.md

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

articles/tar-release.md

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

bin/blog.ml

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

bin/blog.mli

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

bin/dune

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

bin/push.ml

@@ -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>#<branch>"
+    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 including #branch, e.g. " ^ !remote)
+  ; ("--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)

bin/watch.ml

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

blogger.opam

@@ -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,8 +18,8 @@ dev-repo: "git://github.com/dinosaure/blogger.git"
 bug-reports: "https://github.com/dinosaure/blogger/issues"
 
 depends: [
-  "ocaml" { >= "4.11.1" }
-  "dune" { >= "2.8" }
+  "ocaml" { >= "5.1.0" }
+  "dune" { >= "3.16.0" }
   "preface" { >= "0.1.0" }
   "logs" {>= "0.7.0" }
   "cmdliner" { >= "1.0.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" ]
 ]

dune-project

@@ -1,2 +1,2 @@
-(lang dune 2.8)
+(lang dune 3.16)
 (name blogger)

src/blogger.ml

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

src/collection.ml

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

src/collection.mli

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

src/dune

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

src/feed.ml

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

src/feed.mli

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

src/file.ml

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

src/file.mli

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

src/model.ml

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

src/model.mli

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

src/task.ml

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

src/task.mli

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

templates/article.html

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

templates/index.html

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

templates/layout.html

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

update.sh

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