Merge branch 'yocaml2'

pages/about.md

@@ -1,3 +1,6 @@
+---
+title: About me
+---
 ## About
 
 I have an interest in programming languages, and in particular *functional* ones with a *good* type system.

pages/contact.md

@@ -1,3 +1,6 @@
+---
+title: Contact
+---
 ## Email
 
 I have written my email in [BNF](http://en.wikipedia.org/wiki/Backus%E2%80%93Naur_Form):

posts/2013-10-19-12-00-hakyll.markdown

@@ -1,6 +1,7 @@
 ---
 title: Hakyll
 date: 2013-10-19
+description: First post
 ---
 
 I decided to check out [Hakyll](http://jaspervdj.be/hakyll). It is a static

posts/2013-10-19-14-35-intertubes.markdown

@@ -1,6 +1,7 @@
 ---
 title: Intertubes
 date: 2013-10-19
+description: A short description of what happens when you click on Mario
 ---
 
 ![Mario](/images/mario.jpg)\

posts/2014-10-02-12-25-Angular.js.markdown

@@ -1,6 +1,7 @@
 ---
 title: AngularJS training
 date: 2014-10-02
+description: I went to a AngularJS training
 ---
 
 Yesterday I attended a great [AngularJS](https://angularjs.org/) training session by [Matias Niemelä](http://www.yearofmoo.com/) after having volunteered for the [goto Aarhus](http://gotocon.com/aarhus-2014/) conference.

posts/2014-10-05-17-45-DigitalOcean-tcpdump.markdown

@@ -1,6 +1,7 @@
 ---
 date: 2014-10-05
 title: DigitalOcean tcpdump?
+description: I noticed an odd "tcpdump" event in DigitalOcean API output
 ---
 Lately I have been working on implementing v2 of DigitalOcean's API.
 While doing that I ran a query to get all actions on my account.

posts/2015-11-08-14-10-SSH-certificates-with-Gitolite.markdown

@@ -1,6 +1,7 @@
 ---
 title: SSH Certificates with Gitolite
 date: 2015-11-08
+description: How to use SSH certificates with Gitolite
 ---
 
 [Gitolite] is a "an access control layer on top of Git, providing fine access control to Git repositories."

posts/2017-03-20-11-27-Marrakech-2017.markdown

@@ -1,6 +1,7 @@
 ---
 title: Mirage hack retreat 2017
 date: 2017-03-20
+description: I went to a MirageOS hack retreat and wrote a trip report
 ---
 
 Two weeks ago I was in Marrakech to attend the third [Mirage](https://mirage.io/) [hack retreat](http://marrakech2017.mirage.io/).

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

@@ -1,6 +1,7 @@
 ---
 title: Python's `str.__repr__()`
 date: 2024-02-03
+description: Reimplementing Python string escaping in OCaml
 ---
 Sometimes software is written using whatever built-ins you find in your programming language of choice.
 This is usually great!

posts/2024-08-21-OpenVPN-and-MirageVPN.markdown

@@ -1,6 +1,7 @@
 ---
 title: Discoveries made implementing MirageVPN, a OpenVPN-compatible VPN library
 date: 2024-08-21
+description: Discoveries made implementing MirageVPN, a OpenVPN-compatible VPN library
 ---
 At [Robur][robur] we have been busy at work implementing our OpenVPN™-compatible MirageVPN software.
 Recently we have implemented the [server side][miragevpn-server].

posts/banawa-chat.md

@@ -1,6 +1,7 @@
 ---
 title: MirageOS retreat & Banawá chat
 date: 2023-05-07
+description: Notes about a trust on first use application written at the 12th MirageOS hack retreat
 ---
 In beginning of May 2023 I had the joy to participate in the 12th [MirageOS hack retreat][retreat] in Marrakech, Morocco.
 There I met faces I know from previous retreats as well as many new faces.

posts/migrating-to-yocaml.md

@@ -1,6 +1,7 @@
 ---
 title: Migrating to YOCaml
 date: 2023-11-17
+description: Notes about migrating off Hakyll to Yocaml
 ---
 
 About a decade ago I created a blog on this website.

posts/miragevpn-tls-crypt-v2.md

@@ -1,8 +1,11 @@
 ---
 author:
   name: Reynir Björnsson
+  link: https://reyn.ir/
+  email: reynir@reynir.dk
 title: Miragevpn & tls-crypt-v2
 date: 2023-11-14
+description: How we implemented tls-crypt-v2 for MirageVPN
 ---
 
 In 2019 [Robur][robur.coop] started working on a [OpenVPN™-compatible implementation in OCaml][miragevpn].

reynir-www.opam

@@ -22,13 +22,12 @@ depends: [
   "preface" { >= "0.1.0" }
   "logs" {>= "0.7.0" }
   "cmdliner" { >= "1.0.0"}
-  "http-lwt-client"
+  "yocaml" {>= "2.0.0"}
-  "yocaml"
+  "yocaml_unix" {>= "2.0.0"}
-  "yocaml_unix"
+  "yocaml_yaml" {>= "2.0.0"}
-  "yocaml_yaml"
+  "yocaml_git" {>= "2.0.0"}
-  #"yocaml_markdown"
+  "yocaml_jingoo" {>= "2.0.0"}
-  "yocaml_git"
+  "yocaml_cmarkit" {>= "2.0.0"}
-  "yocaml_jingoo"
+  "yocaml_syndication" {>= "2.0.0"}
-  "yocaml_cmark"
   "jingoo" {>= "1.5.0"}
 ]

src/blog.ml

@@ -0,0 +1,749 @@
+open Yocaml
+
+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 string_of_month = function
+    | Jan -> "Jan"
+    | Feb -> "Feb"
+    | Mar -> "Mar"
+    | Apr -> "Apr"
+    | May -> "May"
+    | Jun -> "Jun"
+    | Jul -> "Jul"
+    | Aug -> "Aug"
+    | Sep -> "Sep"
+    | Oct -> "Oct"
+    | Nov -> "Nov"
+    | Dec -> "Dec"
+
+  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))
+      ; ("month_repr", string (string_of_month month))
+      ; ("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
+
+  let normalize (p : t) =
+    let open Data in
+    [
+      ("title", (option string) p#title);
+      ("charset", (option string) p#charset);
+      ("description", (option string) p#description);
+    ]
+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 reynir =
+  new Author.author
+    ~name:"Reynir Björnsson" ~link:"https://reyn.ir/"
+    ~email:"reynir@reynir.dk" ()
+
+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:reynir "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 @@ ((=) []) obj#articles)
+    ; ("title", option string obj#title)
+    ; ("description", option string obj#description)
+    ; ("host", option string obj#get_host)
+    ]
+end
+
+module Page_with_article = struct
+  class type t = object ('self)
+    inherit Page.t
+    method articles : (Path.t * Article.t) list
+  end
+  
+  let normalize_article (ident, article) =
+    let open Data in
+    record (("url", string @@ Path.to_string ident) :: Article.normalize article)
+
+  let normalize (p : t) =
+    let open Data in
+    [
+      ("title", (option string) p#title);
+      ("charset", (option string) p#charset);
+      ("description", (option string) p#description);
+      ("tags", (list_of string) p#tags);
+      ("articles", list_of normalize_article p#articles);
+    ]
+end
+
+
+let is_markdown_file path =
+  Path.has_extension "md" path ||
+  Path.has_extension "markdown" path
+
+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 audio = Path.(source_root / "audio")
+    let articles = Path.(source_root / "posts")
+    let index = Path.(source_root / "pages" / "index.md")
+    let about = Path.(source_root / "pages" / "about.md")
+    let contact = Path.(source_root / "pages" / "contact.md")
+    let archive = Path.(source_root / "pages" / "archive.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 / "posts")
+    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_audio_files =
+    Action.copy_directory ~into:Target.target_root Source.audio
+
+  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:is_markdown_file Source.articles
+      (process_article ~host)
+
+  let process_archive ~host =
+    let file = Source.archive in
+    let file_target = Target.(as_html target_root file) in
+
+    let open Task in
+    let compute_index =
+      Articles.compute_index
+        (module Yocaml_yaml)
+        ~where:is_markdown_file
+        ~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
+        >>> first compute_index
+        >>* (fun (obj, str) -> Eff.return (obj#with_host host, str))
+        >>> (lift (fun (articles, tpl) ->
+            articles,
+            Yocaml_jingoo.render ~strict:true
+              (List.map (fun (k, v) -> k, Yocaml_jingoo.from v) (Articles.normalize articles))
+              tpl))
+        >>> Yocaml_jingoo.Pipeline.as_template ~strict:true
+              (module Articles)
+              (Source.template "layout.html")
+        >>> Yocaml_cmarkit.content_to_html ()
+        >>> drop_first ()
+      end
+
+  let process_page file =
+    let file_target = Target.(as_html target_root file) in
+    let open Task in
+    Action.write_static_file file_target
+      begin
+        Pipeline.track_files [ Source.binary; file ]
+        >>> Yocaml_yaml.Pipeline.read_file_with_metadata (module Page) file
+        >>> Yocaml_cmarkit.content_to_html ()
+        >>> Yocaml_jingoo.Pipeline.as_template ~strict:true
+              (module Page)
+              (Source.template "layout.html")
+        >>> drop_first ()
+      end
+
+  let process_contact = process_page Source.contact
+  let process_about = process_page Source.about
+
+  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 =
+      let rec filter = function
+        | [] | [_] | [_; _] | [_; _; _] as latest_three -> latest_three
+        | _too_old :: more_recent -> filter more_recent
+      in
+      Articles.compute_index
+        ~filter
+        (module Yocaml_yaml)
+        ~where:is_markdown_file
+        ~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
+        >>> first compute_index
+        >>* (fun (obj, str) -> Eff.return (obj#with_host host, str))
+        >>> (lift (fun (articles, tpl) ->
+            articles,
+            Yocaml_jingoo.render ~strict:true
+              (List.map (fun (k, v) -> k, Yocaml_jingoo.from v) (Articles.normalize articles))
+              tpl))
+        >>> Yocaml_jingoo.Pipeline.as_template ~strict:true
+              (module Articles)
+              (Source.template "layout.html")
+        >>> Yocaml_cmarkit.content_to_html ()
+        >>> drop_first ()
+      end
+
+  let feed_title = "Root of Reynir"
+  let site_url = "https://reyn.ir/"
+  let feed_description = "Reynir's 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 "Reynir Björnsson" 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_audio_files
+    >>= process_contact >>= process_about >>= process_archive ~host
+    >>= 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)

src/dune

@@ -2,20 +2,13 @@
   (public_name reynir-www)
   (name reynir_www)
   (libraries
-    logs
-    logs.fmt
-    logs.cli
-    fmt
     fmt.tty
-    fmt.cli
+    logs logs.fmt
-    cmdliner
-    preface
-    mirage-clock-unix
-    http-lwt-client
     git-unix
     yocaml
     yocaml_yaml
-    yocaml_cmark
+    yocaml_cmarkit
     yocaml_unix
     yocaml_git
-    yocaml_jingoo))
+    yocaml_jingoo
+    yocaml_syndication))

src/file.ml

@@ -1,19 +0,0 @@
-open Yocaml
-
-let is_css = with_extension "css"
-let is_javascript =
-  let open Preface.Predicate in
-  with_extension "js" ||
-  with_extension "map"
-
-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,152 +0,0 @@
-open Yocaml
-
-let article_path file =
-  let filename = basename $ replace_extension file "html" in
-  filename |> into "posts"
-
-module Author = struct
-  type t = {
-    name : string;
-  }
-
-  let equal a b = String.equal a.name b.name
-
-  let make name = { name }
-
-  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)
-      obj
-
-  let default_author =
-    make "Reynir Björnsson"
-
-  let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a) { name } =
-    D.[ "name", string name ]
-end
-
-module Article = struct
-  type t = {
-    title : string;
-    date : Date.t;
-    author : Author.t;
-  }
-
-  let make title date author =
-    { title; date; author }
-
-  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) "title" assoc
-         <*> V.(required_assoc (Metadata.Date.from (module V))) "date" assoc
-         <*> V.(optional_assoc_or (Author.from (module V))) "author" assoc ~default:Author.default_author)
-      obj
-
-  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 >>=
-      from (module V)
-
-  let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
-      { title; date; author } =
-    D.[ "title", string title;
-        "date", object_ $ Metadata.Date.inject (module D) date;
-        "author", object_ $ Author.inject (module D) author ];
-end
-
-module Articles = struct
-  type t = (string * Article.t) list
-
-  let make path article = (path, article)
-
-  let sort articles =
-    List.sort
-      (fun (_, a) (_, b) ->
-         ~-(Date.compare a.Article.date b.Article.date))
-      articles
-
-  let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a) articles =
-    D.[
-      "articles",
-      list
-        (List.map (fun (path, article) ->
-             object_ @@
-             [ "location", string path ] @
-             Article.inject (module D) article)
-            articles)
-    ]
-end
-
-module With_path (V : Metadata.INJECTABLE) = struct
-  type t = {
-    path : string;
-    extension : V.t;
-  }
-  
-  let merge path v =
-    { path; extension=v; }
-
-  let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a) { path; extension } =
-    D.[ "path", string path ] @ V.inject (module D) extension
-end
-
-module Page = struct
-  type t = {
-    title : string;
-    head_extra : string option;
-  }
-  
-  let make title head_extra = { title; head_extra }
-
-  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) "title" assoc
-         <*> V.(optional_assoc string) "head_extra" assoc)
-      obj
-
-  let from_string (module V : Metadata.VALIDABLE) = function
-    | None -> Validate.valid { title = "TODO"; head_extra = None }
-    | Some str ->
-      Validate.Monad.bind
-        (from (module V))
-        (V.from_string str)
-
-  let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
-      { title; head_extra } =
-    let r = D.[ "title", string title ] in
-    match head_extra with
-    | None -> r
-    | Some head_extra -> ("head_extra", D.string head_extra) :: r
-end
-
-module With_layout (V : Metadata.INJECTABLE) = struct
-  type t = {
-    title : string;
-    head_extra : string option;
-    extension : V.t
-  }
-
-  let merge ~title ~head_extra v =
-    { title; head_extra; extension = v }
-
-  let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
-      { title; head_extra; extension = v } =
-    let r =
-      D.[ "title", string title ] @
-      V.inject (module D) v
-    in
-    match head_extra with
-    | None -> r
-    | Some head_extra -> ("head_extra", D.string head_extra) :: r
-end

src/reynir_www.ml

@@ -1,76 +1,26 @@
 let caller = Filename.basename Sys.argv.(0)
 let version = "%%VERSION%%"
 let default_port = 8888
-let default_target = Fpath.v "_site"
 
-let program ~target =
+let watch port =
-  let open Yocaml in
+  let level = `Info in
-  let* () = Task.move_css target in
+  let module Dest = Blog.Make(struct
-  let* () = Task.move_images target in
+      let source = Yocaml.Path.rel []
-  let* () = Task.move_js target in
+    end)
-  let* () = Task.move_audio target in
-  let* () = Task.process_articles target in
-  let* () = Task.generate_about target in
-  let* () = Task.generate_contact target in
-  let* () = Task.generate_archive target in
-  Task.generate_index target
-
-let local_build _quiet target =
-  Yocaml_unix.execute (program ~target:(Fpath.to_string target))
-
-let watch quiet target port =
-  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 "REYNIR_LOGS" in
-  Logs_cli.level ~docs:common_options ~env ()
-
-let renderer =
-  let open Cmdliner in
-  let env = Cmd.Env.info "REYNIR_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 =
+  let host = Fmt.str "http://localhost:%d" port in
-      Fmt.kpf
+  Yocaml_unix.serve ~level ~target:Dest.target ~port
-        k
+  @@ fun () -> Dest.process_all ~host
-        ppf
+
-        ("%a[%a]: " ^^ fmt ^^ "\n%!")
+let build () =
-        Logs_fmt.pp_header
+  let level = `Info in
-        (level, header)
+  let module Dest = Blog.Make(struct
-        Fmt.(styled `Magenta string)
+      let source = Yocaml.Path.rel []
-        (Logs.Src.name src)
+    end)
   in
-    msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt
+  let host = Fmt.str "/" in
-  in
+  Yocaml_unix.run ~level
-  { Logs.report }
+  @@ fun () -> Dest.process_all ~host
-
-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
@@ -83,18 +33,13 @@ let watch_cmd =
      website on demand"
   in
   let exits = Cmd.Exit.defaults in
-  let path_arg =
-    let doc = "Specify where we build the website" 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 = "The port" in
     let arg = Arg.info ~doc [ "port"; "P"; "p" ] in
     Arg.(value & opt int default_port & arg)
   in
   let info = Cmd.info "watch" ~version ~doc ~exits ~man in
-  Cmd.v info Term.(const watch $ setup_logs $ path_arg $ port_arg)
+  Cmd.v info Term.(const watch $ port_arg)
 
 
 let build_cmd =
@@ -102,12 +47,7 @@ let build_cmd =
   let doc = "Build the website into the specified directory" in
   let exits = Cmd.Exit.defaults in
   let info = Cmd.info "build" ~version ~doc ~exits ~man in
-  let path_arg =
+  Cmd.v info Term.(const build $ const ())
-    let doc = "Specify where to build the website" 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 cmd = 
   let open Cmdliner in

src/task.ml

@@ -1,109 +0,0 @@
-open Yocaml
-module Metaformat = Yocaml_yaml
-module Markup = Yocaml_cmark
-module Template = Yocaml_jingoo
-
-let css_target target = "css" |> into target
-let images_target target = "images" |> into target
-let js_target target = "js" |> into target
-let audio_target target = "audio" |> into target
-let index_html target = "index.html" |> into target
-let about_html target = "about.html" |> into target
-let contact_html target = "contact.html" |> into target
-let archive_html target = "archive.html" |> into target
-let article_target file target = Model.article_path file |> into target
-
-let move_css target =
-  process_files
-    [ "css" ]
-    File.is_css
-    (Build.copy_file ~into:(css_target target))
-
-let move_images target =
-  process_files
-    [ "images" ]
-    File.is_image
-    (Build.copy_file ~into:(images_target target))
-
-let move_js target =
-  process_files
-    [ "js" ]
-    File.is_javascript
-    (Build.copy_file ~into:(js_target target))
-
-let move_audio target =
-  process_files
-    [ "audio" ]
-    (with_extension "ogg")
-    (Build.copy_file ~into:(audio_target target))
-
-let with_layout (type a) (module M : Metadata.INJECTABLE with type t = a)
-    (read_model : (_, a) Build.t) page target =
-  let open Build in
-  let module M = Model.With_layout(M) in
-  let apply_template_from_string (v, content) =
-    let values = M.inject (module Template) v in
-    let content = Template.to_string ~strict:true values content in
-    (v, content)
-  in
-  create_file target
-    (watch Sys.argv.(0)
-     >>> Metaformat.read_file_with_metadata (module Model.Page) page
-     &&& read_model
-     >>^ (fun (({ Model.Page.title; head_extra }, content), v) ->
-         M.merge ~title ~head_extra v, content)
-     >>^ apply_template_from_string
-     >>> Markup.content_to_html ~strict:false ()
-     >>> Template.apply_as_template (module M) "templates/layout.html"
-     >>^ Stdlib.snd)
-
-let process_articles target =
-  let open Build in
-  process_files [ "posts" ] File.is_markdown (fun article_file ->
-      create_file (article_target article_file target)
-        (Metaformat.read_file_with_metadata (module Model.Article) article_file
-         >>> Markup.content_to_html ~strict:false ()
-         >>> Template.apply_as_template (module Model.Article) "templates/article.html"
-         >>> Template.apply_as_template (module Model.Article) "templates/layout.html"
-         >>^ Stdlib.snd))
-
-
-let articles =
-  let open Build in
-  collection
-    (read_child_files "posts" File.is_markdown)
-    (fun path ->
-       Metaformat.read_file_with_metadata (module Model.Article) path
-       >>^ fun (meta, _data) ->
-       (Model.article_path path, meta))
-    (fun articles () -> Model.Articles.sort articles)
-
-let generate_archive target =
-  let* articles = articles in
-  with_layout (module Model.Articles) articles "pages/archive.md" (archive_html target)
-
-let page page_file target =
-  let open Build in
-  create_file target
-    (watch Sys.argv.(0)
-     >>> Metaformat.read_file_with_metadata (module Model.Page) page_file
-     >>> Markup.content_to_html ~strict:false ()
-     >>> Template.apply_as_template (module Model.Page) "templates/layout.html"
-     >>^ Stdlib.snd)
-
-let generate_about target =
-  page "pages/about.md" (about_html target)
-
-let generate_contact target =
-  page "pages/contact.md" (contact_html target)
-
-let generate_index target =
-  let* articles = articles in
-  let rec take n xs =
-    match n, xs with
-    | 0, _ | _, [] -> []
-    | _, x :: xs -> x :: take (pred n) xs
-  in
-  let open Build in
-  let articles = articles >>^ take 3 in
-  with_layout (module Model.Articles) articles "pages/index.md" (index_html target)

templates/article.html

@@ -3,5 +3,7 @@
   <h2>{{title}}</h2>
   Written by {{author.name}}, {{date.month_repr}} {{date.day}}, {{date.year}}
 </header>
-{{body|safe}}
+{%- autoescape false -%}
+{{yocaml_body}}
+{% endautoescape %}
 </article>

templates/layout.html

@@ -22,7 +22,7 @@
     </header>
     <main>
       {%- autoescape false -%}
-      {{ body }}
+      {{ yocaml_body }}
       {% endautoescape %}
     </main>
     <footer>