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`.master
parent
3d92789cdb
commit
22fe21326f
@ -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/
|
@ -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
|
||||
|
@ -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)
|
@ -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>"
|
@ -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
|
@ -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" ]
|
@ -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))
|
@ -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
|
@ -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)
|
@ -1,3 +0,0 @@
|
||||
Logarion
|
||||
Ymd
|
||||
Web
|
@ -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))
|
@ -0,0 +1,4 @@
|
||||
(library
|
||||
(name http)
|
||||
(public_name logarion.http)
|
||||
(libraries logarion uri cmdliner lwt cohttp cohttp-lwt cohttp-lwt-unix tls msgpck))
|
@ -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"]
|
@ -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
|
@ -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
|
@ -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 -> ""
|
@ -0,0 +1,4 @@
|
||||
(library
|
||||
(name logarion)
|
||||
(public_name logarion)
|
||||
(libraries ptime uuidm uri re.str bos text_parse text_parse.parsers msgpck))
|
@ -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 -> "."
|
||||
}
|
||||
)
|
@ -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 = ()
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
@ -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
|
@ -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;
|
||||
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)
|
||||