From 6b343af91cffe2c4becb3f1ce1563013741b7fcd Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 30 Sep 2024 20:39:49 +0200 Subject: [PATCH] Upgrade to the unreleased version of YOCaml 2 --- .gitignore | 3 + README.md | 13 +- articles/2024-02-03-python-str-repr.md | 4 +- ...wn => 2024-08-21-OpenVPN-and-MirageVPN.md} | 4 +- articles/gptar.md | 4 +- articles/lwt_pause.md | 8 +- articles/miragevpn-ncp.md | 4 +- articles/miragevpn-performance.md | 5 +- articles/miragevpn-server.md | 7 +- articles/miragevpn.md | 4 +- articles/qubes-miragevpn.md | 4 +- articles/speeding-ec-string.md | 6 +- articles/tar-release.md | 4 +- bin/blog.ml | 638 ++++++++++++++++++ bin/blog.mli | 14 + bin/dune | 23 + bin/push.ml | 60 ++ bin/watch.ml | 15 + blogger.opam | 18 +- src/blogger.ml | 332 --------- src/collection.ml | 64 -- src/collection.mli | 18 - src/dune | 21 - src/feed.ml | 15 - src/feed.mli | 1 - src/file.ml | 18 - src/file.mli | 6 - src/model.ml | 256 ------- src/model.mli | 55 -- src/task.ml | 108 --- src/task.mli | 7 - templates/article.html | 8 +- templates/{list_articles.html => index.html} | 12 +- templates/layout.html | 31 +- update.sh | 3 +- 35 files changed, 822 insertions(+), 971 deletions(-) create mode 100644 .gitignore rename articles/{2024-08-21-OpenVPN-and-MirageVPN.markdown => 2024-08-21-OpenVPN-and-MirageVPN.md} (99%) create mode 100644 bin/blog.ml create mode 100644 bin/blog.mli create mode 100644 bin/dune create mode 100644 bin/push.ml create mode 100644 bin/watch.ml delete mode 100644 src/blogger.ml delete mode 100644 src/collection.ml delete mode 100644 src/collection.mli delete mode 100644 src/dune delete mode 100644 src/feed.ml delete mode 100644 src/feed.mli delete mode 100644 src/file.ml delete mode 100644 src/file.mli delete mode 100644 src/model.ml delete mode 100644 src/model.mli delete mode 100644 src/task.ml delete mode 100644 src/task.mli rename templates/{list_articles.html => index.html} (70%) diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..ea972c8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +_build/ +_site/ +_cache diff --git a/README.md b/README.md index 241a4ce..0c59861 100644 --- a/README.md +++ b/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] ``` diff --git a/articles/2024-02-03-python-str-repr.md b/articles/2024-02-03-python-str-repr.md index 35fef77..3915aa7 100644 --- a/articles/2024-02-03-python-str-repr.md +++ b/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 diff --git a/articles/2024-08-21-OpenVPN-and-MirageVPN.markdown b/articles/2024-08-21-OpenVPN-and-MirageVPN.md similarity index 99% rename from articles/2024-08-21-OpenVPN-and-MirageVPN.markdown rename to articles/2024-08-21-OpenVPN-and-MirageVPN.md index 2d96b1e..2888d71 100644 --- a/articles/2024-08-21-OpenVPN-and-MirageVPN.markdown +++ b/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 diff --git a/articles/gptar.md b/articles/gptar.md index c44586d..7627e4d 100644 --- a/articles/gptar.md +++ b/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 diff --git a/articles/lwt_pause.md b/articles/lwt_pause.md index 177bd15..f28c7cf 100644 --- a/articles/lwt_pause.md +++ b/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 --- diff --git a/articles/miragevpn-ncp.md b/articles/miragevpn-ncp.md index 3fd3c73..4f6f2df 100644 --- a/articles/miragevpn-ncp.md +++ b/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 diff --git a/articles/miragevpn-performance.md b/articles/miragevpn-performance.md index 5c76186..19e0649 100644 --- a/articles/miragevpn-performance.md +++ b/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). diff --git a/articles/miragevpn-server.md b/articles/miragevpn-server.md index 51ec0c2..471b11d 100644 --- a/articles/miragevpn-server.md +++ b/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. @@ -37,4 +36,4 @@ The overall progress was tracked in [this issue](https://github.com/robur-coop/m Please move along to our handbook with the [chapter on MirageVPN server](https://robur-coop.github.io/miragevpn-handbook/miragevpn_server.html). -If you encounter any issues, please open an issue at [the repository](https://github.com/robur-coop/miragevpn). \ No newline at end of file +If you encounter any issues, please open an issue at [the repository](https://github.com/robur-coop/miragevpn). diff --git a/articles/miragevpn.md b/articles/miragevpn.md index 5aa782f..3efe4de 100644 --- a/articles/miragevpn.md +++ b/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 diff --git a/articles/qubes-miragevpn.md b/articles/qubes-miragevpn.md index 8c89776..ff8964c 100644 --- a/articles/qubes-miragevpn.md +++ b/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 diff --git a/articles/speeding-ec-string.md b/articles/speeding-ec-string.md index d3c3162..36a0252 100644 --- a/articles/speeding-ec-string.md +++ b/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 @@ -95,4 +95,4 @@ Remove all cstruct, everywhere, apart from in mirage-block-xen and mirage-net-xe Our MirageOS work is only partially funded, we cross-fund our work by commercial contracts and public (EU) funding. We are part of a non-profit company, you can make a (tax-deducable - at least in the EU) [donation](https://aenderwerk.de/donate/) (select "DONATION robur" in the dropdown menu). -We're keen to get MirageOS deployed in production - if you would like to do that, don't hesitate to reach out to us via eMail team at robur.coop \ No newline at end of file +We're keen to get MirageOS deployed in production - if you would like to do that, don't hesitate to reach out to us via eMail team at robur.coop diff --git a/articles/tar-release.md b/articles/tar-release.md index d50afee..8632e79 100644 --- a/articles/tar-release.md +++ b/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 diff --git a/bin/blog.ml b/bin/blog.ml new file mode 100644 index 0000000..11d0884 --- /dev/null +++ b/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) diff --git a/bin/blog.mli b/bin/blog.mli new file mode 100644 index 0000000..1d8a0cc --- /dev/null +++ b/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 diff --git a/bin/dune b/bin/dune new file mode 100644 index 0000000..cc61281 --- /dev/null +++ b/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)) diff --git a/bin/push.ml b/bin/push.ml new file mode 100644 index 0000000..831afdb --- /dev/null +++ b/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 ] [--author ] [--email ] -r \ + " + Sys.argv.(0) + +let specification = + [ + ("--message", Arg.Set_string message, "The commit message") + ; ("--email", Arg.Set_string email, "The email used to craft the commit") + ; ("-r", Arg.Set_string remote, "The Git repository") + ; ("--author", Arg.Set_string author, "The Git commit author") + ; ("--host", Arg.Set_string host, "The host where the blog is available") + ] + +let () = + Arg.parse specification ignore usage; + let author = !author + and email = !email + and message = !message + and remote = !remote in + let module Blog = Blog.Make_with_target (struct + let source = Yocaml.Path.rel [] + let target = Yocaml.Path.rel [] + end) in + Yocaml_git.run + (module Source) + (module Pclock) + ~context:`SSH ~author ~email ~message ~remote + (fun () -> Blog.process_all ~host:!host) + |> Lwt_main.run + |> Result.iter_error (fun (`Msg err) -> invalid_arg err) diff --git a/bin/watch.ml b/bin/watch.ml new file mode 100644 index 0000000..7b5e1e2 --- /dev/null +++ b/bin/watch.ml @@ -0,0 +1,15 @@ +let port = ref 8000 +let usage = Fmt.str "%s [--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 diff --git a/blogger.opam b/blogger.opam index 92d7f42..cac440c 100644 --- a/blogger.opam +++ b/blogger.opam @@ -5,7 +5,7 @@ maintainer: "romain.calascibetta@gmail.com" authors: [ "The XHTMLBoy " ] build: [ - [ "dune" "subst" ] + [ "dune" "subst" ] {dev} [ "dune" "build" "-p" name "-j" jobs ] [ "dune" "runtest" "-p" name ] {with-test} [ "dune" "build" "@doc" "-p" name ] {with-doc} @@ -18,7 +18,7 @@ dev-repo: "git://github.com/dinosaure/blogger.git" bug-reports: "https://github.com/dinosaure/blogger/issues" depends: [ - "ocaml" { >= "4.11.1" } + "ocaml" { >= "5.1.0" } "dune" { >= "2.8" } "preface" { >= "0.1.0" } "logs" {>= "0.7.0" } @@ -27,7 +27,19 @@ depends: [ "yocaml" "yocaml_unix" "yocaml_yaml" - "yocaml_cmark" + "yocaml_cmarkit" "yocaml_git" "yocaml_jingoo" + "yocaml_syndication" +] + +pin-depends: [ + ["yocaml.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ] + ["yocaml_runtime.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ] + ["yocaml_unix.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ] + ["yocaml_yaml.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ] + ["yocaml_cmarkit.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ] + ["yocaml_git.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ] + ["yocaml_jingoo.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ] + ["yocaml_syndication.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ] ] diff --git a/src/blogger.ml b/src/blogger.ml deleted file mode 100644 index 1f10188..0000000 --- a/src/blogger.ml +++ /dev/null @@ -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 diff --git a/src/collection.ml b/src/collection.ml deleted file mode 100644 index 4dac762..0000000 --- a/src/collection.ml +++ /dev/null @@ -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 diff --git a/src/collection.mli b/src/collection.mli deleted file mode 100644 index e721e3d..0000000 --- a/src/collection.mli +++ /dev/null @@ -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 diff --git a/src/dune b/src/dune deleted file mode 100644 index 19d19de..0000000 --- a/src/dune +++ /dev/null @@ -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)) diff --git a/src/feed.ml b/src/feed.ml deleted file mode 100644 index a725464..0000000 --- a/src/feed.ml +++ /dev/null @@ -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) diff --git a/src/feed.mli b/src/feed.mli deleted file mode 100644 index 7c270c3..0000000 --- a/src/feed.mli +++ /dev/null @@ -1 +0,0 @@ -val make : unit * Collection.Articles.t -> Yocaml.Rss.Channel.t diff --git a/src/file.ml b/src/file.ml deleted file mode 100644 index 7723023..0000000 --- a/src/file.ml +++ /dev/null @@ -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" -;; diff --git a/src/file.mli b/src/file.mli deleted file mode 100644 index f808f54..0000000 --- a/src/file.mli +++ /dev/null @@ -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 diff --git a/src/model.ml b/src/model.ml deleted file mode 100644 index e62346d..0000000 --- a/src/model.ml +++ /dev/null @@ -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 diff --git a/src/model.mli b/src/model.mli deleted file mode 100644 index c3ae259..0000000 --- a/src/model.mli +++ /dev/null @@ -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 diff --git a/src/task.ml b/src/task.ml deleted file mode 100644 index 8b80ffe..0000000 --- a/src/task.ml +++ /dev/null @@ -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) -;; diff --git a/src/task.mli b/src/task.mli deleted file mode 100644 index bab6303..0000000 --- a/src/task.mli +++ /dev/null @@ -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 diff --git a/templates/article.html b/templates/article.html index 234ba5e..c79a7fe 100644 --- a/templates/article.html +++ b/templates/article.html @@ -1,13 +1,13 @@ -Back to index +Back to index
-

{{ metadata.title }}

+

{{ title }}

    {%- for tag in tags -%} -
  • {{ tag }}
    • +
  • {{ tag }}
    • {%- endfor -%}
{%- autoescape false -%} - {{ body }} + {{ yocaml_body }} {% endautoescape -%}
diff --git a/templates/list_articles.html b/templates/index.html similarity index 70% rename from templates/list_articles.html rename to templates/index.html index 34cabcf..7137414 100644 --- a/templates/list_articles.html +++ b/templates/index.html @@ -1,7 +1,7 @@ -RSS +RSS {%- autoescape false -%} -{{ body }} +{{ yocaml_body }} {% endautoescape -%}

Essays and ramblings

@@ -20,13 +20,13 @@ {%- endfor -%}
- {{ article.date.canonical }} - {{ article.metadata.title }}
-

{{ article.metadata.description }}

+ {{ article.date.human }} + {{ article.title }}
+

{{ article.description }}

    {%- for tag in article.tags -%} -
  • {{ tag }}
    • +
  • {{ tag }}
    • {%- endfor -%}
diff --git a/templates/layout.html b/templates/layout.html index 669cddf..5ce1db5 100644 --- a/templates/layout.html +++ b/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 -%} @@ -22,13 +5,13 @@ - Robur's blog{{ dash }}{{ page_title }} + Robur's blog{{ dash }}{{ title }} - - - - - + + + + +
@@ -39,7 +22,7 @@
{%- autoescape false -%} - {{ body }} + {{ yocaml_body }} {% endautoescape -%}