Upgrade to the unreleased version of YOCaml 2
This commit is contained in:
parent
aa6bcc5277
commit
6b343af91c
35 changed files with 822 additions and 971 deletions
3
.gitignore
vendored
Normal file
3
.gitignore
vendored
Normal file
|
@ -0,0 +1,3 @@
|
|||
_build/
|
||||
_site/
|
||||
_cache
|
13
README.md
13
README.md
|
@ -10,25 +10,26 @@ $ git clone git@git.robur.coop:robur/blog.robur.coop
|
|||
$ cd blog.robur.coop/
|
||||
$ opam pin add -yn .
|
||||
$ opam install --deps-only blogger
|
||||
$ dune exec src/blogger.exe -- watch
|
||||
$ dune exec src/watch.exe --
|
||||
```
|
||||
|
||||
A little server run on `http://localhost:8888`.
|
||||
A little server run on `http://localhost:8000`.
|
||||
|
||||
The user can add an article into the `articles/` directory. The format is easy.
|
||||
A simple header which starts with `---` and finish with `---`. Inside, you have
|
||||
a YAML description of the article where some fields are required:
|
||||
- `date`
|
||||
- `article.title`
|
||||
- `article.description`
|
||||
- `title`
|
||||
- `description`
|
||||
- `tags`
|
||||
|
||||
You can specify an `author` (with its `name`, `email` and `link`) or not. By
|
||||
default, we use `team@robur.coop`. If everything looks good, you can generate
|
||||
via the `blogger.exe` tool the generated website via:
|
||||
```shell-session
|
||||
$ dune exec src/blogger.exe -- push \
|
||||
-r git@git.robur.coop:robur/blog.robur.coop.git#gh-pages
|
||||
$ dune exec src/push.exe -- push \
|
||||
-r git@git.robur.coop:robur/blog.robur.coop.git#gh-pages \
|
||||
--host https://blog.robur.coop
|
||||
[--name "The Robur team"] \
|
||||
[--email team@robur.coop]
|
||||
```
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
---
|
||||
date: 2024-02-03
|
||||
article.title: Python's `str.__repr__()`
|
||||
article.description: Reimplementing Python string escaping in OCaml
|
||||
title: Python's `str.__repr__()`
|
||||
description: Reimplementing Python string escaping in OCaml
|
||||
tags:
|
||||
- OCaml
|
||||
- Python
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
---
|
||||
date: 2024-08-21
|
||||
article.title: MirageVPN and OpenVPN
|
||||
article.description: Discoveries made implementing MirageVPN, a OpenVPN-compatible VPN library
|
||||
title: MirageVPN and OpenVPN
|
||||
description: Discoveries made implementing MirageVPN, a OpenVPN-compatible VPN library
|
||||
tags:
|
||||
- MirageVPN
|
||||
- OpenVPN
|
|
@ -1,7 +1,7 @@
|
|||
---
|
||||
date: 2024-02-21
|
||||
article.title: GPTar
|
||||
article.description: Hybrid GUID partition table and tar archive
|
||||
title: GPTar
|
||||
description: Hybrid GUID partition table and tar archive
|
||||
tags:
|
||||
- OCaml
|
||||
- gpt
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
---
|
||||
date: 2024-02-11
|
||||
article.title: Cooperation and Lwt.pause
|
||||
article.description:
|
||||
title: Cooperation and Lwt.pause
|
||||
description:
|
||||
A disgression about Lwt and Miou
|
||||
tags:
|
||||
- OCaml
|
||||
|
@ -9,6 +9,10 @@ tags:
|
|||
- Community
|
||||
- Unikernel
|
||||
- Git
|
||||
author:
|
||||
name: Romain Calascibetta
|
||||
email: romain.calascibetta@gmail.com
|
||||
link: https://blog.osau.re/
|
||||
breaks: false
|
||||
---
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
---
|
||||
date: 2023-11-20
|
||||
article.title: MirageVPN updated (AEAD, NCP)
|
||||
article.description:
|
||||
title: MirageVPN updated (AEAD, NCP)
|
||||
description:
|
||||
How we resurrected MirageVPN from its bitrot state
|
||||
tags:
|
||||
- OCaml
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
---
|
||||
date: 2024-04-16
|
||||
article.title: Speeding up MirageVPN and use it in the wild
|
||||
article.description:
|
||||
title: Speeding up MirageVPN and use it in the wild
|
||||
description:
|
||||
Performance engineering of MirageVPN, speeding it up by a factor of 25.
|
||||
tags:
|
||||
- OCaml
|
||||
|
@ -19,7 +19,6 @@ coauthors:
|
|||
name: Reynir Björnsson
|
||||
email: reynir@reynir.dk
|
||||
link: https://reyn.ir/
|
||||
contribution: What is this field used for?
|
||||
---
|
||||
|
||||
As we were busy continuing to work on [MirageVPN](https://github.com/robur-coop/miragevpn), we got in touch with [eduVPN](https://eduvpn.org), who are interested about deploying MirageVPN. We got example configuration from their side, and [fixed](https://github.com/robur-coop/miragevpn/pull/201) [some](https://github.com/robur-coop/miragevpn/pull/168) [issues](https://github.com/robur-coop/miragevpn/pull/202), and also implemented [tls-crypt](https://github.com/robur-coop/miragevpn/pull/169) - which was straightforward since we earlier spend time to implement [tls-crypt-v2](https://blog.robur.coop/articles/miragevpn.html).
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
---
|
||||
date: 2024-06-17
|
||||
article.title: MirageVPN server
|
||||
article.description:
|
||||
title: MirageVPN server
|
||||
description:
|
||||
Announcement of our MirageVPN server.
|
||||
tags:
|
||||
- OCaml
|
||||
|
@ -18,7 +18,6 @@ coauthors:
|
|||
name: Reynir Björnsson
|
||||
email: reynir@reynir.dk
|
||||
link: https://reyn.ir/
|
||||
contribution: What is this field used for?
|
||||
---
|
||||
|
||||
It is a great pleasure to finally announce that we have finished a server implementation for MirageVPN (OpenVPN™-compatible). This allows to setup a very robust VPN network on both the client and the server side.
|
||||
|
@ -37,4 +36,4 @@ The overall progress was tracked in [this issue](https://github.com/robur-coop/m
|
|||
|
||||
Please move along to our handbook with the [chapter on MirageVPN server](https://robur-coop.github.io/miragevpn-handbook/miragevpn_server.html).
|
||||
|
||||
If you encounter any issues, please open an issue at [the repository](https://github.com/robur-coop/miragevpn).
|
||||
If you encounter any issues, please open an issue at [the repository](https://github.com/robur-coop/miragevpn).
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
---
|
||||
date: 2023-11-14
|
||||
article.title: MirageVPN & tls-crypt-v2
|
||||
article.description:
|
||||
title: MirageVPN & tls-crypt-v2
|
||||
description:
|
||||
How we implementated tls-crypt-v2 for miragevpn
|
||||
tags:
|
||||
- OCaml
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
---
|
||||
date: 2024-06-24
|
||||
article.title: qubes-miragevpn, a MirageVPN client for QubesOS
|
||||
article.description: A new OpenVPN client for QubesOS
|
||||
title: qubes-miragevpn, a MirageVPN client for QubesOS
|
||||
description: A new OpenVPN client for QubesOS
|
||||
tags:
|
||||
- OCaml
|
||||
- vpn
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
---
|
||||
date: 2024-02-13
|
||||
article.title: Speeding elliptic curve cryptography
|
||||
article.description:
|
||||
title: Speeding elliptic curve cryptography
|
||||
description:
|
||||
How we improved the performance of elliptic curves by only modifying the underlying byte array
|
||||
tags:
|
||||
- OCaml
|
||||
|
@ -95,4 +95,4 @@ Remove all cstruct, everywhere, apart from in mirage-block-xen and mirage-net-xe
|
|||
|
||||
Our MirageOS work is only partially funded, we cross-fund our work by commercial contracts and public (EU) funding. We are part of a non-profit company, you can make a (tax-deducable - at least in the EU) [donation](https://aenderwerk.de/donate/) (select "DONATION robur" in the dropdown menu).
|
||||
|
||||
We're keen to get MirageOS deployed in production - if you would like to do that, don't hesitate to reach out to us via eMail team at robur.coop
|
||||
We're keen to get MirageOS deployed in production - if you would like to do that, don't hesitate to reach out to us via eMail team at robur.coop
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
---
|
||||
date: 2024-08-15
|
||||
article.title: The new Tar release, a retrospective
|
||||
article.description: A little retrospective to the new Tar release and changes
|
||||
title: The new Tar release, a retrospective
|
||||
description: A little retrospective to the new Tar release and changes
|
||||
tags:
|
||||
- OCaml
|
||||
- Cstruct
|
||||
|
|
638
bin/blog.ml
Normal file
638
bin/blog.ml
Normal file
|
@ -0,0 +1,638 @@
|
|||
open Yocaml
|
||||
|
||||
let is_empty_list = function [] -> true | _ -> false
|
||||
|
||||
module Date = struct
|
||||
type month =
|
||||
| Jan
|
||||
| Feb
|
||||
| Mar
|
||||
| Apr
|
||||
| May
|
||||
| Jun
|
||||
| Jul
|
||||
| Aug
|
||||
| Sep
|
||||
| Oct
|
||||
| Nov
|
||||
| Dec
|
||||
|
||||
type day_of_week = Mon | Tue | Wed | Thu | Fri | Sat | Sun
|
||||
type year = int
|
||||
type day = int
|
||||
type hour = int
|
||||
type min = int
|
||||
type sec = int
|
||||
|
||||
type t = {
|
||||
year : year
|
||||
; month : month
|
||||
; day : day
|
||||
; hour : hour
|
||||
; min : min
|
||||
; sec : sec
|
||||
}
|
||||
|
||||
let invalid_int x message =
|
||||
Data.Validation.fail_with ~given:(string_of_int x) message
|
||||
|
||||
let month_from_int x =
|
||||
if x > 0 && x <= 12 then
|
||||
Result.ok
|
||||
[| Jan; Feb; Mar; Apr; May; Jun; Jul; Aug; Sep; Oct; Nov; Dec |].(x - 1)
|
||||
else invalid_int x "Invalid month value"
|
||||
|
||||
let year_from_int x =
|
||||
if x >= 0 then Result.ok x else invalid_int x "Invalid year value"
|
||||
|
||||
let is_leap year =
|
||||
if year mod 100 = 0 then year mod 400 = 0 else year mod 4 = 0
|
||||
|
||||
let days_in_month year month =
|
||||
match month with
|
||||
| Jan | Mar | May | Jul | Aug | Oct | Dec -> 31
|
||||
| Feb -> if is_leap year then 29 else 28
|
||||
| _ -> 30
|
||||
|
||||
let day_from_int year month x =
|
||||
let dim = days_in_month year month in
|
||||
if x >= 1 && x <= dim then Result.ok x
|
||||
else invalid_int x "Invalid day value"
|
||||
|
||||
let hour_from_int x =
|
||||
if x >= 0 && x < 24 then Result.ok x else invalid_int x "Invalid hour value"
|
||||
|
||||
let min_from_int x =
|
||||
if x >= 0 && x < 60 then Result.ok x else invalid_int x "Invalid min value"
|
||||
|
||||
let sec_from_int x =
|
||||
if x >= 0 && x < 60 then Result.ok x else invalid_int x "Invalid sec value"
|
||||
|
||||
let ( let* ) = Result.bind
|
||||
|
||||
let make ?(time = (0, 0, 0)) ~year ~month ~day () =
|
||||
let hour, min, sec = time in
|
||||
let* year = year_from_int year in
|
||||
let* month = month_from_int month in
|
||||
let* day = day_from_int year month day in
|
||||
let* hour = hour_from_int hour in
|
||||
let* min = min_from_int min in
|
||||
let* sec = sec_from_int sec in
|
||||
Result.ok { year; month; day; hour; min; sec }
|
||||
|
||||
let validate_from_datetime_str str =
|
||||
let str = String.trim str in
|
||||
match
|
||||
Scanf.sscanf_opt str "%04d%c%02d%c%02d%c%02d%c%02d%c%02d"
|
||||
(fun year _ month _ day _ hour _ min _ sec ->
|
||||
((hour, min, sec), year, month, day))
|
||||
with
|
||||
| None -> Data.Validation.fail_with ~given:str "Invalid date format"
|
||||
| Some (time, year, month, day) -> make ~time ~year ~month ~day ()
|
||||
|
||||
let validate_from_date_str str =
|
||||
let str = String.trim str in
|
||||
match
|
||||
Scanf.sscanf_opt str "%04d%c%02d%c%02d" (fun year _ month _ day ->
|
||||
(year, month, day))
|
||||
with
|
||||
| None -> Data.Validation.fail_with ~given:str "Invalid date format"
|
||||
| Some (year, month, day) -> make ~year ~month ~day ()
|
||||
|
||||
let validate =
|
||||
let open Data.Validation in
|
||||
string & (validate_from_datetime_str / validate_from_date_str)
|
||||
|
||||
let month_to_int = function
|
||||
| Jan -> 1
|
||||
| Feb -> 2
|
||||
| Mar -> 3
|
||||
| Apr -> 4
|
||||
| May -> 5
|
||||
| Jun -> 6
|
||||
| Jul -> 7
|
||||
| Aug -> 8
|
||||
| Sep -> 9
|
||||
| Oct -> 10
|
||||
| Nov -> 11
|
||||
| Dec -> 12
|
||||
|
||||
let dow_to_int = function
|
||||
| Mon -> 0
|
||||
| Tue -> 1
|
||||
| Wed -> 2
|
||||
| Thu -> 3
|
||||
| Fri -> 4
|
||||
| Sat -> 5
|
||||
| Sun -> 6
|
||||
|
||||
let compare_date a b =
|
||||
let cmp = Int.compare a.year b.year in
|
||||
if Int.equal cmp 0 then
|
||||
let cmp = Int.compare (month_to_int a.month) (month_to_int b.month) in
|
||||
if Int.equal cmp 0 then Int.compare a.day b.day else cmp
|
||||
else cmp
|
||||
|
||||
let compare_time a b =
|
||||
let cmp = Int.compare a.hour b.hour in
|
||||
if Int.equal cmp 0 then
|
||||
let cmp = Int.compare a.min b.min in
|
||||
if Int.equal cmp 0 then Int.compare a.sec b.sec else cmp
|
||||
else cmp
|
||||
|
||||
let compare a b =
|
||||
let cmp = compare_date a b in
|
||||
if Int.equal cmp 0 then compare_time a b else cmp
|
||||
|
||||
let pp_date ppf { year; month; day; _ } =
|
||||
Format.fprintf ppf "%04d-%02d-%02d" year (month_to_int month) day
|
||||
|
||||
let month_value = function
|
||||
| Jan -> 0
|
||||
| Feb -> 3
|
||||
| Mar -> 3
|
||||
| Apr -> 6
|
||||
| May -> 1
|
||||
| Jun -> 4
|
||||
| Jul -> 6
|
||||
| Aug -> 2
|
||||
| Sep -> 5
|
||||
| Oct -> 0
|
||||
| Nov -> 3
|
||||
| Dec -> 5
|
||||
|
||||
let day_of_week { year; month; day; _ } =
|
||||
let yy = year mod 100 in
|
||||
let cc = (year - yy) / 100 in
|
||||
let c_code = [| 6; 4; 2; 0 |].(cc mod 4) in
|
||||
let y_code = (yy + (yy / 4)) mod 7 in
|
||||
let m_code =
|
||||
let v = month_value month in
|
||||
if is_leap year && (month = Jan || month = Feb) then v - 1 else v
|
||||
in
|
||||
let index = (c_code + y_code + m_code + day) mod 7 in
|
||||
[| Sun; Mon; Tue; Wed; Thu; Fri; Sat |].(index)
|
||||
|
||||
let normalize ({ year; month; day; hour; min; sec } as dt) =
|
||||
let day_of_week = day_of_week dt in
|
||||
let open Data in
|
||||
record
|
||||
[
|
||||
("year", int year); ("month", int (month_to_int month)); ("day", int day)
|
||||
; ("hour", int hour); ("min", int min); ("sec", int sec)
|
||||
; ("day_of_week", int (dow_to_int day_of_week))
|
||||
; ("human", string (Format.asprintf "%a" pp_date dt))
|
||||
]
|
||||
|
||||
let to_archetype_date_time { year; month; day; hour; min; sec } =
|
||||
let time = (hour, min, sec) in
|
||||
let month = month_to_int month in
|
||||
Result.get_ok (Archetype.Datetime.make ~time ~year ~month ~day ())
|
||||
end
|
||||
|
||||
module Page = struct
|
||||
let entity_name = "Page"
|
||||
|
||||
class type t = object ('self)
|
||||
method title : string option
|
||||
method charset : string option
|
||||
method description : string option
|
||||
method tags : string list
|
||||
method with_host : string -> 'self
|
||||
method get_host : string option
|
||||
end
|
||||
|
||||
class page ?title ?description ?charset ?(tags = []) () =
|
||||
object (_ : #t)
|
||||
method title = title
|
||||
method charset = charset
|
||||
method description = description
|
||||
method tags = tags
|
||||
val host = None
|
||||
method with_host v = {< host = Some v >}
|
||||
method get_host = host
|
||||
end
|
||||
|
||||
let neutral = Result.ok @@ new page ()
|
||||
|
||||
let validate fields =
|
||||
let open Data.Validation in
|
||||
let+ title = optional fields "title" string
|
||||
and+ description = optional fields "description" string
|
||||
and+ charset = optional fields "charset" string
|
||||
and+ tags = optional_or fields ~default:[] "tags" (list_of string) in
|
||||
new page ?title ?description ?charset ~tags ()
|
||||
|
||||
let validate =
|
||||
let open Data.Validation in
|
||||
record validate
|
||||
end
|
||||
|
||||
module Author = struct
|
||||
class type t = object
|
||||
method name : string
|
||||
method link : string
|
||||
method email : string
|
||||
method avatar : string option
|
||||
end
|
||||
|
||||
let gravatar email =
|
||||
let tk = String.(lowercase_ascii (trim email)) in
|
||||
let hs = Digest.(to_hex (string tk)) in
|
||||
"https://www.gravatar.com/avatar/" ^ hs
|
||||
|
||||
class author ~name ~link ~email ?(avatar = gravatar email) () =
|
||||
object (_ : #t)
|
||||
method name = name
|
||||
method link = link
|
||||
method email = email
|
||||
method avatar = Some avatar
|
||||
end
|
||||
|
||||
let validate fields =
|
||||
let open Data.Validation in
|
||||
let+ name = required fields "name" string
|
||||
and+ link = required fields "link" string
|
||||
and+ email = required fields "email" string
|
||||
and+ avatar = optional fields "avatar" string in
|
||||
match avatar with
|
||||
| None -> new author ~name ~link ~email ()
|
||||
| Some avatar -> new author ~name ~link ~email ~avatar ()
|
||||
|
||||
let validate =
|
||||
let open Data.Validation in
|
||||
record validate
|
||||
|
||||
let normalize obj =
|
||||
let open Data in
|
||||
record
|
||||
[
|
||||
("name", string obj#name); ("link", string obj#link)
|
||||
; ("email", string obj#email); ("avatar", option string obj#avatar)
|
||||
]
|
||||
end
|
||||
|
||||
let robur_coop =
|
||||
new Author.author
|
||||
~name:"The Robur Team" ~link:"https://robur.coop/"
|
||||
~email:"team@robur.coop" ()
|
||||
|
||||
module Article = struct
|
||||
let entity_name = "Article"
|
||||
|
||||
class type t = object ('self)
|
||||
method title : string
|
||||
method description : string
|
||||
method charset : string option
|
||||
method tags : string list
|
||||
method date : Date.t
|
||||
method author : Author.t
|
||||
method co_authors : Author.t list
|
||||
method with_host : string -> 'self
|
||||
method get_host : string option
|
||||
end
|
||||
|
||||
class article ~title ~description ?charset ?(tags = []) ~date ~author
|
||||
?(co_authors = []) () =
|
||||
object (_ : #t)
|
||||
method title = title
|
||||
method description = description
|
||||
method charset = charset
|
||||
method tags = tags
|
||||
method date = date
|
||||
method author = author
|
||||
method co_authors = co_authors
|
||||
val host = None
|
||||
method with_host v = {< host = Some v >}
|
||||
method get_host = host
|
||||
end
|
||||
|
||||
let title p = p#title
|
||||
let description p = p#description
|
||||
let tags p = p#tags
|
||||
let date p = p#date
|
||||
|
||||
let neutral =
|
||||
Data.Validation.fail_with ~given:"null" "Cannot be null"
|
||||
|> Result.map_error (fun error ->
|
||||
Required.Validation_error { entity = entity_name; error })
|
||||
|
||||
let validate fields =
|
||||
let open Data.Validation in
|
||||
let+ title = required fields "title" string
|
||||
and+ description = required fields "description" string
|
||||
and+ charset = optional fields "charset" string
|
||||
and+ tags = optional_or fields ~default:[] "tags" (list_of string)
|
||||
and+ date = required fields "date" Date.validate
|
||||
and+ author =
|
||||
optional_or fields ~default:robur_coop "author" Author.validate
|
||||
and+ co_authors =
|
||||
optional_or fields ~default:[] "co-authors" (list_of Author.validate)
|
||||
in
|
||||
new article ~title ~description ?charset ~tags ~date ~author ~co_authors ()
|
||||
|
||||
let validate =
|
||||
let open Data.Validation in
|
||||
record validate
|
||||
|
||||
let normalize obj =
|
||||
Data.
|
||||
[
|
||||
("title", string obj#title); ("description", string obj#description)
|
||||
; ("date", Date.normalize obj#date); ("charset", option string obj#charset)
|
||||
; ("tags", list_of string obj#tags)
|
||||
; ("author", Author.normalize obj#author)
|
||||
; ("co-authors", list_of Author.normalize obj#co_authors)
|
||||
; ("host", option string obj#get_host)
|
||||
]
|
||||
end
|
||||
|
||||
module Articles = struct
|
||||
class type t = object ('self)
|
||||
method title : string option
|
||||
method description : string option
|
||||
method articles : (Path.t * Article.t) list
|
||||
method with_host : string -> 'self
|
||||
method get_host : string option
|
||||
end
|
||||
|
||||
class articles ?title ?description articles =
|
||||
object (_ : #t)
|
||||
method title = title
|
||||
method description = description
|
||||
method articles = articles
|
||||
val host = None
|
||||
method with_host v = {< host = Some v >}
|
||||
method get_host = host
|
||||
end
|
||||
|
||||
let sort_by_date ?(increasing = false) articles =
|
||||
List.sort
|
||||
(fun (_, articleA) (_, articleB) ->
|
||||
let r = Date.compare articleA#date articleB#date in
|
||||
if increasing then r else ~-r)
|
||||
articles
|
||||
|
||||
let fetch (module P : Required.DATA_PROVIDER) ?increasing
|
||||
?(filter = fun x -> x) ?(on = `Source) ~where ~compute_link path =
|
||||
Task.from_effect begin fun () ->
|
||||
let open Eff in
|
||||
let* files = read_directory ~on ~only:`Files ~where path in
|
||||
let+ articles =
|
||||
List.traverse
|
||||
(fun file ->
|
||||
let url = compute_link file in
|
||||
let+ metadata, _content =
|
||||
Eff.read_file_with_metadata (module P) (module Article) ~on file
|
||||
in
|
||||
(url, metadata))
|
||||
files
|
||||
in
|
||||
articles |> sort_by_date ?increasing |> filter end
|
||||
|
||||
let compute_index (module P : Required.DATA_PROVIDER) ?increasing
|
||||
?(filter = fun x -> x) ?(on = `Source) ~where ~compute_link path =
|
||||
let open Task in
|
||||
(fun x -> (x, ()))
|
||||
|>> second
|
||||
(fetch (module P) ?increasing ~filter ~on ~where ~compute_link path)
|
||||
>>> lift (fun (v, articles) ->
|
||||
new articles ?title:v#title ?description:v#description articles)
|
||||
|
||||
let normalize (ident, article) =
|
||||
let open Data in
|
||||
record (("url", string @@ Path.to_string ident) :: Article.normalize article)
|
||||
|
||||
let normalize obj =
|
||||
let open Data in
|
||||
[
|
||||
("articles", list_of normalize obj#articles)
|
||||
; ("has_articles", bool @@ is_empty_list obj#articles)
|
||||
; ("title", option string obj#title)
|
||||
; ("description", option string obj#description)
|
||||
; ("host", option string obj#get_host)
|
||||
]
|
||||
end
|
||||
|
||||
module Make_with_target (S : sig
|
||||
val source : Path.t
|
||||
val target : Path.t
|
||||
end) =
|
||||
struct
|
||||
let source_root = S.source
|
||||
|
||||
module Source = struct
|
||||
let css = Path.(source_root / "css")
|
||||
let js = Path.(source_root / "js")
|
||||
let images = Path.(source_root / "images")
|
||||
let articles = Path.(source_root / "articles")
|
||||
let index = Path.(source_root / "pages" / "index.md")
|
||||
let templates = Path.(source_root / "templates")
|
||||
let template file = Path.(templates / file)
|
||||
let binary = Path.rel [ Sys.argv.(0) ]
|
||||
let cache = Path.(source_root / "_cache")
|
||||
end
|
||||
|
||||
module Target = struct
|
||||
let target_root = S.target
|
||||
let pages = target_root
|
||||
let articles = Path.(target_root / "articles")
|
||||
let rss1 = Path.(target_root / "rss1.xml")
|
||||
let rss2 = Path.(target_root / "feed.xml")
|
||||
let atom = Path.(target_root / "atom.xml")
|
||||
|
||||
let as_html into file =
|
||||
file |> Path.move ~into |> Path.change_extension "html"
|
||||
end
|
||||
|
||||
let target = Target.target_root
|
||||
|
||||
let process_css_files =
|
||||
Action.copy_directory ~into:Target.target_root Source.css
|
||||
|
||||
let process_js_files =
|
||||
Action.copy_directory ~into:Target.target_root Source.js
|
||||
|
||||
let process_images_files =
|
||||
Action.copy_directory ~into:Target.target_root Source.images
|
||||
|
||||
let process_article ~host file =
|
||||
let file_target = Target.(as_html articles file) in
|
||||
let open Task in
|
||||
Action.write_static_file file_target
|
||||
begin
|
||||
Pipeline.track_file Source.binary
|
||||
>>> Yocaml_yaml.Pipeline.read_file_with_metadata (module Article) file
|
||||
>>* (fun (obj, str) -> Eff.return (obj#with_host host, str))
|
||||
>>> Yocaml_cmarkit.content_to_html ()
|
||||
>>> Yocaml_jingoo.Pipeline.as_template
|
||||
(module Article)
|
||||
(Source.template "article.html")
|
||||
>>> Yocaml_jingoo.Pipeline.as_template
|
||||
(module Article)
|
||||
(Source.template "layout.html")
|
||||
>>> drop_first ()
|
||||
end
|
||||
|
||||
let process_articles ~host =
|
||||
Action.batch ~only:`Files ~where:(Path.has_extension "md") Source.articles
|
||||
(process_article ~host)
|
||||
|
||||
let process_index ~host =
|
||||
let file = Source.index in
|
||||
let file_target = Target.(as_html pages file) in
|
||||
|
||||
let open Task in
|
||||
let compute_index =
|
||||
Articles.compute_index
|
||||
(module Yocaml_yaml)
|
||||
~where:(Path.has_extension "md")
|
||||
~compute_link:(Target.as_html @@ Path.abs [ "articles" ])
|
||||
Source.articles
|
||||
in
|
||||
|
||||
Action.write_static_file file_target
|
||||
begin
|
||||
Pipeline.track_files [ Source.binary; Source.articles ]
|
||||
>>> Yocaml_yaml.Pipeline.read_file_with_metadata (module Page) file
|
||||
>>> Yocaml_cmarkit.content_to_html ()
|
||||
>>> first compute_index
|
||||
>>* (fun (obj, str) -> Eff.return (obj#with_host host, str))
|
||||
>>> Yocaml_jingoo.Pipeline.as_template ~strict:true
|
||||
(module Articles)
|
||||
(Source.template "index.html")
|
||||
>>> Yocaml_jingoo.Pipeline.as_template ~strict:true
|
||||
(module Articles)
|
||||
(Source.template "layout.html")
|
||||
>>> drop_first ()
|
||||
end
|
||||
|
||||
let feed_title = "The Robur's blog"
|
||||
let site_url = "https://blog.robur.coop/"
|
||||
let feed_description = "The Robur cooperative blog"
|
||||
|
||||
let fetch_articles =
|
||||
let open Task in
|
||||
Pipeline.track_files [ Source.binary; Source.articles ]
|
||||
>>> Articles.fetch
|
||||
(module Yocaml_yaml)
|
||||
~where:(Path.has_extension "md")
|
||||
~compute_link:(Target.as_html @@ Path.abs [ "articles" ])
|
||||
Source.articles
|
||||
|
||||
let rss1 =
|
||||
let from_articles ~title ~site_url ~description ~feed_url () =
|
||||
let open Yocaml_syndication in
|
||||
Rss1.from ~title ~url:feed_url ~link:site_url ~description
|
||||
@@ fun (path, article) ->
|
||||
let title = Article.title article in
|
||||
let link = site_url ^ Yocaml.Path.to_string path in
|
||||
let description = Article.description article in
|
||||
Rss1.item ~title ~link ~description
|
||||
in
|
||||
let open Task in
|
||||
Action.write_static_file Target.rss1
|
||||
begin
|
||||
fetch_articles
|
||||
>>> from_articles ~title:feed_title ~site_url
|
||||
~description:feed_description
|
||||
~feed_url:"https://blog.robur.coop/rss1.xml" ()
|
||||
end
|
||||
|
||||
let rss2 =
|
||||
let open Task in
|
||||
let from_articles ~title ~site_url ~description ~feed_url () =
|
||||
let open Yocaml_syndication in
|
||||
lift
|
||||
begin
|
||||
fun articles ->
|
||||
let last_build_date =
|
||||
List.fold_left
|
||||
begin
|
||||
fun acc (_, elt) ->
|
||||
let v = Date.to_archetype_date_time (Article.date elt) in
|
||||
match acc with
|
||||
| None -> Some v
|
||||
| Some a ->
|
||||
if Archetype.Datetime.compare a v > 0 then Some a
|
||||
else Some v
|
||||
end
|
||||
None articles
|
||||
|> Option.map Datetime.make
|
||||
in
|
||||
let feed =
|
||||
Rss2.feed ?last_build_date ~title ~link:site_url ~url:feed_url
|
||||
~description
|
||||
begin
|
||||
fun (path, article) ->
|
||||
let title = Article.title article in
|
||||
let link = site_url ^ Path.to_string path in
|
||||
let guid = Rss2.guid_from_link in
|
||||
let description = Article.description article in
|
||||
let pub_date =
|
||||
Datetime.make
|
||||
(Date.to_archetype_date_time (Article.date article))
|
||||
in
|
||||
Rss2.item ~title ~link ~guid ~description ~pub_date ()
|
||||
end
|
||||
articles
|
||||
in
|
||||
Xml.to_string feed
|
||||
end
|
||||
in
|
||||
Action.write_static_file Target.rss2
|
||||
begin
|
||||
fetch_articles
|
||||
>>> from_articles ~title:feed_title ~site_url
|
||||
~description:feed_description
|
||||
~feed_url:"https://blog.robur.coop/feed.xml" ()
|
||||
end
|
||||
|
||||
let atom =
|
||||
let open Task in
|
||||
let open Yocaml_syndication in
|
||||
let authors = Yocaml.Nel.singleton @@ Person.make "The Robur Team" in
|
||||
let from_articles ?(updated = Atom.updated_from_entries ()) ?(links = [])
|
||||
?id ~site_url ~authors ~title ~feed_url () =
|
||||
let id = Option.value ~default:feed_url id in
|
||||
let feed_url = Atom.self feed_url in
|
||||
let base_url = Atom.link site_url in
|
||||
let links = base_url :: feed_url :: links in
|
||||
Atom.from ~links ~updated ~title ~authors ~id
|
||||
begin
|
||||
fun (path, article) ->
|
||||
let title = Article.title article in
|
||||
let content_url = site_url ^ Yocaml.Path.to_string path in
|
||||
let updated =
|
||||
Datetime.make (Date.to_archetype_date_time (Article.date article))
|
||||
in
|
||||
let categories = List.map Category.make (Article.tags article) in
|
||||
let summary = Atom.text (Article.description article) in
|
||||
let links = [ Atom.alternate content_url ~title ] in
|
||||
Atom.entry ~links ~categories ~summary ~updated ~id:content_url
|
||||
~title:(Atom.text title) ()
|
||||
end
|
||||
in
|
||||
Action.write_static_file Target.atom
|
||||
begin
|
||||
fetch_articles
|
||||
>>> from_articles ~site_url ~authors ~title:(Atom.text feed_title)
|
||||
~feed_url:"https://blog.robur.coop/atom.xml" ()
|
||||
end
|
||||
|
||||
let process_all ~host =
|
||||
let open Eff in
|
||||
Action.restore_cache ~on:`Source Source.cache
|
||||
>>= process_css_files >>= process_js_files >>= process_images_files
|
||||
>>= process_articles ~host >>= process_index ~host >>= rss1 >>= rss2 >>= atom
|
||||
>>= Action.store_cache ~on:`Source Source.cache
|
||||
end
|
||||
|
||||
module Make (S : sig
|
||||
val source : Path.t
|
||||
end) =
|
||||
Make_with_target (struct
|
||||
include S
|
||||
|
||||
let target = Path.(source / "_site")
|
||||
end)
|
14
bin/blog.mli
Normal file
14
bin/blog.mli
Normal file
|
@ -0,0 +1,14 @@
|
|||
module Make_with_target (_ : sig
|
||||
val source : Yocaml.Path.t
|
||||
val target : Yocaml.Path.t
|
||||
end) : sig
|
||||
val target : Yocaml.Path.t
|
||||
val process_all : host:string -> unit Yocaml.Eff.t
|
||||
end
|
||||
|
||||
module Make (_ : sig
|
||||
val source : Yocaml.Path.t
|
||||
end) : sig
|
||||
val target : Yocaml.Path.t
|
||||
val process_all : host:string -> unit Yocaml.Eff.t
|
||||
end
|
23
bin/dune
Normal file
23
bin/dune
Normal file
|
@ -0,0 +1,23 @@
|
|||
(executable
|
||||
(name watch)
|
||||
(libraries
|
||||
yocaml
|
||||
yocaml_syndication
|
||||
yocaml_yaml
|
||||
yocaml_jingoo
|
||||
yocaml_cmarkit
|
||||
yocaml_unix))
|
||||
|
||||
(executable
|
||||
(name push)
|
||||
(libraries
|
||||
fmt.tty
|
||||
logs.fmt
|
||||
git-unix
|
||||
yocaml
|
||||
yocaml_git
|
||||
yocaml_syndication
|
||||
yocaml_yaml
|
||||
yocaml_jingoo
|
||||
yocaml_cmarkit
|
||||
yocaml_unix))
|
60
bin/push.ml
Normal file
60
bin/push.ml
Normal file
|
@ -0,0 +1,60 @@
|
|||
let reporter ppf =
|
||||
let report src level ~over k msgf =
|
||||
let k _ =
|
||||
over ();
|
||||
k ()
|
||||
in
|
||||
let with_metadata header _tags k ppf fmt =
|
||||
Format.kfprintf k ppf
|
||||
("%a[%a]: " ^^ fmt ^^ "\n%!")
|
||||
Logs_fmt.pp_header (level, header)
|
||||
Fmt.(styled `Magenta string)
|
||||
(Logs.Src.name src)
|
||||
in
|
||||
msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt
|
||||
in
|
||||
{ Logs.report }
|
||||
|
||||
let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ()
|
||||
let () = Logs.set_reporter (reporter Fmt.stdout)
|
||||
(* let () = Logs.set_level ~all:true (Some Logs.Debug) *)
|
||||
let author = ref "The Robur Team"
|
||||
let email = ref "team@robur.coop"
|
||||
let message = ref "Pushed by YOCaml 2"
|
||||
let remote = ref "git@git.robur.coop:robur/blog.robur.coop.git#gh-pages"
|
||||
let host = ref "https://blog.robur.coop"
|
||||
|
||||
module Source = Yocaml_git.From_identity (Yocaml_unix.Runtime)
|
||||
|
||||
let usage =
|
||||
Fmt.str
|
||||
"%s [--message <message>] [--author <author>] [--email <email>] -r \
|
||||
<repository>"
|
||||
Sys.argv.(0)
|
||||
|
||||
let specification =
|
||||
[
|
||||
("--message", Arg.Set_string message, "The commit message")
|
||||
; ("--email", Arg.Set_string email, "The email used to craft the commit")
|
||||
; ("-r", Arg.Set_string remote, "The Git repository")
|
||||
; ("--author", Arg.Set_string author, "The Git commit author")
|
||||
; ("--host", Arg.Set_string host, "The host where the blog is available")
|
||||
]
|
||||
|
||||
let () =
|
||||
Arg.parse specification ignore usage;
|
||||
let author = !author
|
||||
and email = !email
|
||||
and message = !message
|
||||
and remote = !remote in
|
||||
let module Blog = Blog.Make_with_target (struct
|
||||
let source = Yocaml.Path.rel []
|
||||
let target = Yocaml.Path.rel []
|
||||
end) in
|
||||
Yocaml_git.run
|
||||
(module Source)
|
||||
(module Pclock)
|
||||
~context:`SSH ~author ~email ~message ~remote
|
||||
(fun () -> Blog.process_all ~host:!host)
|
||||
|> Lwt_main.run
|
||||
|> Result.iter_error (fun (`Msg err) -> invalid_arg err)
|
15
bin/watch.ml
Normal file
15
bin/watch.ml
Normal file
|
@ -0,0 +1,15 @@
|
|||
let port = ref 8000
|
||||
let usage = Fmt.str "%s [--port <port>]" Sys.argv.(0)
|
||||
|
||||
let specification =
|
||||
[ ("--port", Arg.Set_int port, "The port where we serve the website") ]
|
||||
|
||||
module Dest = Blog.Make (struct
|
||||
let source = Yocaml.Path.rel []
|
||||
end)
|
||||
|
||||
let () =
|
||||
Arg.parse specification ignore usage;
|
||||
let host = Fmt.str "http://localhost:%d" !port in
|
||||
Yocaml_unix.serve ~level:`Info ~target:Dest.target ~port:!port
|
||||
@@ fun () -> Dest.process_all ~host
|
18
blogger.opam
18
blogger.opam
|
@ -5,7 +5,7 @@ maintainer: "romain.calascibetta@gmail.com"
|
|||
authors: [ "The XHTMLBoy <xhtmlboi@gmail.com>" ]
|
||||
|
||||
build: [
|
||||
[ "dune" "subst" ]
|
||||
[ "dune" "subst" ] {dev}
|
||||
[ "dune" "build" "-p" name "-j" jobs ]
|
||||
[ "dune" "runtest" "-p" name ] {with-test}
|
||||
[ "dune" "build" "@doc" "-p" name ] {with-doc}
|
||||
|
@ -18,7 +18,7 @@ dev-repo: "git://github.com/dinosaure/blogger.git"
|
|||
bug-reports: "https://github.com/dinosaure/blogger/issues"
|
||||
|
||||
depends: [
|
||||
"ocaml" { >= "4.11.1" }
|
||||
"ocaml" { >= "5.1.0" }
|
||||
"dune" { >= "2.8" }
|
||||
"preface" { >= "0.1.0" }
|
||||
"logs" {>= "0.7.0" }
|
||||
|
@ -27,7 +27,19 @@ depends: [
|
|||
"yocaml"
|
||||
"yocaml_unix"
|
||||
"yocaml_yaml"
|
||||
"yocaml_cmark"
|
||||
"yocaml_cmarkit"
|
||||
"yocaml_git"
|
||||
"yocaml_jingoo"
|
||||
"yocaml_syndication"
|
||||
]
|
||||
|
||||
pin-depends: [
|
||||
["yocaml.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
|
||||
["yocaml_runtime.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
|
||||
["yocaml_unix.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
|
||||
["yocaml_yaml.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
|
||||
["yocaml_cmarkit.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
|
||||
["yocaml_git.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
|
||||
["yocaml_jingoo.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
|
||||
["yocaml_syndication.dev" "git+https://gitlab.com/funkywork/yocaml.git#c2809182a59571a863d6ad14a77f720f6fa577dc" ]
|
||||
]
|
||||
|
|
332
src/blogger.ml
332
src/blogger.ml
|
@ -1,332 +0,0 @@
|
|||
let caller = Sys.argv.(0)
|
||||
let version = "%%VERSION%%"
|
||||
let default_port = 8888
|
||||
let default_target = Fpath.v "_site"
|
||||
|
||||
let program ~target =
|
||||
let open Yocaml in
|
||||
let* () = Task.move_javascript target in
|
||||
let* () = Task.move_css target in
|
||||
let* () = Task.move_images target in
|
||||
let* () = Task.process_articles target in
|
||||
let* () = Task.generate_feed target in
|
||||
let* () = Task.generate_tags target in
|
||||
Task.generate_index target
|
||||
|
||||
let local_build _quiet target =
|
||||
Yocaml_unix.execute (program ~target:(Fpath.to_string target))
|
||||
|
||||
module SSH = struct
|
||||
open Lwt.Infix
|
||||
|
||||
type error = Unix.error * string * string
|
||||
type write_error = [ `Closed | `Error of Unix.error * string * string ]
|
||||
|
||||
let pp_error ppf (err, f, v) =
|
||||
Fmt.pf ppf "%s(%s): %s" f v (Unix.error_message err)
|
||||
|
||||
let pp_write_error ppf = function
|
||||
| `Closed -> Fmt.pf ppf "Connection closed by peer"
|
||||
| `Error (err, f, v) -> Fmt.pf ppf "%s(%s): %s" f v (Unix.error_message err)
|
||||
|
||||
type flow = { ic : in_channel; oc : out_channel }
|
||||
|
||||
type endpoint = {
|
||||
user : string;
|
||||
path : string;
|
||||
host : Unix.inet_addr;
|
||||
port : int;
|
||||
capabilities : [ `Rd | `Wr ];
|
||||
}
|
||||
|
||||
let pp_inet_addr ppf inet_addr =
|
||||
Fmt.string ppf (Unix.string_of_inet_addr inet_addr)
|
||||
|
||||
let connect { user; path; host; port; capabilities } =
|
||||
let edn = Fmt.str "%s@%a" user pp_inet_addr host in
|
||||
let cmd =
|
||||
match capabilities with
|
||||
| `Wr -> Fmt.str {sh|git-receive-pack '%s'|sh} path
|
||||
| `Rd -> Fmt.str {sh|git-upload-pack '%s'|sh} path
|
||||
in
|
||||
let cmd = Fmt.str "ssh -p %d %s %a" port edn Fmt.(quote string) cmd in
|
||||
try
|
||||
let ic, oc = Unix.open_process cmd in
|
||||
Lwt.return_ok { ic; oc }
|
||||
with Unix.Unix_error (err, f, v) -> Lwt.return_error (`Error (err, f, v))
|
||||
|
||||
let read t =
|
||||
let tmp = Bytes.create 0x1000 in
|
||||
try
|
||||
let len = input t.ic tmp 0 0x1000 in
|
||||
if len = 0 then Lwt.return_ok `Eof
|
||||
else Lwt.return_ok (`Data (Cstruct.of_bytes tmp ~off:0 ~len))
|
||||
with Unix.Unix_error (err, f, v) -> Lwt.return_error (err, f, v)
|
||||
|
||||
let write t cs =
|
||||
let str = Cstruct.to_string cs in
|
||||
try
|
||||
output_string t.oc str;
|
||||
flush t.oc;
|
||||
Lwt.return_ok ()
|
||||
with Unix.Unix_error (err, f, v) -> Lwt.return_error (`Error (err, f, v))
|
||||
|
||||
let writev t css =
|
||||
let rec go t = function
|
||||
| [] -> Lwt.return_ok ()
|
||||
| x :: r -> (
|
||||
write t x >>= function
|
||||
| Ok () -> go t r
|
||||
| Error _ as err -> Lwt.return err)
|
||||
in
|
||||
go t css
|
||||
|
||||
let close t =
|
||||
close_in t.ic;
|
||||
close_out t.oc;
|
||||
Lwt.return_unit
|
||||
|
||||
let shutdown t mode =
|
||||
match mode with
|
||||
| `read -> close_in t.ic ; Lwt.return_unit
|
||||
| `write -> close_out t.oc ; Lwt.return_unit
|
||||
| `read_write -> close t
|
||||
end
|
||||
|
||||
let ssh_edn, ssh_protocol = Mimic.register ~name:"ssh" (module SSH)
|
||||
|
||||
let unix_ctx_with_ssh () =
|
||||
let open Lwt.Infix in
|
||||
Git_unix.ctx (Happy_eyeballs_lwt.create ()) >|= fun ctx ->
|
||||
let open Mimic in
|
||||
let k0 scheme user path host port capabilities =
|
||||
match (scheme, Unix.gethostbyname host) with
|
||||
| `SSH, { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 ->
|
||||
Lwt.return_some
|
||||
{ SSH.user; path; host = h_addr_list.(0); port; capabilities }
|
||||
| _ -> Lwt.return_none
|
||||
in
|
||||
ctx
|
||||
|> Mimic.fold Smart_git.git_transmission
|
||||
Fun.[ req Smart_git.git_scheme ]
|
||||
~k:(function `SSH -> Lwt.return_some `Exec | _ -> Lwt.return_none)
|
||||
|> Mimic.fold ssh_edn
|
||||
Fun.
|
||||
[
|
||||
req Smart_git.git_scheme;
|
||||
req Smart_git.git_ssh_user;
|
||||
req Smart_git.git_path;
|
||||
req Smart_git.git_hostname;
|
||||
dft Smart_git.git_port 22;
|
||||
req Smart_git.git_capabilities;
|
||||
]
|
||||
~k:k0
|
||||
|
||||
let run_git_config key = function
|
||||
| Some value -> Some value
|
||||
| None -> (
|
||||
let open Bos in
|
||||
let value = OS.Cmd.run_out Cmd.(v "git" % "config" % "--global" % key) in
|
||||
match OS.Cmd.out_string value with
|
||||
| Ok (value, _) -> Some value
|
||||
| Error _ -> None)
|
||||
|
||||
let run_git_rev_parse default =
|
||||
let open Bos in
|
||||
let value = OS.Cmd.run_out
|
||||
Cmd.(v "git" % "describe" % "--always" % "--dirty"
|
||||
% "--exclude=*" % "--abbrev=0")
|
||||
in
|
||||
match OS.Cmd.out_string value with
|
||||
| Ok (value, (_, `Exited 0)) -> value
|
||||
| Ok (value, (run_info, _)) ->
|
||||
Logs.warn (fun m -> m "Failed to get commit id: %a: %s"
|
||||
Cmd.pp (OS.Cmd.run_info_cmd run_info)
|
||||
value);
|
||||
default
|
||||
| Error `Msg e ->
|
||||
Logs.warn (fun m -> m "Failed to get commit id: %s" e);
|
||||
default
|
||||
|
||||
let get_name_and_email name email =
|
||||
let name = run_git_config "user.name" name in
|
||||
let email = run_git_config "user.email" email in
|
||||
(name, email)
|
||||
|
||||
let name_and_email =
|
||||
let name_arg =
|
||||
let doc = "Name of the committer." in
|
||||
Cmdliner.Arg.(value & opt (some string) None & info [ "name" ] ~doc)
|
||||
in
|
||||
let email_arg =
|
||||
let doc = "Email of the committer." in
|
||||
Cmdliner.Arg.(value & opt (some string) None & info [ "email" ] ~doc)
|
||||
in
|
||||
Cmdliner.Term.(const get_name_and_email $ name_arg $ email_arg)
|
||||
|
||||
let build_and_push _quiet remote (author, email) hook =
|
||||
let fiber () =
|
||||
let open Lwt.Syntax in
|
||||
let commit_id = run_git_rev_parse "an unknown state" in
|
||||
let comment = Printf.sprintf "Built from %s" commit_id in
|
||||
let* ctx = unix_ctx_with_ssh () in
|
||||
let* res =
|
||||
Yocaml_git.execute
|
||||
(module Yocaml_unix)
|
||||
(module Pclock)
|
||||
~ctx ?author ?email ~comment remote (program ~target:"")
|
||||
in
|
||||
match res with
|
||||
| Error (`Msg err) -> Fmt.failwith "build-and-push: %s." err
|
||||
| Ok () -> (
|
||||
match hook with
|
||||
| None -> Lwt.return_unit
|
||||
| Some hook -> (
|
||||
let open Lwt.Infix in
|
||||
Http_lwt_client.request ~config:(`HTTP_1_1 Httpaf.Config.default)
|
||||
~meth:`GET (Uri.to_string hook)
|
||||
(fun _ () _ -> Lwt.return_unit)
|
||||
()
|
||||
>>= function
|
||||
| Ok (_response, ()) -> Lwt.return_unit
|
||||
| Error (`Msg err) -> failwith err))
|
||||
in
|
||||
Lwt_main.run (fiber ())
|
||||
|
||||
let watch quiet target potential_port =
|
||||
let port = Option.value ~default:default_port potential_port in
|
||||
let () = local_build quiet target in
|
||||
let target = Fpath.to_string target in
|
||||
let server = Yocaml_unix.serve ~filepath:target ~port (program ~target) in
|
||||
Lwt_main.run server
|
||||
|
||||
let common_options = "COMMON OPTIONS"
|
||||
|
||||
let verbosity =
|
||||
let open Cmdliner in
|
||||
let env = Cmd.Env.info "BLOGGER_LOGS" in
|
||||
Logs_cli.level ~docs:common_options ~env ()
|
||||
|
||||
let renderer =
|
||||
let open Cmdliner in
|
||||
let env = Cmd.Env.info "BLOGGER_FMT" in
|
||||
Fmt_cli.style_renderer ~docs:common_options ~env ()
|
||||
|
||||
let utf_8 =
|
||||
let open Cmdliner in
|
||||
let doc = "Allow binaries to emit UTF-8 characters." in
|
||||
let env = Cmd.Env.info "BLOGGER_UTF_8" in
|
||||
Arg.(value & opt bool true & info [ "with-utf-8" ] ~doc ~env)
|
||||
|
||||
let reporter ppf =
|
||||
let report src level ~over k msgf =
|
||||
let k _ =
|
||||
over ();
|
||||
k ()
|
||||
in
|
||||
let with_metadata header _tags k ppf fmt =
|
||||
Fmt.kpf k ppf
|
||||
("%a[%a]: " ^^ fmt ^^ "\n%!")
|
||||
Logs_fmt.pp_header (level, header)
|
||||
Fmt.(styled `Magenta string)
|
||||
(Logs.Src.name src)
|
||||
in
|
||||
msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt
|
||||
in
|
||||
{ Logs.report }
|
||||
|
||||
let setup_logs utf_8 style_renderer level =
|
||||
Fmt_tty.setup_std_outputs ~utf_8 ?style_renderer ();
|
||||
Logs.set_level level;
|
||||
Logs.set_reporter (reporter Fmt.stderr);
|
||||
Option.is_none level
|
||||
|
||||
let setup_logs = Cmdliner.Term.(const setup_logs $ utf_8 $ renderer $ verbosity)
|
||||
|
||||
let man =
|
||||
let open Cmdliner in
|
||||
[ `S Manpage.s_authors; `P "blog.robur.coop" ]
|
||||
|
||||
let build_cmd =
|
||||
let open Cmdliner in
|
||||
let doc = Format.asprintf "Build the blog into the specified directory" in
|
||||
let exits = Cmd.Exit.defaults in
|
||||
let info = Cmd.info "build" ~version ~doc ~exits ~man in
|
||||
let path_arg =
|
||||
let doc =
|
||||
Format.asprintf "Specify where we build the website (default: %a)"
|
||||
Fpath.pp default_target
|
||||
in
|
||||
let arg = Arg.info ~doc [ "destination" ] in
|
||||
Arg.(value & opt (conv (Fpath.of_string, Fpath.pp)) default_target & arg)
|
||||
in
|
||||
Cmd.v info Term.(const local_build $ setup_logs $ path_arg)
|
||||
|
||||
let watch_cmd =
|
||||
let open Cmdliner in
|
||||
let doc =
|
||||
Format.asprintf
|
||||
"Serve from the specified directory as an HTTP server and rebuild \
|
||||
website on demand"
|
||||
in
|
||||
let exits = Cmd.Exit.defaults in
|
||||
let path_arg =
|
||||
let doc =
|
||||
Format.asprintf "Specify where we build the website (default: %a)"
|
||||
Fpath.pp default_target
|
||||
in
|
||||
let arg = Arg.info ~doc [ "destination" ] in
|
||||
Arg.(value & opt (conv (Fpath.of_string, Fpath.pp)) default_target & arg)
|
||||
in
|
||||
let port_arg =
|
||||
let doc = Format.asprintf "The port (default: %d)" default_port in
|
||||
let arg = Arg.info ~doc [ "port"; "P"; "p" ] in
|
||||
Arg.(value & opt (some int) None & arg)
|
||||
in
|
||||
let info = Cmd.info "watch" ~version ~doc ~exits ~man in
|
||||
Cmd.v info Term.(const watch $ setup_logs $ path_arg $ port_arg)
|
||||
|
||||
let push_cmd =
|
||||
let open Cmdliner in
|
||||
let doc =
|
||||
Format.asprintf
|
||||
"Push the blog (from the specified directory) into a Git repository"
|
||||
in
|
||||
let exits = Cmd.Exit.defaults in
|
||||
let remote_arg =
|
||||
let remote =
|
||||
let parser str =
|
||||
match Smart_git.Endpoint.of_string str with
|
||||
| Ok _ -> Ok str
|
||||
| Error _ as err -> err
|
||||
in
|
||||
Arg.conv (parser, Fmt.string)
|
||||
in
|
||||
let doc = "The remote Git repository" in
|
||||
let arg = Arg.info ~doc [ "r"; "remote" ] in
|
||||
Arg.(required & opt (some remote) None & arg)
|
||||
in
|
||||
let hook_arg =
|
||||
let doc = "The URL of the hook to update the unikernel" in
|
||||
let arg = Arg.info ~doc [ "h"; "hook" ] in
|
||||
let of_string str =
|
||||
match Uri.of_string str with
|
||||
| v -> Ok v
|
||||
| exception _ -> Rresult.R.error_msgf "Invalid URI: %s" str
|
||||
in
|
||||
Arg.(value & opt (some (conv (of_string, Uri.pp))) None & arg)
|
||||
in
|
||||
let info = Cmd.info "push" ~version ~doc ~exits ~man in
|
||||
Cmd.v info
|
||||
Term.(
|
||||
const build_and_push $ setup_logs $ remote_arg $ name_and_email $ hook_arg)
|
||||
|
||||
let cmd =
|
||||
let open Cmdliner in
|
||||
let sdocs = Manpage.s_common_options in
|
||||
let doc = "Build, push or serve my personal website" in
|
||||
let default_info = Cmd.info caller ~version ~doc ~sdocs ~man in
|
||||
let default = Term.(ret (const (`Help (`Pager, None)))) in
|
||||
Cmd.group ~default default_info [ build_cmd; watch_cmd; push_cmd ]
|
||||
|
||||
let () = exit @@ Cmdliner.Cmd.eval cmd
|
|
@ -1,64 +0,0 @@
|
|||
open Yocaml
|
||||
|
||||
let get_article (module V : Metadata.VALIDABLE) article_file =
|
||||
let arr =
|
||||
Build.read_file_with_metadata
|
||||
(module V)
|
||||
(module Model.Article)
|
||||
article_file
|
||||
in
|
||||
let deps = Build.get_dependencies arr in
|
||||
let task = Build.get_task arr in
|
||||
let+ meta, _ = task () in
|
||||
deps, (meta, Model.article_path article_file)
|
||||
;;
|
||||
|
||||
let get_articles (module V : Metadata.VALIDABLE) path =
|
||||
let* files = read_child_files path File.is_markdown in
|
||||
let+ articles = Traverse.traverse (get_article (module V)) files in
|
||||
let deps, effects = List.split articles in
|
||||
Deps.Monoid.reduce deps, effects
|
||||
;;
|
||||
|
||||
module Articles = struct
|
||||
type t = (Model.Article.t * Filepath.t) list
|
||||
|
||||
let get_all (module V : Metadata.VALIDABLE) ?(decreasing = true) path =
|
||||
let+ deps, articles = get_articles (module V) path in
|
||||
let sorted_article = Model.Articles.sort ~decreasing articles in
|
||||
Build.make deps (fun x -> return (x, sorted_article))
|
||||
;;
|
||||
end
|
||||
|
||||
module Tags = struct
|
||||
module M = Map.Make (String)
|
||||
|
||||
let by_quantity ?(decreasing = true) (_, a) (_, b) =
|
||||
let r = Int.compare $ List.length a $ List.length b in
|
||||
if decreasing then ~-r else r
|
||||
;;
|
||||
|
||||
let group metas =
|
||||
List.fold_left
|
||||
(fun accumulator (article, path) ->
|
||||
List.fold_left
|
||||
(fun map tag ->
|
||||
match M.find_opt tag map with
|
||||
| Some articles -> M.add tag ((article, path) :: articles) map
|
||||
| None -> M.add tag [ article, path ] map)
|
||||
accumulator
|
||||
(Model.Article.tags article))
|
||||
M.empty
|
||||
metas
|
||||
|> M.map
|
||||
(List.sort (fun (a, _) (b, _) -> Model.Article.compare_by_date a b))
|
||||
|> M.to_seq
|
||||
|> List.of_seq
|
||||
|> List.sort by_quantity
|
||||
;;
|
||||
|
||||
let compute (module V : Metadata.VALIDABLE) path =
|
||||
let+ deps, articles = get_articles (module V) path in
|
||||
deps, group articles
|
||||
;;
|
||||
end
|
|
@ -1,18 +0,0 @@
|
|||
open Yocaml
|
||||
|
||||
module Articles : sig
|
||||
type t = (Model.Article.t * Filepath.t) list
|
||||
|
||||
val get_all
|
||||
: (module Metadata.VALIDABLE)
|
||||
-> ?decreasing:bool
|
||||
-> Filepath.t
|
||||
-> ('a, 'a * t) Build.t Effect.t
|
||||
end
|
||||
|
||||
module Tags : sig
|
||||
val compute
|
||||
: (module Metadata.VALIDABLE)
|
||||
-> Filepath.t
|
||||
-> (Deps.t * (string * (Model.Article.t * string) list) list) Effect.t
|
||||
end
|
21
src/dune
21
src/dune
|
@ -1,21 +0,0 @@
|
|||
(executable
|
||||
(name blogger)
|
||||
(libraries
|
||||
logs
|
||||
logs.fmt
|
||||
logs.cli
|
||||
fmt
|
||||
fmt.tty
|
||||
fmt.cli
|
||||
cmdliner
|
||||
preface
|
||||
mirage-clock-unix
|
||||
http-lwt-client
|
||||
git-unix
|
||||
cmarkit
|
||||
yocaml
|
||||
yocaml_yaml
|
||||
yocaml_cmark
|
||||
yocaml_unix
|
||||
yocaml_git
|
||||
yocaml_jingoo))
|
15
src/feed.ml
15
src/feed.ml
|
@ -1,15 +0,0 @@
|
|||
open Yocaml
|
||||
|
||||
let domain = "https://blog.robur.coop"
|
||||
let feed_url = into domain "feed.xml"
|
||||
|
||||
let articles_to_items articles =
|
||||
List.map
|
||||
(fun (article, url) -> Model.Article.to_rss_item (into domain url) article)
|
||||
articles
|
||||
|
||||
let make ((), articles) =
|
||||
Yocaml.Rss.Channel.make ~title:"Robur's blog" ~link:domain ~feed_link:feed_url
|
||||
~description:"The Robur cooperative blog" ~generator:"yocaml"
|
||||
~webmaster:"team@robur.coop"
|
||||
(articles_to_items articles)
|
|
@ -1 +0,0 @@
|
|||
val make : unit * Collection.Articles.t -> Yocaml.Rss.Channel.t
|
18
src/file.ml
18
src/file.ml
|
@ -1,18 +0,0 @@
|
|||
open Yocaml
|
||||
|
||||
let is_css = with_extension "css"
|
||||
let is_javascript = with_extension "js"
|
||||
|
||||
let is_image =
|
||||
let open Preface.Predicate in
|
||||
with_extension "png"
|
||||
|| with_extension "svg"
|
||||
|| with_extension "jpg"
|
||||
|| with_extension "jpeg"
|
||||
|| with_extension "gif"
|
||||
;;
|
||||
|
||||
let is_markdown =
|
||||
let open Preface.Predicate in
|
||||
with_extension "md" || with_extension "markdown"
|
||||
;;
|
|
@ -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
|
256
src/model.ml
256
src/model.ml
|
@ -1,256 +0,0 @@
|
|||
open Yocaml
|
||||
|
||||
let article_path file =
|
||||
let filename = basename $ replace_extension file "html" in
|
||||
filename |> into "articles"
|
||||
|
||||
let tag_path tag = add_extension tag "html" |> into "tags"
|
||||
|
||||
module Author = struct
|
||||
type t = {
|
||||
name : string;
|
||||
link : string;
|
||||
email : string;
|
||||
avatar : string option;
|
||||
}
|
||||
|
||||
let equal a b =
|
||||
String.equal a.name b.name && String.equal a.link b.link
|
||||
&& String.equal a.email b.email
|
||||
&& Option.equal String.equal a.avatar b.avatar
|
||||
|
||||
let make name link email avatar = { name; link; email; avatar }
|
||||
|
||||
let from (type a) (module V : Metadata.VALIDABLE with type t = a) obj =
|
||||
V.object_and
|
||||
(fun assoc ->
|
||||
let open Validate.Applicative in
|
||||
make
|
||||
<$> V.(required_assoc string) "name" assoc
|
||||
<*> V.(required_assoc string) "link" assoc
|
||||
<*> V.(required_assoc string) "email" assoc
|
||||
<*> V.(optional_assoc string) "avatar" assoc)
|
||||
obj
|
||||
|
||||
let default_user =
|
||||
make "robur" "https://blog.robur.coop/" "team@robur.coop" None
|
||||
|
||||
let gravatar email =
|
||||
let tk = String.(lowercase_ascii $ trim email) in
|
||||
let hs = Digest.(to_hex $ string tk) in
|
||||
"https://www.gravatar.com/avatar/" ^ hs
|
||||
|
||||
let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
|
||||
{ name; link; email; avatar } =
|
||||
let avatar = match avatar with Some uri -> uri | None -> gravatar email in
|
||||
D.
|
||||
[
|
||||
("name", string name);
|
||||
("link", string link);
|
||||
("email", string email);
|
||||
("avatar", string avatar);
|
||||
]
|
||||
end
|
||||
|
||||
module Co_author = struct
|
||||
type t = { author : Author.t; contribution : string }
|
||||
|
||||
let make author contribution = { author; contribution }
|
||||
|
||||
let from (type a) (module V : Metadata.VALIDABLE with type t = a) obj =
|
||||
V.object_and
|
||||
(fun assoc ->
|
||||
let open Validate.Applicative in
|
||||
make
|
||||
<$> V.(required_assoc (Author.from (module V))) "author" assoc
|
||||
<*> V.(required_assoc string) "contribution" assoc)
|
||||
obj
|
||||
|
||||
let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
|
||||
{ author; contribution } =
|
||||
D.
|
||||
[
|
||||
("author", object_ $ Author.inject (module D) author);
|
||||
("contribution", string contribution);
|
||||
]
|
||||
end
|
||||
|
||||
module Article = struct
|
||||
type t = {
|
||||
article_title : string;
|
||||
article_description : string;
|
||||
tags : string list;
|
||||
date : Date.t;
|
||||
title : string option;
|
||||
description : string option;
|
||||
author : Author.t;
|
||||
co_authors : Co_author.t list;
|
||||
invited_article : bool;
|
||||
}
|
||||
|
||||
let date { date; _ } = date
|
||||
let tags { tags; _ } = tags
|
||||
|
||||
let escape_string str =
|
||||
let renderer = Cmarkit_renderer.make () in
|
||||
let buffer = Buffer.create (String.length str) in
|
||||
let ctx = Cmarkit_renderer.Context.make renderer buffer in
|
||||
Cmarkit_html.html_escaped_string ctx str;
|
||||
Buffer.contents buffer
|
||||
|
||||
let to_rss_item url article =
|
||||
let title = escape_string article.article_title in
|
||||
let description = escape_string article.article_description in
|
||||
Rss.(
|
||||
Item.make ~title ~link:url ~pub_date:article.date ~description
|
||||
~guid:(Guid.link url) ())
|
||||
|
||||
let make article_title article_description tags date title description author
|
||||
co_authors =
|
||||
let author = Option.value ~default:Author.default_user author in
|
||||
let invited_article = not (Author.equal author Author.default_user) in
|
||||
{
|
||||
article_title;
|
||||
article_description;
|
||||
tags = List.map String.lowercase_ascii tags;
|
||||
date;
|
||||
title;
|
||||
description;
|
||||
author;
|
||||
co_authors;
|
||||
invited_article;
|
||||
}
|
||||
|
||||
let from_string (module V : Metadata.VALIDABLE) = function
|
||||
| None -> Validate.error $ Error.Required_metadata [ "Article" ]
|
||||
| Some str ->
|
||||
let open Validate.Monad in
|
||||
V.from_string str
|
||||
>>= V.object_and (fun assoc ->
|
||||
let open Validate.Applicative in
|
||||
make
|
||||
<$> V.(required_assoc string) "article.title" assoc
|
||||
<*> V.(required_assoc string) "article.description" assoc
|
||||
<*> V.(optional_assoc_or ~default:[] (list_of string))
|
||||
"tags" assoc
|
||||
<*> V.required_assoc
|
||||
(Metadata.Date.from (module V))
|
||||
"date" assoc
|
||||
<*> V.(optional_assoc string) "title" assoc
|
||||
<*> V.(optional_assoc string) "description" assoc
|
||||
<*> V.(optional_assoc (Author.from (module V))) "author" assoc
|
||||
<*> V.(
|
||||
optional_assoc_or ~default:[]
|
||||
(list_of (Co_author.from (module V)))
|
||||
"coauthors" assoc))
|
||||
|
||||
let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
|
||||
{
|
||||
article_title;
|
||||
article_description;
|
||||
tags;
|
||||
date;
|
||||
title;
|
||||
description;
|
||||
author;
|
||||
co_authors;
|
||||
invited_article;
|
||||
} =
|
||||
let co_authors =
|
||||
List.map (fun c -> D.object_ $ Co_author.inject (module D) c) co_authors
|
||||
in
|
||||
let has_co_authors = match co_authors with [] -> false | _ -> true in
|
||||
D.
|
||||
[
|
||||
("root", string "..");
|
||||
( "metadata",
|
||||
object_
|
||||
[
|
||||
("title", string article_title);
|
||||
("description", string article_description);
|
||||
] );
|
||||
("tags", list (List.map string tags));
|
||||
("date", object_ $ Metadata.Date.inject (module D) date);
|
||||
("author", object_ $ Author.inject (module D) author);
|
||||
("coauthors", list co_authors);
|
||||
("invited", boolean invited_article);
|
||||
("has_coauthors", boolean has_co_authors);
|
||||
]
|
||||
@ Metadata.Page.inject (module D) (Metadata.Page.make title description)
|
||||
|
||||
let compare_by_date a b = Date.compare a.date b.date
|
||||
end
|
||||
|
||||
module Articles = struct
|
||||
type t = {
|
||||
articles : (Article.t * string) list;
|
||||
title : string option;
|
||||
description : string option;
|
||||
}
|
||||
|
||||
let make ?title ?description articles = { articles; title; description }
|
||||
let title p = p.title
|
||||
let description p = p.description
|
||||
let articles p = p.articles
|
||||
let set_articles new_articles p = { p with articles = new_articles }
|
||||
let set_title new_title p = { p with title = new_title }
|
||||
let set_description new_desc p = { p with description = new_desc }
|
||||
|
||||
let sort ?(decreasing = true) articles =
|
||||
List.sort
|
||||
(fun (a, _) (b, _) ->
|
||||
let a_date = Article.date a and b_date = Article.date b in
|
||||
let r = Date.compare a_date b_date in
|
||||
if decreasing then ~-r else r)
|
||||
articles
|
||||
|
||||
let sort_articles_by_date ?(decreasing = true) p =
|
||||
{ p with articles = sort ~decreasing p.articles }
|
||||
|
||||
let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
|
||||
{ articles; title; description } =
|
||||
( "articles",
|
||||
D.list
|
||||
(List.map
|
||||
(fun (article, url) ->
|
||||
D.object_
|
||||
(("url", D.string url) :: Article.inject (module D) article))
|
||||
articles) )
|
||||
:: ("root", D.string ".")
|
||||
:: (Metadata.Page.inject (module D) $ Metadata.Page.make title description)
|
||||
end
|
||||
|
||||
let article_object (type a) (module D : Key_value.DESCRIBABLE with type t = a)
|
||||
(article, url) =
|
||||
D.object_ (("url", D.string url) :: Article.inject (module D) article)
|
||||
|
||||
module Tag = struct
|
||||
type t = {
|
||||
tag : string;
|
||||
tags : (string * int) list;
|
||||
articles : (Article.t * string) list;
|
||||
title : string option;
|
||||
description : string option;
|
||||
}
|
||||
|
||||
let make ?title ?description tag articles tags =
|
||||
{ tag; tags; articles = Articles.sort articles; title; description }
|
||||
|
||||
let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
|
||||
{ tag; tags; articles; title; description } =
|
||||
("tag", D.string tag)
|
||||
:: ("root", D.string "..")
|
||||
:: ("articles", D.list (List.map (article_object (module D)) articles))
|
||||
:: ( "tags",
|
||||
D.list
|
||||
(List.map
|
||||
(fun (tag, n) ->
|
||||
D.object_
|
||||
[
|
||||
("name", D.string tag);
|
||||
("link", D.string (tag_path tag));
|
||||
("number", D.integer n);
|
||||
])
|
||||
tags) )
|
||||
:: (Metadata.Page.inject (module D) $ Metadata.Page.make title description)
|
||||
end
|
|
@ -1,55 +0,0 @@
|
|||
open Yocaml
|
||||
|
||||
val article_path : Filepath.t -> Filepath.t
|
||||
val tag_path : string -> Filepath.t
|
||||
|
||||
module Article : sig
|
||||
type t
|
||||
|
||||
val date : t -> Date.t
|
||||
val tags : t -> string list
|
||||
val to_rss_item : string -> t -> Rss.Item.t
|
||||
val compare_by_date : t -> t -> int
|
||||
|
||||
include Metadata.INJECTABLE with type t := t
|
||||
include Metadata.READABLE with type t := t
|
||||
end
|
||||
|
||||
module Tag : sig
|
||||
type t
|
||||
|
||||
val make
|
||||
: ?title:string
|
||||
-> ?description:string
|
||||
-> string
|
||||
-> (Article.t * string) list
|
||||
-> (string * int) list
|
||||
-> t
|
||||
|
||||
include Metadata.INJECTABLE with type t := t
|
||||
end
|
||||
|
||||
module Articles : sig
|
||||
type t
|
||||
|
||||
val make
|
||||
: ?title:string
|
||||
-> ?description:string
|
||||
-> (Article.t * string) list
|
||||
-> t
|
||||
|
||||
val sort
|
||||
: ?decreasing:bool
|
||||
-> (Article.t * string) list
|
||||
-> (Article.t * string) list
|
||||
|
||||
val sort_articles_by_date : ?decreasing:bool -> t -> t
|
||||
val articles : t -> (Article.t * string) list
|
||||
val title : t -> string option
|
||||
val description : t -> string option
|
||||
val set_title : string option -> t -> t
|
||||
val set_description : string option -> t -> t
|
||||
val set_articles : (Article.t * string) list -> t -> t
|
||||
|
||||
include Metadata.INJECTABLE with type t := t
|
||||
end
|
108
src/task.ml
108
src/task.ml
|
@ -1,108 +0,0 @@
|
|||
open Yocaml
|
||||
module Metaformat = Yocaml_yaml
|
||||
module Markup = Yocaml_cmark
|
||||
module Template = Yocaml_jingoo
|
||||
|
||||
let css_target target = "css" |> into target
|
||||
let javascript_target target = "js" |> into target
|
||||
let images_target target = "images" |> into target
|
||||
let template file = add_extension file "html" |> into "templates"
|
||||
let article_template = template "article"
|
||||
let layout_template = template "layout"
|
||||
let list_template = template "list_articles"
|
||||
let article_target file target = Model.article_path file |> into target
|
||||
let binary_update = Build.watch Sys.argv.(0)
|
||||
let index_html target = "index.html" |> into target
|
||||
let index_md = "index.md" |> into "pages"
|
||||
let rss_feed target = "feed.xml" |> into target
|
||||
let tag_file tag target = Model.tag_path tag |> into target
|
||||
let tag_template = template "tag"
|
||||
|
||||
let move_css target =
|
||||
process_files
|
||||
[ "css" ]
|
||||
File.is_css
|
||||
(Build.copy_file ~into:(css_target target))
|
||||
;;
|
||||
|
||||
let move_javascript target =
|
||||
process_files
|
||||
[ "js" ]
|
||||
File.is_javascript
|
||||
(Build.copy_file ~into:(javascript_target target))
|
||||
;;
|
||||
|
||||
let move_images target =
|
||||
process_files
|
||||
[ "images" ]
|
||||
File.is_image
|
||||
(Build.copy_file ~into:(images_target target))
|
||||
;;
|
||||
|
||||
let process_articles target =
|
||||
process_files [ "articles" ] File.is_markdown (fun article_file ->
|
||||
let open Build in
|
||||
create_file
|
||||
(article_target article_file target)
|
||||
(binary_update
|
||||
>>> Metaformat.read_file_with_metadata
|
||||
(module Model.Article)
|
||||
article_file
|
||||
>>> Markup.content_to_html ~strict:false ()
|
||||
>>> Template.apply_as_template (module Model.Article) article_template
|
||||
>>> Template.apply_as_template (module Model.Article) layout_template
|
||||
>>^ Stdlib.snd))
|
||||
;;
|
||||
|
||||
let merge_with_page ((meta, content), articles) =
|
||||
let title = Metadata.Page.title meta in
|
||||
let description = Metadata.Page.description meta in
|
||||
Model.Articles.make ?title ?description articles, content
|
||||
;;
|
||||
|
||||
let generate_feed target =
|
||||
let open Build in
|
||||
let* articles_arrow =
|
||||
Collection.Articles.get_all (module Metaformat) "articles"
|
||||
in
|
||||
create_file
|
||||
(rss_feed target)
|
||||
(binary_update >>> articles_arrow >>^ Feed.make >>^ Rss.Channel.to_rss)
|
||||
;;
|
||||
|
||||
let generate_tags target =
|
||||
let* deps, tags = Collection.Tags.compute (module Metaformat) "articles" in
|
||||
let tags_string = List.map (fun (i, s) -> i, List.length s) tags in
|
||||
let mk_meta tag articles () = Model.Tag.make tag articles tags_string, "" in
|
||||
List.fold_left
|
||||
(fun program (tag, articles) ->
|
||||
let open Build in
|
||||
program
|
||||
>> create_file
|
||||
(tag_file tag target)
|
||||
(init deps
|
||||
>>> binary_update
|
||||
>>^ mk_meta tag articles
|
||||
>>> Template.apply_as_template (module Model.Tag) tag_template
|
||||
>>> Template.apply_as_template (module Model.Tag) layout_template
|
||||
>>^ Stdlib.snd))
|
||||
(return ())
|
||||
tags
|
||||
;;
|
||||
|
||||
let generate_index target =
|
||||
let open Build in
|
||||
let* articles_arrow =
|
||||
Collection.Articles.get_all (module Metaformat) "articles"
|
||||
in
|
||||
create_file
|
||||
(index_html target)
|
||||
(binary_update
|
||||
>>> Metaformat.read_file_with_metadata (module Metadata.Page) index_md
|
||||
>>> Markup.content_to_html ~strict:false ()
|
||||
>>> articles_arrow
|
||||
>>^ merge_with_page
|
||||
>>> Template.apply_as_template (module Model.Articles) list_template
|
||||
>>> Template.apply_as_template (module Model.Articles) layout_template
|
||||
>>^ Stdlib.snd)
|
||||
;;
|
|
@ -1,7 +0,0 @@
|
|||
val move_css : string -> unit Yocaml.Effect.t
|
||||
val move_images : string -> unit Yocaml.Effect.t
|
||||
val move_javascript : string -> unit Yocaml.Effect.t
|
||||
val process_articles : string -> unit Yocaml.Effect.t
|
||||
val generate_feed : string -> unit Yocaml.Effect.t
|
||||
val generate_index : string -> unit Yocaml.Effect.t
|
||||
val generate_tags : string -> unit Yocaml.Effect.t
|
|
@ -1,13 +1,13 @@
|
|||
<a href="/index.html">Back to index</a>
|
||||
<a href="{{ host }}/index.html">Back to index</a>
|
||||
|
||||
<article>
|
||||
<h1>{{ metadata.title }}</h1>
|
||||
<h1>{{ title }}</h1>
|
||||
<ul class="tags-list">
|
||||
{%- for tag in tags -%}
|
||||
<li><a href="/tags/{{ tag }}.html">{{ tag }}</a></li>
|
||||
<li>{{ tag }}</li>
|
||||
{%- endfor -%}
|
||||
</ul>
|
||||
{%- autoescape false -%}
|
||||
{{ body }}
|
||||
{{ yocaml_body }}
|
||||
{% endautoescape -%}
|
||||
</article>
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
<a class="small-button rss" href="./feed.xml">RSS</a>
|
||||
<a class="small-button rss" href="{{ host }}/feed.xml">RSS</a>
|
||||
|
||||
{%- autoescape false -%}
|
||||
{{ body }}
|
||||
{{ yocaml_body }}
|
||||
{% endautoescape -%}
|
||||
|
||||
<h3>Essays and ramblings</h3>
|
||||
|
@ -20,13 +20,13 @@
|
|||
{%- endfor -%}
|
||||
</div>
|
||||
<div class="content">
|
||||
<span class="date">{{ article.date.canonical }}</span>
|
||||
<a href="{{ article.url }}">{{ article.metadata.title }}</a><br />
|
||||
<p>{{ article.metadata.description }}</p>
|
||||
<span class="date">{{ article.date.human }}</span>
|
||||
<a href="{{ host }}{{ article.url }}">{{ article.title }}</a><br />
|
||||
<p>{{ article.description }}</p>
|
||||
<div class="bottom">
|
||||
<ul class="tags-list">
|
||||
{%- for tag in article.tags -%}
|
||||
<li><a href="/tags/{{ tag }}.html">{{ tag }}</a></li>
|
||||
<li>{{ tag }}</li>
|
||||
{%- endfor -%}
|
||||
</ul>
|
||||
</div>
|
|
@ -1,20 +1,3 @@
|
|||
{%- if metadata.title -%}
|
||||
{%- set dash = " - " -%}
|
||||
{%- set page_title = metadata.title -%}
|
||||
{%- elseif title -%}
|
||||
{%- set dash = " - " -%}
|
||||
{%- set page_title = title -%}
|
||||
{%- else -%}
|
||||
{%- set dash = "" -%}
|
||||
{%- set page_title = "" -%}
|
||||
{%- endif %}
|
||||
{% if metadata.description -%}
|
||||
{%- set page_description = metadata.description -%}
|
||||
{%- elseif description -%}
|
||||
{%- set page_description = description -%}
|
||||
{%- else -%}
|
||||
{%- set page_description = "blog.robur.coop" -%}
|
||||
{%- endif -%}
|
||||
<!doctype html>
|
||||
<html lang="en">
|
||||
<head>
|
||||
|
@ -22,13 +5,13 @@
|
|||
<meta http-equiv="x-ua-compatible" content="ie=edge">
|
||||
<meta name="viewport" content="width=device-width, initial-scale=1">
|
||||
<title>
|
||||
Robur's blog{{ dash }}{{ page_title }}
|
||||
Robur's blog{{ dash }}{{ title }}
|
||||
</title>
|
||||
<meta name="description" content="{{ page_description }}">
|
||||
<link type="text/css" rel="stylesheet" href="{{ root }}/css/hl.css">
|
||||
<link type="text/css" rel="stylesheet" href="{{ root }}/css/style.css">
|
||||
<script src="{{ root }}/js/hl.js"></script>
|
||||
<link rel="alternate" type="application/rss+xml" href="{{ root }}/feed.xml" title="blog.robur.coop">
|
||||
<meta name="description" content="{{ description }}">
|
||||
<link type="text/css" rel="stylesheet" href="{{ host }}/css/hl.css">
|
||||
<link type="text/css" rel="stylesheet" href="{{ host }}/css/style.css">
|
||||
<script src="{{ host }}/js/hl.js"></script>
|
||||
<link rel="alternate" type="application/rss+xml" href="{{ host }}/feed.xml" title="blog.robur.coop">
|
||||
</head>
|
||||
<body>
|
||||
<header>
|
||||
|
@ -39,7 +22,7 @@
|
|||
</header>
|
||||
<main>
|
||||
{%- autoescape false -%}
|
||||
{{ body }}
|
||||
{{ yocaml_body }}
|
||||
{% endautoescape -%}
|
||||
</main>
|
||||
<footer>
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
#!/bin/sh
|
||||
|
||||
opam exec -- dune exec src/blogger.exe -- push \
|
||||
opam exec -- dune exec src/push.exe --
|
||||
-r git@git.robur.coop:robur/blog.robur.coop.git#gh-pages \
|
||||
--host https://blog.robur.coop \
|
||||
--name "The Robur team" \
|
||||
--email team@robur.coop
|
||||
|
|
Loading…
Reference in a new issue