Merge pull request #6 from muhokama/add-blog

Add a federated blog

data/articles/guarded-methods.yml

@@ -0,0 +1,13 @@
+title: Guarded methods using equality witnesses
+synopsis: Guarded methods allow constraints to be attached to the receiver
+  (self) only for certain methods, so that these methods can only
+  be called if the receiver satisfies these constraints (these guards).
+  OCaml does not syntactically allow this type of method to be defined
+  directly. In this note, we'll look at how to encode them using a
+  type equality witness.
+date: 2022-05-29
+authors: [xvw]
+link:
+  url: https://xvw.lol/pages/oop-refl.html
+  lang: fra
+tags: [ocaml, oop, refl, gadt]

data/articles/import-modules.yml

@@ -0,0 +1,10 @@
+title: OCaml, modules and import schemes
+synopsis: In this article, we're going to look at how generalised openings
+  can be used to reproduce a common practice in other languages,
+  which I call, somewhat pompously, import strategies,
+date: 2023-10-31
+authors: [xvw]
+link:
+  url: https://xvw.lol/pages/modules-import.html
+  lang: fra
+tags: [ocaml, module]

data/articles/merlin-destruct.yml

@@ -0,0 +1,8 @@
+title: Effective ML Through Merlin's Destruct Command
+synopsis: This article presents the use of the destruct command in Merlin
+  and OCaml-lsp to generate missing patterns, or to specify patterns in
+  pattern matching.
+date: 2024-05-29
+authors: [xvw]
+link: https://tarides.com/blog/2024-05-29-effective-ml-through-merlin-s-destruct-command/
+tags: [ocaml, lsp, ide, emacs, vscode, vim, merlin]

data/blog.md

@@ -0,0 +1,9 @@
+---
+page_title: Blog
+description: A federated blog of Webring's member
+---
+
+The **Federated Blog** allows [webring members](/) to showcase federated
+articles on this page from _time to time_. The list of articles is not
+calculated automatically (via RSS/Atom feeds) but is the result of **a manual
+addition**. You can retrieve the [ATOM feed from the federated blog](/atom.xml).

lib/action/all.ml

@@ -13,6 +13,8 @@ let run (module R : Sigs.RESOLVER) () =
   >>= Fonts.run (module R)
   >>= Css.run (module R)
   >>= Images.run (module R)
+  >>= Articles.run (module R) chain
+  >>= Atom.run (module R) chain
   >>= Opml.run (module R) chain
   >>= Chain.run (module R) chain
   >>= Index.run (module R) chain

lib/action/articles.ml

@@ -0,0 +1,17 @@
+let run (module R : Sigs.RESOLVER) chain =
+  Yocaml.Action.write_static_file R.Target.blog
+    (let open Yocaml.Task in
+     R.track_common_dependencies
+     >>> Yocaml.Pipeline.track_file R.Source.articles
+     >>> Yocaml_yaml.Pipeline.read_file_with_metadata
+           (module Model.Page)
+           R.Source.blog
+     >>> first @@ Model.Articles.index chain R.Source.articles
+     >>> Yocaml_omd.content_to_html ()
+     >>> Yocaml_jingoo.Pipeline.as_template
+           (module Model.Articles)
+           (R.Source.template "blog.html")
+     >>> Yocaml_jingoo.Pipeline.as_template
+           (module Model.Articles)
+           (R.Source.template "layout.html")
+     >>> drop_first ())

lib/action/articles.mli

@@ -0,0 +1,3 @@
+(** An action that builds the webring blog. *)
+
+val run : (module Sigs.RESOLVER) -> Model.Chain.t -> Yocaml.Action.t

lib/action/atom.ml

@@ -0,0 +1,6 @@
+let run (module R : Sigs.RESOLVER) chain =
+  Yocaml.Action.write_static_file R.Target.atom
+    (let open Yocaml.Task in
+     R.track_common_dependencies
+     >>> Yocaml.Pipeline.track_file R.Source.articles
+     >>> Model.Articles.atom chain R.Source.articles)

lib/action/atom.mli

@@ -0,0 +1,3 @@
+(** An action that builds the Atom file of the federated blog. *)
+
+val run : (module Sigs.RESOLVER) -> Model.Chain.t -> Yocaml.Action.t

lib/model/article.ml

@@ -0,0 +1,66 @@
+open Model_util
+
+type t = {
+  title : string;
+  synopsis : string option;
+  date : Yocaml.Archetype.Datetime.t;
+  tags : string list;
+  authors : string list;
+  link : Link.t;
+}
+
+let entity_name = "Article"
+let neutral = Yocaml.Metadata.required entity_name
+
+let validate =
+  let open Yocaml.Data.Validation in
+  record (fun fl ->
+      let+ title = required fl "title" string
+      and+ synopsis = optional fl "synopsis" string
+      and+ date = required fl "date" Yocaml.Archetype.Datetime.validate
+      and+ link = required fl "link" Link.validate
+      and+ tags =
+        optional_or fl ~default:[] "tags" @@ list_of Yocaml.Slug.validate
+      and+ authors =
+        required fl "authors"
+        @@ ((string $ fun x -> [ x ]) / list_of Yocaml.Slug.validate)
+      in
+      { title; synopsis; date; tags; authors; link })
+
+let authors_in_chain chain { authors; _ } =
+  let chain = Chain.to_list chain in
+  List.for_all
+    (fun author ->
+      chain |> List.exists (fun (x, _) -> String.equal author (Member.id x)))
+    authors
+
+let normalize { title; synopsis; date; tags; authors; link } =
+  let open Yocaml.Data in
+  [
+    ("title", string title);
+    ("has_synopsis", has_opt synopsis);
+    ("synopsis", option string synopsis);
+    ("date", Yocaml.Archetype.Datetime.normalize date);
+    ("tags", list_of string tags);
+    ("has_tags", has_list tags);
+    ("authors", list_of string authors);
+    ("link", Link.normalize link);
+  ]
+
+let pp ppf article =
+  Format.fprintf ppf "%a" Yocaml.Data.pp
+    (article |> normalize |> Yocaml.Data.record)
+
+let sort a b = Yocaml.Archetype.Datetime.compare a.date b.date
+
+let to_atom chain { title; synopsis; date; tags; authors; link } =
+  let open Yocaml_syndication in
+  let title = title in
+  let authors = List.map (Chain.as_author chain) authors in
+  let updated = Datetime.make date in
+  let categories = List.map Category.make tags in
+  let url = link |> Link.url |> Url.to_string in
+  let summary = synopsis |> Option.map Atom.text in
+  let links = [ Atom.alternate url ~title ] in
+  Atom.entry ~authors ~updated ~categories ?summary ~links
+    ~title:(Atom.text title) ~id:url ()

lib/model/article.mli

@@ -0,0 +1,16 @@
+(** Describes an external Article. *)
+
+type t
+(** The type describing an article. *)
+
+val authors_in_chain : Chain.t -> t -> bool
+(** Ensure that authors are present in chain. *)
+
+val pp : Format.formatter -> t -> unit
+val sort : t -> t -> int
+val to_atom : Chain.t -> t -> Yocaml_syndication.Atom.entry
+
+(** {1 Dealing as metadata} *)
+
+include Yocaml.Required.DATA_READABLE with type t := t
+include Yocaml.Required.DATA_INJECTABLE with type t := t

lib/model/articles.ml

@@ -0,0 +1,53 @@
+open Model_util
+
+type t = { page : Page.t; articles : Article.t list }
+
+let from_page = Yocaml.Task.lift (fun (page, articles) -> { page; articles })
+
+let fetch ?limit chain path =
+  Yocaml.Task.from_effect (fun () ->
+      let open Yocaml.Eff in
+      let* files =
+        read_directory ~on:`Source ~only:`Files
+          ~where:(Yocaml.Path.has_extension "yml")
+          path
+      in
+
+      let+ articles =
+        List.traverse
+          (fun file ->
+            Yocaml_yaml.Eff.read_file_as_metadata
+              (module Article)
+              ~on:`Source file)
+          files
+      in
+      limit
+      |> Option.fold ~none:articles ~some:(fun limit ->
+             articles |> Stdlib.List.filteri (fun i _ -> i > limit))
+      |> Stdlib.List.sort (fun a b -> Article.sort b a)
+      |> Stdlib.List.filter (Article.authors_in_chain chain))
+
+let index ?limit chain path =
+  let open Yocaml.Task in
+  lift (fun x -> (x, ())) >>> second (fetch ?limit chain path) >>> from_page
+
+let normalize { page; articles } =
+  let open Yocaml.Data in
+  Page.normalize page
+  @ [
+      ("articles", list_of (fun x -> record (Article.normalize x)) articles);
+      ("has_articles", has_list articles);
+    ]
+
+let atom chain path =
+  let open Yocaml_syndication in
+  let open Yocaml.Task in
+  let id = "https://ring.muhokama.fun/atom.xml" in
+  let title = Atom.text "ring.muhokama.fun" in
+  let subtitle = Atom.text "federated blog of Muhokama webring" in
+  let links = [ Atom.self id; Atom.link "https://ring.muhokama.fun" ] in
+  let updated = Atom.updated_from_entries () in
+  let authors = Chain.to_authors chain in
+  fetch chain path
+  >>> Atom.from ~updated ~title ~subtitle ~id ~links ~authors
+        (Article.to_atom chain)

lib/model/articles.mli

@@ -0,0 +1,11 @@
+(** Describes a federation page of external articles published by ring members. *)
+
+type t
+(** The type describing the federation. *)
+
+val index : ?limit:int -> Chain.t -> Yocaml.Path.t -> (Page.t, t) Yocaml.Task.t
+val atom : Chain.t -> Yocaml.Path.t -> (unit, string) Yocaml.Task.t
+
+(** {1 Dealing as metadata} *)
+
+include Yocaml.Required.DATA_INJECTABLE with type t := t

lib/model/chain.ml

@@ -69,5 +69,18 @@ let normalize_elt { pred; curr; succ } =
     @ [ ("pred", string @@ Member.id pred); ("succ", string @@ Member.id succ) ]
     )
 
+let unknow_author = Yocaml_syndication.Person.make "Unknown author"
 let normalize = Yocaml.Data.list_of normalize_elt
 let is_empty = List.is_empty
+
+let to_authors chain =
+  match List.map (fun { curr; _ } -> Member.as_author curr) chain with
+  | [] -> (* Should never happen *) Yocaml.Nel.singleton unknow_author
+  | x :: xs -> Yocaml.Nel.(x :: xs)
+
+let as_author chain id =
+  chain
+  |> List.find_map (fun { curr; _ } ->
+         if String.equal (Member.id curr) id then Some curr else None)
+  |> Option.fold ~none:unknow_author (* Should never happen *)
+       ~some:Member.as_author

lib/model/chain.mli

@@ -31,6 +31,8 @@ val to_list : t -> (Member.t * (Member.t * Member.t)) list
 val to_opml : (t, string) Yocaml.Task.t
 (** [to_opml] An arrow that lift a chain into an OPML file. *)
 
+val as_author : t -> string -> Yocaml_syndication.Person.t
+val to_authors : t -> Yocaml_syndication.Person.t Yocaml.Nel.t
 val is_empty : t -> bool
 val normalize : t -> Yocaml.Data.t
 

lib/model/link.ml

@@ -4,14 +4,15 @@ type t = string * Lang.t * Url.t
 
 let validate =
   let open Yocaml.Data.Validation in
-  record (fun fields ->
-      let* url = required fields "url" Url.validate in
-      let+ lang = optional_or fields "lang" ~default:Lang.Eng Lang.validate
-      and+ title =
-        optional_or fields ~default:(Url.url url) "title"
-          (string & minimal_length 1)
-      in
-      (title, lang, url))
+  (Url.validate $ fun url -> (Url.url url, Lang.Eng, url))
+  / record (fun fields ->
+        let* url = required fields "url" Url.validate in
+        let+ lang = optional_or fields "lang" ~default:Lang.Eng Lang.validate
+        and+ title =
+          optional_or fields ~default:(Url.url url) "title"
+            (string & minimal_length 1)
+        in
+        (title, lang, url))
 
 let normalize_underlying_link (title, lang, url) =
   let open Yocaml.Data in

lib/model/member.ml

@@ -146,3 +146,8 @@ let to_outline member =
            feed_to_outline title description feed)
   in
   main_feed @ additional_feeds
+
+let as_author m =
+  Yocaml_syndication.Person.make
+    ~uri:(m.main_link |> Link.url |> Url.url)
+    (display_name m)

lib/model/member.mli

@@ -31,6 +31,8 @@ val to_string : t -> string
 val equal : t -> t -> bool
 (** Equality between members. *)
 
+val as_author : t -> Yocaml_syndication.Person.t
+
 (** {1 Dealing as metadata} *)
 
 include Yocaml.Required.DATA_READABLE with type t := t

lib/resolver.ml

@@ -12,10 +12,12 @@ module Make (R : Sigs.RESOLVABLE) = struct
     let templates = Path.(static / "templates")
     let template file = Path.(templates / file)
     let members = Path.(data / "members")
+    let articles = Path.(data / "articles")
     let chain = Path.(data / "chain.yml")
     let common_deps = [ binary; chain ]
     let cname = Path.(static / "CNAME")
     let index = Path.(data / "index.md")
+    let blog = Path.(data / "blog.md")
     let static_images = Path.(static / "images")
     let avatars = Path.(data / "avatars")
   end
@@ -24,6 +26,7 @@ module Make (R : Sigs.RESOLVABLE) = struct
     let root = R.target
     let cache = Path.(R.target / "cache")
     let opml = Path.(R.target / "opml")
+    let atom = Path.(R.target / "atom.xml")
     let ring_opml = Path.(opml / "ring.opml")
     let members = Path.(R.target / "u")
     let css = Path.(R.target / "css")
@@ -32,6 +35,7 @@ module Make (R : Sigs.RESOLVABLE) = struct
     let images = Path.(R.target / "images")
     let avatars = Path.(images / "avatars")
     let member ~id = Path.(members / id / "index.html")
+    let blog = Path.(R.target / "blog.html")
 
     let member_redirection ~id pred_or_succ =
       let target = Path.(members / id) in

lib/sigs.mli

@@ -41,8 +41,10 @@ module type RESOLVER = sig
     val fonts : Yocaml.Path.t
     val templates : Yocaml.Path.t
     val members : Yocaml.Path.t
+    val articles : Yocaml.Path.t
     val chain : Yocaml.Path.t
     val index : Yocaml.Path.t
+    val blog : Yocaml.Path.t
     val avatars : Yocaml.Path.t
 
     val template : Yocaml.Path.fragment -> Yocaml.Path.t
@@ -67,12 +69,14 @@ module type RESOLVER = sig
     val css : Yocaml.Path.t
     val fonts : Yocaml.Path.t
     val opml : Yocaml.Path.t
+    val atom : Yocaml.Path.t
     val ring_opml : Yocaml.Path.t
     val index : Yocaml.Path.t
     val images : Yocaml.Path.t
     val members : Yocaml.Path.t
     val member_redirection : id:string -> [ `Pred | `Succ ] -> Yocaml.Path.t
     val member : id:string -> Yocaml.Path.t
     val avatars : Yocaml.Path.t
+    val blog : Yocaml.Path.t
   end
 end