Compare commits
No commits in common. "82ccf565fca6ee96ce207f8a65e3de99eed84bb7" and "c363e84b9632c49b66eb83e1a2cf8c7ede690f33" have entirely different histories.
82ccf565fc
...
c363e84b96
|
|
@ -1,6 +1,3 @@
|
||||||
---
|
|
||||||
title: About me
|
|
||||||
---
|
|
||||||
## About
|
## About
|
||||||
|
|
||||||
I have an interest in programming languages, and in particular *functional* ones with a *good* type system.
|
I have an interest in programming languages, and in particular *functional* ones with a *good* type system.
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,3 @@
|
||||||
---
|
|
||||||
title: Contact
|
|
||||||
---
|
|
||||||
## Email
|
## Email
|
||||||
|
|
||||||
I have written my email in [BNF](http://en.wikipedia.org/wiki/Backus%E2%80%93Naur_Form):
|
I have written my email in [BNF](http://en.wikipedia.org/wiki/Backus%E2%80%93Naur_Form):
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,6 @@
|
||||||
---
|
---
|
||||||
title: Hakyll
|
title: Hakyll
|
||||||
date: 2013-10-19
|
date: 2013-10-19
|
||||||
description: First post
|
|
||||||
---
|
---
|
||||||
|
|
||||||
I decided to check out [Hakyll](http://jaspervdj.be/hakyll). It is a static
|
I decided to check out [Hakyll](http://jaspervdj.be/hakyll). It is a static
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,6 @@
|
||||||
---
|
---
|
||||||
title: Intertubes
|
title: Intertubes
|
||||||
date: 2013-10-19
|
date: 2013-10-19
|
||||||
description: A short description of what happens when you click on Mario
|
|
||||||
---
|
---
|
||||||
|
|
||||||
\
|
\
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,6 @@
|
||||||
---
|
---
|
||||||
title: AngularJS training
|
title: AngularJS training
|
||||||
date: 2014-10-02
|
date: 2014-10-02
|
||||||
description: I went to a AngularJS training
|
|
||||||
---
|
---
|
||||||
|
|
||||||
Yesterday I attended a great [AngularJS](https://angularjs.org/) training session by [Matias Niemelä](http://www.yearofmoo.com/) after having volunteered for the [goto Aarhus](http://gotocon.com/aarhus-2014/) conference.
|
Yesterday I attended a great [AngularJS](https://angularjs.org/) training session by [Matias Niemelä](http://www.yearofmoo.com/) after having volunteered for the [goto Aarhus](http://gotocon.com/aarhus-2014/) conference.
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,6 @@
|
||||||
---
|
---
|
||||||
date: 2014-10-05
|
date: 2014-10-05
|
||||||
title: DigitalOcean tcpdump?
|
title: DigitalOcean tcpdump?
|
||||||
description: I noticed an odd "tcpdump" event in DigitalOcean API output
|
|
||||||
---
|
---
|
||||||
Lately I have been working on implementing v2 of DigitalOcean's API.
|
Lately I have been working on implementing v2 of DigitalOcean's API.
|
||||||
While doing that I ran a query to get all actions on my account.
|
While doing that I ran a query to get all actions on my account.
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,6 @@
|
||||||
---
|
---
|
||||||
title: SSH Certificates with Gitolite
|
title: SSH Certificates with Gitolite
|
||||||
date: 2015-11-08
|
date: 2015-11-08
|
||||||
description: How to use SSH certificates with Gitolite
|
|
||||||
---
|
---
|
||||||
|
|
||||||
[Gitolite] is a "an access control layer on top of Git, providing fine access control to Git repositories."
|
[Gitolite] is a "an access control layer on top of Git, providing fine access control to Git repositories."
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,6 @@
|
||||||
---
|
---
|
||||||
title: Mirage hack retreat 2017
|
title: Mirage hack retreat 2017
|
||||||
date: 2017-03-20
|
date: 2017-03-20
|
||||||
description: I went to a MirageOS hack retreat and wrote a trip report
|
|
||||||
---
|
---
|
||||||
|
|
||||||
Two weeks ago I was in Marrakech to attend the third [Mirage](https://mirage.io/) [hack retreat](http://marrakech2017.mirage.io/).
|
Two weeks ago I was in Marrakech to attend the third [Mirage](https://mirage.io/) [hack retreat](http://marrakech2017.mirage.io/).
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,6 @@
|
||||||
---
|
---
|
||||||
title: Python's `str.__repr__()`
|
title: Python's `str.__repr__()`
|
||||||
date: 2024-02-03
|
date: 2024-02-03
|
||||||
description: Reimplementing Python string escaping in OCaml
|
|
||||||
---
|
---
|
||||||
Sometimes software is written using whatever built-ins you find in your programming language of choice.
|
Sometimes software is written using whatever built-ins you find in your programming language of choice.
|
||||||
This is usually great!
|
This is usually great!
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,6 @@
|
||||||
---
|
---
|
||||||
title: Discoveries made implementing MirageVPN, a OpenVPN-compatible VPN library
|
title: Discoveries made implementing MirageVPN, a OpenVPN-compatible VPN library
|
||||||
date: 2024-08-21
|
date: 2024-08-21
|
||||||
description: Discoveries made implementing MirageVPN, a OpenVPN-compatible VPN library
|
|
||||||
---
|
---
|
||||||
At [Robur][robur] we have been busy at work implementing our OpenVPN™-compatible MirageVPN software.
|
At [Robur][robur] we have been busy at work implementing our OpenVPN™-compatible MirageVPN software.
|
||||||
Recently we have implemented the [server side][miragevpn-server].
|
Recently we have implemented the [server side][miragevpn-server].
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,6 @@
|
||||||
---
|
---
|
||||||
title: MirageOS retreat & Banawá chat
|
title: MirageOS retreat & Banawá chat
|
||||||
date: 2023-05-07
|
date: 2023-05-07
|
||||||
description: Notes about a trust on first use application written at the 12th MirageOS hack retreat
|
|
||||||
---
|
---
|
||||||
In beginning of May 2023 I had the joy to participate in the 12th [MirageOS hack retreat][retreat] in Marrakech, Morocco.
|
In beginning of May 2023 I had the joy to participate in the 12th [MirageOS hack retreat][retreat] in Marrakech, Morocco.
|
||||||
There I met faces I know from previous retreats as well as many new faces.
|
There I met faces I know from previous retreats as well as many new faces.
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,6 @@
|
||||||
---
|
---
|
||||||
title: Migrating to YOCaml
|
title: Migrating to YOCaml
|
||||||
date: 2023-11-17
|
date: 2023-11-17
|
||||||
description: Notes about migrating off Hakyll to Yocaml
|
|
||||||
---
|
---
|
||||||
|
|
||||||
About a decade ago I created a blog on this website.
|
About a decade ago I created a blog on this website.
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,8 @@
|
||||||
---
|
---
|
||||||
author:
|
author:
|
||||||
name: Reynir Björnsson
|
name: Reynir Björnsson
|
||||||
link: https://reyn.ir/
|
|
||||||
email: reynir@reynir.dk
|
|
||||||
title: Miragevpn & tls-crypt-v2
|
title: Miragevpn & tls-crypt-v2
|
||||||
date: 2023-11-14
|
date: 2023-11-14
|
||||||
description: How we implemented tls-crypt-v2 for MirageVPN
|
|
||||||
---
|
---
|
||||||
|
|
||||||
In 2019 [Robur][robur.coop] started working on a [OpenVPN™-compatible implementation in OCaml][miragevpn].
|
In 2019 [Robur][robur.coop] started working on a [OpenVPN™-compatible implementation in OCaml][miragevpn].
|
||||||
|
|
|
||||||
|
|
@ -22,12 +22,13 @@ depends: [
|
||||||
"preface" { >= "0.1.0" }
|
"preface" { >= "0.1.0" }
|
||||||
"logs" {>= "0.7.0" }
|
"logs" {>= "0.7.0" }
|
||||||
"cmdliner" { >= "1.0.0"}
|
"cmdliner" { >= "1.0.0"}
|
||||||
"yocaml" {>= "2.0.0"}
|
"http-lwt-client"
|
||||||
"yocaml_unix" {>= "2.0.0"}
|
"yocaml"
|
||||||
"yocaml_yaml" {>= "2.0.0"}
|
"yocaml_unix"
|
||||||
"yocaml_git" {>= "2.0.0"}
|
"yocaml_yaml"
|
||||||
"yocaml_jingoo" {>= "2.0.0"}
|
#"yocaml_markdown"
|
||||||
"yocaml_cmarkit" {>= "2.0.0"}
|
"yocaml_git"
|
||||||
"yocaml_syndication" {>= "2.0.0"}
|
"yocaml_jingoo"
|
||||||
|
"yocaml_cmark"
|
||||||
"jingoo" {>= "1.5.0"}
|
"jingoo" {>= "1.5.0"}
|
||||||
]
|
]
|
||||||
|
|
|
||||||
749
src/blog.ml
749
src/blog.ml
|
|
@ -1,749 +0,0 @@
|
||||||
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
15
src/dune
|
|
@ -2,13 +2,20 @@
|
||||||
(public_name reynir-www)
|
(public_name reynir-www)
|
||||||
(name reynir_www)
|
(name reynir_www)
|
||||||
(libraries
|
(libraries
|
||||||
|
logs
|
||||||
|
logs.fmt
|
||||||
|
logs.cli
|
||||||
|
fmt
|
||||||
fmt.tty
|
fmt.tty
|
||||||
logs logs.fmt
|
fmt.cli
|
||||||
|
cmdliner
|
||||||
|
preface
|
||||||
|
mirage-clock-unix
|
||||||
|
http-lwt-client
|
||||||
git-unix
|
git-unix
|
||||||
yocaml
|
yocaml
|
||||||
yocaml_yaml
|
yocaml_yaml
|
||||||
yocaml_cmarkit
|
yocaml_cmark
|
||||||
yocaml_unix
|
yocaml_unix
|
||||||
yocaml_git
|
yocaml_git
|
||||||
yocaml_jingoo
|
yocaml_jingoo))
|
||||||
yocaml_syndication))
|
|
||||||
|
|
|
||||||
19
src/file.ml
Normal file
19
src/file.ml
Normal file
|
|
@ -0,0 +1,19 @@
|
||||||
|
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
Normal file
6
src/file.mli
Normal file
|
|
@ -0,0 +1,6 @@
|
||||||
|
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
Normal file
152
src/model.ml
Normal file
|
|
@ -0,0 +1,152 @@
|
||||||
|
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
|
||||||
|
|
@ -1,26 +1,76 @@
|
||||||
let caller = Filename.basename Sys.argv.(0)
|
let caller = Filename.basename Sys.argv.(0)
|
||||||
let version = "%%VERSION%%"
|
let version = "%%VERSION%%"
|
||||||
let default_port = 8888
|
let default_port = 8888
|
||||||
|
let default_target = Fpath.v "_site"
|
||||||
|
|
||||||
let watch port =
|
let program ~target =
|
||||||
let level = `Info in
|
let open Yocaml in
|
||||||
let module Dest = Blog.Make(struct
|
let* () = Task.move_css target in
|
||||||
let source = Yocaml.Path.rel []
|
let* () = Task.move_images target in
|
||||||
end)
|
let* () = Task.move_js target in
|
||||||
in
|
let* () = Task.move_audio target in
|
||||||
let host = Fmt.str "http://localhost:%d" port in
|
let* () = Task.process_articles target in
|
||||||
Yocaml_unix.serve ~level ~target:Dest.target ~port
|
let* () = Task.generate_about target in
|
||||||
@@ fun () -> Dest.process_all ~host
|
let* () = Task.generate_contact target in
|
||||||
|
let* () = Task.generate_archive target in
|
||||||
|
Task.generate_index target
|
||||||
|
|
||||||
let build () =
|
let local_build _quiet target =
|
||||||
let level = `Info in
|
Yocaml_unix.execute (program ~target:(Fpath.to_string target))
|
||||||
let module Dest = Blog.Make(struct
|
|
||||||
let source = Yocaml.Path.rel []
|
let watch quiet target port =
|
||||||
end)
|
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
|
in
|
||||||
let host = Fmt.str "/" in
|
let with_metadata header _tags k ppf fmt =
|
||||||
Yocaml_unix.run ~level
|
Fmt.kpf
|
||||||
@@ fun () -> Dest.process_all ~host
|
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 man =
|
||||||
let open Cmdliner in
|
let open Cmdliner in
|
||||||
|
|
@ -33,13 +83,18 @@ let watch_cmd =
|
||||||
website on demand"
|
website on demand"
|
||||||
in
|
in
|
||||||
let exits = Cmd.Exit.defaults 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 port_arg =
|
||||||
let doc = "The port" in
|
let doc = "The port" in
|
||||||
let arg = Arg.info ~doc [ "port"; "P"; "p" ] in
|
let arg = Arg.info ~doc [ "port"; "P"; "p" ] in
|
||||||
Arg.(value & opt int default_port & arg)
|
Arg.(value & opt int default_port & arg)
|
||||||
in
|
in
|
||||||
let info = Cmd.info "watch" ~version ~doc ~exits ~man in
|
let info = Cmd.info "watch" ~version ~doc ~exits ~man in
|
||||||
Cmd.v info Term.(const watch $ port_arg)
|
Cmd.v info Term.(const watch $ setup_logs $ path_arg $ port_arg)
|
||||||
|
|
||||||
|
|
||||||
let build_cmd =
|
let build_cmd =
|
||||||
|
|
@ -47,7 +102,12 @@ let build_cmd =
|
||||||
let doc = "Build the website into the specified directory" in
|
let doc = "Build the website into the specified directory" in
|
||||||
let exits = Cmd.Exit.defaults in
|
let exits = Cmd.Exit.defaults in
|
||||||
let info = Cmd.info "build" ~version ~doc ~exits ~man in
|
let info = Cmd.info "build" ~version ~doc ~exits ~man in
|
||||||
Cmd.v info Term.(const build $ const ())
|
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)
|
||||||
|
|
||||||
let cmd =
|
let cmd =
|
||||||
let open Cmdliner in
|
let open Cmdliner in
|
||||||
|
|
|
||||||
109
src/task.ml
Normal file
109
src/task.ml
Normal file
|
|
@ -0,0 +1,109 @@
|
||||||
|
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)
|
||||||
|
|
@ -3,7 +3,5 @@
|
||||||
<h2>{{title}}</h2>
|
<h2>{{title}}</h2>
|
||||||
Written by {{author.name}}, {{date.month_repr}} {{date.day}}, {{date.year}}
|
Written by {{author.name}}, {{date.month_repr}} {{date.day}}, {{date.year}}
|
||||||
</header>
|
</header>
|
||||||
{%- autoescape false -%}
|
{{body|safe}}
|
||||||
{{yocaml_body}}
|
|
||||||
{% endautoescape %}
|
|
||||||
</article>
|
</article>
|
||||||
|
|
|
||||||
|
|
@ -22,7 +22,7 @@
|
||||||
</header>
|
</header>
|
||||||
<main>
|
<main>
|
||||||
{%- autoescape false -%}
|
{%- autoescape false -%}
|
||||||
{{ yocaml_body }}
|
{{ body }}
|
||||||
{% endautoescape %}
|
{% endautoescape %}
|
||||||
</main>
|
</main>
|
||||||
<footer>
|
<footer>
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue