Samhain 21

Converter
- type selection
- subdir conversion
- htm extension

Gemini
- index.gmi
- topics and latest
- gmi.atom feed

Add pull (http(s)) operation
- peers.pub.conf and peers.priv.conf

HTML5 format & fixes by Novaburst
Phony target (thanks Gergely)

May

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.
Logarion created texts have part of the UUID in filename.
Logarion's index re-written in Messagepack format. Removed `indices` command. They are generated during `convert`.
This commit is contained in:
orbifx 2021-03-13 18:40:07 +00:00
parent 3d92789cdb
commit 22fe21326f
56 changed files with 1256 additions and 1583 deletions

View file

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

View file

@ -1,18 +1,18 @@
all: cli
all:
dune build
cli:
dune build src/logarion_cli.exe
dune build cli/cli.exe
clean:
dune clean
theme-dark:
sassc share/sass/main-dark.sass > share/static/main.css
theme-light:
sassc share/sass/main-light.sass > share/static/main.css
tgz:
cp _build/default/src/logarion_cli.exe logarion
strip logarion
tar czvf "logarion-$(shell ./logarion --version)-$(shell uname -s)-$(shell uname -m)-$(shell git rev-parse --short HEAD).tar.gz" share logarion
dune subst
dune build
cp _build/default/cli/cli.exe txt
strip txt
tar czvf "logarion-$(shell date -r _build/default/cli/cli.exe "+%y-%m-%d")-$(shell uname -s)-$(shell uname -m)-$(shell git rev-parse --short HEAD).tar.gz" txt ReadMe
rm txt
.PHONY: cli

View file

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

57
cli/atom.ml Normal file
View file

@ -0,0 +1,57 @@
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 id txt = "<id>urn:uuid:" ^ Logarion.(Id.to_string txt.Text.uuid) ^ "</id>"
let title text = "<title>" ^ esc text.Logarion.Text.title ^ "</title>"
let authors text =
let u acc addr = acc ^ element "uri" (Uri.to_string addr) in
let open Logarion in
let fn txt a =
a ^ "<author>" ^ (opt_element "name" @@ esc txt.Person.name)
^ (List.fold_left u "" txt.Person.addresses)
^ "</author>" in
Person.Set.fold fn text.Text.authors ""
let updated txt = let open Logarion in
"<updated>"^ Date.(txt.Text.date |> listing |> rfc_string) ^"</updated>"
let htm_entry base_url text =
let open Logarion in
let u = Text.short_id text in
"<entry><link rel=\"alternate\" href=\"" ^ base_url ^ "/" ^ u ^ ".htm\" />"
^ title text ^ id text ^ updated text ^ authors text
^ (opt_element "summary" @@ esc @@ Text.str "abstract" text)
^ String_set.fold (fun elt a -> a ^ "<category term=\"" ^ esc elt ^ "\"/>") (Text.set "topics" text) ""
^ "<content type=\"xhtml\"><div xmlns=\"http://www.w3.org/1999/xhtml\">"
^ P.of_string text.body ""
^ "</div></content></entry>\n"
let gmi_entry base_url text =
let open Logarion in
let u = Text.short_id text in
"<entry><link rel=\"alternate\" href=\"" ^ base_url ^ "/" ^ u ^ ".gmi\" />"
^ title text ^ id text ^ updated text ^ authors text
^ (opt_element "summary" @@ esc @@ Text.str "abstract" text)
^ String_set.fold (fun elt a -> a ^ "<category term=\"" ^ elt ^ "\"/>") (Text.set "topics" text) ""
^ "</entry>\n"
let feed title archive_id base_url alternate_type texts =
let entry, self = match alternate_type with
| "text/gemini" -> gmi_entry, base_url^"/gmi.atom"
| "text/html" | _ -> htm_entry, base_url^"/feed.atom" in
{|<?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="|} ^ alternate_type ^ {|" href="|}
^ base_url ^ {|/" /><link rel="self" type="application/atom+xml" href="|}
^ self ^ {|" /><id>urn:uuid:|} ^ Logarion.Id.to_string archive_id ^ "</id><updated>"
^ Ptime.to_rfc3339 (Ptime_clock.now ()) ^ "</updated>\n"
^ List.fold_left (fun acc t -> acc ^ entry base_url t) "" texts
^ "</feed>"

142
cli/cli.ml Normal file
View file

@ -0,0 +1,142 @@
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 order_opt reverse_opt number_opt values_opt authors_opt topics_opt =
match A.of_path (Sys.getcwd ()) with
| Error msg -> prerr_endline msg
| Ok archive ->
let predicates = A.predicate A.authored authors_opt @ A.predicate A.topics topics_opt in
let predicate text = List.fold_left (fun a e -> a && e text) true predicates in
let print_fold ~predicate fn =
let ts = A.fold ~predicate fn String_set.empty archive in
String_set.iter (print_endline) ts
in
let list_text (t, fname) = print_endline (Text.short_id t ^ " " ^ t.Text.title ^ "\t" ^ fname) in
match values_opt with
| Some "topics" -> print_fold ~predicate (fun a (e,_) -> (String_set.union a (Text.set "topics" e)))
| Some "authors" ->
let s = A.fold ~predicate (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
| None -> match order_opt with
| false -> A.iter ~predicate list_text archive
| true ->
let order = match reverse_opt with true -> A.newest | false -> A.oldest in
match number_opt with
| Some number -> A.iter ~predicate ~order ~number list_text archive
| None -> A.iter ~predicate ~order list_text archive
let list_term =
let reverse = Arg.(value & flag & info ["r"] ~doc:"reverse order") in
let time = Arg.(value & flag & info ["t"] ~doc:"Sort by time, newest first") in
let number = Arg.(value & opt (some int) None & info ["n"] ~docv:"NUMBER" ~doc:"number of entries to list") in
let values = Arg.(value & opt (some string) None & info ["values"] ~docv:"HEADER-FIELD" ~doc:"unique values for header field") in
let authed = Arg.(value & opt (some string) None & info ["authored"] ~docv:"AUTHORS" ~doc:"texts by authors") in
let topics = Arg.(value & opt (some string) None & info ["topics"] ~docv:"TOPICS" ~doc:"texts with topics") in
Term.(const text_list $ time $ reverse $ number $ values $ authed $ topics),
Term.info "list" ~doc:"list texts" ~man:[ `S "DESCRIPTION"; `P "List texts" ]
let print_last search_mine =
let last a ((t,_) as pair) = match a with None -> Some pair
| Some (t', _) as pair' -> if Text.newest t t' > 0 then Some pair else pair' in
match A.of_path (Sys.getcwd ()) with
| Error msg -> prerr_endline msg
| Ok archive ->
let last_mine a ((t,_) as pair) =
let open Text in
match a with None ->
if Person.Set.subset archive.A.archivists t.authors then Some pair else None
| Some (t', _) as pair' ->
if Text.newest t t' > 0 && Person.Set.subset archive.A.archivists t'.authors
then Some pair else pair'
in
match A.fold (if search_mine then last_mine else last) None archive with
| Some (_,f) -> print_endline f | None -> ()
let last_term =
let mine = Arg.(value & flag & info ["mine"] ~doc:"last text authored by me") in
Term.(const print_last $ mine),
Term.info "last" ~doc:"most recent test" ~man:[ `S "DESCRIPTION"; `P "Print the filename of most recent text" ]
let split_filetypes files =
let acc (dirs, files) x = if Sys.is_directory x then (x::dirs, files) else (dirs, x::files) in
List.fold_left acc ([],[]) files
let file files = match A.of_path "." with
| Error msg -> prerr_endline msg
| Ok _archive ->
let dirs, files = split_filetypes files in
let _link_as_named dir file = Unix.link file (dir ^"/"^ file) in
let link_with_id dir file =
match File_store.to_text file with Error s -> prerr_endline s
| Ok t -> Unix.link file (dir ^"/"^ String.sub (Id.to_string (t.Text.uuid)) 0 8 ^".txt")
in
let link = link_with_id in
List.iter (fun d -> List.iter (link d) files) dirs
let file_term =
let files = Arg.(value & pos_all string [] & info [] ~doc:"filenames") in
let doc = "file texts in directories" in
let man = [ `S "DESCRIPTION"; `P doc ] in
Term.(const file $ files), Term.info "file" ~doc ~man
let unfile files = match A.of_path "." with
| Error msg -> prerr_endline msg
| Ok _archive ->
let dirs, files = split_filetypes files in
let unlink dir file = try Unix.unlink (dir ^"/"^ file) with Unix.(Unix_error(ENOENT,_,_))-> () in
List.iter (fun d -> List.iter (unlink d) files) dirs
let unfile_term =
let files = Arg.(value & pos_all string [] & info [] ~doc:"filenames") in
let doc = "unfile texts from directories" in
let man = [ `S "DESCRIPTION"; `P doc ] in
Term.(const unfile $ files), Term.info "unfile" ~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 text repository in present directory" in
let man = [ `S "DESCRIPTION"; `P "Start an archive in current directory" ] in
Term.(const init $ force), Term.info "init" ~doc ~man
let new_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 _code = Sys.command ("$EDITOR " ^ filepath) in
()
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 "new" ~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: " ] in
Term.(ret (const (`Help (`Pager, None)))), Term.info "txt" ~version ~doc ~man
let cmds = [ init_term; new_term; file_term; unfile_term; list_term; last_term; Convert.term; Http.pull_term ]
let () =
Random.self_init();
match Term.eval_choice default_cmd cmds with `Error _ -> exit 1 | _ -> exit 0

90
cli/convert.ml Normal file
View file

@ -0,0 +1,90 @@
open Logarion
module A = Archive.Make (Logarion.File_store)
let convert_modified 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); true) else false
let word_fname dir text = dir ^ "/" ^ Text.alias text
let id_fname dir text = dir ^ "/" ^ Text.short_id text
let writer types dir name (text,store_item) = (* todo: single_parser -> [files] *)
(* convert_modified store_item idfilename (fun _title -> Text.to_string) text.title text;*)
let h = if "htm" = types || "all" = types then
convert_modified store_item (id_fname dir text ^ ".htm") Html.page name text
else false in
let g = if "gmi" = types || "all" = types then
convert_modified store_item (id_fname dir text ^ ".gmi") Gemini.page name text
else false in
h || g
let index_writer types noindex dir archive topic_roots topic_map texts =
let name = archive.A.name in
let file path = File_store.file (dir ^ path) in
file "/index.pck" (Header_pack.pack archive texts);
if not noindex && ("htm" = types || "all" = types) then (
let index_name = try Store.KV.find "HTML-index" archive.File_store.kv
with Not_found -> "index.html" in
if index_name <> "" then
file ("/"^index_name) (Html.topic_main_index name topic_roots texts);
file "/index.date.htm" (Html.date_index name texts);
List.iter
(fun topic -> file ("/index." ^ topic ^ ".htm")
(Html.topic_sub_index name topic_map topic texts))
topic_roots;
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 "text/html" texts)
);
if not noindex && ("gmi" = types || "all" = types) then (
let index_name = try Store.KV.find "Gemini-index" archive.File_store.kv
with Not_found -> "index.gmi" in
if index_name <> "" then
file ("/"^index_name) (Gemini.topic_main_index name topic_roots texts);
file "/index.date.gmi" (Gemini.date_index name texts);
List.iter
(fun topic -> file ("/index." ^ topic ^ ".gmi")
(Gemini.topic_sub_index name topic_map topic texts))
topic_roots;
let base_url = try Store.KV.find "GEMINI-URL" archive.File_store.kv
with Not_found -> prerr_endline "Missing `GEMINI-URL:` in config"; "" in
file "/gmi.atom" (Atom.feed archive.A.name archive.A.id base_url "text/gemini" texts)
)
let txt_writer types dir name ((text, _store_item) as r) =
match Text.str "Content-Type" text with
| "" | "text/plain" -> writer types dir name r
| x -> prerr_endline ("Can't convert Content-Type: "^x^" file: " ^text.Text.title); false
let convert_all types noindex dir archive =
let name = archive.A.name in
let fn (ts,ls,acc) ((elt,_) as r) =
(Topic_set.to_map ts (Text.set "topics" elt)),
elt::ls, if txt_writer types dir name r then acc+1 else acc in
let empty = Topic_set.Map.empty in
let topic_map, texts, count = A.(fold ~order:newest fn (empty,[],0) archive) in
let topic_roots = Topic_set.roots topic_map in
index_writer types noindex dir archive topic_roots topic_map texts;
print_endline @@ "Converted: " ^ string_of_int (count)
^ "\nIndexed: " ^ string_of_int (List.length texts);
Ok ()
let convert_dir types noindex cmd_dir =
let (>>=) = Result.bind in
let with_dir 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 "" -> Error "unspecified export dir" | x -> Ok x)
>>= fun dir -> with_dir dir
>>= fun _ -> convert_all types noindex dir { archive with store = dir })
|> 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
let types = Arg.(value & opt string "all" & info ["t"; "type"] ~docv:"TYPES" ~doc:"Convert to type") in
let noindex = Arg.(value & flag & info ["noindex"] ~doc:"don't write an index when converting") in
Term.(const convert_dir $ types $ noindex $ directory),
Term.info "convert" ~doc:"convert archive" ~man:[ `S "DESCRIPTION"; `P "Convert Logarion archive" ]

5
cli/dune Normal file
View file

@ -0,0 +1,5 @@
(executable
(name cli)
(public_name txt)
(modules cli convert html atom gemini)
(libraries logarion logarion.http re.str cmdliner bos ptime ptime.clock.os text_parse.converter text_parse.parsers msgpck))

73
cli/gemini.ml Normal file
View file

@ -0,0 +1,73 @@
let page _archive_title text =
let open Logarion.Text in
"# " ^ text.title
^ "\nAuthors: " ^ Logarion.Person.Set.to_string text.authors
^ "\nDate: " ^ 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.short_id m ^ ".gmi " ^
Logarion.(Date.(pretty_date (listing m.date)) ^ " " ^ m.title) ^ "\n")
("# " ^ title ^ "\n\n## Posts by date\n\n") meta_list
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.Text.short_id m ^ ".gmi "
^ Logarion.(Date.(pretty_date (listing m.Text.date))) ^ " "
^ m.Logarion.Text.title ^ "\n")
"" meta_list
let topic_link root topic =
"=> index." ^ root ^ ".gmi " ^ String.capitalize_ascii topic ^ "\n"
let text_item path meta =
let open Logarion in
"=> " ^ path ^ Text.short_id meta ^ ".gmi "
^ Date.(pretty_date (listing meta.Text.date)) ^ " "
^ meta.Text.title ^ "\n"
let listing_index topic_map topic_roots path metas =
let rec item_group topics =
List.fold_left (fun acc topic -> acc ^ sub_groups topic ^ 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 -> "## " ^ String.capitalize_ascii topic ^ "\n\n" ^ x
in
item_group topic_roots
let fold_topic_roots topic_roots =
let list_item root t = topic_link root t in
List.fold_left (fun a x -> a ^ list_item x x) "" (List.rev topic_roots)
let topic_main_index title topic_roots metas =
"# " ^ title ^ "\n\n"
^ (if topic_roots <> [] then ("## Main topics\n\n" ^ fold_topic_roots topic_roots) else "")
^ "\n## Latest\n\n" ^ to_dated_links ~limit:10 metas
^ "\n=> index.date.gmi More by date\n"
let topic_sub_index title topic_map topic_root metas =
"# " ^ title ^ "\n\n"
^ listing_index topic_map [topic_root] "" metas

125
cli/html.ml Normal file
View file

@ -0,0 +1,125 @@
let wrap (title:string) (subtitle:string) body =
{|<!DOCTYPE HTML>|}
^ {|<html><head><title>|}
^ subtitle ^ " | " ^ title
^ {|</title><link rel="stylesheet" href="main.css">|}
^ {|<link rel="alternate" href="feed.atom" type="application/atom+xml">|}
^ {|<meta charset="utf-8"/>|}
^ {|<meta name="viewport" content="width=device-width, initial-scale=1.0">|}
^ {|</head><body><header><a href=".">|} ^ title
^ {|</a> <nav><a href="feed.atom" id="feed">feed</a></nav></header>|} ^ body
^ "</body></html>"
let topic_link root topic =
let replaced_space = String.map (function ' '->'+' | x->x) in
{|<a href="index.|} ^ root ^ {|.htm#|} ^ replaced_space topic ^ {|">|}
^ String.capitalize_ascii topic ^ "</a>"
let page 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 = (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 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.short_id m ^ {|.htm">|} ^ 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 String.capitalize_ascii 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
"<time>" ^ Date.(pretty_date (listing meta.Text.date))
^ {|</time> <a href="|} ^ path ^ Text.short_id meta ^ {|.htm">|} ^ meta.Text.title
^ "</a><br>"
let listing_index topic_map topic_roots path metas =
let rec item_group topics =
List.fold_left (fun acc topic -> acc ^ sub_groups topic ^ 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 -> {|<h2 id="|} ^ topic ^ {|">|} ^ String.capitalize_ascii topic ^ "</h2>" ^ x
in
"<nav><h1>Texts</h1>" ^ item_group topic_roots ^ "</nav>"
let topic_main_index title topic_roots metas =
wrap title "Topics"
(fold_topic_roots topic_roots
^ "<nav><h1>Latest</h1>" ^ to_dated_links ~limit:10 metas
^ {|<a href="index.date.htm">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=".atom" id="feed">|}^ String.capitalize_ascii topic_root ^{| feed </a>|}*)
^ listing_index topic_map [topic_root] "" metas)

View file

@ -1,3 +0,0 @@
Logarion
Ymd
Web

16
dune-project Normal file
View file

@ -0,0 +1,16 @@
(lang dune 2.0)
(name logarion)
(homepage "https://logarion.orbitalfox.eu")
(source (uri git://orbitalfox.eu/logarion))
(license EUPL-1.2)
(authors "orbifx")
(maintainers "fox@orbitalfox.eu")
(bug_reports "mailto:logarion@lists.orbitalfox.eu?subject=Issue:")
(generate_opam_files true)
(package
(name logarion)
(synopsis "Texts archival and exchange")
(depends re cmdliner bos ptime uuidm uri text_parse msgpck cohttp-lwt-unix tls))

4
http/dune Normal file
View file

@ -0,0 +1,4 @@
(library
(name http)
(public_name logarion.http)
(libraries logarion uri cmdliner lwt cohttp cohttp-lwt cohttp-lwt-unix tls msgpck))

143
http/http.ml Normal file
View file

@ -0,0 +1,143 @@
let http_body fn uri =
let open Lwt in
let open Cohttp_lwt_unix in
Client.get uri >>= fun (headers, body) ->
body |> Cohttp_lwt.Body.to_string >|= fun body -> fn (headers, body)
let response (headers, body) =
let open Cohttp in
match Header.get (headers |> Response.headers) "content-type" with
| Some "application/msgpack" | Some "application/octet-stream"
| Some "text/plain" | Some "text/plain; charset=utf-8" -> Ok body
| Some x -> Error ("Invalid content-type: " ^ x)
| None -> Ok body
let http_apply fn uri = Lwt_main.run (http_body fn uri)
module S = Set.Make(String)
(*let is_selected sl =*)
(* let check str a b c = Option.(fold ~none:(is_none b && is_none c) ~some:(fun x -> x = str) a) in*)
(* function*)
(* | `Author s -> check s sl.authors sl.topics*)
(* | `Topic s -> check s sl.topics sl.authors*)
(* TODO: parse using Header_pack *)
let sub_id text = Logarion.(String.sub (text.Text.uuid |> Id.to_string) 0 8)
let fname dir text = dir ^ sub_id text ^ ".txt"
let newer time id dir =
match Logarion.File_store.to_text @@ Filename.concat dir (String.sub (Logarion.Id.to_string id) 0 8 ^ ".txt") with
| Error x -> prerr_endline x; true
| Ok txt -> time > (Logarion.(Header_pack.date (Date.listing txt.date)))
| exception (Sys_error _) -> true
let pull_text url dir id =
let path = Uri.path url in
let u = Uri.with_path url (path ^ "/" ^ String.sub (Logarion.Id.to_string id) 0 8 ^ ".txt") in
match http_apply response u with
| Error msg -> prerr_endline @@ " Failed " ^ Uri.to_string u ^ " " ^ msg
| Ok txt ->
match Logarion.Text.of_string txt with
| Error s -> prerr_endline s
| Ok text ->
let file = open_out_gen [Open_creat; Open_trunc; Open_wronly] 0o640 (fname dir text) in
output_string file txt; close_out file
(*TODO: adapt Archive predication function to work with free sets*)
let parse_index _is_selected fn url p =
let open Logarion.Header_pack in
let dir = "peers/" ^ match Uri.host url with
None -> "local/" ^ Uri.path url | Some s -> s ^ Uri.path url ^ "/" in
Printf.printf "%s => %s\n" p.info.name dir;
(match Msgpck.to_list p.peers with [] -> () | ps ->
print_string " peers: ";
List.iter (fun x -> print_string (" " ^ Msgpck.to_string x)) ps;
print_newline ());
match Msgpck.to_list p.texts with
| [] -> print_endline ", has empty index"
| texts ->
match Bos.OS.Dir.create ~mode:0o740 (Fpath.v dir) with
| Error (`msg s) -> prerr_endline ("Error making domain dir:" ^ s);
| _ ->
let numof_texts = string_of_int @@ List.length texts in
let text_num_len = String.length numof_texts in
let of_pck i x =
Printf.printf "\r%*d/%s %!" text_num_len (i+1) numof_texts;
match x with
| Msgpck.List (id::time::title::_authors::_topics) ->
(match Logarion.Id.of_bytes Msgpck.(to_bytes id) with
| None -> prerr_endline ("Invalid id for " ^ Msgpck.to_string title)
| Some id ->
let t = match time with Msgpck.Int i -> Int32.of_int i | Msgpck.Uint32 i -> i | x -> Msgpck.to_uint32 x in
if newer t id dir then fn url dir id)
| _ -> prerr_endline ("Invalid record structure") in
List.iteri of_pck texts;
print_newline ()
let pull_index url _authors _topics =
let index_url = Uri.(with_path url (path url ^ "/index.pck")) in
match http_apply response index_url with
| Error msg -> prerr_endline @@ "Failed index request for " ^ Uri.to_string index_url ^ " " ^ msg
| Ok body ->
let _i, pack = Msgpck.StringBuf.read body in
(* let predicates =*)
(* A.predicate A.authored authors_opt*)
(* @ A.predicate A.topics topics_opt*)
(* in*)
let is_selected text = List.fold_left (fun a e -> a && e text) true [](*predicates*) in
match Logarion.Header_pack.unpack pack with None -> ()
| Some headers -> parse_index is_selected pull_text url headers
module Msg = struct
type t = Ptime.t * string
let compare (x0,y0) (x1,y1) = match Ptime.compare x1 x0 with 0 -> String.compare y0 y1 | c -> c
end
module MsgSet = Set.Make(Msg)
let pull_msgs url _authors _topics = match http_apply response url with
| Error msg -> prerr_endline @@ "Failed index request for " ^ Uri.(to_string url) ^ " " ^ msg
| Ok body ->
let rec fold_msgs s a fn =
let t, msg = Scanf.bscanf s "%s %s@\n" (fun t m -> t, m) in
if t <> "" then fold_msgs s (fn a t msg) fn else a
in
let s = Scanf.Scanning.from_string body in
let msgs = MsgSet.empty in
let date_string t = Ptime.to_date t |>
fun (y, m, d) -> Printf.sprintf "%04d-%02d-%02d" y m d in
let msgs = fold_msgs s msgs
(fun msgs t m -> match Ptime.of_rfc3339 t with
| Ok (v,_,_) -> let open MsgSet in
let msgs = if cardinal msgs > 1 then remove (max_elt msgs) msgs else msgs in
add (v,m) msgs
| _ -> msgs) in
print_endline ("\n┌────=[ " ^ Uri.to_string url);
MsgSet.iter
(fun (t,m) -> print_endline
("" ^ date_string t ^ "\n" ^ m ^ "\n└─────────")) msgs
let pull_url url = match Uri.of_string url with
| x when x = Uri.empty -> (fun _ _ -> ())
| x when Uri.scheme x = Some "msg+http" -> pull_msgs Uri.(with_scheme x (Some "http"))
| x when Uri.scheme x = Some "msg+https"-> pull_msgs Uri.(with_scheme x (Some "https"))
| x -> pull_index x
let pull_list auths topics =
let pull peer_url () = pull_url peer_url auths topics in
let open Logarion.Peers in
fold_file pull () public_fname;
fold_file pull () private_fname
let pull = function "" -> pull_list | x -> pull_url x
open Cmdliner
let pull_term =
let authors = Arg.(value & opt (some string) None & info ["a"; "authors"] ~docv:"AUTHORS" ~doc:"select authors") in
let topics = Arg.(value & opt (some string) None & info ["t"; "topics"] ~docv:"TOPICS" ~doc:"select topics") in
let url = Arg.(value & pos 0 string "" & info [] ~docv:"URL" ~doc:"HTTP URL of Logarion") in
Term.(const pull $ url $ authors $ topics),
Term.info "pull" ~doc:"pull listed texts" ~man:[ `S "DESCRIPTION"; `P "Pull texts from archive at address"]

33
lib/archive.ml Normal file
View 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
View 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
View 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
View file

@ -0,0 +1,4 @@
(library
(name logarion)
(public_name logarion)
(libraries ptime uuidm uri re.str bos text_parse text_parse.parsers msgpck))

166
lib/file_store.ml Normal file
View file

@ -0,0 +1,166 @@
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 extension = ".txt"
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 file path content = let out = open_out path in
output_string out content; close_out out
let (//) a b = a ^ "/" ^ b
let to_text path =
if Filename.extension path = extension then
(to_string path |> Text.of_string |> Result.map_error (fun m -> path ^": "^ m))
else Error "Not txt"
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 (Filename.concat store f)
with Ok t -> fn store t f | Error s -> prerr_endline s in
List.iter link paths
let iter_valid_text pred fn p =
match to_text p with Error _ -> () | Ok t -> if pred t then fn (t, p)
let fold_valid_text pred fn acc p =
match to_text p with Error _ -> acc | Ok t -> if pred t then fn acc (t, p) else acc
let list_fs dir =
let rec loop result = function
| [] -> result
| f::fs when Sys.is_directory f ->
Array.map (Filename.concat f) (Sys.readdir f)
|> Array.to_list |> List.append fs |> loop result
| f::fs -> loop (f::result) fs
in loop [] [dir]
let list_take n =
let rec take acc n = function [] -> []
| x::_ when n = 1 -> x::acc
| x::xs -> take (x::acc) (n-1) xs
in take [] n
let iter ?(predicate=fun _ -> true) ?order ?number fn {store;_} =
match order with
| None -> List.iter (iter_valid_text predicate fn) @@ list_fs store
| Some comp ->
List.iter fn
@@ (match number with None -> (fun x -> x) | Some n -> list_take n)
@@ List.fast_sort comp
@@ List.fold_left (fold_valid_text predicate (fun a e -> List.cons e a)) []
@@ list_fs store
let fold ?(predicate=fun _ -> true) ?order ?number fn acc {store;_} =
match order with
| None -> List.fold_left (fold_valid_text predicate fn) acc @@ list_fs store
| Some comp ->
List.fold_left fn acc
@@ (match number with None -> (fun x -> x) | Some n -> list_take n)
@@ List.fast_sort comp
@@ List.fold_left (fold_valid_text predicate (fun a e -> List.cons e a)) []
@@ list_fs store
let with_id { store; _ } id =
let matched acc path =
match to_text path with
| Error x -> prerr_endline x; acc
| Ok text when text.Text.uuid <> id -> acc
| Ok text ->
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 List.fold_left matched (Ok None) (list_fs 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 with_text {store;_} new_text =
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_config () =
"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"] 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_config ());
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 = try Sys.getenv "LOGARION_DIR" with Not_found -> "."
}
)

84
lib/header_pack.ml Normal file
View file

@ -0,0 +1,84 @@
type info_t = { version: int; name: string; archivists: string list }
type text_t = { id: Msgpck.t; time: Msgpck.t; title: Msgpck.t; authors: Msgpck.t }
type t = { info: info_t; fields: string list; texts: Msgpck.t; peers: Msgpck.t }
let of_id id = Msgpck.Bytes (Id.to_bytes id)
let to_id pck_id = Id.of_bytes Msgpck.(to_bytes pck_id)
let person p = Msgpck.String (Person.to_string p)
let persons ps = List.rev @@ Person.Set.fold (fun p a -> person p :: a) ps []
let of_set field t =
List.rev @@ String_set.fold (fun s a -> Msgpck.String s :: a) (Text.set field t) []
let date = function
| None -> Int32.zero
| Some date ->
let days, ps = Ptime.Span.to_d_ps (Ptime.to_span date) in
Int32.add Int32.(mul (of_int days) 86400l) Int64.(to_int32 (div ps 1000000000000L))
let to_sec = function
Msgpck.Int i -> Int32.of_int i | Msgpck.Uint32 i -> i | x -> Msgpck.to_uint32 x
let public_peers () =
Peers.fold_file (fun x a -> Msgpck.String x :: a) [] Peers.public_fname
let fields = Msgpck.(List [String "id"; String "time"; String "title"; String "authors"; String "topics"])
let to_fields fieldpack = List.map Msgpck.to_string (Msgpck.to_list fieldpack)
let to_pack a t =
let open Text in
Msgpck.(List [
Bytes (Id.to_bytes t.uuid); of_uint32 (date (Date.listing t.date));
String t.title; List (persons t.authors); List (of_set "topics" t)
]) :: a
let pack_filename ?(filename="index.pck") archive =
let dir = Store.KV.find "Export-Dir" archive.File_store.kv in (*raises Not_found*)
dir ^ "/" ^ filename
let to_info = function
| Msgpck.List (v::n::a::[]) ->
let archivists = List.map Msgpck.to_string (Msgpck.to_list a) in
Msgpck.({version = to_int v; name = to_string n; archivists})
| _ -> invalid_arg "Pack header"
let unpack = function
| Msgpck.List (i::f::texts::[]) ->
Some { info = to_info i; fields = to_fields f; texts; peers = Msgpck.List [] }
| Msgpck.List (i::f::texts::peers::[]) ->
Some { info = to_info i; fields = to_fields f; texts; peers }
| _ -> None
let list filename = try
let texts_list = function
| Msgpck.List (_info :: _fields :: [texts]) -> Msgpck.to_list texts
| _ -> prerr_endline "malformed feed"; [] in
let _pos, data = Msgpck.StringBuf.read @@ File_store.to_string filename in
Ok (texts_list data)
with Not_found -> Error "unspecified export dir"
let contains text = function
| Msgpck.List (id::_time::title::_authors::_topics::[]) ->
(match Id.of_bytes (Msgpck.to_bytes id) with
| None -> prerr_endline ("Invalid id for " ^ Msgpck.to_string title); false
| Some id -> text.Text.uuid = id)
| _ -> prerr_endline ("Invalid record pattern"); false
let pack archive records =
let header_pack = List.fold_left to_pack [] records in
let info = Msgpck.(List [Int 0; String archive.File_store.name; List (persons archive.archivists)]) in
Bytes.to_string @@ Msgpck.Bytes.to_string
(List [info; fields; Msgpck.List header_pack; Msgpck.List (public_peers ())])
let add archive records =
let fname = pack_filename archive in
let append published (t, _f) = if List.exists (contains t) published then published else to_pack published t in
match list fname with Error e -> prerr_endline e | Ok published_list ->
let header_pack = List.fold_left append published_list records in
let archive = Msgpck.(List [Int 0; String archive.File_store.name;
List (persons archive.archivists)]) in
File_store.file fname @@ Bytes.to_string
@@ Msgpck.Bytes.to_string (List [archive; fields; Msgpck.List header_pack])
let unpublish _archive _records = ()

9
lib/id.ml Normal file
View 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

9
lib/peers.ml Normal file
View file

@ -0,0 +1,9 @@
let public_fname = "peers.pub.conf"
let private_fname = "peers.priv.conf"
let fold_file fn init file = match open_in file with
| exception (Sys_error msg) -> prerr_endline msg; init
| file ->
let rec read acc = try read (fn (input_line file) acc)
with End_of_file -> close_in file; acc in
read init

31
lib/person.ml Normal file
View 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
View 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 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) -> ?number:int
-> (record_t -> unit) -> archive_t -> unit
val fold: ?predicate:(Text.t -> bool) -> ?order:(record_t -> record_t -> int) -> ?number:int
-> ('a -> record_t -> 'a) -> 'a -> archive_t -> 'a
end

15
lib/string_set.ml Normal file
View 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

102
lib/text.ml Normal file
View file

@ -0,0 +1,102 @@
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;