reynir/reynir.dk
1
0
Fork 0
Code Issues 5 Pull requests Packages Projects Releases Wiki Activity

Update to Yocaml 2

Browse source
This commit is contained in:
Reynir Björnsson 2024-10-07 19:01:52 +02:00
parent c363e84b96
commit ae943d2b33
12 changed files with 789 additions and 386 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
pages/about.md
View file

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

3
pages/contact.md
View file

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

15
reynir-www.opam
View file

@ -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"}
]

749
src/blog.ml Normal file
View file

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

15
src/dune
View file

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

19
src/file.ml
View file

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

6
src/file.mli
View file

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

152
src/model.ml
View file

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

98
src/reynir_www.ml
View file

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

109
src/task.ml
View file

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

4
templates/article.html
View file

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

2
templates/layout.html
View file

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