Draft
Basic unit renamed from Note to Text. New modular text-parser, internal to Logarion, for generic notation parsing. The default input format is now a much plainer text. Eliminated Meta module and generally lib/ modules. New Store interface, with additional information from Store. For example the converter can now check filesystem dates. Changed to filesystem hardlinks for tracking publications & indexing, instead of categories. New commands `publish [-i]` and `deindex [-u]`. Categories are ignored now. Logarion created texts have part of the UUID instead of a counter in their filename. New -i, --interactive flag for interactive creation & publication. Logarion's index re-written in Messagepack format. Removed `indices` command. They are generated during `convert`.
This commit is contained in:
orbifx
parent
3d92789cdb
commit
6c27c7c6fb
@ -1,83 +0,0 @@
|
||||
# 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/
|
||||
13
Makefile
13
Makefile
@ -1,18 +1,13 @@
|
||||
all: cli
|
||||
|
||||
cli:
|
||||
dune build src/logarion_cli.exe
|
||||
dune build app/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
|
||||
cp _build/default/app/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
|
||||
tar czvf "logarion-$(shell date -r _build/default/src/logarion_cli.exe "+%y-%m-%d")-$(shell uname -s)-$(shell uname -m)-$(shell git rev-parse --short HEAD).tar.gz" share logarion
|
||||
rm logarion
|
||||
|
||||
29
README
Normal file
29
README
Normal file
@ -0,0 +1,29 @@
|
||||
Logarion is a free and open-source text archive system. A blog-wiki hybrid.
|
||||
|
||||
Download: <https://logarion.orbitalfox.eu/downloads/>
|
||||
EUPL licence: <https://joinup.ec.europa.eu/software/page/eupl>
|
||||
|
||||
Start
|
||||
|
||||
Create a folder and run `logarion init` from within it to produce `.logarion/config` configuration file.
|
||||
Run `logarion --help` for more options.
|
||||
|
||||
Community & support
|
||||
|
||||
* Website: <https://logarion.orbitalfox.eu>
|
||||
* Report an issue: <mailto:logarion@lists.orbitalfox.eu?subject=Issue:>
|
||||
* Discussion: <https://lists.orbitalfox.eu/listinfo/logarion>
|
||||
or join via <mailto:logarion-join@lists.orbitalfox.eu>
|
||||
|
||||
|
||||
Install stable from source
|
||||
|
||||
opam add repo orbifx https://opam.orbitalfox.eu
|
||||
opam install logarion
|
||||
|
||||
|
||||
Install development version
|
||||
|
||||
opam pin add text git://orbitalfox.eu/text-parse-ml
|
||||
opam pin add logarion git://orbitalfox.eu/logarion
|
||||
opam install logarion
|
||||
50
README.md
50
README.md
@ -1,50 +0,0 @@
|
||||
# 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)
|
||||
37
app/atom.ml
Normal file
37
app/atom.ml
Normal file
@ -0,0 +1,37 @@
|
||||
let esc = Converter.Html.esc
|
||||
|
||||
let element tag content = "<" ^ tag ^ ">" ^ content ^ "</" ^ tag ^ ">"
|
||||
|
||||
let opt_element tag_name content =
|
||||
if content <> ""
|
||||
then element tag_name content
|
||||
else ""
|
||||
|
||||
module P = Parsers.Plain_text.Make (Converter.Html)
|
||||
|
||||
let entry base_url text =
|
||||
let open Logarion in
|
||||
let u = Text.alias text in
|
||||
let authors elt a =
|
||||
a ^ "<author>"
|
||||
^ (opt_element "name" @@ esc elt.Person.name)
|
||||
^ (List.fold_left (fun acc addr -> acc ^ element "uri" (Uri.to_string addr)) "" elt.Person.addresses)
|
||||
^ "</author>"
|
||||
in
|
||||
"<entry><title>" ^ esc text.title ^ "</title><id>urn:uuid:" ^ Id.to_string text.uuid ^ "</id><link rel=\"alternate\" href=\""
|
||||
^ base_url ^ "/" ^ u ^ ".html\" /><updated>"
|
||||
^ Date.(text.date |> listing |> rfc_string) ^ "</updated>"
|
||||
^ Person.Set.fold authors text.authors ""
|
||||
^ (opt_element "summary" @@ esc @@ Text.str "abstract" text)
|
||||
^ String_set.fold (fun elt a -> a ^ "<category term=\"" ^ elt ^ "\"/>") (Text.set "topics" text) ""
|
||||
^ "<content type=\"xhtml\"><div xmlns=\"http://www.w3.org/1999/xhtml\">"
|
||||
^ P.of_string text.body ""
|
||||
^ "</div></content></entry>"
|
||||
|
||||
let feed title archive_id base_url texts =
|
||||
{|<?xml version="1.0" encoding="utf-8"?><feed xmlns="http://www.w3.org/2005/Atom" xml:base="|} ^ base_url ^ {|"><title>|}
|
||||
^ title ^ {|</title><link rel="alternate" type="text/html" href="|}
|
||||
^ base_url ^ {|/"/><link rel="self" type="application/atom+xml" href="|}
|
||||
^ base_url ^ {|/feed.atom" /><id>urn:uuid:|} ^ Logarion.Id.to_string archive_id ^ "</id><updated>"
|
||||
^ Ptime.to_rfc3339 (Ptime_clock.now ()) ^ "</updated>"
|
||||
^ List.fold_left (fun acc t -> acc ^ entry base_url t) "" texts ^ "</feed>"
|
||||
80
app/convert.ml
Normal file
80
app/convert.ml
Normal file
@ -0,0 +1,80 @@
|
||||
let version = "%%VERSION%%"
|
||||
|
||||
open Logarion
|
||||
module A = Archive.Make (Logarion.File_store)
|
||||
|
||||
let file_when_changed source dest fn title text =
|
||||
if (try Unix.((stat dest).st_mtime < (stat source).st_mtime) with _-> true) then
|
||||
File_store.file dest (fn title text)
|
||||
|
||||
let writer dir name acc (text,store_item) = (* todo: single_parser -> [files] *)
|
||||
let open Logarion in
|
||||
match Text.(str "Content-Type" text) with
|
||||
| "" | "text/plain" ->
|
||||
let filename = dir ^ "/" ^ Text.alias text in
|
||||
let idfilename = dir ^ "/" ^ Id.to_string text.Text.uuid ^ ".txt" in
|
||||
file_when_changed store_item idfilename (fun _title -> Text.to_string) text.title text;
|
||||
file_when_changed store_item (filename ^ ".html") (Html.page "") name text;
|
||||
file_when_changed store_item (filename ^ ".gmi") Gemini.page name text;
|
||||
(acc + 1)
|
||||
| x -> prerr_endline ("No converter for Content-Type: " ^ x ^ ", for " ^ text.Text.title); acc
|
||||
|
||||
let index_pack archive indexed_texts =
|
||||
let persons ps = List.rev @@ Person.Set.fold (fun x a -> Msgpck.String (Person.to_string x) :: a) ps [] in
|
||||
let to_pack a t =
|
||||
let open Text in
|
||||
let of_set field t = List.rev @@ String_set.fold (fun x a -> Msgpck.String x :: a) (set field t) [] in
|
||||
Msgpck.(List [Bytes (Id.to_bytes t.uuid); String t.title; List (persons t.authors); List (of_set "topics" t); List (of_set "keywords" t)])
|
||||
:: a
|
||||
in
|
||||
let header_pack = Msgpck.List List.(fold_left to_pack [] indexed_texts) in
|
||||
let columns = Msgpck.(List [String "id"; String "title"; String "authors"; String "topics"; String "keywords"]) in
|
||||
let archive = Msgpck.(List [Int 0; String archive.A.name; List (persons archive.A.archivists)]) in
|
||||
Bytes.to_string @@ Msgpck.Bytes.to_string (List [archive; columns; header_pack])
|
||||
|
||||
let index_writer dir archive topic_roots topic_map indexed_texts =
|
||||
let name = archive.A.name in
|
||||
let file path = File_store.file (dir ^ path) in
|
||||
file "/index.pck" (index_pack archive indexed_texts);
|
||||
file "/index.html" (Html.topic_main_index name topic_roots indexed_texts);
|
||||
List.iter
|
||||
(fun topic -> file ("/index." ^ topic ^ ".htm") (Html.topic_sub_index name topic_map topic indexed_texts))
|
||||
topic_roots;
|
||||
file "/index.date.html" (Html.date_index name indexed_texts);
|
||||
let base_url = try Store.KV.find "HTTP-URL" archive.File_store.kv
|
||||
with Not_found -> prerr_endline "Missing `HTTP-URL:` in config"; ""
|
||||
in
|
||||
file "/feed.atom" (Atom.feed archive.A.name archive.A.id base_url indexed_texts);
|
||||
file "/index.date.gmi" (Gemini.date_index name indexed_texts)
|
||||
|
||||
let convert_all dir archive =
|
||||
let name = archive.A.name in
|
||||
let published_count = A.(fold ~order:newest (writer dir name) 0 (published archive)) in
|
||||
let topic_map, indexed_metas =
|
||||
let topic_map = Logarion.Topic_set.Map.empty in
|
||||
let fn (ts,ls) (elt,_) = Logarion.(Topic_set.to_map ts (Text.set "topics" elt)), elt::ls in
|
||||
A.(fold ~order:newest fn (topic_map,[]) (indexed archive)) in
|
||||
let topic_roots = Logarion.Topic_set.roots topic_map in
|
||||
index_writer dir archive topic_roots topic_map indexed_metas;
|
||||
print_endline @@ "Converted: " ^ string_of_int (published_count) ^ "\nIndexed: " ^ string_of_int (List.length indexed_metas);
|
||||
Ok ()
|
||||
|
||||
let convert_dir cmd_dir =
|
||||
let (>>=) = Result.bind in
|
||||
let config_dir archive = try Ok (Store.KV.find "Export-Dir" archive.File_store.kv) with Not_found -> Error "unspecified export dir" in
|
||||
let init dir =
|
||||
Result.map_error (function `Msg m -> m) Logarion.File_store.Directory.(directory dir |> print ~descr:"export" dir) in
|
||||
(A.of_path "."
|
||||
>>= fun archive -> (match cmd_dir with "" -> config_dir archive | x -> Ok x)
|
||||
>>= fun dir -> init dir
|
||||
>>= fun _ -> convert_all dir archive)
|
||||
|> function Ok () -> () | Error x -> prerr_endline x
|
||||
|
||||
open Cmdliner
|
||||
|
||||
let term =
|
||||
let directory = Arg.(value & pos 0 string "" & info [] ~docv:"target directory" ~doc:"Directory to convert into") in
|
||||
Term.(const convert_dir $ directory),
|
||||
Term.info
|
||||
"convert" ~doc:"convert archive"
|
||||
~man:[ `S "DESCRIPTION"; `P "Convert Logarion archive" ]
|
||||
5
app/dune
Normal file
5
app/dune
Normal file
@ -0,0 +1,5 @@
|
||||
(executable
|
||||
(name logarion_cli)
|
||||
(public_name logarion)
|
||||
(modules logarion_cli convert html atom gemini)
|
||||
(libraries logarion re.str cmdliner bos ptime ptime.clock.os text_parse.converter text_parse.parsers msgpck))
|
||||
14
app/gemini.ml
Normal file
14
app/gemini.ml
Normal file
@ -0,0 +1,14 @@
|
||||
let page _archive_title text =
|
||||
let open Logarion.Text in
|
||||
"# " ^ text.title
|
||||
^ "\nAuthors: " ^ Logarion.Person.Set.to_string text.authors
|
||||
^ "\nDated: " ^ Logarion.Date.(pretty_date @@ listing text.date)
|
||||
^ let module T = Parsers.Plain_text.Make (Converter.Gemini) in
|
||||
"\n" ^ T.of_string text.body ""
|
||||
|
||||
let date_index title meta_list =
|
||||
List.fold_left
|
||||
(fun a m ->
|
||||
a ^ "=> " ^ Logarion.Text.alias m ^ ".gmi " ^
|
||||
Logarion.(Date.(pretty_date (listing m.date)) ^ " " ^ m.title) ^ "\n")
|
||||
("# " ^ title ^ "\n") meta_list
|
||||
117
app/html.ml
Normal file
117
app/html.ml
Normal file
@ -0,0 +1,117 @@
|
||||
let wrap ?(keywords="") (title:string) (subtitle:string) body =
|
||||
{|<!DOCTYPE html><html xmlns="http://www.w3.org/1999/xhtml"><head><title>|}
|
||||
^ subtitle ^ " | " ^ title
|
||||
^ {|</title><link rel="stylesheet" href="main.css" media/><link rel="alternate" href="feed.atom" type="application/atom+xml"/><meta charset="utf-8"/> <meta name="keywords" content="|}
|
||||
^ keywords ^ {|"></head><body><header><h1><a href=".">|} ^ title
|
||||
^ "</a></h1></header>" ^ body
|
||||
^ {|<footer><a href="feed.atom" id="feed">Subscribe to feed 📰</a></footer></body></html>|}
|
||||
|
||||
let topic_link root topic =
|
||||
{|<a href="index.|} ^ root ^ {|.htm#|} ^ topic ^ {|">|} ^ String.capitalize_ascii topic ^ "</a>"
|
||||
|
||||
let page _topic_roots archive_title text =
|
||||
let open Logarion in
|
||||
let open Text in
|
||||
let module T = Parsers.Plain_text.Make (Converter.Html) in
|
||||
let sep_append ?(sep=", ") a x = match a,x with "",_ -> x | _, "" -> a | _ -> a ^ sep ^ x in
|
||||
let opt_kv key value = if String.length value > 0 then "<dt>" ^ key ^ "<dd>" ^ value else "" in
|
||||
(* let author acc auth = sep_append acc Person.(auth.name ^ " ") in*)
|
||||
let authors = T.of_string (Person.Set.to_string text.authors ^ " ") "" in
|
||||
let keywords = str_set "keywords" text in
|
||||
let header =
|
||||
let time x = {|<time datetime="|} ^ x ^ {|">|} ^ x ^ "</time>" in
|
||||
let topic_links x =
|
||||
let to_linked t a =
|
||||
let ts = Topic_set.of_string t in
|
||||
sep_append a (List.fold_left (fun a t -> sep_append ~sep:" > " a (topic_link (List.hd ts) t)) "" ts) in
|
||||
String_set.fold to_linked x "" in
|
||||
"<article><header><dl>"
|
||||
^ opt_kv "Title:" text.title
|
||||
^ opt_kv "Authors:" authors
|
||||
^ opt_kv "Date: " (time (Date.(pretty_date @@ listing text.date)))
|
||||
^ opt_kv "Series: " (str_set "series" text)
|
||||
^ opt_kv "Topics: " (topic_links (set "topics" text))
|
||||
^ opt_kv "Keywords: " keywords
|
||||
^ opt_kv "Id: " (Id.to_string text.uuid)
|
||||
^ {|</dl></header><pre style="white-space:pre-wrap">|} in
|
||||
wrap ~keywords archive_title text.title ((T.of_string text.body header) ^ "</pre></article>")
|
||||
|
||||
let to_dated_links ?(limit) meta_list =
|
||||
let meta_list = match limit with
|
||||
| None -> meta_list
|
||||
| Some limit->
|
||||
let rec reduced acc i = function
|
||||
| [] -> acc
|
||||
| h::t -> if i < limit then reduced (h::acc) (i+1) t else acc in
|
||||
List.rev @@ reduced [] 0 meta_list
|
||||
in
|
||||
List.fold_left
|
||||
(fun a m ->
|
||||
a ^ Logarion.(Date.(pretty_date (listing m.Text.date)) ^ " ")
|
||||
^ {|<a href="|} ^ Logarion.Text.alias m ^ {|.html">|} ^ m.Logarion.Text.title ^ "</a><br/>")
|
||||
"" meta_list
|
||||
|
||||
let date_index ?(limit) title meta_list =
|
||||
match limit with
|
||||
| Some limit -> wrap title "Index" (to_dated_links ~limit meta_list)
|
||||
| None -> wrap title "Index" (to_dated_links meta_list)
|
||||
|
||||
let fold_topic_roots topic_roots =
|
||||
let list_item root t = "<li>" ^ topic_link root t in
|
||||
"<nav><h2>Main topics</h2>"
|
||||
^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
|
||||
^ "</ul></nav>"
|
||||
|
||||
let fold_topics topic_map topic_roots metas =
|
||||
let open Logarion in
|
||||
let rec unordered_list root topic =
|
||||
List.fold_left (fun a x -> a ^ list_item root x) "<ul>" topic ^ "</ul>"
|
||||
and sub_items root topic = match Topic_set.Map.find_opt topic topic_map with
|
||||
| None -> ""
|
||||
| Some (_, subtopics) -> unordered_list root (String_set.elements subtopics)
|
||||
and list_item root t =
|
||||
let item =
|
||||
if List.exists (fun x -> String_set.mem t (String_set.map Topic_set.topic (Text.set "topics" x))) metas
|
||||
then topic_link root t else t
|
||||
in
|
||||
"<li>" ^ item ^ sub_items root t
|
||||
in
|
||||
"<nav><h2>Topics</h2>"
|
||||
^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
|
||||
^ "</ul></nav>"
|
||||
|
||||
let text_item path meta =
|
||||
let open Logarion in
|
||||
{|<tr><td><a href="|} ^ path ^ Text.alias meta ^ {|.html">|} ^ meta.Text.title
|
||||
^ "</a><td><time>" ^ Date.(pretty_date (listing meta.Text.date)) ^ "</time>"
|
||||
|
||||
let listing_index topic_map topic_roots path metas =
|
||||
let rec item_group topics =
|
||||
List.fold_left (fun acc topic -> acc ^ sub_groups topic ^ "<tbody>" ^ items topic) "" topics
|
||||
and sub_groups topic = match Logarion.Topic_set.Map.find_opt topic topic_map with
|
||||
| None -> ""
|
||||
| Some (_, subtopics) -> item_group (Logarion.String_set.elements subtopics)
|
||||
and items topic =
|
||||
let items =
|
||||
let open Logarion in
|
||||
List.fold_left
|
||||
(fun a e ->
|
||||
if String_set.mem topic (String_set.map (Logarion.Topic_set.topic) (Text.set "Topics" e))
|
||||
then text_item path e ^ a else a) "" metas in
|
||||
match items with
|
||||
| "" -> ""
|
||||
| x -> {|<tr id="|} ^ topic ^ {|"><th colspan="3">|} ^ topic ^ "</th></tr>" ^ x
|
||||
in
|
||||
"<nav><h2>Texts</h2><table>" ^ item_group topic_roots ^ "</table></nav>"
|
||||
|
||||
let topic_main_index title topic_roots metas =
|
||||
wrap title "Topics"
|
||||
(fold_topic_roots topic_roots
|
||||
^ "<nav><h2>Recent</h2>" ^ to_dated_links ~limit:5 metas
|
||||
^ {|<br/><a href="index.date.html">More by date</a></nav>|} )
|
||||
|
||||
let topic_sub_index title topic_map topic_root metas =
|
||||
wrap title topic_root
|
||||
(fold_topics topic_map [topic_root] metas
|
||||
^ {|<a href="feed.atom" id="feed">Subscribe to |}^ topic_root ^{| feed 📰</a>|}
|
||||
^ listing_index topic_map [topic_root] "" metas)
|
||||
111
app/logarion_cli.ml
Normal file
111
app/logarion_cli.ml
Normal file
@ -0,0 +1,111 @@
|
||||
let version = "%%VERSION%%"
|
||||
|
||||
open Cmdliner
|
||||
open Logarion
|
||||
module A = Logarion.Archive.Make(File_store)
|
||||
|
||||
(* TODO: merge in lib/ so other modules can use (.e.g HTTP pull) *)
|
||||
let text_list field_opt authors_opt keywords_opt topics_opt =
|
||||
match A.of_path "." with
|
||||
| Error msg -> prerr_endline msg
|
||||
| Ok archive ->
|
||||
let predicates =
|
||||
A.predicate A.authored authors_opt
|
||||
@ A.predicate A.keyworded keywords_opt
|
||||
@ A.predicate A.topics topics_opt
|
||||
in
|
||||
let predicate text = List.fold_left (fun a e -> a && e text) true predicates in
|
||||
let order = A.newest in
|
||||
let print_fold ~predicate fn =
|
||||
let ts = A.fold ~predicate ~order fn String_set.empty archive in
|
||||
String_set.iter (print_endline) ts
|
||||
in
|
||||
match field_opt with
|
||||
| None -> A.iter ~predicate ~order (fun (n,_) -> print_endline n.Text.title) archive
|
||||
| Some "keywords"-> print_fold ~predicate (fun a (e,_) -> (String_set.union a (Text.set "keywords" e)))
|
||||
| Some "topics" -> print_fold ~predicate (fun a (e,_) -> (String_set.union a (Text.set "topics" e)))
|
||||
| Some "authors" ->
|
||||
let s = A.fold ~predicate ~order (fun a (e,_) -> Person.Set.union a e.Text.authors) Person.Set.empty archive in
|
||||
print_endline @@ Person.Set.to_string s
|
||||
| Some x -> prerr_endline @@ "Unrecognised field: " ^ x
|
||||
|
||||
let list_term =
|
||||
let field = Arg.(value & opt (some string) None & info ["f"; "field"] ~docv:"FIELD" ~doc:"what to list") in
|
||||
let authors = Arg.(value & opt (some string) None & info ["a"; "authors"] ~docv:"AUTHORS" ~doc:"texts with authors") in
|
||||
let keywords= Arg.(value & opt (some string) None & info ["k"; "keywords"] ~docv:"KEYWORDS" ~doc:"texts with keywords") in
|
||||
let topics = Arg.(value & opt (some string) None & info ["t"; "topics"] ~docv:"TOPICS" ~doc:"texts with topics") in
|
||||
Term.(const text_list $ field $ authors $ keywords $ topics),
|
||||
Term.info "list" ~doc:"list texts" ~man:[ `S "DESCRIPTION"; `P "List texts in Logarion archive" ]
|
||||
|
||||
let publish and_index files = match A.of_path "." with
|
||||
| Error msg -> prerr_endline msg
|
||||
| Ok archive -> File_store.(list_iter (if and_index then index else publish) archive files)
|
||||
|
||||
let publish_term =
|
||||
let files = Arg.(value & pos_all string [] & info [] ~doc:"filenames") in
|
||||
let index = Arg.(value & flag & info ["i"; "index"] ~doc:"Also index") in
|
||||
let doc = "publish notes; it will become available in exports and for distribution" in
|
||||
let man = [ `S "DESCRIPTION"; `P doc ] in
|
||||
Term.(const publish $ index $ files), Term.info "publish" ~doc ~man
|
||||
|
||||
let deindex and_unpub files = match A.of_path "." with
|
||||
| Error msg -> prerr_endline msg
|
||||
| Ok archive -> File_store.(list_iter (if and_unpub then unpublish else deindex) archive files)
|
||||
|
||||
let deindex_term =
|
||||
let files = Arg.(value & pos_all string [] & info [] ~doc:"filenames") in
|
||||
let unpub = Arg.(value & flag & info ["u"; "unpublish"] ~doc:"Also unpublish") in
|
||||
let doc = "deindex; it will disappear from indices" in
|
||||
let man = [ `S "DESCRIPTION"; `P doc ] in
|
||||
Term.(const deindex $ unpub $ files), Term.info "deindex" ~doc ~man
|
||||
|
||||
let init _force = File_store.init ()
|
||||
|
||||
let init_term =
|
||||
let force = Arg.(value & flag & info ["f"; "force"] ~doc:"Initialise even if directory is not empty") in
|
||||
let doc = "initialise a logarion repository in present directory" in
|
||||
let man = [ `S "DESCRIPTION"; `P "Create a repository in current directory" ] in
|
||||
Term.(const init $ force), Term.info "init" ~doc ~man
|
||||
|
||||
let create_term =
|
||||
let f title topics_opt interactive =
|
||||
match A.of_path "." with
|
||||
| Error m -> prerr_endline m
|
||||
| Ok archive ->
|
||||
let t = match title with "" -> "Draft" | _ -> title in
|
||||
let authors = archive.archivists in
|
||||
let date = Date.({ created = Some (Ptime_clock.now ()); edited = None }) in
|
||||
let text = { (Text.blank ()) with title = t; authors; date } in
|
||||
let text = try Text.with_str_set text "Topics" (Option.get topics_opt) with _ -> text in
|
||||
match File_store.with_text archive text with
|
||||
| Error s -> prerr_endline s
|
||||
| Ok (filepath, _note) ->
|
||||
match interactive with false -> print_endline filepath
|
||||
| true ->
|
||||
print_endline @@ "Created: " ^ filepath;
|
||||
let rec yn () = match read_line () with "y" -> true | "n" -> false
|
||||
| _ -> print_string "y or n? "; flush stdout; yn () in
|
||||
let _code = Sys.command ("$EDITOR " ^ filepath) in
|
||||
print_string "Publish? [yn]: ";
|
||||
match yn () with false -> ()
|
||||
| true ->
|
||||
print_string "Index? [yn]: ";
|
||||
let and_index = yn () in
|
||||
File_store.(list_iter (if and_index then index else publish) archive [filepath])
|
||||
in
|
||||
let title = Arg.(value & pos 0 string "" & info [] ~docv:"TITLE" ~doc:"Title for new article") in
|
||||
let topics= Arg.(value & opt (some string) None & info ["t"; "topics"] ~docv:"TOPICS" ~doc:"Topics for new article") in
|
||||
let inter = Arg.(value & flag & info ["i"; "interactive"] ~doc:"Prompts through the steps of creation and publication") in
|
||||
let man = [ `S "DESCRIPTION"; `P "Create a new article, with title 'Draft' when none provided"] in
|
||||
Term.(const f $ title $ topics $ inter), Term.info "create" ~doc:"create a new article" ~man
|
||||
|
||||
let default_cmd =
|
||||
let doc = "text archival & publishing" in
|
||||
let man = [ `S "BUGS"; `P "Submit bugs <mailto:logarion@lists.orbitalfox.eu?subject=[Issue] summary-here>" ] in
|
||||
Term.(ret (const (`Help (`Pager, None)))), Term.info "logarion" ~version ~doc ~man
|
||||
|
||||
let cmds = [ init_term; create_term; publish_term; deindex_term; list_term; Convert.term ]
|
||||
|
||||
let () =
|
||||
Random.self_init();
|
||||
match Term.eval_choice default_cmd cmds with `Error _ -> exit 1 | _ -> exit 0
|
||||
@ -1,3 +0,0 @@
|
||||
Logarion
|
||||
Ymd
|
||||
Web
|
||||
16
dune-project
Normal file
16
dune-project
Normal file
@ -0,0 +1,16 @@
|
||||
(lang dune 2.0)
|
||||
(name logarion)
|
||||
(homepage "https://logarion.orbitalfox.eu")
|
||||
|
||||
(source (uri git://orbitalfox.eu/logarion))
|
||||
(license EUPL)
|
||||
(authors "orbifx")
|
||||
(maintainers "fox@orbitalfox.eu")
|
||||
(bug_reports "mailto:logarion@lists.orbitalfox.eu?subject=Issue:")
|
||||
|
||||
(generate_opam_files true)
|
||||
|
||||
(package
|
||||
(name logarion)
|
||||
(synopsis "A texts system")
|
||||
(depends re cmdliner bos ptime uuidm uri text_parse msgpck))
|
||||
33
lib/archive.ml
Normal file
33
lib/archive.ml
Normal file
@ -0,0 +1,33 @@
|
||||
(*let module S = Set.Make (Text) in*)
|
||||
(*let module M = Map.Make (String) in*)
|
||||
(*let module I = Map.Make (Id) in*)
|
||||
(*let aggr = I.empty, M.empty, M.empty, M.empty in*)
|
||||
(*let fn (id, a, t, k) (n,_) =*)
|
||||
(* let id = I.add n.Text.uuid n id in*)
|
||||
(* let a =*)
|
||||
(* let f e a = M.update (e.Person.name) (function Some v -> Some (S.add n v) | None -> Some (S.singleton n)) a in*)
|
||||
(* Person.Set.fold f n.Text.authors a in*)
|
||||
(* let t =*)
|
||||
(* let f e a = M.update e (function Some v -> Some (S.add n v) | None -> Some (S.singleton n)) a in*)
|
||||
(* String_set.fold f (Text.set "Topics" n) t in*)
|
||||
(* let k =*)
|
||||
(* let f e a = M.update e (function Some v -> Some (S.add n v) | None -> Some (S.singleton n)) a in*)
|
||||
(* String_set.fold f (Text.set "Keywords" n) k in*)
|
||||
(* (id, a, t, k)*)
|
||||
|
||||
module Make (Store : Store.T) = struct
|
||||
include Store
|
||||
let predicate fn opt = Option.(to_list @@ map fn opt)
|
||||
|
||||
let authored query_string =
|
||||
let q = Person.Set.of_query @@ String_set.query query_string in
|
||||
fun n -> Person.Set.predicate q n.Text.authors
|
||||
|
||||
let keyworded query_string =
|
||||
let q = String_set.query query_string in
|
||||
fun n -> String_set.(predicate q (Text.set "Keywords" n))
|
||||
|
||||
let topics query_string =
|
||||
let q = String_set.query query_string in
|
||||
fun n -> String_set.(predicate q (Text.set "Topics" n))
|
||||
end
|
||||
22
lib/category.ml
Normal file
22
lib/category.ml
Normal file
@ -0,0 +1,22 @@
|
||||
module Category = struct
|
||||
type t = Unlisted | Published | Invalid | Custom of string
|
||||
let compare = Stdlib.compare
|
||||
let of_string = function "unlisted" | "published" -> Invalid | c -> Custom c
|
||||
let to_string = function Custom c -> c | _ -> ""
|
||||
end
|
||||
|
||||
include Category
|
||||
|
||||
module CategorySet = struct
|
||||
include Set.Make (Category)
|
||||
let of_stringset s = String_set.fold (fun e a -> add (Category.of_string e) a) s empty
|
||||
let of_query q = of_stringset (fst q), of_stringset (snd q)
|
||||
let predicate (inc, exl) set = not (disjoint inc set) && disjoint exl set
|
||||
let of_string x = of_stringset (String_set.of_string x)
|
||||
let to_string set =
|
||||
let f elt a =
|
||||
let s = Category.to_string elt in
|
||||
if a <> "" then a ^ ", " ^ s else s
|
||||
in
|
||||
fold f set ""
|
||||
end
|
||||
8
lib/date.ml
Normal file
8
lib/date.ml
Normal file
@ -0,0 +1,8 @@
|
||||
type t = { created: Ptime.t option; edited: Ptime.t option }
|
||||
let compare = compare
|
||||
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 = if Option.is_some date.edited then date.edited else date.created
|
||||
let pretty_date = function
|
||||
| Some t -> Ptime.to_date t |> fun (y, m, d) -> Printf.sprintf "%04d-%02d-%02d" y m d
|
||||
| None -> ""
|
||||
4
lib/dune
Normal file
4
lib/dune
Normal file
@ -0,0 +1,4 @@
|
||||
(library
|
||||
(name logarion)
|
||||
(public_name logarion)
|
||||
(libraries ptime uuidm uri re.str bos text_parse text_parse.parsers))
|
||||
183
lib/file_store.ml
Normal file
183
lib/file_store.ml
Normal file
@ -0,0 +1,183 @@
|
||||
type t = string
|
||||
type item_t = string
|
||||
type archive_t = { name: string; archivists: Person.Set.t; id: Id.t;
|
||||
kv: string Store.KV.t; store: t }
|
||||
type record_t = Text.t * item_t
|
||||
|
||||
let extensions = [ ".txt"; ".gmi"; ".md"; ".org" ]
|
||||
let pubdir = "/.logarion/published/"
|
||||
let idxdir = "/.logarion/indexed/"
|
||||
|
||||
let to_string f =
|
||||
let ic = open_in f in
|
||||
let n = in_channel_length ic in
|
||||
let s = Bytes.create n in
|
||||
really_input ic s 0 n;
|
||||
close_in ic;
|
||||
Bytes.to_string s
|
||||
|
||||
let (//) a b = a ^ "/" ^ b
|
||||
|
||||
let to_text dir filename = let f = dir // filename in
|
||||
to_string f |> Text.of_string |> Result.map_error (fun m -> f^": "^m)
|
||||
let text_filetype dir name =
|
||||
try Fpath.(let v = v name in mem_ext extensions v || (not (exists_ext v) && not (Sys.is_directory @@ dir^"/"^name)))
|
||||
with Invalid_argument str -> prerr_endline ("file: " ^ name ^ " invalid (" ^ str ^ ")"); false
|
||||
|
||||
let clean_unlinked dir filepath =
|
||||
let file = dir ^ filepath in
|
||||
match (Unix.lstat file).st_nlink with 1 -> Unix.unlink file | _ -> ()
|
||||
| exception Unix.Unix_error(Unix.ENOENT,_,_) -> ()
|
||||
|
||||
let purged_substore archive subdir =
|
||||
let store = archive.store ^ subdir in
|
||||
Array.iter (clean_unlinked store) @@ Sys.readdir store;
|
||||
{ archive with store }
|
||||
|
||||
let published archive = purged_substore archive pubdir
|
||||
let indexed archive = purged_substore archive idxdir
|
||||
|
||||
let publish dir text file =
|
||||
try Unix.link file (dir ^ pubdir ^ Id.to_string text.Text.uuid)
|
||||
with Unix.Unix_error(Unix.EEXIST,_,_) -> ()
|
||||
let deindex dir text _file =
|
||||
try Unix.unlink (dir ^ idxdir ^ Id.to_string text.Text.uuid)
|
||||
with Unix.Unix_error(Unix.ENOENT,_,_) -> ()
|
||||
let unpublish dir text file =
|
||||
deindex dir text file;
|
||||
try Unix.unlink (dir ^ pubdir ^ Id.to_string text.Text.uuid)
|
||||
with Unix.Unix_error(Unix.ENOENT,_,_) -> ()
|
||||
let index dir text file =
|
||||
publish dir text file;
|
||||
try Unix.link file (dir ^ idxdir ^ Id.to_string text.Text.uuid)
|
||||
with Unix.Unix_error(Unix.EEXIST,_,_) -> ()
|
||||
|
||||
let newest (a,_pa) (b,_pb) = Text.newest a b
|
||||
let oldest (a,_pa) (b,_pb) = Text.oldest a b
|
||||
|
||||
let list_iter fn {store;_} paths =
|
||||
let link f = match to_text store f with Ok t -> fn store t f | Error s -> prerr_endline s in
|
||||
List.iter link paths
|
||||
|
||||
let iter_valid_text dir pred fn p =
|
||||
if text_filetype dir p then
|
||||
match to_text dir p with Error x -> prerr_endline x | Ok t -> if pred t then fn (t, dir^p)
|
||||
|
||||
let fold_valid_text dir pred fn acc p =
|
||||
if not (text_filetype dir p) then acc else
|
||||
match to_text dir p with
|
||||
Error x -> prerr_endline x; acc | Ok t -> if pred t then fn acc (t, dir^p) else acc
|
||||
|
||||
let iter ?(predicate=fun _ -> true) ?order fn {store;_} =
|
||||
match order with
|
||||
| None -> Array.iter (iter_valid_text store predicate fn) @@ Sys.readdir store
|
||||
| Some comp ->
|
||||
List.iter fn @@ List.fast_sort comp
|
||||
@@ Array.fold_left (fold_valid_text store predicate (fun a e -> List.cons e a)) []
|
||||
@@ Sys.readdir store
|
||||
|
||||
let fold ?(predicate=fun _ -> true) ?order fn acc {store;_} =
|
||||
match order with
|
||||
| None -> Array.fold_left (fold_valid_text store predicate fn) acc @@ Sys.readdir store
|
||||
| Some comp ->
|
||||
List.fold_left fn acc @@ List.fast_sort comp
|
||||
@@ Array.fold_left (fold_valid_text store predicate (fun a e -> List.cons e a)) []
|
||||
@@ Sys.readdir store
|
||||
|
||||
let with_id { store; _ } id =
|
||||
let matched acc path =
|
||||
if not (text_filetype store path) then acc
|
||||
else
|
||||
match to_text store path with
|
||||
| Error x -> prerr_endline x; acc
|
||||
| Ok text ->
|
||||
if text.Text.uuid <> id then acc
|
||||
else
|
||||
match acc with
|
||||
| Ok None -> Ok (Some text)
|
||||
| Ok (Some prev) -> if prev = text then acc else Error [text; prev]
|
||||
| Error x -> Error (text :: x)
|
||||
in
|
||||
Array.fold_left matched (Ok None) @@ Sys.readdir store
|
||||
|
||||
module Directory = struct
|
||||
let print ?(descr="") dir result =
|
||||
let () = match result with
|
||||
| Ok true -> print_endline ("Created " ^ descr ^ " directory " ^ dir)
|
||||
| Ok false -> print_endline ("Using existing " ^ descr ^ " directory " ^ dir)
|
||||
| Error (`Msg msg) -> prerr_endline @@ "Failed making " ^ descr ^ ". " ^ msg
|
||||
in
|
||||
result
|
||||
|
||||
let directory dir = Result.bind (Fpath.of_string dir) Bos.OS.Dir.create
|
||||
|
||||
let rec directories = function
|
||||
| [] -> Ok ()
|
||||
| (d, descr)::tl ->
|
||||
match directory d |> print ~descr d with
|
||||
| Ok _ -> directories tl
|
||||
| Error _ -> Error (d, descr)
|
||||
end
|
||||
|
||||
let copy ?(recursive = false) src dst =
|
||||
Bos.OS.Cmd.run (Bos.Cmd.(v "cp" %% (on recursive @@ v "-r") % src % dst))
|
||||
|
||||
let versioned_basename_of_title ?(version=0) repo extension (title : string) =
|
||||
let basename = Text.string_alias title in
|
||||
let rec next version =
|
||||
let candidate = repo // basename ^ "." ^ string_of_int version ^ extension in
|
||||
if Sys.file_exists candidate then next (succ version) else candidate
|
||||
in
|
||||
next version
|
||||
|
||||
let uuid_filename repo extension text =
|
||||
let basename = Text.alias text in
|
||||
let candidate = repo // String.sub (Id.to_string text.uuid) 0 6 ^ "." ^ basename ^ extension in
|
||||
if Sys.file_exists candidate then Error "Name clash, try again" else Ok candidate
|
||||
|
||||
let file path content = let out = open_out path in output_string out content; close_out out
|
||||
|
||||
let with_text {store;_} new_text =
|
||||
let extension = List.hd extensions in
|
||||
Result.bind (uuid_filename store extension new_text) @@
|
||||
fun path ->
|
||||
try file path (Text.to_string new_text); Ok (path, new_text) with Sys_error s -> Error s
|
||||
|
||||
let basic_toml_bytes =
|
||||
"Archive-Name: "
|
||||
^ "\nArchive-ID: " ^ Id.(generate () |> to_string)
|
||||
^ "\nArchivists: " ^ Bos.OS.Env.opt_var "USER" ~absent:""
|
||||
|> Bytes.of_string
|
||||
|
||||
let init ?(dotdir=".logarion/") () =
|
||||
match Directory.directories [dotdir, "dotdir"; dotdir//"published", "linkdir"; dotdir//"indexed", "link dir"] with
|
||||
| Error (_dir, _desc) -> ()
|
||||
| Ok () ->
|
||||
let config_file =
|
||||
open_out_gen [Open_creat; Open_excl; Open_wronly]
|
||||
0o700 (dotdir // "config") in
|
||||
output_bytes config_file basic_toml_bytes;
|
||||
close_out config_file
|
||||
|
||||
module Config = struct
|
||||
type t = archive_t
|
||||
let key_value k v a = match k with
|
||||
| "Archive-Name" -> { a with name = String.trim v }
|
||||
| "Archive-ID" -> { a with id = Option.get (Id.of_string (String.trim v)) }
|
||||
| "Archivists" -> { a with archivists = Person.Set.of_string v }
|
||||
| _ -> { a with kv = Store.KV.add k (String.trim v) a.kv }
|
||||
end
|
||||
|
||||
let of_path store =
|
||||
let open Text_parse in
|
||||
let subsyntaxes = [| (module Parsers.Key_value.Make (Config) : Parser.S with type t = Config.t); (module Parsers.Key_value.Make (Config)); |] in
|
||||
let of_string text acc = Parser.parse subsyntaxes { text; pos = 0; right_boundary = String.length text - 1 } acc in
|
||||
Ok (of_string (to_string @@ store ^ "/.logarion/config")
|
||||
{
|
||||
name = "";
|
||||
archivists = Person.Set.empty;
|
||||
id = Id.nil;
|
||||
kv = Store.KV.empty;
|
||||
store = Bos.OS.Env.opt_var "LOGARION_DIR" ~absent:"."
|
||||
}
|
||||
)
|
||||
9
lib/id.ml
Normal file
9
lib/id.ml
Normal file
@ -0,0 +1,9 @@
|
||||
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 to_bytes = Uuidm.to_bytes
|
||||
let of_bytes = Uuidm.of_bytes
|
||||
let generate ?(random_state=random_state) = Uuidm.v4_gen random_state
|
||||
let nil = Uuidm.nil
|
||||
31
lib/person.ml
Normal file
31
lib/person.ml
Normal file
@ -0,0 +1,31 @@
|
||||
module Person = struct
|
||||
type name_t = string
|
||||
type address_t = Uri.t
|
||||
type t = { name: name_t; addresses: address_t list }
|
||||
let empty = { name = ""; addresses = [] }
|
||||
let compare = Stdlib.compare
|
||||
let to_string p = List.fold_left (fun a e -> a^" <"^Uri.to_string e^">") p.name p.addresses
|
||||
let of_string s = match String.trim s with "" -> empty | s ->
|
||||
match Re.Str.(split (regexp " *< *") s) with
|
||||
| [] -> empty
|
||||
| [n] -> let name = String.trim n in { empty with name }
|
||||
| n::adds ->
|
||||
let name = String.trim n in
|
||||
let addresses = List.map (fun f -> Uri.of_string @@ String.(sub f 0 (length f -1))) adds in
|
||||
{ name; addresses }
|
||||
end
|
||||
|
||||
include Person
|
||||
|
||||
module Set = struct
|
||||
include Set.Make(Person)
|
||||
let to_string ?(pre="") ?(sep=", ") s =
|
||||
let str = Person.to_string in
|
||||
let j x a = match a, x with "",_ -> str x | _,x when x = Person.empty -> a | _ -> a^sep^str x in
|
||||
fold j s pre
|
||||
let of_string s = of_list (List.map Person.of_string (String_set.list_of_csv s))
|
||||
|
||||
let of_stringset s = String_set.fold (fun e a -> union (of_string e) a) s empty
|
||||
let of_query q = of_stringset (fst q), of_stringset (snd q)
|
||||
let predicate (inc, exl) set = not (disjoint inc set) && disjoint exl set
|
||||
end
|
||||
17
lib/store.ml
Normal file
17
lib/store.ml
Normal file
@ -0,0 +1,17 @@
|
||||
module KV = Map.Make (String)
|
||||
|
||||
module type T = sig
|
||||
type t
|
||||
type item_t
|
||||
type archive_t = { name : string; archivists : Person.Set.t; id : Id.t; kv : string KV.t; store : t }
|
||||
type record_t = Text.t * item_t
|
||||
val of_path: string -> (archive_t, string) result
|
||||
val published: archive_t -> archive_t
|
||||
val indexed: archive_t -> archive_t
|
||||
val newest: record_t -> record_t -> int
|
||||
val oldest: record_t -> record_t -> int
|
||||
val with_id: archive_t -> Id.t -> (Text.t option, Text.t list) result
|
||||
val with_text: archive_t -> Text.t -> (string * Text.t, string) result
|
||||
val iter: ?predicate:(Text.t -> bool) -> ?order:(record_t -> record_t -> int) -> (record_t -> unit) -> archive_t -> unit
|
||||
val fold: ?predicate:(Text.t -> bool) -> ?order:(record_t -> record_t -> int) -> ('a -> record_t -> 'a) -> 'a -> archive_t -> 'a
|
||||
end
|
||||
15
lib/string_set.ml
Normal file
15
lib/string_set.ml
Normal file
@ -0,0 +1,15 @@
|
||||
include Set.Make(String)
|
||||
|
||||
let list_of_csv x = Re.Str.(split (regexp " *, *")) (String.trim x)
|
||||
let of_string x = of_list (list_of_csv x)
|
||||
let to_string ?(pre="") ?(sep=", ") s =
|
||||
let j a x = match a, x with "", _ -> x | _, "" -> a | _ -> a ^ sep ^ x in
|
||||
fold (fun x acc -> j acc x) s pre
|
||||
|
||||
let query string =
|
||||
let partition (include_set, exclude_set) elt =
|
||||
if String.get elt 0 = '!' then (include_set, add String.(sub elt 1 (length elt - 1)) exclude_set)
|
||||
else (add elt include_set, exclude_set) in
|
||||
List.fold_left partition (empty, empty) @@ list_of_csv string
|
||||
|
||||
let predicate (inc, exl) set = not (disjoint inc set) && disjoint exl set
|
||||
101
lib/text.ml
Normal file
101
lib/text.ml
Normal file
@ -0,0 +1,101 @@
|
||||
module String_map = Map.Make (String)
|
||||
type t = {
|
||||
title: string;
|
||||
uuid: Id.t;
|
||||
authors: Person.Set.t;
|
||||
date: Date.t;
|
||||
string_map: string String_map.t;
|
||||
stringset_map: String_set.t String_map.t;
|
||||
body: string;
|
||||
}
|
||||
|
||||
let blank ?(uuid=(Id.generate ())) () = {
|
||||
title = "";
|
||||
uuid;
|
||||
authors = Person.Set.empty;
|
||||
date = Date.({ created = None; edited = None});
|
||||
string_map = String_map.empty;
|
||||
stringset_map = String_map.empty;
|
||||
body = "";
|
||||
}
|
||||
|
||||
let compare = Stdlib.compare
|
||||
let newest a b = Date.(compare a.date b.date)
|
||||
let oldest a b = Date.(compare b.date a.date)
|
||||
let str key m = try String_map.find (String.lowercase_ascii key) m.string_map with Not_found -> ""
|
||||
let set key m = try String_map.find (String.lowercase_ascii key) m.stringset_map with Not_found -> String_set.empty
|
||||
let str_set key m = String_set.to_string @@ set key m
|
||||
let with_str_set m key str = { m with stringset_map = String_map.add (String.lowercase_ascii key) (String_set.of_string str) m.stringset_map }
|
||||
|
||||
let with_kv x (k,v) =
|
||||
let trim = String.trim in
|
||||
match String.lowercase_ascii k with
|
||||
| "body" -> { x with body = String.trim v }
|
||||
| "title"-> { x with title = trim v }
|
||||
| "id" -> (match Id.of_string v with Some id -> { x with uuid = id } | None -> x)
|
||||
| "author"
|
||||
| "authors" -> { x with authors = Person.Set.of_string (trim v)}
|
||||
| "date" -> { x with date = Date.{ x.date with created = Date.of_string v }}
|
||||
| "date-edited"-> { x with date = Date.{ x.date with edited = Date.of_string v }}
|
||||
| "licences" | "topics" | "keywords" | "series" as k -> with_str_set x k v
|
||||
| k -> { x with string_map = String_map.add k (trim v) x.string_map }
|
||||
|
||||
let kv_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), ""
|
||||
| _ -> "",""
|
||||
|
||||
let of_header front_matter =
|
||||
let fields = List.map kv_of_string (Re.Str.(split (regexp "\n")) front_matter) in
|
||||
List.fold_left with_kv (blank ~uuid:Id.nil ()) fields
|
||||
|
||||
let front_matter_body_split s =
|
||||
if Re.Str.(string_match (regexp ".*:.*")) s 0
|
||||
then match Re.Str.(bounded_split (regexp "^$")) 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 = { (of_header front_matter) with body } in
|
||||
if note.uuid <> Id.nil then Ok note else Error "Missing ID header"
|
||||
with _ -> Error ("Failed parsing" ^ s)
|
||||
|
||||
let to_string x =
|
||||
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 Person.Set.is_empty value then "" else "Authors: " ^ Person.Set.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" x.title;
|
||||
a x.authors;
|
||||
d "Date" x.date.Date.created;
|
||||
d "Edited" x.date.Date.edited;
|
||||
s "Licences" (str_set "licences" x);
|
||||
s "Topics" (str_set "topics" x);
|
||||
s "Keywords" (str_set "keywords" x);
|
||||
s "Series" (str_set "series" x);
|
||||
s "Abstract" (str "abstract" x);
|
||||
s "ID" (Uuidm.to_string x.uuid);
|
||||
s "Alias" (str "Alias" x) ]
|
||||
in
|
||||
String.concat "" rows ^ "\n" ^ x.body
|
||||
|
||||
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
|
||||
|
||||
let alias t = match str "alias" t with "" -> string_alias t.title | x -> x
|
||||
35
lib/topic_set.ml
Normal file
35
lib/topic_set.ml
Normal file
@ -0,0 +1,35 @@
|
||||
let of_string x = Re.Str.(split (regexp " *> *")) (String.trim x)
|
||||
|
||||
let topic x =
|
||||
let path = of_string x in
|
||||
try List.nth path (List.length path - 1) with _ -> ""
|
||||
|
||||
module Map = Map.Make(String)
|
||||
|
||||
let edges x map = try Map.find x map with Not_found -> (String_set.empty, String_set.empty)
|
||||
|
||||
let edges_with_context context (contexts, subtopics) = (String_set.add context contexts, subtopics)
|
||||
let edges_with_subtopic subtopic (contexts, subtopics) = (contexts, String_set.add subtopic subtopics)
|
||||
|
||||
let rec list_to_map map = function
|
||||
| [] -> map
|
||||
| [topic] ->
|
||||
let edges = edges topic map in
|
||||
Map.add topic edges map
|
||||
| context :: topic :: tail ->
|
||||
let context_edges = edges context map in
|
||||
let topic_edges = edges topic map in
|
||||
let map =
|
||||
map
|
||||
|> Map.add context (edges_with_subtopic topic context_edges)
|
||||
|> Map.add topic (edges_with_context context topic_edges)
|
||||
in
|
||||
list_to_map map (topic :: tail)
|
||||
|
||||
let to_map map set =
|
||||
List.fold_left (fun acc elt -> list_to_map acc (of_string elt)) map @@ String_set.elements set
|
||||
|
||||
let roots map =
|
||||
let root_keys acc (key, (contexts, _topics)) = if String_set.is_empty contexts then key :: acc else acc in
|
||||
List.fold_left root_keys [] @@ Map.bindings map
|
||||
|
||||
@ -1,29 +1,34 @@
|
||||
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>"
|
||||
# This file is generated by dune, edit dune-project instead
|
||||
opam-version: "2.0"
|
||||
synopsis: "A texts system"
|
||||
maintainer: ["fox@orbitalfox.eu"]
|
||||
authors: ["orbifx"]
|
||||
license: "EUPL"
|
||||
build: [
|
||||
["dune" "build" "--root" "." "-j" jobs "@install"]
|
||||
]
|
||||
homepage: "https://logarion.orbitalfox.eu"
|
||||
bug-reports: "mailto:logarion@lists.orbitalfox.eu?subject=Issue:"
|
||||
depends: [
|
||||
"dune" {build}
|
||||
"dune" {>= "2.0"}
|
||||
"re"
|
||||
"cmdliner"
|
||||
"bos"
|
||||
"ptime"
|
||||
"uuidm"
|
||||
"uri"
|
||||
"re"
|
||||
"emile"
|
||||
"omd"
|
||||
"lwt"
|
||||
"mustache"
|
||||
"tyxml"
|
||||
|
||||
"cmdliner"
|
||||
"bos"
|
||||
"toml"
|
||||
"fpath"
|
||||
"text_parse"
|
||||
"msgpck"
|
||||
]
|
||||
build: [
|
||||
["dune" "subst"] {pinned}
|
||||
[
|
||||
"dune"
|
||||
"build"
|
||||
"-p"
|
||||
name
|
||||
"-j"
|
||||
jobs
|
||||
"@install"
|
||||
"@runtest" {with-test}
|
||||
"@doc" {with-doc}
|
||||
]
|
||||
]
|
||||
dev-repo: "git://orbitalfox.eu/logarion"
|
||||
|
||||
@ -1,16 +0,0 @@
|
||||
#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"
|
||||
@ -1,15 +0,0 @@
|
||||
@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')
|
||||
@ -1,99 +0,0 @@
|
||||
$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
|
||||
@ -1,23 +0,0 @@
|
||||
@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
|
||||
@ -1,23 +0,0 @@
|
||||
@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
|
||||
@ -1,131 +0,0 @@
|
||||
@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; }
|
||||
@ -1,3 +0,0 @@
|
||||
## Articles
|
||||
|
||||
{{recent_texts_listing}}
|
||||
@ -1 +0,0 @@
|
||||
{{title}}
|
||||
@ -1,3 +0,0 @@
|
||||
{{date_human}}
|
||||
{{link}}
|
||||
{{abstract}}
|
||||
@ -1,7 +0,0 @@
|
||||
### Topics
|
||||
|
||||
{{topics}}
|
||||
|
||||
### Recent articles
|
||||
|
||||
{{recent_texts_listing}}
|
||||
@ -1,5 +0,0 @@
|
||||
# {{title}}
|
||||
|
||||
{{details}}
|
||||
|
||||
{{body}}
|
||||
@ -1,82 +0,0 @@
|
||||
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
|
||||
@ -1,23 +0,0 @@
|
||||
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
|
||||
@ -1,7 +0,0 @@
|
||||
(jbuild_version 1)
|
||||
|
||||
(library
|
||||
((name confix)
|
||||
(public_name logarion.confix)
|
||||
(libraries (fpath toml))
|
||||
))
|
||||
@ -1,50 +0,0 @@
|
||||
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>"
|
||||
@ -1,133 +0,0 @@
|
||||
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 ]
|
||||
]
|
||||
@ -1,5 +0,0 @@
|
||||
(library
|
||||
((name converters)
|
||||
(public_name logarion.converters)
|
||||
(libraries (logarion logarion.file mustache tyxml ptime ptime.clock.os))
|
||||
))
|
||||
@ -1,81 +0,0 @@
|
||||
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])
|
||||
@ -1,89 +0,0 @@
|
||||
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
|
||||
@ -1,5 +0,0 @@
|
||||
(library
|
||||
((name logarion)
|
||||
(public_name logarion)
|
||||
(libraries (confix omd ptime lwt uuidm uri re.str emile))
|
||||
))
|
||||
@ -1,25 +0,0 @@
|
||||
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
|
||||
222
src/core/meta.ml
222
src/core/meta.ml
@ -1,222 +0,0 @@
|
||||
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
|
||||
@ -1,47 +0,0 @@
|
||||
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
|
||||
@ -1,7 +0,0 @@
|
||||
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
|
||||
16
src/jbuild
16
src/jbuild
@ -1,16 +0,0 @@
|
||||
(executable
|
||||
((name logarion_cli)
|
||||
(public_name logarion_cli)
|
||||
(modules logarion_cli)
|
||||
(libraries (logarion logarion.confix logarion.converters logarion.file re.str cmdliner bos))))
|
||||
|
||||
(install
|
||||
((section share)
|
||||
(files (
|
||||
(../share/config.toml as config.toml)
|
||||
(../share/template/frontpage.mustache as template/frontpage.mustache)
|
||||
(../share/template/header.mustache as template/header.mustache)
|
||||
(../share/template/item.mustache as template/item.mustache)
|
||||
(../share/template/list.mustache as template/list.mustache)
|
||||
(../share/template/note.mustache as template/note.mustache)
|
||||
))))
|
||||
@ -1,176 +0,0 @@
|
||||
let version = "0.5"
|
||||
open Cmdliner
|
||||
open Logarion
|
||||
module C = Archive.Configuration
|
||||
module Lpath = Logarion.Lpath
|
||||
|
||||
let conf () =
|
||||
let module Config = Confix.Config.Make (Confix.ConfixToml) in
|
||||
let archive_res =
|
||||
let open Confix.Config in
|
||||
Confix.Config.Path.with_file "config.toml"
|
||||
&> Config.from_path
|
||||
|> Config.to_record C.of_config
|
||||
in
|
||||
match archive_res with
|
||||
| Ok config -> config
|
||||
| Error str -> prerr_endline str; exit 1
|
||||
|
||||
let create_dir dir = Bos.OS.Dir.create (Fpath.v dir)
|
||||
|
||||
let create_dir_msg ?(descr="") dir res =
|
||||
let () = match res with
|
||||
| Ok true -> print_endline ("Created " ^ descr ^ " directory " ^ dir)
|
||||
| Ok false -> print_endline ("Reinitialise existing " ^ descr ^ " directory " ^ dir)
|
||||
| Error (`Msg msg) -> prerr_endline @@ "Failed making " ^ descr ^ ". " ^ msg
|
||||
in
|
||||
res
|
||||
|
||||
let copy ?(recursive = false) src dst =
|
||||
Bos.OS.Cmd.run (Bos.Cmd.(v "cp" %% (on recursive @@ v "-r") % src % dst))
|
||||
|
||||
let init _force =
|
||||
let rec create_dirs = function
|
||||
| [] -> ()
|
||||
| (dir,descr)::tl ->
|
||||
match create_dir dir |> create_dir_msg ~descr dir with
|
||||
| Ok _ -> create_dirs tl
|
||||
| Error _ -> ()
|
||||
in
|
||||
let dirs = [
|
||||
".logarion", "Logarion";
|
||||
".logarion/static", "static files";
|
||||
".logarion/html-templates", "templates";
|
||||
]
|
||||
in
|
||||
let toml_data =
|
||||
let open Toml in
|
||||
let open TomlTypes in
|
||||
of_key_values [
|
||||
key "archive",
|
||||
TTable (
|
||||
of_key_values [
|
||||
key "title", TString "";
|
||||
key "owner", TString (Bos.OS.Env.opt_var "USER" ~absent:"");
|
||||
key "email", TString (Bos.OS.Env.opt_var "EMAIL" ~absent:"");
|
||||
key "uuid", TString (Meta.Id.(generate () |> to_string));
|
||||
]);
|
||||
key "web",
|
||||
TTable (
|
||||
of_key_values [
|
||||
key "url", TString "http://localhost:3666";
|
||||
key "stylesheets", TArray ( NodeString ["main.css"] );
|
||||
key "static_dir", TString ".logarion/static";
|
||||
]);
|
||||
key "templates", TTable (of_key_values []);
|
||||
]
|
||||
in
|
||||
create_dirs dirs;
|
||||
let config_file = open_out "config.toml" in
|
||||
output_bytes config_file (Toml.Printer.string_of_table toml_data |> Bytes.of_string);
|
||||
close_out config_file
|
||||
|
||||
let init_term =
|
||||
let force =
|
||||
let doc = "Initialise repository even if directory is non empty" in
|
||||
Arg.(value & flag & info ["f"; "force"] ~doc)
|
||||
in
|
||||
Term.(const init $ force),
|
||||
Term.info
|
||||
"init" ~doc:"initialise a logarion repository in present directory"
|
||||
~man:[ `S "DESCRIPTION"; `P "Create a repository in current directory" ]
|
||||
|
||||
let create_term =
|
||||
let title =
|
||||
Arg.(value & pos 0 string "" & info [] ~docv:"TITLE" ~doc:"Title for new article")
|
||||
in
|
||||
let f title =
|
||||
let conf = conf () in
|
||||
let t = match title with "" -> "Draft" | _ -> title in
|
||||
let note =
|
||||
let meta =
|
||||
let open Meta in
|
||||
let authors = AuthorSet.singleton Author.({ name = conf.C.owner; address = Uri.of_string conf.C.email }) in
|
||||
let date = Date.({ created = Some (Ptime_clock.now ()); published = None; edited = None }) in
|
||||
{ (blank ()) with title = t; authors; date }
|
||||
in
|
||||
Note.({ (blank ()) with meta })
|
||||
in
|
||||
File.Lwt.with_note (File.store conf.C.repository) note
|
||||
|> Lwt_main.run
|
||||
|> ignore
|
||||
in
|
||||
Term.(const f $ title),
|
||||
Term.info "create"
|
||||
~doc:"create a new article"
|
||||
~man:[ `S "DESCRIPTION"; `P "Create a new article, with title 'Draft' when none provided"]
|
||||
|
||||
let convert directory =
|
||||
let module Config = Confix.Config.Make (Confix.ConfixToml) in
|
||||
|
||||
let toml_config =
|
||||
let open Confix.Config in
|
||||
Path.with_file "config.toml"
|
||||
|> function Ok cfg -> Config.from_path cfg | Error str -> prerr_endline str; exit 1
|
||||
in
|
||||
let config = Config.to_record_or_exit Logarion.Archive.Configuration.of_config toml_config in
|
||||
|
||||
let module L = Logarion.Archive.Make(File) in
|
||||
let store = File.store config.repository in
|
||||
let archive = L.{ config; store } in
|
||||
let notes =
|
||||
List.filter Meta.(fun n -> CategorySet.published n.Note.meta.categories)
|
||||
@@ File.to_list L.note_lens archive.store
|
||||
in
|
||||
let metas =
|
||||
List.filter Meta.(fun m -> CategorySet.published m.categories && CategorySet.listed m.categories)
|
||||
@@ File.to_list ~order:(L.recency_order) L.meta_lens archive.store
|
||||
in
|
||||
|
||||
let template_config = toml_config in
|
||||
let module T = Converters.Template in
|
||||
let header = T.header_converter template_config in
|
||||
let body = T.body_converter template_config in
|
||||
let style = T.default_style in
|
||||
let linker x = match Fpath.(relativize ~root:(v "/") (v x)) with Some l -> Fpath.to_string l | None -> "" in
|
||||
let page_of_log metas = T.page_of_log linker header config metas in
|
||||
let page_of_index metas = T.page_of_index linker header config metas in
|
||||
let page_of_note note = T.page_of_note linker header body config note in
|
||||
let path_of_note note = directory ^ "/" ^ Meta.alias note.Note.meta ^ ".html" in
|
||||
let file_creation path content =
|
||||
let out = open_out path in
|
||||
output_string out content;
|
||||
close_out out
|
||||
in
|
||||
match create_dir directory |> create_dir_msg ~descr:"export" directory with
|
||||
| Error _ -> ()
|
||||
| Ok _ ->
|
||||
match copy ~recursive:true ".logarion/static" (directory) with
|
||||
| Ok _ ->
|
||||
let note_write note = file_creation (path_of_note note) (page_of_note ~style note) in
|
||||
List.iter note_write notes;
|
||||
file_creation (directory ^ "/log.html") (page_of_log ~style metas);
|
||||
file_creation (directory ^ "/index.html") (page_of_index ~style metas);
|
||||
file_creation (directory ^ "/feed.atom") (Converters.Atom.feed config "/" (L.note_with_id archive) metas)
|
||||
| Error (`Msg m) -> prerr_endline m
|
||||
|
||||
let convert_term =
|
||||
let directory =
|
||||
Arg.(value & pos 0 string "html-conversion" & info [] ~docv:"Directory" ~doc:"Directory to convert to")
|
||||
in
|
||||
Term.(const convert $ directory),
|
||||
Term.info
|
||||
"convert" ~doc:"convert archive to HTML"
|
||||
~man:[ `S "DESCRIPTION"; `P "Create a repository in current directory" ]
|
||||
|
||||
let default_cmd =
|
||||
Term.(ret (const (`Help (`Pager, None)))),
|
||||
Term.info "logarion" ~version ~doc:"an article collection & publishing system"
|
||||
~man:[ `S "BUGS";
|
||||
`P "Submit bugs <mailto:logarion@lists.orbitalfox.eu?subject=[Issue] summary-here>"; ]
|
||||
|
||||
let cmds = [ init_term; create_term; convert_term ]
|
||||
|
||||
let () =
|
||||
Random.self_init();
|
||||
match Term.eval_choice default_cmd cmds with `Error _ -> exit 1 | _ -> exit 0
|
||||
@ -1,112 +0,0 @@
|
||||
let extensions = [ ".md"; ".org" ]
|
||||
|
||||
open Logarion
|
||||
let load f =
|
||||
let ic = open_in (Fpath.to_string f) in
|
||||
let n = in_channel_length ic in
|
||||
let s = Bytes.create n in
|
||||
really_input ic s 0 n;
|
||||
close_in ic;
|
||||
Bytes.to_string s
|
||||
|
||||
let note path = Lpath.fpath_of_note path |> load |> Note.of_string
|
||||
|
||||
type t = { repo_path : Lpath.repo_t }
|
||||
|
||||
let note_filetype name =
|
||||
try Fpath.(mem_ext extensions @@ v name) with
|
||||
| Invalid_argument _ -> false
|
||||
|
||||
let to_list ?(order) lens_fn store =
|
||||
let repo_path = store.repo_path in
|
||||
let cons_valid_meta list path =
|
||||
try
|
||||
let note = note (Lpath.note_of_basename repo_path path) in
|
||||
lens_fn note :: list
|
||||
with Note.Syntax_error str -> prerr_endline str; list
|
||||
in
|
||||
Lpath.string_of_repo repo_path
|
||||
|> Sys.readdir
|
||||
|> Array.to_list
|
||||
|> List.filter note_filetype
|
||||
|> List.fold_left cons_valid_meta []
|
||||
|> match order with
|
||||
| Some fn -> List.fast_sort fn
|
||||
| None -> (fun x -> x)
|
||||
|
||||
let note_with_id store id =
|
||||
let repo_path = store.repo_path in
|
||||
let note_of_path path = note (Lpath.note_of_basename repo_path path) in
|
||||
let with_id path =
|
||||
try
|
||||
let note = note_of_path path in
|
||||
note.Note.meta.Meta.uuid = id
|
||||
with Note.Syntax_error str -> prerr_endline str; false
|
||||
in
|
||||
let notes =
|
||||
Lpath.string_of_repo repo_path
|
||||
|> Sys.readdir
|
||||
|> Array.to_list
|
||||
|> List.filter note_filetype
|
||||
in
|
||||
try Some (note_of_path (List.find with_id notes))
|
||||
with Not_found -> None
|
||||
|
||||
let note_with_alias store alias =
|
||||
let repo_path = store.repo_path in
|
||||
let cons_valid_meta list path =
|
||||
try (note (Lpath.note_of_basename repo_path path)) :: list
|
||||
with Note.Syntax_error str -> prerr_endline str; list
|
||||
in
|
||||
let recency_order a b = Meta.(Date.compare b.date a.date) in
|
||||
let notes =
|
||||
Lpath.string_of_repo repo_path
|
||||
|> Sys.readdir
|
||||
|> Array.to_list
|
||||
|> List.filter note_filetype
|
||||
|> List.fold_left cons_valid_meta []
|
||||
|> List.filter (fun note -> Meta.alias note.Note.meta = alias)
|
||||
|> List.fast_sort (fun a b -> recency_order a.Note.meta b.Note.meta)
|
||||
in
|
||||
try Some (List.hd notes)
|
||||
with Failure _ -> None
|
||||
|
||||
let notepath_with_id _store _id = None
|
||||
|
||||
let store repo_path = { repo_path }
|
||||
|
||||
module Lwt = struct
|
||||
let of_filename f =
|
||||
let open Lwt in
|
||||
Lwt_io.(open_file ~mode:(Input) f >|= read_lines)
|
||||
>|= (fun stream -> Lwt_stream.fold (^) stream "")
|
||||
|
||||
let with_note store new_note =
|
||||
let extension = List.hd extensions in
|
||||
let open Lwt in
|
||||
let open Lwt.Infix in
|
||||
let store =
|
||||
let write_note out = Lwt_io.write out (Note.to_string new_note) in
|
||||
match notepath_with_id store new_note.Note.meta.Meta.uuid with
|
||||
| Some previous_path ->
|
||||
let filepath =
|
||||
let open Note in
|
||||
let open Meta in
|
||||
if (note previous_path).meta.title <> new_note.meta.title
|
||||
then Lpath.versioned_basename_of_title store.repo_path extension new_note.meta.title
|
||||
else previous_path
|
||||
in
|
||||
Lwt_io.with_file ~mode:Lwt_io.output (Lpath.string_of_note filepath) write_note
|
||||
>>= (fun () ->
|
||||
if previous_path <> filepath
|
||||
then Lwt_unix.unlink @@ Lpath.string_of_note previous_path
|
||||
else Lwt.return_unit
|
||||
)
|
||||
| None ->
|
||||
let filepath = Lpath.versioned_basename_of_title store.repo_path extension new_note.meta.title in
|
||||
Lwt_io.with_file ~mode:Lwt_io.output (Lpath.string_of_note filepath) write_note
|
||||
in
|
||||
store >>= (fun () -> return new_note);
|
||||
end
|
||||
|
||||
let with_note = Lwt.with_note
|
||||
@ -1,7 +0,0 @@
|
||||
(jbuild_version 1)
|
||||
|
||||
(library
|
||||
((name file)
|
||||
(public_name logarion.file)
|
||||
(libraries (logarion lwt lwt.unix))
|
||||
))
|
||||
Loading…
x
Reference in New Issue
Block a user