From bce085878d80b7e1ed03f82b145fe15465e3a3d9 Mon Sep 17 00:00:00 2001 From: orbifx Date: Sun, 3 Oct 2021 13:29:50 +0100 Subject: [PATCH] Dictory-recursing archives & peer text features * `-n` number option for `txt ls`, limits number of ordered lines printed * `--values` string option to select listing of field values instead of entries * `--mine` for `txt last`, prints last text authored by archivist --- cli/cli.ml | 36 +++++--- http/http.ml | 2 +- lib/file_store.ml | 229 +++++++++++++++++++++++----------------------- lib/store.ml | 24 ++--- 4 files changed, 154 insertions(+), 137 deletions(-) diff --git a/cli/cli.ml b/cli/cli.ml index 8b78ddd..ba85022 100644 --- a/cli/cli.ml +++ b/cli/cli.ml @@ -5,7 +5,7 @@ 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 values_opt authors_opt topics_opt = +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 -> @@ -15,7 +15,7 @@ let text_list order_opt reverse_opt values_opt authors_opt topics_opt = 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 ^ " " ^ fname) 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" -> @@ -26,26 +26,40 @@ let text_list order_opt reverse_opt values_opt authors_opt topics_opt = | false -> A.iter ~predicate list_text archive | true -> let order = match reverse_opt with true -> A.newest | false -> A.oldest in - A.iter ~predicate ~order list_text archive + 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 time = Arg.(value & flag & info ["t"] ~doc:"Sort by time, newest first") in let reverse = Arg.(value & flag & info ["r"] ~doc:"reverse order") in - let values = Arg.(value & opt (some string) None & info ["values"] ~docv:"HEADER-FIELD" ~doc:"unique values for header field") 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 $ values $ authed $ topics), + 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 () = +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 a (_t,fname) = match a with "" -> fname | x -> x in - print_endline @@ A.fold ~order:A.oldest last "" 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 = - Term.(const print_last $ const ()), + 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 = @@ -58,7 +72,7 @@ let file files = match A.of_path "." with 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 + 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 diff --git a/http/http.ml b/http/http.ml index a36167a..d95b4b4 100644 --- a/http/http.ml +++ b/http/http.ml @@ -28,7 +28,7 @@ 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 dir (String.sub (Logarion.Id.to_string id) 0 8 ^ ".txt") with + 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 diff --git a/lib/file_store.ml b/lib/file_store.ml index 26e9ce8..b7133fa 100644 --- a/lib/file_store.ml +++ b/lib/file_store.ml @@ -1,159 +1,160 @@ 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 } + name: string; archivists: Person.Set.t; id: Id.t; + kv: string Store.KV.t; store: t } type record_t = Text.t * item_t -let extensions = [ ".txt" ] +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 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 + output_string out content; close_out out let (//) a b = a ^ "/" ^ b -let to_text dir filename = let f = dir // filename in - to_string f |> Text.of_string |> Result.map_error (fun m -> f^": "^m) - -let text_filetype dir name = try - let open Fpath in - let v = v name in - mem_ext extensions v && not (Sys.is_directory @@ dir^"/"^name) - with Invalid_argument str -> - prerr_endline ("file: " ^ name ^ " invalid (" ^ str ^ ")"); false +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 store f with Ok t -> fn store t f | Error s -> prerr_endline s in - List.iter link 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 dir pred fn p = - if text_filetype dir p then - match to_text dir p with Error x -> prerr_endline x | Ok t -> if pred t then fn (t, p) +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 dir pred fn acc p = - if not (text_filetype dir p) then acc else - match to_text dir p with - Error _x -> acc | Ok t -> if pred t then fn acc (t, p) else acc +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 iter ?(predicate=fun _ -> true) ?order fn {store;_} = - match order with - | None -> Array.iter (iter_valid_text store predicate fn) @@ Sys.readdir store - | Some comp -> - List.iter fn @@ List.fast_sort comp - @@ Array.fold_left (fold_valid_text store predicate (fun a e -> List.cons e a)) [] - @@ Sys.readdir store +let 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 fold ?(predicate=fun _ -> true) ?order fn acc {store;_} = - match order with - | None -> Array.fold_left (fold_valid_text store predicate fn) acc @@ Sys.readdir store - | Some comp -> - List.fold_left fn acc @@ List.fast_sort comp - @@ Array.fold_left (fold_valid_text store predicate (fun a e -> List.cons e a)) [] - @@ Sys.readdir store +let 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.filteri (fun x _ -> x < 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.filteri (fun x _ -> x < 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 = - if not (text_filetype store path) then acc - else - match to_text store path with - | Error x -> prerr_endline x; acc - | Ok text -> - if text.Text.uuid <> id then acc - else - match acc with - | Ok None -> Ok (Some text) - | Ok (Some prev) -> if prev = text then acc else Error [text; prev] - | Error x -> Error (text :: x) - in - Array.fold_left matched (Ok None) @@ Sys.readdir store + 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 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 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) + 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)) + 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 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 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 = - let extension = List.hd extensions in - Result.bind (uuid_filename store extension new_text) @@ - fun path -> - try file path (Text.to_string new_text); Ok (path, new_text) with Sys_error s -> Error s + 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 + "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 + 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 } + type t = archive_t + let key_value k v a = match k with + | "Archive-Name" -> { a with name = String.trim v } + | "Archive-ID" -> { a with id = Option.get (Id.of_string (String.trim v)) } + | "Archivists" -> { a with archivists = Person.Set.of_string v } + | _ -> { a with kv = Store.KV.add k (String.trim v) a.kv } end let of_path store = - let open Text_parse in - let subsyntaxes = [| (module Parsers.Key_value.Make (Config) : Parser.S with type t = Config.t); (module Parsers.Key_value.Make (Config)); |] in - let of_string text acc = Parser.parse subsyntaxes { text; pos = 0; right_boundary = String.length text - 1 } acc in - Ok (of_string (to_string @@ store ^ "/.logarion/config") - { - name = ""; - archivists = Person.Set.empty; - id = Id.nil; - kv = Store.KV.empty; - store = Bos.OS.Env.opt_var "LOGARION_DIR" ~absent:(Sys.getcwd ()) - } - ) + 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 -> "." + } + ) diff --git a/lib/store.ml b/lib/store.ml index dd5b686..2064335 100644 --- a/lib/store.ml +++ b/lib/store.ml @@ -1,15 +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) -> (record_t -> unit) -> archive_t -> unit - val fold: ?predicate:(Text.t -> bool) -> ?order:(record_t -> record_t -> int) -> ('a -> record_t -> 'a) -> 'a -> archive_t -> 'a + 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