logarion/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 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 -> "."
		}
	)