From 4dff69cb4af803b41de8912c0bdcebf20968e558 Mon Sep 17 00:00:00 2001 From: fox Date: Thu, 15 Dec 2022 21:25:18 +0000 Subject: [PATCH] Preliminary support for cross-domain references git-svn-id: file:///srv/svn/repo/kosuzu/trunk@42 eb64cd80-c68d-6f47-b6a3-0ada418499da --- cli/convert.ml | 57 +++++++++++++++++++++++++---------------- cli/html.ml | 2 +- cli/peers.ml | 2 +- cli/pull.ml | 7 +++--- lib/file_store.ml | 2 +- lib/header_pack.ml | 63 +++++++++++++++++++++++++++++++--------------- lib/peers.ml | 4 +-- 7 files changed, 88 insertions(+), 49 deletions(-) diff --git a/cli/convert.ml b/cli/convert.ml index f47c30e..777880d 100644 --- a/cli/convert.ml +++ b/cli/convert.ml @@ -26,29 +26,46 @@ let converters types kv = let t = if List.(mem "all" n || mem "gmi-atom" n) then (Atom.converter "text/gemini")::t else t in t -let acc_ref id t a = - Conversion.Id_map.update t (function - | Some s -> Some (Conversion.Ref_set.add id s) - | None -> Some (Conversion.Ref_set.singleton id) - ) a +let acc_rel source target a = + prerr_endline source; + Conversion.Id_map.update target + (function Some set -> Some (Conversion.Ref_set.add source set) + | None -> Some (Conversion.Ref_set.singleton source)) + a -let fold_refs text refs = String_set.fold (acc_ref text.Text.id) (Text.set "references" text) refs -let fold_reps text reps = String_set.fold (acc_ref text.Text.id) (Text.set "in-reply-to" text) reps +let empty_rels () = Conversion.Id_map.empty, Conversion.Id_map.empty + +let acc_txt_refs text refs = String_set.fold (acc_rel text.Text.id) (Text.set "references" text) refs +let acc_txt_reps text reps = String_set.fold (acc_rel text.Text.id) (Text.set "in-reply-to" text) reps +let acc_txt_rels (refs, reps) (elt, _paths) = + acc_txt_refs elt refs, acc_txt_reps elt reps + +let acc_pck_refs id refs_ls refs = String_set.fold (acc_rel id) (String_set.of_list refs_ls) refs +let acc_pck_reps id reps_ls reps = String_set.fold (acc_rel id) (String_set.of_list reps_ls) reps +let acc_pck_rels refs_reps peer = + let path = try List.hd peer.Peers.pack.Header_pack.info.locations with Failure _ -> "" in + try Header_pack.fold + (fun (refs, reps) id _t _title _authors _topics refs_ls reps_ls -> + let id = Filename.concat path id in + acc_pck_refs id refs_ls refs, acc_pck_reps id reps_ls reps) + refs_reps peer.Peers.pack + with e -> prerr_endline "acc_pck_rels"; raise e let directory converters noindex repo = - let fn (ts,refs,reps,ls,acc) ((elt,_) as r) = - Topic_set.to_map ts (Text.set "topics" elt), - fold_refs elt refs, fold_reps elt reps, - elt::ls, - if convert converters {repo with references = refs; replies = reps} r then acc+1 else acc in - let topics, references, replies, texts, count = - File_store.(fold ~dir:repo.Conversion.dir ~order:oldest fn - (Topic_set.Map.empty, Conversion.Id_map.empty, Conversion.Id_map.empty, [], 0)) in + let order = File_store.oldest in + let repo = + let references, replies = + File_store.fold ~dir:repo.Conversion.dir ~order acc_txt_rels (empty_rels ()) in + let references, replies = Peers.fold acc_pck_rels (references, replies) in + Printf.eprintf "%s %d\n" repo.Conversion.dir (Conversion.Id_map.cardinal replies); + { repo with references; replies } in + let acc (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:repo.Conversion.dir ~order acc (Topic_set.Map.empty, [], 0) in let topic_roots = try List.rev @@ String_set.list_of_csv (Store.KV.find "Topics" repo.kv) with Not_found -> Topic_set.roots topics in - Printf.eprintf "%d\n" (Conversion.Id_map.cardinal replies); - let repo = Conversion.{ repo with - topic_roots; topics; references; replies; texts = List.rev texts } in + let repo = Conversion.{ repo with topic_roots; topics; texts = List.rev texts } in if not noindex then List.iter (fun c -> match c.Conversion.indices with None -> () | Some f -> f repo) converters; Printf.printf "Converted: %d Indexed: %d\n" count (List.length texts) @@ -78,9 +95,7 @@ let at_path types noindex path = match path with | Error s -> prerr_endline s | Ok text -> let dir = "." in - let references, replies = File_store.(fold ~dir ~order:newest - (fun (refs, reps) (elt, _) -> fold_refs elt refs, fold_reps elt reps) - (Conversion.Id_map.empty, Conversion.Id_map.empty)) in + let references, replies = File_store.(fold ~dir ~order:newest acc_txt_rels (empty_rels ())) in let repo = { (Conversion.empty ()) with dir; kv = load_kv ""; references; replies } in ignore @@ convert (converters types repo.kv) repo (text, [path]) ) diff --git a/cli/html.ml b/cli/html.ml index b76134e..c976542 100644 --- a/cli/html.ml +++ b/cli/html.ml @@ -88,7 +88,7 @@ let page htm conversion text = with Not_found -> "") ^ opt_kv "Replies:" (try ref_links (Conversion.Id_map.find text.id conversion.Conversion.replies) - with Not_found -> "empty replies") + with Not_found -> "") ^ {|
|} in
 	wrap conversion htm text.title ((T.of_string text.body header) ^ "
") diff --git a/cli/peers.ml b/cli/peers.ml index af92ff1..7a18212 100644 --- a/cli/peers.ml +++ b/cli/peers.ml @@ -9,7 +9,7 @@ type filter_t = { authors: Logarion.Person.Set.t; topics: Logarion.String_set.t let print_peer () peer = let open Logarion.Peers in Printf.printf "%s" peer.path; - List.iter (Printf.printf "\t%s\n") peer.locations + List.iter (Printf.printf "\t%s\n") peer.pack.info.locations let remove_repo id = let repopath = Filename.concat Logarion.Peers.text_dir id in diff --git a/cli/pull.ml b/cli/pull.ml index 6f07cef..44c0ddf 100644 --- a/cli/pull.ml +++ b/cli/pull.ml @@ -75,7 +75,7 @@ let pull_text url dir id = let file = open_out_gen [Open_creat; Open_trunc; Open_wronly] 0o640 (fname dir text) in output_string file txt; close_out file -let per_text url dir filter print i id time title authors topics = match id with +let per_text url dir filter print i id time title authors topics _refs _reps = match id with | "" -> Printf.eprintf "\nInvalid id for %s\n" title | id -> let open Logarion in print i; @@ -127,11 +127,12 @@ 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 + let open Logarion in let fold_locations init peer = - ignore @@ List.fold_left pull init peer.Logarion.Peers.locations; + ignore @@ List.fold_left pull init peer.Peers.pack.Header_pack.info.locations; false in - ignore @@ Logarion.Peers.fold fold_locations false; + ignore @@ Peers.fold fold_locations false; Curl.global_cleanup () let pull url auths topics = match url with diff --git a/lib/file_store.ml b/lib/file_store.ml index d2d633c..3f63a18 100644 --- a/lib/file_store.ml +++ b/lib/file_store.ml @@ -69,7 +69,7 @@ let list_fs ?(r=false) dir = let valid_dir f = r && String.get f 0 <> '.' && Sys.is_directory f in let expand_dir d = Array.(to_list @@ map (Filename.concat d) (Sys.readdir d)) in let rec loop result = function - | f::fs when valid_dir f -> expand_dir f |> List.append fs |> loop result + | f::fs when valid_dir f -> prerr_endline f; expand_dir f |> List.append fs |> loop result | f::fs -> loop (f::result) fs | [] -> result in let dirs = if dir = "." then Array.to_list (Sys.readdir dir) else diff --git a/lib/header_pack.ml b/lib/header_pack.ml index 851e4fb..9ccd480 100644 --- a/lib/header_pack.ml +++ b/lib/header_pack.ml @@ -10,7 +10,8 @@ let persons ps = Msgpck.of_list @@ List.rev @@ Person.Set.fold (fun p a -> perso let str = Msgpck.of_string let str_list ls = Msgpck.of_list @@ List.map str ls -let to_str_list x = List.map Msgpck.to_string (Msgpck.to_list x) +let to_str_list x = List.map Msgpck.to_string + (try Msgpck.to_list x with e -> prerr_endline "to_str_list"; raise e) let of_set field t = List.rev @@ String_set.fold (fun s a -> Msgpck.String s :: a) (Text.set field t) [] @@ -19,7 +20,10 @@ let date = function "" -> Int32.zero | date -> Int32.of_int (Date.to_secs date) let to_sec = function Msgpck.Int i -> Int32.of_int i | Msgpck.Uint32 i -> i | x -> Msgpck.to_uint32 x -let fields = Msgpck.(List [String "id"; String "time"; String "title"; String "authors"; String "topics"]) +let fields = Msgpck.(List [ + String "id"; String "time"; String "title"; String "authors"; String "topics"; + String "references"; String "replies"; + ]) let to_fields fieldpack = List.map Msgpck.to_string (Msgpck.to_list fieldpack) let to_info = function @@ -35,8 +39,13 @@ let of_info i = let open Msgpck in let of_text a t = let open Text in Msgpck.(List [ - of_id t.id; of_uint32 (date (Date.listing t.date)); - String t.title; persons t.authors; List (of_set "topics" t) + of_id t.id; + of_uint32 (date (Date.listing t.date)); + String t.title; + persons t.authors; + List (of_set "topics" t); + List (of_set "references" t); + List (of_set "in-reply-to" t); ]) :: a let of_text_list l = Msgpck.List l @@ -81,28 +90,42 @@ let contains text = function let numof_texts pack = List.length (Msgpck.to_list pack.texts) -let iteri fn pack = - let of_pck i = function Msgpck.List (id::time::title::authors::topics::[]) -> +let txt_iter_apply fn i = function + | Msgpck.List (id::time::title::authors::topics::extra) -> let t = match time with Msgpck.Int i -> Int32.of_int i | Msgpck.Uint32 i -> i | x -> Msgpck.to_uint32 x in let id = to_id id in let title = Msgpck.to_string title in let topics = to_str_list topics in let authors = to_str_list authors in - fn i id t title authors topics + let references, replies = + try begin match extra with [] -> [], [] + | refs::[] -> to_str_list refs, [] + | refs::replies::_xs -> to_str_list refs, to_str_list replies + end with e -> prerr_endline "iter ref reps"; raise e + in + fn i id t title authors topics references replies | _ -> prerr_endline ("\n\nInvalid record structure\n\n") - in List.iteri of_pck (Msgpck.to_list pack.texts); -(*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 txt_fold_apply fn i m = +(* Printf.eprintf "%s\n%!" @@ Msgpck.show m;*) + match m with + | Msgpck.List (id::time::title::authors::topics::extra) -> + let t = match time with Msgpck.Int i -> Int32.of_int i | Msgpck.Uint32 i -> i + | x -> Msgpck.to_uint32 x in + let id = to_id id in + let title = Msgpck.to_string title in + let topics = try to_str_list topics with _e -> Printf.eprintf "topics %s" title; [] in + let authors = try to_str_list authors with _e -> Printf.eprintf "authors %s" title; [] in + let references, replies = begin match extra with + | [] -> [], [] + | refs::[] -> (try to_str_list refs, [] with e -> prerr_endline "fold ref"; raise e) + | refs::replies::_xs -> to_str_list refs, to_str_list replies + end + in + fn i id t title authors topics references replies + | x -> Printf.eprintf "Invalid record structure: %s\n%!" (Msgpck.show x); i -(*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; persons archive.people]) in*) -(* File_store.file fname @@ Bytes.to_string*) -(* @@ Msgpck.Bytes.to_string (List [archive; fields; Msgpck.List header_pack])*) +let iteri fn pack = List.iteri (txt_iter_apply fn) (Msgpck.to_list pack.texts) +let fold fn init pack = List.fold_left (txt_fold_apply fn) init + (try Msgpck.to_list pack.texts with e -> prerr_string "Pack.fold"; raise e) diff --git a/lib/peers.ml b/lib/peers.ml index bed53ab..8b2ae69 100644 --- a/lib/peers.ml +++ b/lib/peers.ml @@ -1,6 +1,6 @@ let text_dir = Filename.concat (File_store.txtdir ()) "peers" -type t = { path: string; locations: string list } +type t = { path: string; pack: Header_pack.t } let fold fn init = match Sys.readdir text_dir with | exception (Sys_error msg) -> prerr_endline msg; init @@ -13,7 +13,7 @@ let fold fn init = match Sys.readdir text_dir with | false -> Printf.eprintf "Missing index.pck for %s\n" path; init | true -> match Header_pack.of_string (File_store.to_string pack_path) with | Error s -> Printf.eprintf "%s %s\n" s pack_path; init - | Ok p -> fn init { path; locations = Header_pack.(p.info.locations) } + | Ok pack -> fn init { path; pack } end else init in Array.fold_left read_pack init dirs