
commit
3d92789cdb
34 changed files with 1605 additions and 0 deletions
@ -0,0 +1,9 @@
|
||||
.merlin |
||||
.logarion |
||||
*.ymd |
||||
\#*\# |
||||
.\#*1 |
||||
*~ |
||||
*.o |
||||
*.native |
||||
_build |
@ -0,0 +1,83 @@
|
||||
# Contributing to Logarion |
||||
|
||||
Logarions primary aim is to create a note system, which doesn't waste resources. |
||||
The secondary aim is to provide an exemplary OCaml project to demonstrate and promote the language (as it happens with many other "Blogging" systems written in other languages). |
||||
|
||||
As part of the secondary aim, the source code needs to written in a way that encourages the language's adoption and the participation to the OCaml developer community. |
||||
|
||||
## Starting with OCaml |
||||
|
||||
_"OCaml is an industrial strength programming language supporting functional, imperative and object-oriented styles"_ -- https://ocaml.org/ |
||||
|
||||
OCaml simply rocks. |
||||
|
||||
If you are unfamiliar with OCaml, consider starting with these resources: |
||||
|
||||
- Install OCaml: https://ocaml.org/docs/install.html |
||||
- Read about OCaml: https://ocaml.org/learn/books.html |
||||
- Ask questions & join the community: |
||||
- Mailing lists: https://ocaml.org/community/ |
||||
- IRC: irc://irc.freenode.net/#ocaml (Web client: https://riot.im/app/#/room/#freenode_#ocaml:matrix.org ) |
||||
- Reddit: http://www.reddit.com/r/ocaml/ |
||||
- Discourse: https://discuss.ocaml.org/ |
||||
- .. other: https://ocaml.org/community/ |
||||
|
||||
## Design principles |
||||
|
||||
[Unix philosophy](https://en.wikipedia.org/wiki/Unix_philosophy#Do_One_Thing_and_Do_It_Well) |
||||
|
||||
1. System simplicity & interoperability. |
||||
2. Output quality. |
||||
3. Distributed interactivity, like sharing with friends. |
||||
|
||||
## Developing & contributing |
||||
|
||||
### Clone |
||||
|
||||
``` |
||||
git clone https://cgit.orbitalfox.eu/logarion/ |
||||
``` |
||||
|
||||
Install dependencies: |
||||
|
||||
``` |
||||
cd logarion |
||||
pin add logarion . -n |
||||
opam depext --install logarion |
||||
``` |
||||
|
||||
Build the project: |
||||
|
||||
``` |
||||
dune build src/logarion.exe |
||||
``` |
||||
|
||||
This will create `_build/default/src/logarion.exe` (the command line interface). |
||||
|
||||
### Project structure |
||||
|
||||
There are three layers: |
||||
|
||||
- notes |
||||
- archive |
||||
- interfaces & intermediate formats |
||||
|
||||
### Core |
||||
|
||||
- `logarion.ml`: repository related functions (listing, adding/removing, etc). ([src/logarion.ml](https://gitlab.com/orbifx/logarion/blob/master/src/logarion.ml)) |
||||
- `note.ml`: parsing from and to note files. ([src/note.ml](https://gitlab.com/orbifx/logarion/blob/master/src/note.ml)) |
||||
|
||||
### Intermediate formats |
||||
|
||||
Converters: |
||||
|
||||
- `html.ml`: archive to HTML pages. |
||||
- `atom.ml`: archive to Atom feeds. |
||||
|
||||
### Servers & utilities |
||||
|
||||
Logarion's archives can be served over various protocols using servers. |
||||
Find related software here: |
||||
|
||||
- https://logarion.orbitalfox.eu/ |
||||
- https://cgit.orbitalfox.eu/ |
@ -0,0 +1,18 @@
|
||||
all: cli |
||||
|
||||
cli: |
||||
dune build src/logarion_cli.exe
|
||||
|
||||
clean: |
||||
dune clean
|
||||
|
||||
theme-dark: |
||||
sassc share/sass/main-dark.sass > share/static/main.css
|
||||
|
||||
theme-light: |
||||
sassc share/sass/main-light.sass > share/static/main.css
|
||||
|
||||
tgz: |
||||
cp _build/default/src/logarion_cli.exe logarion
|
||||
strip logarion
|
||||
tar czvf "logarion-$(shell ./logarion --version)-$(shell uname -s)-$(shell uname -m)-$(shell git rev-parse --short HEAD).tar.gz" share logarion
|
@ -0,0 +1,50 @@
|
||||
# Logarion |
||||
|
||||
Logarion is a [free and open-source][Licence] personal note taking, journaling and publication system; a blog-wiki hybrid. |
||||
|
||||
## Features |
||||
|
||||
- Plain file system store, where each note is a file. |
||||
- Command line & web interfaces. |
||||
- Atom feeds |
||||
- Static (conversion to files for uploading) & dynamic serving (HTTP, Gopher, ..). |
||||
|
||||
|
||||
## Community & support |
||||
|
||||
- Website: <https://logarion.orbitalfox.eu> |
||||
- Mailing list: <https://lists.orbitalfox.eu/listinfo/logarion> |
||||
- Matrix (chat): `#logarion:matrix.org`. Via Riot web-app: <https://riot.im/app/#/room/#logarion:matrix.org> |
||||
- For issues peferably email to [mailto:logarion@lists.orbitalfox.eu](mailto:logarion@lists.orbitalfox.eu?subject=[Issue] summary-here). |
||||
Alternatively <https://gitlab.com/orbifx/logarion/issues> |
||||
|
||||
|
||||
## Install |
||||
|
||||
The following instructions are the quickest way to install Logarion (in the absence of binary releases). |
||||
|
||||
``` |
||||
opam pin add logarion git://orbitalfox.eu/logarion |
||||
opam install logarion |
||||
``` |
||||
|
||||
Once installed you will have `logarion` for command line control of the repository. |
||||
|
||||
## Archives |
||||
|
||||
### Command line |
||||
|
||||
Create a folder and run `logarion init` from within it to produce `.logarion/config.toml`, which is the core configuration file. |
||||
The archive options are under the `[archive]` section. |
||||
|
||||
Run `logarion --help` for more options. |
||||
|
||||
|
||||
#### Theme |
||||
|
||||
Optionally install a [Sass](http://sass-lang.com/) compiler, like [sassc](http://sass-lang.com/libsass#sassc), and then run `make theme-dark` or `make theme-light`, to generate a stylesheet as `share/static/main.css`, using the respective Sass files in `share/sass/`. |
||||
|
||||
## See also |
||||
|
||||
- [CONTRIBUTING.md](CONTRIBUTING.md) |
||||
- [Licence](https://joinup.ec.europa.eu/software/page/eupl) |
@ -0,0 +1,29 @@
|
||||
opam-version: "1.2" |
||||
name: "logarion" |
||||
version: "0.5.0" |
||||
homepage: "https://logarion.orbitalfox.eu" |
||||
dev-repo: "git://orbitalfox.eu/logarion" |
||||
bug-reports: "mailto:logarion@lists.orbitalfox.eu?subject=[Issue]" |
||||
maintainer: "Stavros Polymenis <sp@orbitalfox.eu>" |
||||
authors: "Stavros Polymenis <sp@orbitalfox.eu>" |
||||
license: "EUPL" |
||||
build: [ |
||||
["dune" "build" "--root" "." "-j" jobs "@install"] |
||||
] |
||||
depends: [ |
||||
"dune" {build} |
||||
"ptime" |
||||
"uuidm" |
||||
"uri" |
||||
"re" |
||||
"emile" |
||||
"omd" |
||||
"lwt" |
||||
"mustache" |
||||
"tyxml" |
||||
|
||||
"cmdliner" |
||||
"bos" |
||||
"toml" |
||||
"fpath" |
||||
] |
@ -0,0 +1,16 @@
|
||||
#This is an exemplar config file. Use `logarion_cli init` to have one generated. |
||||
|
||||
[archive] |
||||
title = "Logarion" |
||||
owner = "Name" |
||||
email = "name@example.com" |
||||
uuid = "" # Generate UUID using `uuidgen` or https://www.uuidgenerator.net/ |
||||
|
||||
[web] |
||||
static_dir = ".logarion/static" |
||||
stylesheets = ["main.css"] |
||||
url = "http://localhost:3666" |
||||
|
||||
[gopher] |
||||
static_dir = ".logarion/static" |
||||
url = "gopher://localhost" |
@ -0,0 +1,15 @@
|
||||
@font-face |
||||
font-family: "Orbitron Medium" |
||||
src: url('#{$font-url}/orbitron/orbitron-medium.otf') |
||||
|
||||
@font-face |
||||
font-family: "Orbitron Light" |
||||
src: url('#{$font-url}/orbitron/orbitron-light.otf') |
||||
|
||||
@font-face |
||||
font-family: "Orbitron Bold" |
||||
src: url('#{$font-url}/orbitron/orbitron-bold.otf') |
||||
|
||||
@font-face |
||||
font-family: "Orbitron Black" |
||||
src: url('#{$font-url}/orbitron/orbitron-black.otf') |
@ -0,0 +1,99 @@
|
||||
$font-url: "fonts" |
||||
|
||||
@import fonts/orbitron.sass |
||||
|
||||
$font-face: "DejaVu Sans" |
||||
|
||||
body |
||||
font-family: $font-face |
||||
font-weight: 400 |
||||
|
||||
main, article |
||||
margin: auto |
||||
padding: 2pt |
||||
|
||||
main, article, p, img, h1, h2, h3, h4, h5 |
||||
max-width: 75ch |
||||
|
||||
pre |
||||
display: block |
||||
overflow: auto |
||||
padding-left: 1ch |
||||
|
||||
blockquote |
||||
font-style: italic |
||||
|
||||
article > .meta |
||||
margin: auto 2ch |
||||
|
||||
article > h1 |
||||
text-align: center |
||||
|
||||
header > h1 |
||||
font-family: "Orbitron Light" |
||||
|
||||
header, footer |
||||
text-align: center |
||||
|
||||
li a, header a, header a:hover |
||||
text-decoration: none |
||||
|
||||
a:hover |
||||
text-decoration: underline |
||||
|
||||
h1, h2, h3, h4, h5 |
||||
font-family: "Orbitron Medium" |
||||
|
||||
footer |
||||
clear: both |
||||
margin-top: 2em |
||||
border-top: 1px dotted |
||||
padding: 1em 0 |
||||
|
||||
fieldset |
||||
border: .5mm dashed |
||||
|
||||
fieldset > p |
||||
margin: .5em auto |
||||
padding: .5em |
||||
float: left |
||||
|
||||
label |
||||
margin: .2em |
||||
display: block |
||||
|
||||
input, textarea |
||||
display: block |
||||
border: none |
||||
border-bottom: .5mm solid |
||||
min-width: 100% |
||||
|
||||
textarea |
||||
border: .5mm solid |
||||
width: 80ch |
||||
height: 40ch |
||||
display: block-inline |
||||
clear: both |
||||
|
||||
button |
||||
clear: both |
||||
display: block |
||||
margin: 1em auto |
||||
border: .5mm solid |
||||
|
||||
.topics > li |
||||
list-style-type: none |
||||
text-transform: capitalize |
||||
|
||||
ul.listing |
||||
padding: 0 1ch |
||||
|
||||
.listing > li |
||||
list-style-type: none |
||||
text-transform: none |
||||
padding: 4px |
||||
margin-bottom: .5em |
||||
|
||||
.listing p |
||||
padding: 0 |
||||
margin: 0 |
@ -0,0 +1,23 @@
|
||||
@import layout.sass |
||||
|
||||
body |
||||
background-color: #191b22 |
||||
|
||||
body, a, header a:visited |
||||
color: #f2f2f2 |
||||
|
||||
pre |
||||
border-left: 1mm solid #f2f2f233 |
||||
|
||||
a |
||||
color: PaleTurquoise |
||||
|
||||
.abstract, .meta |
||||
color: #909090 |
||||
|
||||
article, .listing > li |
||||
background-color: rgba(100,100,100,.1) |
||||
border: 1px solid rgba(100,100,100,.2) |
||||
|
||||
.pipe |
||||
opacity: .3 |
@ -0,0 +1,23 @@
|
||||
@import layout.sass |
||||
|
||||
body |
||||
background-color: WhiteSmoke |
||||
|
||||
body, a, header a:visited |
||||
color: #191B22 |
||||
|
||||
pre |
||||
border-left: 1mm solid #191B22 |
||||
|
||||
a |
||||
color: SteelBlue |
||||
|
||||
.abstract, .meta |
||||
color: #909090 |
||||
|
||||
article, .listing > li |
||||
background-color: rgba(100,100,100,.1) |
||||
border: 1px solid rgba(100,100,100,.2) |
||||
|
||||
.pipe |
||||
opacity: .3 |
@ -0,0 +1,131 @@
|
||||
@font-face { |
||||
font-family: "Orbitron Medium"; |
||||
src: url("fonts/orbitron/orbitron-medium.otf"); } |
||||
|
||||
@font-face { |
||||
font-family: "Orbitron Light"; |
||||
src: url("fonts/orbitron/orbitron-light.otf"); } |
||||
|
||||
@font-face { |
||||
font-family: "Orbitron Bold"; |
||||
src: url("fonts/orbitron/orbitron-bold.otf"); } |
||||
|
||||
@font-face { |
||||
font-family: "Orbitron Black"; |
||||
src: url("fonts/orbitron/orbitron-black.otf"); } |
||||
|
||||
body { |
||||
font-family: "DejaVu Sans"; |
||||
font-weight: 400; } |
||||
|
||||
main, article { |
||||
margin: auto; |
||||
padding: 2pt; } |
||||
|
||||
main, article, p, img, h1, h2, h3, h4, h5 { |
||||
max-width: 75ch; } |
||||
|
||||
pre { |
||||
display: block; |
||||
overflow: auto; |
||||
padding-left: 1ch; } |
||||
|
||||
blockquote { |
||||
font-style: italic; } |
||||
|
||||
article > .meta { |
||||
margin: auto 2ch; } |
||||
|
||||
article > h1 { |
||||
text-align: center; } |
||||
|
||||
header > h1 { |
||||
font-family: "Orbitron Light"; } |
||||
|
||||
header, footer { |
||||
text-align: center; } |
||||
|
||||
li a, header a, header a:hover { |
||||
text-decoration: none; } |
||||
|
||||
a:hover { |
||||
text-decoration: underline; } |
||||
|
||||
h1, h2, h3, h4, h5 { |
||||
font-family: "Orbitron Medium"; } |
||||
|
||||
footer { |
||||
clear: both; |
||||
margin-top: 2em; |
||||
border-top: 1px dotted; |
||||
padding: 1em 0; } |
||||
|
||||
fieldset { |
||||
border: .5mm dashed; } |
||||
|
||||
fieldset > p { |
||||
margin: .5em auto; |
||||
padding: .5em; |
||||
float: left; } |
||||
|
||||
label { |
||||
margin: .2em; |
||||
display: block; } |
||||
|
||||
input, textarea { |
||||
display: block; |
||||
border: none; |
||||
border-bottom: .5mm solid; |
||||
min-width: 100%; } |
||||
|
||||
textarea { |
||||
border: .5mm solid; |
||||
width: 80ch; |
||||
height: 40ch; |
||||
display: block-inline; |
||||
clear: both; } |
||||
|
||||
button { |
||||
clear: both; |
||||
display: block; |
||||
margin: 1em auto; |
||||
border: .5mm solid; } |
||||
|
||||
.topics > li { |
||||
list-style-type: none; |
||||
text-transform: capitalize; } |
||||
|
||||
ul.listing { |
||||
padding: 0 1ch; } |
||||
|
||||
.listing > li { |
||||
list-style-type: none; |
||||
text-transform: none; |
||||
padding: 4px; |
||||
margin-bottom: .5em; } |
||||
|
||||
.listing p { |
||||
padding: 0; |
||||
margin: 0; } |
||||
|
||||
body { |
||||
background-color: #191b22; } |
||||
|
||||
body, a, header a:visited { |
||||
color: #f2f2f2; } |
||||
|
||||
pre { |
||||
border-left: 1mm solid #f2f2f233; } |
||||
|
||||
a { |
||||
color: PaleTurquoise; } |
||||
|
||||
.abstract, .meta { |
||||
color: #909090; } |
||||
|
||||
article, .listing > li { |
||||
background-color: rgba(100, 100, 100, 0.1); |
||||
border: 1px solid rgba(100, 100, 100, 0.2); } |
||||
|
||||
.pipe { |
||||
opacity: .3; } |
@ -0,0 +1,3 @@
|
||||
## Articles |
||||
|
||||
{{recent_texts_listing}} |
@ -0,0 +1,3 @@
|
||||
{{date_human}} |
||||
{{link}} |
||||
{{abstract}} |
@ -0,0 +1,7 @@
|
||||
### Topics |
||||
|
||||
{{topics}} |
||||
|
||||
### Recent articles |
||||
|
||||
{{recent_texts_listing}} |
@ -0,0 +1,82 @@
|
||||
module Validation = struct |
||||
let empty = [] |
||||
|
||||
let (&>) report = function None -> report | Some msg -> msg :: report |
||||
let (&&>) report = function [] -> report | msgs -> msgs @ report |
||||
|
||||
let check ok msg = if ok then None else Some msg |
||||
|
||||
let file_exists ?(msg=(fun s -> (s ^ " is not a file"))) ?(parent_dir=Fpath.v ".") file = |
||||
let str = Fpath.(to_string (parent_dir // file)) in |
||||
check (Sys.file_exists str) (msg str) |
||||
|
||||
let is_directory ?(msg=(fun s -> (s ^ " is not a directory"))) dir = |
||||
let str = Fpath.to_string dir in |
||||
check (Sys.file_exists str && Sys.is_directory str) (msg str) |
||||
|
||||
let files_exist ?(msg=(fun s -> (s ^ " is not a file"))) ?(parent_dir=Fpath.v ".") files = |
||||
let f report file = report &> file_exists ~msg ~parent_dir file in |
||||
List.fold_left f empty files |
||||
|
||||
let terminate_when_invalid ?(print_error=true) = |
||||
let error i msg = prerr_endline ("Error " ^ string_of_int i ^ ": " ^ msg) in |
||||
function |
||||
| [] -> () |
||||
| msgs -> if print_error then List.iteri error (List.rev msgs); exit 1 |
||||
end |
||||
|
||||
module Path = struct |
||||
let of_string str = |
||||
if Sys.file_exists str then |
||||
match Fpath.v str with |
||||
| path -> Ok path |
||||
| exception (Invalid_argument msg) -> Error ("Invalid path " ^ msg) |
||||
else Error (str ^ " not found") |
||||
|
||||
let path_exists x = Fpath.to_string x |> Sys.file_exists |
||||
|
||||
let conventional_paths = |
||||
let paths = |
||||
try [ ".logarion"; Sys.getenv "HOME" ^ "/.config/logarion"; "/etc/logarion" ] |
||||
with Not_found -> [ ".logarion"; "/etc/logarion" ] |
||||
in |
||||
List.map Fpath.v paths |
||||
|
||||
let with_file ?(conventional_paths=conventional_paths) config_file = |
||||
let (//) = Fpath.(//) in |
||||
let basepath = Fpath.v config_file in |
||||
let existing dir = path_exists (dir // basepath) in |
||||
try Ok (List.find existing conventional_paths // basepath) |
||||
with Not_found -> Error (config_file ^ " not found in: " ^ String.concat ", " (List.map Fpath.to_string conventional_paths)) |
||||
end |
||||
|
||||
let with_default default = function Some x -> x | None -> default |
||||
|
||||
let with_default_paths default = |
||||
function Some ss -> List.map Fpath.v ss | None -> default |
||||
|
||||
let mandatory = function Some x -> x | None -> failwith "undefined mandatory setting" |
||||
|
||||
let (&>) a b = match a with Ok x -> b x | Error e -> Error e |
||||
|
||||
module type Store = sig |
||||
type t |
||||
val from_path : Fpath.t -> (t, string) result |
||||
end |
||||
|
||||
module Make (S : Store) = struct |
||||
include S |
||||
|
||||
let of_path path = S.from_path path |
||||
|
||||
let (&>) = (&>) |
||||
|
||||
let to_record converter = function |
||||
| Ok store -> converter store |
||||
| Error s -> Error s |
||||
|
||||
let to_record_or_exit ?(print_error=true) ?(validator=(fun _cfg -> [])) converter store_result = |
||||
match to_record converter store_result with |
||||
| Ok cfg -> Validation.terminate_when_invalid (validator cfg); cfg |
||||
| Error s -> if print_error then prerr_endline s; exit 1 |
||||
end |
@ -0,0 +1,23 @@
|
||||
type t = TomlTypes.table |
||||
|
||||
let from_path path = |
||||
match Toml.Parser.from_filename (Fpath.to_string path) with |
||||
| `Error (str, _loc) -> Error str |
||||
| `Ok toml -> Ok toml |
||||
|
||||
open TomlLenses |
||||
let (/) a b = (key a |-- table |-- key b) |
||||
let (//) a b = (key a |-- table |-- key b |-- table) |
||||
|
||||
let int toml path = get toml (path |-- int) |
||||
|
||||
let float toml path = get toml (path |-- float) |
||||
|
||||
let string toml path = get toml (path |-- string) |
||||
|
||||
let strings toml path = get toml (path |-- array |-- strings) |
||||
|
||||
let path toml path = match string toml path with Some s -> Some (Fpath.v s) | None -> None |
||||
|
||||
let paths toml path = match strings toml path with |
||||
Some ss -> Some (List.map Fpath.v ss) | None -> None |
@ -0,0 +1,7 @@
|
||||
(jbuild_version 1) |
||||
|
||||
(library |
||||
((name confix) |
||||
(public_name logarion.confix) |
||||
(libraries (fpath toml)) |
||||
)) |
@ -0,0 +1,50 @@
|
||||
let esc = Xml_print.encode_unsafe_char |
||||
|
||||
let header config url = |
||||
let open Logarion.Meta in |
||||
let open Logarion.Archive.Configuration in |
||||
"<title>" ^ config.title ^ "</title>" |
||||
(* TODO: ^ "<subtitle>A subtitle.</subtitle>"*) |
||||
^ "<link rel=\"alternate\" type=\"text/html\" href=\"" ^ url ^ "\"/>" |
||||
^ "<link rel=\"self\" type=\"application/atom+xml\" href=\"" ^ url ^ "/feed.atom\" />" |
||||
^ "<id>urn:uuid:" ^ Id.to_string config.id ^ "</id>" |
||||
^ "<updated>" ^ Ptime.to_rfc3339 (Ptime_clock.now ()) ^ "</updated>" |
||||
|
||||
let opt_element tag_name content = |
||||
if content <> "" |
||||
then "<" ^ tag_name ^ ">" ^ content ^ "</" ^ tag_name ^ ">" |
||||
else "" |
||||
|
||||
let entry url note = |
||||
let open Logarion in |
||||
let meta = note.Note.meta in |
||||
let u = "note/" ^ Meta.alias meta in |
||||
let open Meta in |
||||
let authors elt a = |
||||
a ^ "<author>" |
||||
^ (opt_element "name" @@ esc elt.Author.name) |
||||
^ (opt_element "uri" @@ esc (Uri.to_string elt.Author.address)) |
||||
^ "</author>" |
||||
in |
||||
("<entry>" |
||||
^ "<title>" ^ meta.title ^ "</title>" |
||||
^ "<id>urn:uuid:" ^ Meta.Id.to_string meta.uuid ^ "</id>" |
||||
^ "<link rel=\"alternate\" href=\"" ^ url ^ "/" ^ u ^ "\" />" |
||||
^ "<updated>" ^ Date.(meta.date |> listing |> rfc_string) ^ "</updated>" |
||||
^ Meta.AuthorSet.fold authors meta.authors "" |
||||
^ opt_element "summary" @@ esc meta.abstract) |
||||
^ Meta.StringSet.fold (fun elt a -> a ^ "<category term=\"" ^ elt ^ "\"/>") meta.topics "" |
||||
^ "<content type=\"xhtml\"><div xmlns=\"http://www.w3.org/1999/xhtml\">" |
||||
^ (Omd.to_html @@ Omd.of_string @@ esc note.Note.body) |
||||
^ "</div></content>" |
||||
^ "</entry>" |
||||
|
||||
let feed config url note_fn articles = |
||||
let fold_valid feed m = match note_fn m.Logarion.Meta.uuid with |
||||
| Some note -> feed ^ "\n" ^ entry url note |
||||
| None -> feed |
||||
in |
||||
"<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<feed xmlns=\"http://www.w3.org/2005/Atom\">\n" |
||||
^ header config url |
||||
^ List.fold_left fold_valid "" articles |
||||
^ "</feed>" |
@ -0,0 +1,133 @@
|
||||
open Tyxml.Html |
||||
open Logarion |
||||
|
||||
let to_string tyxml = Format.asprintf "%a" (Tyxml.Html.pp ()) tyxml |
||||
|
||||
let head ~style linker t = |
||||
head (title (pcdata t)) [ |
||||
link ~rel:[`Stylesheet] ~href:(linker style) (); |
||||
link ~rel:[`Alternate] ~href:(linker "/feed.atom") ~a:[a_mime_type "application/atom+xml"] (); |
||||
meta ~a:[a_charset "utf-8"] (); |
||||
] |
||||
|
||||
let default_style = "/static/main.css" |
||||
|
||||
let page ?(style=default_style) linker head_title header main = |
||||
html (head ~style linker head_title) (body [ header; main ]) |
||||
|
||||
let anchor url content = a ~a:[ a_href (uri_of_string url) ] content |
||||
|
||||
let div ?(style_class="") content = |
||||
let a = if style_class <> "" then [a_class [style_class]] else [] in |
||||
div ~a content |
||||
|
||||
let main = main |
||||
|
||||
let unescaped_data = Unsafe.data |
||||
let data = pcdata |
||||
let title = h1 |
||||
let header = header |
||||
|
||||
let pipe = span ~a:[a_class ["pipe"]] [pcdata " | "] |
||||
|
||||
let meta ~abstract ~authors ~date ~series ~topics ~keywords ~uuid = |
||||
let opt_span name value = if String.length value > 0 then (span [pipe; pcdata (name ^ value)]) else pcdata "" in |
||||
let authors = List.fold_left (fun acc x -> a ~a:[a_rel [`Author]] [pcdata x] :: acc) [] authors in |
||||
[ p ~a:[a_class ["abstract"]] [Unsafe.data abstract]; ] |
||||
@ authors |
||||
@ [ |
||||
pipe; |
||||
time ~a:[a_datetime date] [pcdata date]; |
||||
pipe; |
||||
opt_span "series: " series; |
||||
opt_span "topics: " topics; |
||||
opt_span "keywords: " keywords; |
||||
div [pcdata ("id: " ^ uuid)]; |
||||
] |
||||
|> div ~style_class:"meta" |
||||
|
||||
let note = article |
||||
|
||||
let text_item path meta = |
||||
let module Meta = Logarion.Meta in |
||||
tr [ |
||||
td [ a ~a:[a_class ["title"]; a_href (path ^ Meta.alias meta ^ ".html")] [data meta.Meta.title] ]; |
||||
td [ span [pcdata Meta.(stringset_csv meta.keywords)] ]; |
||||
td [ time @@ [unescaped_data Meta.Date.(pretty_date (listing meta.Meta.date))] ]; |
||||
] |
||||
|
||||
let listing_texts path metas = |
||||
let item meta = text_item path meta in |
||||
table @@ List.map item metas |
||||
|
||||
let listing_index path metas = |
||||
let items topic = |
||||
List.fold_left Meta.(fun a e -> if StringSet.mem topic e.topics then text_item path e :: a else a) |
||||
[] metas |
||||
in |
||||
let item topic = |
||||
let module Meta = Logarion.Meta in |
||||
[ h3 ~a:[a_id topic] [pcdata topic]; table (items topic)] |
||||
in |
||||
List.fold_left (fun a e -> a @ item e) [] |
||||
@@ Meta.StringSet.elements |
||||
@@ List.fold_left Meta.(fun a e -> unique_topics a e) Meta.StringSet.empty metas |
||||
|
||||
module Renderer = struct |
||||
let meta meta e = |
||||
let e = List.hd e in |
||||
match e with |
||||
| "urn_name" -> [unescaped_data @@ "/note/" ^ Logarion.Meta.alias meta] |
||||
| "date" | "date_created" | "date_edited" | "date_published" | "date_human" -> |
||||
[time @@ [unescaped_data @@ Logarion.Meta.value_with_name meta e]] |
||||
| tag -> [unescaped_data @@ Logarion.Meta.value_with_name meta tag] |
||||
|
||||
let note note e = match List.hd e with |
||||
| "body" -> [unescaped_data @@ Omd.to_html @@ Omd.of_string note.Logarion.Note.body] |
||||
| _ -> meta note.Logarion.Note.meta e |
||||
|
||||
let archive archive e = match List.hd e with |
||||
| "title" -> [h1 [anchor ("index.html") [data archive.Logarion.Archive.Configuration.title]]] |
||||
| tag -> prerr_endline ("unknown tag: " ^ tag); [unescaped_data ""] |
||||
end |
||||
|
||||
let form ymd = |
||||
let article_form = |
||||
let input_set title input = p [ label [ pcdata title; input ] ] in |
||||
let open Note in |
||||
let open Meta in |
||||
let authors = AuthorSet.to_string ymd.meta.authors in |
||||
[ |
||||
input ~a:[a_name "uuid"; a_value (Id.to_string ymd.meta.uuid); a_input_type `Hidden] (); |
||||
input_set |
||||
"Title" |
||||
(input ~a:[a_name "title"; a_value ymd.meta.title; a_required ()] ()); |
||||
input_set |
||||
"Authors" |
||||
(input ~a:[a_name "authors"; a_value authors] ()); |
||||
input_set |
||||
"Topics" |
||||
(input ~a:[a_name "topics"; a_value (stringset_csv ymd.meta.topics)] ()); |
||||
input_set |
||||
"Categories" |
||||
(input ~a:[a_name "categories"; a_value (CategorySet.to_csv ymd.meta.categories)] ()); |
||||
input_set |
||||
"Keywords" |
||||
(input ~a:[a_name "keywords"; a_value (stringset_csv ymd.meta.keywords)] ()); |
||||
input_set |
||||
"Series" |
||||
(input ~a:[a_name "series"; a_value (stringset_csv ymd.meta.series)] ()); |
||||
input_set |
||||
"Abstract" |
||||
(input ~a:[a_name "abstract"; a_value ymd.meta.abstract] ()); |
||||
input_set |
||||
"Text" |
||||
(textarea ~a:[a_name "body"] (pcdata ymd.body)); |
||||
p [ button ~a:[a_button_type `Submit] [pcdata "Submit"] ]; |
||||
] |
||||
in |
||||
div |
||||
[ form |
||||
~a:[a_method `Post; a_action (uri_of_string "/post.note"); a_accept_charset ["utf-8"]] |
||||
[ fieldset ~legend:(legend [pcdata "Article"]) article_form ] |
||||
] |
@ -0,0 +1,5 @@
|
||||
(library |
||||
((name converters) |
||||
(public_name logarion.converters) |
||||
(libraries (logarion logarion.file mustache tyxml ptime ptime.clock.os)) |
||||
)) |
@ -0,0 +1,81 @@
|
||||
type t = Mustache.t |
||||
|
||||
let of_string = Mustache.of_string |
||||
let of_file f = File.load f |> of_string |
||||
|
||||
let string s = [Html.data s] |
||||
let section ~inverted:_ _name _contents = prerr_endline "Mustache sections unsupported"; [] |
||||
let unescaped _elts = prerr_endline "Mustache unescaped not supported; used escaped instead"; [] |
||||
let partial ?indent:_ _name _ _ = prerr_endline "Mustache sections unsupported"; [] |
||||
let comment _ = [Html.data ""] |
||||
let concat = List.concat |
||||
|
||||
let escaped_index ~from:_ ~n:_ _metas _e = [Html.data "temp"] |
||||
(* match List.hd e with *) |
||||
(* | "topics" -> *) |
||||
(* let topics = *) |
||||
(* ListLabels.fold_left *) |
||||
(* ~init:(Logarion.Meta.StringSet.empty) *) |
||||
(* ~f:(fun a e -> Logarion.Meta.unique_topics a e ) metas *) |
||||
(* in *) |
||||
(* Logarion.Meta.StringSet.fold (fun e a -> a ^ "<li><a href=\"/topic/" ^ e ^ "\">" ^ e ^ "</a></li>") topics "" *) |
||||
|
||||
let header_custom template _linker archive = |
||||
Mustache.fold ~string ~section ~escaped:(Html.Renderer.archive archive) ~unescaped ~partial ~comment ~concat template |
||||
|> Html.header |
||||
|
||||
let header_default linker archive = |
||||
Html.(header [title [anchor (linker "/") [data archive.Logarion.Archive.Configuration.title]]]) |
||||
|
||||
let meta meta = |
||||
let open Logarion.Meta in |
||||
let abstract = meta.abstract in |
||||
let authors = List.map (fun elt -> elt.Author.name) @@ AuthorSet.elements meta.authors in |
||||
let date = Date.(pretty_date @@ listing meta.date) in |
||||
let series = stringset_csv meta.series in |
||||
let topics = stringset_csv meta.topics in |
||||
let keywords = stringset_csv meta.keywords in |
||||
let uuid = Id.to_string meta.uuid in |
||||
Html.meta ~abstract ~authors ~date ~series ~topics ~keywords ~uuid |
||||
|
||||
let body_custom template note = |
||||
Mustache.fold ~string ~section ~escaped:(Html.Renderer.note note) ~unescaped ~partial ~comment ~concat template |
||||
|> Html.note |
||||
|
||||
let body_default note = |
||||
Html.note |
||||
[ Html.title [Html.unescaped_data note.Logarion.Note.meta.Logarion.Meta.title]; (* Don't add title if body contains one *) |
||||
meta note.meta; |
||||
Html.unescaped_data @@ Omd.to_html @@ Omd.of_string note.Logarion.Note.body ] |
||||
|
||||
let page ~style linker title header body = |
||||
Html.to_string @@ Html.page ~style linker title header body |
||||
|
||||
let of_config config k = match config with |
||||
| Error msg -> prerr_endline ("Couldn't load [templates] section;" ^ msg); None |
||||
| Ok c -> |
||||
let open Confix.ConfixToml in |
||||
path c ("templates" / k) |
||||
|
||||
let converter default custom = function |
||||
| Some p -> |
||||
if Confix.Config.Path.path_exists p then custom @@ of_file p |
||||
else (prerr_endline @@ "Couldn't find: " ^ Fpath.to_string p; default) |
||||
| None -> default |
||||
|
||||
let header_converter config = converter header_default header_custom @@ of_config config "header" |
||||
let body_converter config = converter body_default body_custom @@ of_config config "body" |
||||
|
||||
let default_style = Html.default_style |
||||
|
||||
let page_of_index ~style linker header archive metas = |
||||
page ~style linker ("Index | " ^ archive.Logarion.Archive.Configuration.title) (header linker archive) (Html.main (Html.listing_index "" metas)) |
||||
|
||||
let page_of_log ~style linker header archive metas = |
||||
page ~style linker ("Log | " ^ archive.Logarion.Archive.Configuration.title) (header linker archive) (Html.main [Html.listing_texts "" metas]) |
||||
|
||||
let page_of_note ~style linker header body archive note = |
||||
page ~style linker note.Logarion.Note.meta.Logarion.Meta.title (header linker archive) (body note) |
||||
|
||||
let page_of_msg ~style linker header archive title msg = |
||||
page ~style linker title (header linker archive) (Html.div [Html.data msg]) |
@ -0,0 +1,89 @@
|
||||
module Id = Meta.Id |
||||
type alias_t = string |
||||
|
||||
module Configuration = struct |
||||
type t = { |
||||
repository : Lpath.repo_t; |
||||
title : string; |
||||
owner : string; |
||||
email : string; |
||||
id : Id.t; |
||||
} |
||||
|
||||
let of_config config = |
||||
let open Confix in |
||||
let open Confix.Config in |
||||
let str k = ConfixToml.(string config ("archive" / k)) in |
||||
try |
||||
Ok { |
||||
repository = |
||||
(try Lpath.repo_of_string (str "repository" |> with_default ".") |
||||
with |
||||
| Invalid_argument s -> failwith ("Invalid repository: " ^ s) |
||||
| Failure s -> failwith ("Missing repository value: " ^ s)); |
||||
title = str "title" |> with_default ""; |
||||
owner = str "owner" |> with_default ""; |
||||
email = str "email" |> with_default ""; |
||||
id = match Id.of_string (str "uuid" |> mandatory) with Some id -> id | None -> failwith "Invalid UUID in config"; |
||||
} |
||||
with Failure str -> Error str |
||||
|
||||
let validity config = |
||||
let repo = Lpath.fpath_of_repo config.repository in |
||||
let open Confix.Config.Validation in |
||||
empty |
||||
&> is_directory repo |
||||
end |
||||
|
||||
module AliasMap = Meta.AliasMap |
||||
|
||||
module Make (Store : Store.T) = struct |
||||
type t = { |
||||
config : Configuration.t; |
||||
store : Store.t; |
||||
} |
||||
|
||||
let note_lens note = note |
||||
let meta_lens note = note.Note.meta |
||||
|
||||
let recency_order a b = Meta.(Date.compare a.date b.date) |
||||
|
||||
let latest archive = |
||||
Store.to_list ~order:recency_order meta_lens archive.store |
||||
|
||||
let listed archive = |
||||
let notes = Store.to_list meta_lens archive.store in |
||||
List.filter Meta.(fun e -> CategorySet.listed e.categories) notes |
||||
|
||||
let published archive = |
||||
let notes = Store.to_list meta_lens archive.store in |
||||
List.filter Meta.(fun e -> CategorySet.published e.categories) notes |
||||
|
||||
let latest_listed archive = |
||||
let notes = Store.to_list ~order:recency_order meta_lens archive.store in |
||||
List.filter Meta.(fun e -> CategorySet.listed e.categories) notes |
||||
|
||||
let with_topic archive topic = |
||||
let notes = Store.to_list ~order:recency_order meta_lens archive.store in |
||||
List.filter Meta.(fun e -> StringSet.exists (fun t -> t = topic) e.topics) notes |
||||
|
||||
let topics archive = |
||||
let notes = Store.to_list meta_lens archive.store in |
||||
List.fold_left Meta.(fun a e -> unique_topics a e) Meta.StringSet.empty notes |
||||
|
||||
let latest_entry archive fragment = |
||||
let notes = Store.to_list ~order:recency_order meta_lens archive.store in |
||||
let containing_fragment e = Re.Str.(string_match (regexp fragment)) (e.Meta.title) 0 in |
||||
try Some (List.find containing_fragment notes) |
||||
with Not_found -> None |
||||
|
||||
let note_with_id archive id = Store.note_with_id archive.store id |
||||
let note_with_alias archive alias = Store.note_with_alias archive.store alias |
||||
|
||||
let with_note archive note = Store.with_note archive.store note |
||||
|
||||
let sublist ~from ~n list = |
||||
let aggregate_subrange (i, elms) e = succ i, if i >= from && i <= n then e::elms else elms in |
||||
List.fold_left aggregate_subrange (0, []) list |> snd |
||||
|
||||
end |
@ -0,0 +1,5 @@
|
||||
(library |
||||
((name logarion) |
||||
(public_name logarion) |
||||
(libraries (confix omd ptime lwt uuidm uri re.str emile)) |
||||
)) |
@ -0,0 +1,25 @@
|
||||
open Fpath |
||||
type repo_t = Repo of t |
||||
type note_t = Note of { repo: repo_t; basename: t } |
||||
|
||||
let fpath_of_repo = function Repo p -> p |
||||
let string_of_repo r = fpath_of_repo r |> to_string |
||||
let repo_of_string s = Repo (v s) |
||||
|
||||
let fpath_of_note = function Note n -> (fpath_of_repo n.repo // n.basename) |
||||
let string_of_note n = fpath_of_note n |> to_string |
||||
let note_of_basename repo s = Note { repo; basename = v s } |
||||
|
||||
let alias_of_note = function Note n -> n.basename |> rem_ext |> to_string |
||||
let note_of_alias repo extension alias = note_of_basename repo (alias ^ extension) |
||||
|
||||
let versioned_basename_of_title ?(version=0) repo extension (title : string) = |
||||
let notes_fpath = fpath_of_repo repo in |
||||
let basename = v @@ Meta.string_alias title in |
||||
let rec next version = |
||||
let candidate = basename |> add_ext (string_of_int version) |> add_ext extension in |
||||
if Sys.file_exists (to_string (notes_fpath // candidate)) |
||||
then next (succ version) |
||||
else note_of_basename repo (to_string candidate) |
||||
in |
||||
next version |
@ -0,0 +1,222 @@
|
||||
module Date = struct |
||||
type t = { |
||||
created: Ptime.t option; |
||||
published: Ptime.t option; |
||||
edited: Ptime.t option; |
||||
} [@@deriving lens { submodule = true }] |
||||
|
||||
let rfc_string date = match date with Some t -> Ptime.to_rfc3339 t | None -> "" |
||||
|
||||
let of_string (rfc : string) = match Ptime.of_rfc3339 rfc with |
||||
Ok (t,_,_) -> Some t | Error _ -> None |
||||
|
||||
let listing date = match date.published, date.created with |
||||
| Some _, _ -> date.published |
||||
| None, Some _ -> date.created |
||||
| None, None -> None |
||||
|
||||
let compare = compare |
||||
|
||||
let pretty_date = function |
||||
| Some t -> Ptime.to_date t |> fun (y, m, d) -> Printf.sprintf "%04d-%02d-%02d" y m d |
||||
| None -> "" |
||||
end |
||||
|
||||
module Id = struct |
||||
let random_state = Random.State.make_self_init () |
||||
type t = Uuidm.t |
||||
let compare = Uuidm.compare |
||||
let to_string = Uuidm.to_string |
||||
let of_string = Uuidm.of_string |
||||
let generate ?(random_state=random_state) = Uuidm.v4_gen random_state |
||||
end |
||||
|
||||
module Author = struct |
||||
type name_t = string |
||||
type address_t = Uri.t |
||||
type t = { |
||||
name: name_t; |
||||
address: address_t; |
||||
} [@@deriving lens { submodule = true } ] |
||||
|
||||
let empty = { name = ""; address = Uri.empty } |
||||
|
||||
let compare = Pervasives.compare |
||||
|
||||
end |
||||
|
||||
module AuthorSet = struct |
||||
include Set.Make(Author) |
||||
|
||||
let to_string authors = |
||||
let to_string a = a.Author.name ^ " <" ^ Uri.to_string a.Author.address ^ ">" in |
||||
let f elt acc = if String.length acc > 1 then acc ^ ", " ^ to_string elt else to_string elt in |
||||
fold f authors "" |
||||
|
||||
let of_string s = |
||||
match Emile.List.of_string s with |
||||
| Error _ -> prerr_endline @@ "Error parsing: " ^ s; empty |
||||
| Ok emails -> |
||||
let to_author = |
||||
let module L = List in |
||||
let open Emile in |
||||
function |
||||
| `Group _ -> prerr_endline @@ "Can't deal with groups in author: " ^ s; Author.empty |
||||
| `Mailbox { name; local; _ } -> |
||||
let s_of_phrase = function `Dot -> "" | `Word w -> (match w with `Atom a -> a | `String s -> s) | `Encoded _ -> "" in |
||||
let name = match name with None -> "" | Some phrase -> L.fold_left (fun a e -> a ^ s_of_phrase e) "" phrase in |
||||
let address = |
||||
L.fold_left (fun a e -> a ^ match e with `Atom a -> a | `String s -> s) "" local ^ "@" (* TODO: Author address unimplemented *) |
||||
in |
||||
Author.{ name; address = Uri.of_string address } |
||||
in |
||||
of_list @@ List.map to_author emails |
||||
end |
||||
|
||||
module Category = struct |
||||
type t = Draft | Unlisted | Published | Custom of string |
||||
|
||||
let compare = Pervasives.compare |
||||
|
||||
let of_string = function |
||||
| "draft" -> Draft |
||||
| "unlisted" -> Unlisted |
||||
| "published" -> Published |
||||
| c -> Custom c |
||||
|
||||
let to_string = function |
||||
| Draft -> "draft" |
||||
| Unlisted -> "unlisted" |
||||
| Published -> "published" |
||||
| Custom c -> c |
||||
end |
||||
|
||||
module CategorySet = struct |
||||
include Set.Make(Category) |
||||
let to_csv set = |
||||
let f elt a = |
||||
let s = Category.to_string elt in |
||||
if a <> "" then a ^ ", " ^ s else s |
||||
in |
||||
fold f set "" |
||||
let categorised categs cs = of_list categs |> (fun s -> subset s cs) |
||||
let published = categorised [Category.Published] |
||||
let listed cs = not @@ categorised [Category.Unlisted] cs |
||||
end |
||||
|
||||
module StringSet = Set.Make(String) |
||||
|
||||
let stringset_csv set = |
||||
let f elt a = if a <> "" then a ^ ", " ^ elt else elt in |
||||
StringSet.fold f set "" |
||||
|
||||
let string_alias t = |
||||
let is_reserved = function |
||||
| '!' | '*' | '\'' | '(' | ')' | ';' | ':' | '@' | '&' | '=' | '+' | '$' |
||||
| ',' | '/' | '?' | '#' | '[' | ']' | ' ' | '\t' | '\x00' -> true |
||||
| _ -> false |
||||
in |
||||
let b = Buffer.create (String.length t) in |
||||
let filter char = |
||||
let open Buffer in |
||||
if is_reserved char then (try (if nth b (pred (length b)) <> '-' then add_char b '-') with Invalid_argument _ -> prerr_endline "reserved") |
||||
else add_char b char |
||||
in |
||||
String.(iter filter (lowercase_ascii t)); |
||||
Buffer.contents b |
||||
|
||||
type t = { |
||||
title: string; |
||||
authors: AuthorSet.t; |
||||
date: Date.t; |
||||
categories: CategorySet.t; |
||||
topics: StringSet.t; |
||||
keywords: StringSet.t; |
||||
series: StringSet.t; |
||||
abstract: string; |
||||
uuid: Id.t; |
||||
alias: string; |
||||
} [@@deriving lens { submodule = true }] |
||||
|
||||
let blank ?(uuid=(Id.generate ())) () = { |
||||
title = ""; |
||||
authors = AuthorSet.empty; |
||||
date = Date.({ created = None; edited = None; published = None }); |
||||
categories = CategorySet.empty; |
||||
topics = StringSet.empty; |
||||
keywords = StringSet.empty; |
||||
series = StringSet.empty; |
||||
abstract = ""; |
||||
uuid; |
||||
alias = ""; |
||||
} |
||||
|
||||
let listed e = CategorySet.listed e.categories |
||||
let published e = CategorySet.published e.categories |
||||
let unique_topics ts x = StringSet.union ts x.topics |
||||
|
||||
module AliasMap = Map.Make(String) |
||||
module IdMap = Map.Make(Id) |
||||
|
||||
let alias meta = if meta.alias = "" then string_alias meta.title else meta.alias |
||||
|
||||
let value_with_name (_meta as m) = function |
||||
| "Title" -> m.title |
||||
| "Abstract" -> m.abstract |
||||
| "Authors" -> AuthorSet.to_string m.authors |
||||
| "Date" -> Date.(rfc_string m.date.created) |
||||
| "Edited" -> Date.(rfc_string m.date.edited) |
||||
| "Published"-> Date.(rfc_string m.date.published) |
||||
| "Human" -> Date.(pretty_date @@ listing m.date) |
||||
| "Topics" -> stringset_csv m.topics; |
||||
| "Categories" -> CategorySet.to_csv m.categories; |
||||
| "Keywords" -> stringset_csv m.keywords; |
||||
| "Series" -> stringset_csv m.series; |
||||
| "ID" -> Id.to_string m.uuid |
||||
| "Alias" -> alias m |
||||
| e -> invalid_arg e |
||||
|
||||
let with_kv meta (k,v) = |
||||
let list_of_csv = Re.Str.(split (regexp " *, *")) in |
||||
let trim = String.trim in |
||||
match k with |
||||
| "Title" -> { meta with title = trim v } |
||||
| "Author" |
||||
| "Authors" -> { meta with authors = AuthorSet.of_string (trim v)} |
||||
| "Abstract" -> { meta with abstract = trim v } |
||||
| "Date" -> { meta with date = Date.{ meta.date with created = Date.of_string v }} |
||||
| "Published" -> { meta with date = Date.{ meta.date with published = Date.of_string v }} |
||||
| "Edited" -> { meta with date = Date.{ meta.date with edited = Date.of_string v }} |
||||
| "Topics" -> { meta with topics = trim v |> list_of_csv |> StringSet.of_list } |
||||
| "Keywords" -> { meta with keywords = trim v |> list_of_csv |> StringSet.of_list } |
||||
| "Categories"-> |
||||
let categories = trim v |> list_of_csv |> List.map Category.of_string |> CategorySet.of_list in |
||||
{ meta with categories } |
||||
| "Series" -> { meta with series = trim v |> list_of_csv |> StringSet.of_list } |
||||
| "ID" -> (match Id.of_string v with Some id -> { meta with uuid = id } | None -> meta) |
||||
| "Alias" -> { meta with alias = v } |
||||
| k -> prerr_endline ("Unknown key: " ^ k ^ ", with value: " ^ v ); meta |
||||
|
||||
let to_string (_meta as m) = |
||||
let has_len v = String.length v > 0 in |
||||
let s field value = if has_len value then field ^ ": " ^ value ^ "\n" else "" in |
||||
let a value = if AuthorSet.is_empty value then "" else "Authors: " ^ AuthorSet.to_string value ^ "\n" in |
||||
let d field value = match value with |
||||
| Some _ -> field ^ ": " ^ Date.rfc_string value ^ "\n" | None -> "" |
||||
in |
||||
let rows = |
||||
[ s "Title" m.title; |
||||
a m.authors; |
||||
d "Date" m.date.Date.created; |
||||
d "Edited" m.date.Date.edited; |
||||
d "Published" m.date.Date.published; |
||||
s "Topics" (stringset_csv m.topics); |
||||
s "Categories" (CategorySet.to_csv m.categories); |
||||
s "Keywords" (stringset_csv m.keywords); |
||||
s "Series" (stringset_csv m.series); |
||||
s "Abstract" m.abstract; |
||||
s "ID" (Uuidm.to_string m.uuid); |
||||
s "Alias" m.alias |
||||
] |
||||
in |
||||
String.concat "" rows |
@ -0,0 +1,47 @@
|
||||
type t = { |
||||
meta: Meta.t; |
||||
body: string; |
||||
} [@@deriving lens { submodule = true }] |
||||
|
||||
let blank ?(uuid=(Meta.Id.generate ())) () = { meta = Meta.blank ~uuid (); body = "" } |
||||
|
||||
let title ymd = |
||||
let mtitle = ymd.meta.Meta.title in |
||||
if String.length mtitle > 0 then mtitle else |
||||
let open Omd in |
||||
try List.find (function H1 _ -> true | _ -> false) (Omd.of_string ymd.body) |
||||
|> function H1 h -> to_text h | _ -> "" |
||||
with Not_found -> "" |
||||
|
||||
let categorised categs ymd = Meta.CategorySet.categorised categs ymd.meta.Meta.categories |
||||
|
||||
let with_kv ymd (k,v) = match k with |
||||
| "body" -> { ymd with body = String.trim v } |
||||
| _ -> { ymd with meta = Meta.with_kv ymd.meta (k,v) } |
||||
|
||||
let meta_pair_of_string line = match Re.Str.(bounded_split (regexp ": *")) line 2 with |
||||
| [ key; value ] -> Re.Str.(replace_first (regexp "^#\\+") "" key), value |
||||
| [ key ] -> Re.Str.(replace_first (regexp "^#\\+") "" key), "" |
||||
| _ -> prerr_endline line; ("","") |
||||
|
||||
let meta_of_string front_matter = |
||||
let fields = List.map meta_pair_of_string (String.split_on_char '\n' front_matter) in |
||||
List.fold_left Meta.with_kv (Meta.blank ()) fields |
||||
|
||||
exception Syntax_error of string |
||||
|
||||
let front_matter_body_split s = |
||||
if Re.Str.(string_match (regexp ".*:.*")) s 0 |
||||
then match Re.Str.(bounded_split (regexp "\n\n")) s 2 with |
||||
| front::body::[] -> (front, body) |
||||
| _ -> ("", s) |
||||
else ("", s) |
||||
|
||||
let of_string s = |
||||
let (front_matter, body) = front_matter_body_split s in |
||||
try |
||||
let note = { meta = meta_of_string front_matter; body } in |
||||
{ note with meta = { note.meta with title = title note } } |
||||
with _ -> prerr_endline ("Failed parsing" ^ s); blank () |
||||
|
||||
let to_string ymd = Meta.to_string ymd.meta ^ "\n" ^ ymd.body |
@ -0,0 +1,7 @@
|
||||
module type T = sig |
||||
type t |
||||
val to_list: ?order:('a -> 'a -> int) -> (Note.t -> 'a) -> t -> 'a list |
||||
val note_with_id: t -> Meta.Id.t -> Note.t option |
||||
val note_with_alias: t -> string -> Note.t option |
||||
val with_note: t -> Note.t -> Note.t Lwt.t |
||||
end |