Browse Source

- Removed 'txt init'

Format

- New B32 ID

Index

- New option: txt index --print
- Move scheme to peers
- Replace peer.*.conf files with index packed locations
  Instead of adding a URL to peers.*.conf, run `txt pull <url>`

Conversion

- Rewritten converters
- txt-convert looks for a .convert.conf containing `key: value` lines.
- Specifiable topic-roots from .convert.conf.
- Added `Topics:` key, with comma seperated topics.
	If set only those topics will appear in the main index and used as topic roots.
	Other topics will have sub-indices generated, but won't be listed in the main index.
- HTML converter header & footer options
- HTML-index renamed to HTM-index

Internal

- Change types: uuid:Uuid -> id:string
- File_store merges identical texts
- Use peer ID for store path, store peers' texts in .local/share/texts
- Simple URN resolution for converter
	Continue to next feed if parsing one fails
- Phasing-out Archive, replaced by improved packs
- Eliminate Bos, Cohttp, lwt, uri, tls, Re, Ptime, dependencies
- Lock version for Cmdliner, fix dune-project
- Optional resursive store
- Improve header_pack
- Fix recursive mkdir
master
orbifx 2 months ago
parent
commit
e878dedbb6
  1. 6
      Makefile
  2. 8
      cli/atom.ml
  3. 17
      cli/authors.ml
  4. 142
      cli/cli.ml
  5. 14
      cli/conversion.ml
  6. 135
      cli/convert.ml
  7. 6
      cli/dune
  8. 39
      cli/file.ml
  9. 39
      cli/gemini.ml
  10. 100
      cli/html.ml
  11. 59
      cli/index.ml
  12. 24
      cli/last.ml
  13. 38
      cli/listing.ml
  14. 27
      cli/new.ml
  15. 160
      cli/pull.ml
  16. 17
      cli/topics.ml
  17. 19
      cli/txt.ml
  18. 11
      dune-project
  19. 4
      http/dune
  20. 143
      http/http.ml
  21. 40
      lib/archive.ml
  22. 20
      lib/date.ml
  23. 2
      lib/dune
  24. 202
      lib/file_store.ml
  25. 104
      lib/header_pack.ml
  26. 42
      lib/id.ml
  27. 26
      lib/peers.ml
  28. 13
      lib/person.ml
  29. 2
      lib/store.ml
  30. 2
      lib/string_set.ml
  31. 152
      lib/text.ml
  32. 2
      lib/topic_set.ml
  33. 18
      logarion.opam
  34. 35
      readme

6
Makefile

@ -2,7 +2,7 @@ all:
dune build
cli:
dune build cli/cli.exe
dune build cli/txt.exe
clean:
dune clean
@ -10,9 +10,9 @@ clean:
tgz:
dune subst
dune build
cp _build/default/cli/cli.exe txt
cp _build/default/cli/txt.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
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

8
cli/atom.ml

@ -9,11 +9,11 @@ let opt_element tag_name content =
module P = Parsers.Plain_text.Make (Converter.Html)
let id txt = "<id>urn:uuid:" ^ Logarion.(Id.to_string txt.Text.uuid) ^ "</id>"
let id txt = "<id>urn:uuid:" ^ Logarion.(txt.Text.id) ^ "</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 u acc addr = acc ^ element "uri" addr in
let open Logarion in
let fn txt a =
a ^ "<author>" ^ (opt_element "name" @@ esc txt.Person.name)
@ -51,7 +51,7 @@ let feed title archive_id base_url alternate_type texts =
{|<?xml version="1.0" encoding="utf-8"?><feed xmlns="http://www.w3.org/2005/Atom" xml:base="|} ^ base_url ^ {|"><title>|}
^ title ^ {|</title><link rel="alternate" type="|} ^ 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"
^ self ^ {|" /><id>urn:uuid:|} ^ archive_id ^ "</id><updated>"
^ Logarion.Date.now () ^ "</updated>\n"
^ List.fold_left (fun acc t -> acc ^ entry base_url t) "" texts
^ "</feed>"

17
cli/authors.ml

@ -0,0 +1,17 @@
open Logarion
let authors r topics_opt =
let predicates = Archive.(predicate topics topics_opt) in
let predicate text = List.fold_left (fun a e -> a && e text) true predicates in
let author_union a (e, _) = Person.Set.union a e.Text.authors in
let s = File_store.fold ~r ~predicate author_union Person.Set.empty in
Person.Set.iter (fun x -> print_endline (Person.to_string x)) s
open Cmdliner
let term =
let recurse = Arg.(value & flag & info ["R"]
~doc:"include texts in subdirectories too") in
let topics = Arg.(value & opt (some string) None & info ["topics"]
~docv:"TOPICS" ~doc:"display authors who have written on topics") in
Term.(const authors $ recurse $ topics),
Term.info "authors" ~doc:"list authors"
~man:[ `S "DESCRIPTION"; `P "List author names" ]

142
cli/cli.ml

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

14
cli/conversion.ml

@ -0,0 +1,14 @@
open Logarion
type t = {
id: string; dir: string;
kv: string Store.KV.t;
topic_roots: string list;
topics: (String_set.t * String_set.t) Topic_set.Map.t;
texts: Text.t list
}
type fn_t = {
ext: string;
page: t -> Logarion.Text.t -> string;
indices: t -> unit;
}

135
cli/convert.ml

@ -1,90 +1,67 @@
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 is_older source dest = try
Unix.((stat dest).st_mtime < (stat source).st_mtime) with _-> true
let word_fname dir text = dir ^ "/" ^ Text.alias text
let id_fname dir text = dir ^ "/" ^ Text.short_id text
let convert cs r (text, files) = match Text.str "Content-Type" text with
| "" | "text/plain" ->
let source = List.hd files in
let dest = Filename.concat r.Conversion.dir (Text.short_id text) in
List.fold_left
(fun a f ->
let dest = dest ^ f.Conversion.ext in
if is_older source dest then (File_store.file dest (f.Conversion.page r text); true) else false
|| a)
false cs
| x -> Printf.eprintf "Can't convert Content-Type: %s file: %s" x text.Text.title; false
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 converters types kv =
let t = [] in
let t = if ("htm" = types || "all" = types) then
(let htm = Html.init kv in
Conversion.{ ext = Html.ext; page = Html.page htm; indices = Html.indices htm })::t
else t in
let t = if ("gmi" = types || "all" = types) then
Conversion.{ ext = Gemini.ext; page = Gemini.page; indices = Gemini.indices}::t else t in
t
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 convert_all converters noindex dir id kv =
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 repo = Conversion.{ id; dir; kv; topic_roots = []; topics = empty; texts = [] } in
let fn (ts,ls,acc) ((elt,_) as r) =
(Topic_set.to_map ts (Text.set "topics" elt)), elt::ls,
if convert converters repo r then acc+1 else acc in
let topics, texts, count = File_store.(fold ~dir ~order:newest fn (empty,[],0)) in
let topic_roots = try List.rev @@ String_set.list_of_csv (Store.KV.find "Topics" kv)
with Not_found -> Topic_set.roots topics in
let repo = Conversion.{ repo with topic_roots; topics; texts } in
if not noindex then List.iter (fun c -> c.Conversion.indices repo) converters;
Printf.printf "Converted: %d Indexed: %d\n" count (List.length texts)
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
let convert_dir types noindex dir =
match dir with "" -> prerr_endline "unspecified dir"
| dir ->
let fname = Filename.concat dir "index.pck" in
match Header_pack.of_string @@ File_store.to_string fname with
| Error s -> prerr_endline s
| Ok { info; _ } ->
let kv = let f = Filename.concat dir ".convert.conf" in (* TODO: better place to store convert conf? *)
if Sys.file_exists f then File_store.of_kv_file f else Store.KV.empty in
let kv = if Store.KV.mem "Title" kv then kv
else Store.KV.add "Title" info.Header_pack.title kv in
let kv = Store.KV.add "Locations" (String.concat ";\n" info.Header_pack.locations) kv in
let cs = converters types kv in
convert_all cs noindex dir info.Header_pack.id kv
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
let directory = Arg.(value & pos 0 string "" & info [] ~docv:"target directory"
~doc:"Directory to convert") 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 create indices in target format") in
Term.(const convert_dir $ types $ noindex $ directory),
Term.info "convert" ~doc:"convert archive" ~man:[ `S "DESCRIPTION"; `P "Convert Logarion archive" ]
Term.info "convert" ~doc:"convert txts"
~man:[ `S "DESCRIPTION"; `P "Convert texts within a directory to another format.
Directory must contain an index.pck. Run `txt index` first." ]

6
cli/dune

@ -1,5 +1,5 @@
(executable
(name cli)
(name txt)
(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))
(modules txt authors convert conversion file index last listing new topics html atom gemini pull)
(libraries text_parse.converter text_parse.parsers logarion msgpck curl str cmdliner))

39
cli/file.ml

@ -0,0 +1,39 @@
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
open Logarion
let file files =
let dirs, files = split_filetypes files in
let _link_as_named dir file = Unix.link file (Filename.concat 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 (Filename.concat dir (Text.short_id t^".txt")) in
let link = link_with_id in
List.iter (fun d -> List.iter (link d) files) dirs
let unfile files =
let dirs, files = split_filetypes files in
let unlink dir file = try Unix.unlink (Filename.concat dir file)
with Unix.(Unix_error(ENOENT,_,_))-> () in
List.iter (fun d -> List.iter (unlink d) files) dirs
open Cmdliner
let term =
let files = Arg.(value & pos_all string [] & info []
~docv:"text filenames and subdirectories") in
Term.(const file $ files), Term.info "file"
~doc:"file texts in subdirectories"
~man:[ `S "DESCRIPTION"; `P "Files all texts in parameter in every
directory in parameter, using hardlinks.
Use it to create sub-repositories for sharing or converting" ]
let unfile_term =
let files = Arg.(value & pos_all string [] & info []
~docv:"text filenames and subdirectories") in
Term.(const unfile $ files), Term.info "unfile"
~doc:"unfile texts from subdirectories"
~man:[ `S "DESCRIPTION"; `P "unfile texts in parameter from
directories in parameter, by removing hardlinks" ]

39
cli/gemini.ml

@ -1,9 +1,17 @@
let page _archive_title text =
let ext = ".gmi"
module GeminiConverter = struct
include Converter.Gemini
let angled_uri u a = if String.sub u 0 10 <> "urn:txtid:" then
angled_uri u a else angled_uri (String.(sub u 10 (length u - 10)) ^ ext) a
end
let page _conversion 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
^ let module T = Parsers.Plain_text.Make (GeminiConverter) in
"\n" ^ T.of_string text.body ""
let date_index title meta_list =
@ -30,8 +38,9 @@ let to_dated_links ?(limit) meta_list =
^ m.Logarion.Text.title ^ "\n")
"" meta_list
let topic_link root topic =
"=> index." ^ root ^ ".gmi " ^ String.capitalize_ascii topic ^ "\n"
let topic_link root topic =
let replaced_space = String.map (function ' '->'+' | x->x) in
"=> index." ^ replaced_space root ^ ".gmi " ^ String.capitalize_ascii topic ^ "\n"
let text_item path meta =
let open Logarion in
@ -71,3 +80,25 @@ let topic_main_index title topic_roots metas =
let topic_sub_index title topic_map topic_root metas =
"# " ^ title ^ "\n\n"
^ listing_index topic_map [topic_root] "" metas
let indices r =
let open Logarion in
let file name = File_store.file (Filename.concat r.Conversion.dir name) in
let index_name = try Store.KV.find "Gemini-index" r.kv with Not_found -> "index.gmi" in
let title = try Store.KV.find "Title" r.Conversion.kv with Not_found -> "" in
if index_name <> "" then
file index_name (topic_main_index title r.topic_roots r.texts);
file "index.date.gmi" (date_index title r.texts);
List.iter
(fun topic -> file ("index." ^ topic ^ ".gmi")
(topic_sub_index title r.topics topic r.texts))
r.topic_roots;
let base_url = try
let _i = Str.(search_forward (regexp "gemini?://[^;]*") (Store.KV.find "Locations" r.kv) 0) in
Str.(matched_string (Store.KV.find "Locations" r.kv))
with Not_found -> prerr_endline "Missing location for Gemini"; "" in
file "gmi.atom" (Atom.feed title r.id base_url "text/gemini" r.texts)

100
cli/html.ml

@ -1,26 +1,57 @@
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>"
type templates_t = { header: string option; footer: string option }
type t = { templates : templates_t }
let ext = ".htm"
let empty_templates = { header = None; footer = None }
let default_opts = { templates = empty_templates }
let init kv =
let open Logarion in
let header = match Store.KV.find "HTM-header" kv with
| fname -> Some (File_store.to_string fname)
| exception Not_found -> None in
let footer = match Store.KV.find "HTM-footer" kv with
| fname -> Some (File_store.to_string fname)
| exception Not_found -> None in
{ templates = { header; footer} }
let wrap c htm text_title body =
let site_title = try Logarion.Store.KV.find "Title" c.Conversion.kv
with Not_found -> "" in
let replace x = let open Str in
global_replace (regexp "{{archive-title}}") site_title x
|> global_replace (regexp "{{text-title}}") text_title
in
let header = match htm.templates.header with
| Some x -> replace x
| None -> "<header><a href='.'>" ^ site_title ^
"</a><nav><a href='feed.atom' id='feed'>feed</a></nav></header>"
in
let footer = match htm.templates.footer with None -> "" | Some x -> replace x in
"<!DOCTYPE HTML><html><head><title>" ^ text_title ^ " โ€ข " ^ site_title ^ "</title>\n\
<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>\n" ^ header ^ body ^ footer ^ "</body></html>"
let topic_link root topic =
let replaced_space = String.map (function ' '->'+' | x->x) in
{|<a href="index.|} ^ root ^ {|.htm#|} ^ replaced_space topic ^ {|">|}
"<a href='index." ^ replaced_space root ^ ".htm#" ^ replaced_space topic ^ "'>"
^ String.capitalize_ascii topic ^ "</a>"
let page archive_title text =
module HtmlConverter = struct
include Converter.Html
let angled_uri u a = if String.sub u 0 10 <> "urn:txtid:" then
angled_uri u a else angled_uri (String.(sub u 10 (length u - 10)) ^ ext) a
end
let page htm conversion text =
let open Logarion in
let open Text in
let module T = Parsers.Plain_text.Make (Converter.Html) in
let module T = Parsers.Plain_text.Make (HtmlConverter) 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 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
@ -38,9 +69,9 @@ let page archive_title text =
^ 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)
^ opt_kv "Id: " text.id
^ {|</dl></header><pre style="white-space:pre-wrap">|} in
wrap archive_title text.title ((T.of_string text.body header) ^ "</pre></article>")
wrap conversion htm text.title ((T.of_string text.body header) ^ "</pre></article>")
let to_dated_links ?(limit) meta_list =
let meta_list = match limit with
@ -57,10 +88,10 @@ let to_dated_links ?(limit) meta_list =
^ {|<a href="|} ^ Logarion.Text.short_id m ^ {|.htm">|} ^ m.Logarion.Text.title ^ "</a><br>")
"" meta_list
let date_index ?(limit) title meta_list =
let date_index ?(limit) conv htm 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)
| Some limit -> wrap conv htm "Index" (to_dated_links ~limit meta_list)
| None -> wrap conv htm "Index" (to_dated_links meta_list)
let fold_topic_roots topic_roots =
let list_item root t = "<li>" ^ topic_link root t in
@ -112,14 +143,35 @@ let listing_index topic_map topic_roots path metas =
in
"<nav><h1>Texts</h1>" ^ item_group topic_roots ^ "</nav>"
let topic_main_index title topic_roots metas =
wrap title "Topics"
let topic_main_index conv htm topic_roots metas =
wrap conv htm "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
let topic_sub_index conv htm topic_map topic_root metas =
wrap conv htm 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)
open Logarion
let indices htm c =
let file name = Logarion.File_store.file (Filename.concat c.Conversion.dir name) in
let index_name = try Store.KV.find "HTM-index" c.Conversion.kv with Not_found -> "index.html" in
let title = try Store.KV.find "Title" c.Conversion.kv with Not_found -> "" in
if index_name <> "" then
file index_name (topic_main_index c htm c.topic_roots c.texts);
file "index.date.htm" (date_index c htm c.texts);
List.iter
(fun root -> file ("index." ^ root ^ ".htm") (topic_sub_index c htm c.topics root c.texts))
c.topic_roots;
let base_url = try
let _i = Str.(search_forward (regexp "https?://[^;]*") (Store.KV.find "Locations" c.kv) 0) in
Str.(matched_string (Store.KV.find "Locations" c.kv))
with Not_found -> prerr_endline "Missing location for HTTP(S)"; "" in
file "feed.atom" (Atom.feed title c.id base_url "text/html" c.texts)

59
cli/index.ml

@ -0,0 +1,59 @@
open Logarion
let index print title authors locations peers dir =
let fname = Filename.concat dir "index.pck" in
let pck = match Header_pack.of_string @@ File_store.to_string fname with
| Error s -> failwith s
| Ok pck -> let info = Header_pack.{ pck.info with
title = if title <> "" then title else pck.info.title;
people = if authors <> ""
then (String_set.list_of_csv authors) else pck.info.people;
locations = if locations <> ""
then (String_set.list_of_csv locations) else pck.info.locations;
} in
Header_pack.{ info; fields;
texts = of_text_list @@ File_store.fold ~dir
(fun a (t,_) -> of_text a t) [];
peers = if peers <> ""
then (str_list @@ String_set.list_of_csv peers) else pck.peers;
}
| exception (Sys_error _) -> Header_pack.{
info = {
version = version; id = Id.generate (); title;
people = String_set.list_of_csv authors;
locations = String_set.list_of_csv locations };
fields;
texts = of_text_list @@ File_store.fold ~dir
(fun a (t,_) -> of_text a t) [];
peers = str_list @@ String_set.list_of_csv peers;
} in
File_store.file fname (Header_pack.string pck);
let open Header_pack in
let s ss = String.concat "\n\t" ss in
if print then
Printf.printf "Title: %s\nAuthors: %s\nLocations:\n\t%s\nPeers:\n\t%s\n"
pck.info.title (String.concat "," pck.info.people)
(s pck.info.locations) (s (to_str_list pck.peers))
open Cmdliner
let term =
let print = Arg.(value & flag & info ["print"] ~doc:"print info") in
let title= Arg.(value & opt string "" & info ["t"; "title"]
~docv:"string" ~doc:"Title for index") in
let auth = Arg.(value & opt string "" & info ["a"; "authors"]
~docv:"comma-separated names" ~doc:"Index authors") in
let locs = Arg.(value & opt string "" & info ["l"; "locations"]
~docv:"comma-separated URLs" ~doc:"repository URLs") in
let peers= Arg.(value & opt string "" & info ["p"; "peers"]
~docv:"comma-separated URLs" ~doc:"URLs to other known text repositories") in
let dir = Arg.(value & pos 0 string "." & info []
~docv:"directory to index") in
let doc = "Generate an index.pck for texts in a directory" in
Term.(const index $ print $ title $ auth $ locs $ peers $ dir),
Term.info "index" ~doc
~man:[ `S "DESCRIPTION"; `Pre "An index contains:\n
* an info section with: title for the index, the authors, locations (URLs) the texts can be access\n
* listing of texts with: ID, date, title, authors, topics\n
* list of other text repositories (peers)\n\n
MessagePack format. <msgpack.org>" ]

24
cli/last.ml

@ -0,0 +1,24 @@
open Logarion
let 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
let last_mine a ((t,_) as pair) =
let name = Person.Set.of_string (Sys.getenv "USER") in
let open Text in
match a with
| None -> if Person.Set.subset name t.authors then Some pair else None
| Some (t', _) as pair' ->
if Text.newest t t' > 0 && Person.Set.subset name t'.authors
then Some pair else pair'
in
match File_store.fold (if search_mine then last_mine else last) None with
| Some (_,f) -> List.iter print_endline f | None -> ()
open Cmdliner
let term =
let mine = Arg.(value & flag & info ["mine"]
~doc:"last text authored by me") in
Term.(const last $ mine),
Term.info "last" ~doc:"most recent text"
~man:[ `S "DESCRIPTION"; `P "Print the filename of most recent text" ]

38
cli/listing.ml

@ -0,0 +1,38 @@
open Logarion
module FS = File_store
module A = Archive
let listing r order_opt reverse_opt number_opt authors_opt topics_opt =
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 list_text a (t, fnames) = a ^ Printf.sprintf "%s %s %s ๐„ %s [%s]\n"
(Text.short_id t) Date.(pretty_date @@ listing t.Text.date)
(Person.Set.to_string ~names_only:true t.Text.authors)
t.Text.title (List.hd fnames)
in
print_string @@ match order_opt with
| false -> FS.fold ~r ~predicate list_text ""
| true ->
let order = match reverse_opt with true -> FS.newest | false -> FS.oldest in
match number_opt with
| Some number -> FS.fold ~r ~predicate ~order ~number list_text ""
| None -> FS.fold ~r ~predicate ~order list_text ""
open Cmdliner
let term =
let recurse = Arg.(value & flag & info ["R"]
~doc:"recursive, include texts in subdirectories too") in
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 authed = Arg.(value & opt (some string) None & info ["authored"]
~docv:"comma-separated names" ~doc:"texts by authors") in
let topics = Arg.(value & opt (some string) None & info ["topics"]
~docv:"comma-separated topics" ~doc:"texts with topics") in
Term.(const listing $ recurse $ time $ reverse $ number $ authed $ topics),
Term.info "list" ~doc:"list texts" ~man:[ `S "DESCRIPTION";
`P "List header information for current directory. If -R is used, list header
information for texts found in subdirectories too, along with their filepaths" ]

27
cli/new.ml

@ -0,0 +1,27 @@
open Logarion
open Cmdliner
let new_txt title topics_opt interactive =
let t = match title with "" -> "Draft" | _ -> title in
let authors = Person.Set.of_string (Sys.getenv "USER") in
let text = { (Text.blank ()) with title = t; authors } in
let text = try Text.with_str_set text "Topics" (Option.get topics_opt)
with _ -> text in
match File_store.with_text text with
| Error s -> prerr_endline s
| Ok (filepath, _note) ->
if not interactive then print_endline filepath
else
(print_endline @@ "Created: " ^ filepath;
Sys.command ("$EDITOR " ^ filepath) |> ignore)
let term =
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:"comma-separated topics" ~doc:"Topics for new article") in
let inter = Arg.(value & flag & info ["i"; "interactive"]
~doc:"Prompts through the steps of creation") in
Term.(const new_txt $ title $ topics $ inter), Term.info "new"
~doc:"create a new article" ~man:[ `S "DESCRIPTION";
`P "Create a new article, with title 'Draft' when none provided"]

160
cli/pull.ml

@ -0,0 +1,160 @@
let writer accum data =
Buffer.add_string accum data;
String.length data
let showContent content =
Printf.printf "%s" (Buffer.contents content);
flush stdout
let showInfo connection =
Printf.printf "Time: %f for: %s\n"
(Curl.get_totaltime connection)
(Curl.get_effectiveurl connection)
let getContent connection url =
Curl.set_url connection url;
Curl.perform connection
let curl_pull url =
let result = Buffer.create 4069
and errorBuffer = ref "" in
let connection = Curl.init () in
try
Curl.set_errorbuffer connection errorBuffer;
Curl.set_writefunction connection (writer result);
Curl.set_followlocation connection true;
Curl.set_url connection url;
Curl.perform connection;
(* showContent result;*)
(* showInfo connection;*)
Curl.cleanup connection;
Ok result
with
| Curl.CurlException (_reason, _code, _str) ->
Curl.cleanup connection;
Error (Printf.sprintf "Error: %s %s" url !errorBuffer)
| Failure s ->
Curl.cleanup connection;
Error (Printf.sprintf "Caught exception: %s" s)
let newer time id dir =
match Logarion.File_store.to_text @@ Filename.(concat dir (Logarion.Id.short id) ^ ".txt") with
| Error x -> prerr_endline x; true
| Ok txt -> time > (Logarion.(Header_pack.date (Date.listing txt.date)))
| exception (Sys_error _) -> true
let print_peers p =
let open Logarion.Header_pack in
match Msgpck.to_list p.peers with [] -> ()
| ps -> print_endline @@
List.fold_left (fun a x -> Printf.sprintf "%s %s" a (Msgpck.to_string x)) "peers: " ps
let parse_index _is_selected fn url dir p =
let open Logarion.Header_pack in
match Msgpck.to_list p.texts with
| [] -> Printf.printf "%s => %s, has empty index\n" p.info.title dir; false
| texts ->
let numof_texts = string_of_int @@ List.length texts in
let text_num_len = String.length numof_texts in
Printf.printf "%*d/%s %s => %s\r" text_num_len 0 numof_texts p.info.title dir;
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.Header_pack.to_id id with
| "" -> Printf.eprintf "Invalid id for%s " (Msgpck.to_string title)
| 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 ();
true
let fname dir text = Filename.concat dir (Logarion.Text.short_id text ^ ".txt")
let pull_text url dir id =
let u = Filename.concat url ((Logarion.Id.short id) ^ ".txt") in
match curl_pull u with
| Error msg -> Printf.eprintf "Failed getting %s: %s" u msg
| Ok txt ->
let txt = Buffer.contents txt in
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
let pull_index url _authors _topics =
let index_url = url ^ "/index.pck" in
match curl_pull index_url with
| Error s -> prerr_endline s; false
| Ok body ->
match Logarion.Header_pack.of_string (Buffer.contents body) with
| Error s -> Printf.printf "Error with %s: %s\n" url s; false
| Ok pk ->
let dir = Filename.concat Logarion.Peers.text_dir pk.info.id in
Logarion.File_store.with_dir dir;
let file = open_out_gen [Open_creat; Open_trunc; Open_wronly] 0o640 (Filename.concat dir "index.pck") in
output_string file ( Logarion.Header_pack.string {
pk with info = { pk.info with locations = url::pk.info.locations }});
close_out file;
(* 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
try parse_index is_selected pull_text url dir pk with
Invalid_argument msg -> Printf.eprintf "Failed to parse: %s\n%!" msg; false
let pull_list auths topics =
Curl.global_init Curl.CURLINIT_GLOBALALL;
let pull got_one peer_url = if got_one then got_one else
(pull_index peer_url auths topics) in
Logarion.Peers.fold pull false;
Curl.global_cleanup ()
let pull url auths topics = match url with
| "" -> pull_list auths topics | x -> ignore (pull_index x auths topics)
open Cmdliner
let term =
let authors = Arg.(value & opt (some string) None & info ["a"; "authors"]
~docv:"comma-separated names" ~doc:"filter by authors") in
let topics = Arg.(value & opt (some string) None & info ["t"; "topics"]
~docv:"comma-separated topics" ~doc:"filter by topics") in
let url = Arg.(value & pos 0 string "" & info [] ~docv:"URL"
~doc:"Repository location") in
Term.(const pull $ url $ authors $ topics),
Term.info "pull" ~doc:"pull listed texts" ~man:[ `S "DESCRIPTION";
`P "Pull texts from known repositories. To add a new repository use:";
`P "txt pull [url]";
`P ("This creates a directory in " ^ Logarion.Peers.text_dir
^ " and downloads the text index.pck file in it")]
(*module Msg = struct*)
(* type t = string * string*)
(* let compare (x0,y0) (x1,y1) =*)
(* match 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 ->*)
(* Printf.eprintf "Failed index request for %s %s" 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*)
(* let msg_string = MsgSet.fold*)
(* (fun (t,m) a -> a ^ Printf.sprintf " %s ๐„ %s\n" (date_string t) m)*)
(* msgs "" in*)
(* Printf.printf "โ”Œโ”€โ”€โ”€{ %s }โ”€โ”€โ”€โ”\n%s" url msg_string*)

17
cli/topics.ml

@ -0,0 +1,17 @@
open Logarion
let topics r authors_opt =
let predicates = Archive.(predicate authored authors_opt) in
let predicate text = List.fold_left (fun a e -> a && e text) true predicates in
let topic_union a (e, _) = String_set.union a (Text.set "topics" e) in
let s = File_store.fold ~r ~predicate topic_union String_set.empty in
print_endline @@ String_set.to_string s
open Cmdliner
let term =
let recurse = Arg.(value & flag & info ["R"]
~doc:"include texts in subdirectories") in
let authed = Arg.(value & opt (some string) None & info ["authored"]
~docv:"comma-separated authors" ~doc:"topics by authors") in
Term.(const topics $ recurse $ authed),
Term.info "topics" ~doc:"list topics" ~man:[ `S "DESCRIPTION";
`P "List of topics" ]

19
cli/txt.ml

@ -0,0 +1,19 @@
let version = "%%VERSION%%"
open Cmdliner
let default_cmd =
let doc = "Discover, collect & exchange texts" in
let man = [ `S "Contact"; `P "<mailto:fox@orbitalfox.eu?subject=Logarion>" ] in
Term.(ret (const (`Help (`Pager, None)))), Term.info "txt" ~version ~doc ~man
let () = match Term.eval_choice default_cmd [
Authors.term;
Convert.term;
File.term; File.unfile_term;
Index.term;
Last.term;
Listing.term;
New.term;
Pull.term;
Topics.term;
] with `Error _ -> exit 1 | _ -> exit 0

11
dune-project

@ -1,16 +1,13 @@
(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:")
(maintainers "orbifx <fox@orbitalfox.eu>")
(homepage "http://logarion.orbitalfox.eu")
(source (uri git+https://git.disroot.org/orbifx/logarion.git))
(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))
(depends text_parse (cmdliner (<= 1.0.4)) msgpck ocurl))

4
http/dune

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

143
http/http.ml

@ -1,143 +0,0 @@
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"]

40
lib/archive.ml

@ -1,33 +1,13 @@
(*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