logarion-2021/lib/file_store.ml

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 extensions = [ ".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 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 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 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, dir^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 -> prerr_endline x; acc | Ok t -> if pred t then fn acc (t, dir^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 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 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

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 =
  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

let basic_toml_bytes =
  "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"; dotdir//"published", "linkdir"; dotdir//"indexed", "link dir"] 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_toml_bytes;
     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 = Bos.OS.Env.opt_var "LOGARION_DIR" ~absent:"."
        }
    )