From ae943d2b3342b81ccef0ef7e17fdee4a8942a324 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Mon, 7 Oct 2024 19:01:52 +0200 Subject: [PATCH] Update to Yocaml 2 --- pages/about.md | 3 + pages/contact.md | 3 + reynir-www.opam | 15 +- src/blog.ml | 749 +++++++++++++++++++++++++++++++++++++++++ src/dune | 15 +- src/file.ml | 19 -- src/file.mli | 6 - src/model.ml | 152 --------- src/reynir_www.ml | 98 ++---- src/task.ml | 109 ------ templates/article.html | 4 +- templates/layout.html | 2 +- 12 files changed, 789 insertions(+), 386 deletions(-) create mode 100644 src/blog.ml delete mode 100644 src/file.ml delete mode 100644 src/file.mli delete mode 100644 src/model.ml delete mode 100644 src/task.ml diff --git a/pages/about.md b/pages/about.md index 4f0a16e..0a41cdc 100644 --- a/pages/about.md +++ b/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. diff --git a/pages/contact.md b/pages/contact.md index 9a4a124..42ee1b4 100644 --- a/pages/contact.md +++ b/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): diff --git a/reynir-www.opam b/reynir-www.opam index 83ce8f6..8f76e43 100644 --- a/reynir-www.opam +++ b/reynir-www.opam @@ -22,13 +22,12 @@ depends: [ "preface" { >= "0.1.0" } "logs" {>= "0.7.0" } "cmdliner" { >= "1.0.0"} - "http-lwt-client" - "yocaml" - "yocaml_unix" - "yocaml_yaml" - #"yocaml_markdown" - "yocaml_git" - "yocaml_jingoo" - "yocaml_cmark" + "yocaml" {>= "2.0.0"} + "yocaml_unix" {>= "2.0.0"} + "yocaml_yaml" {>= "2.0.0"} + "yocaml_git" {>= "2.0.0"} + "yocaml_jingoo" {>= "2.0.0"} + "yocaml_cmarkit" {>= "2.0.0"} + "yocaml_syndication" {>= "2.0.0"} "jingoo" {>= "1.5.0"} ] diff --git a/src/blog.ml b/src/blog.ml new file mode 100644 index 0000000..1c08945 --- /dev/null +++ b/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) diff --git a/src/dune b/src/dune index 1cbf4a4..b8ab338 100644 --- a/src/dune +++ b/src/dune @@ -2,20 +2,13 @@ (public_name reynir-www) (name reynir_www) (libraries - logs - logs.fmt - logs.cli - fmt fmt.tty - fmt.cli - cmdliner - preface - mirage-clock-unix - http-lwt-client + logs logs.fmt git-unix yocaml yocaml_yaml - yocaml_cmark + yocaml_cmarkit yocaml_unix yocaml_git - yocaml_jingoo)) + yocaml_jingoo + yocaml_syndication)) diff --git a/src/file.ml b/src/file.ml deleted file mode 100644 index d6db82d..0000000 --- a/src/file.ml +++ /dev/null @@ -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" diff --git a/src/file.mli b/src/file.mli deleted file mode 100644 index c44bc0d..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 53454d3..0000000 --- a/src/model.ml +++ /dev/null @@ -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 diff --git a/src/reynir_www.ml b/src/reynir_www.ml index 636240a..6bca397 100644 --- a/src/reynir_www.ml +++ b/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 open Yocaml in - let* () = Task.move_css target in - let* () = Task.move_images target in - let* () = Task.move_js target in - 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 = - 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 +let watch port = + let level = `Info in + let module Dest = Blog.Make(struct + let source = Yocaml.Path.rel [] + end) in - { Logs.report } + let host = Fmt.str "http://localhost:%d" port in + Yocaml_unix.serve ~level ~target:Dest.target ~port + @@ 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 build () = + let level = `Info in + let module Dest = Blog.Make(struct + let source = Yocaml.Path.rel [] + end) + in + let host = Fmt.str "/" in + Yocaml_unix.run ~level + @@ fun () -> Dest.process_all ~host 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 = - 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) + Cmd.v info Term.(const build $ const ()) let cmd = let open Cmdliner in diff --git a/src/task.ml b/src/task.ml deleted file mode 100644 index 18a3b2f..0000000 --- a/src/task.ml +++ /dev/null @@ -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) diff --git a/templates/article.html b/templates/article.html index cb7e7b7..3cde9ee 100644 --- a/templates/article.html +++ b/templates/article.html @@ -3,5 +3,7 @@

{{title}}

Written by {{author.name}}, {{date.month_repr}} {{date.day}}, {{date.year}} -{{body|safe}} +{%- autoescape false -%} +{{yocaml_body}} +{% endautoescape %} diff --git a/templates/layout.html b/templates/layout.html index d20ad06..162d51f 100644 --- a/templates/layout.html +++ b/templates/layout.html @@ -22,7 +22,7 @@
{%- autoescape false -%} - {{ body }} + {{ yocaml_body }} {% endautoescape %}