logarion/lib/file_store.ml

type t = string
type item_t = t list
type record_t = Text.t * item_t

let extension = ".txt"
let def_dir () = try Sys.getenv "txtdir" with Not_found ->
	let share = Filename.concat (Sys.getenv "HOME") ".local/share/texts/" in
	match Sys.is_directory share with true -> share
	| false | exception (Sys_error _) -> "."

let to_string f =
	let ic = open_in f in
	let s = really_input_string ic (in_channel_length ic) in
	close_in ic;
	s

let fold_file_line fn init file = match open_in file with
	| exception (Sys_error msg) -> prerr_endline msg; init
	| file ->
		let rec read acc = match input_line file with
			| "" as s | s when String.get s 0 = '#' -> read acc
			| s -> read (fn s acc)
			| exception End_of_file -> close_in file; acc
		in read init

let file path str = let o = open_out path in output_string o str; close_out o

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 (Printf.sprintf "Not txt: %s" path)

let newest (a,_pa) (b,_pb) = Text.newest a b
let oldest (a,_pa) (b,_pb) = Text.oldest a b

let list_iter fn dir paths =
	let link f = match to_text (Filename.concat dir f) with
		| Ok t -> fn dir t f | Error s -> prerr_endline s in
	List.iter link paths

module TextMap = Map.Make(Text)

type iteration_t = item_t TextMap.t
let new_iteration = TextMap.empty

(*let iter_valid_text pred fn path =*)
(*	match to_text path with Error _ -> () | Ok t -> if pred t then fn (t, p)*)

let fold_valid_text pred it path =
	match to_text path with Error _ -> it
	| Ok t -> if pred t then (TextMap.update t
			(function None -> Some [path] | Some ps -> Some (path::ps)) it
		) else it

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

(* Compare file system nodes to skip reparsing? *)
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 -> loop (f::result) fs
		| [] -> result in
	let dirs = if dir = "." then Array.to_list (Sys.readdir dir) else
		if not r then expand_dir dir else [dir] in
	loop [] dirs

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 fold_sort_take ?(predicate=fun _ -> true) ?(number=None) comp flist =
	(match number with None -> (fun x -> x) | Some n -> list_take n)
	@@ List.fast_sort comp @@ TextMap.bindings
	@@ List.fold_left (fold_valid_text predicate) new_iteration flist

let iter ?(r=false) ?(dir=def_dir ()) ?(predicate=fun _ -> true) ?order ?number fn =
	let flist = list_fs ~r dir in match order with
	| Some comp -> List.iter fn @@ fold_sort_take ~predicate ~number comp flist
	| None -> List.iter fn @@ TextMap.bindings @@
		List.fold_left (fold_valid_text predicate) new_iteration flist

let fold ?(r=false) ?(dir=def_dir ()) ?(predicate=fun _ -> true) ?order ?number fn acc =
	let flist = list_fs ~r dir in match order with
	| Some comp -> List.fold_left fn acc @@ fold_sort_take ~predicate ~number comp flist
	| None -> List.fold_left fn acc @@ TextMap.bindings @@
		List.fold_left (fold_valid_text predicate) new_iteration flist

let with_dir ?(descr="") ?(perm=0o740) dir =
	let mkdir dir = match Unix.mkdir dir perm with
	| exception Unix.Unix_error (EEXIST, _, _) -> ()
	| exception Unix.Unix_error (code, _fn, arg) ->
		failwith @@ Printf.sprintf "Error %s making %s dir: %s"
			(Unix.error_message code) descr arg
	| _ -> () in
	let rec mkeach path = function [] | [""] -> () | ""::t -> mkeach path t
		| hd::t -> let d = Filename.concat path hd in mkdir d; mkeach d t in
	mkeach
		(if Filename.is_relative dir then "" else "/")
		(String.split_on_char '/' dir)

let rec with_dirs = function [] -> () | (d, descr)::tl -> with_dir ~descr d; with_dirs tl

let versioned_basename_of_title ?(version=0) repo extension (title : string) =
	let basename = Text.string_alias title in
	let rec next version =
		let candidate = Filename.concat repo
			(basename ^ "." ^ string_of_int version ^ extension) in
		if Sys.file_exists candidate then next (succ version) else candidate
	in
	next version

let id_filename repo extension text =
	let basename = Text.alias text in
	let candidate = Filename.concat repo (text.id ^ "." ^ basename ^ extension) in
	if Sys.file_exists candidate then Error "Name clash, try again" else Ok candidate

let with_text ?(dir=def_dir ()) new_text =
	match id_filename dir extension new_text with
	| Error _ as e -> e
	| Ok path ->
		try file path (Text.to_string new_text); Ok (path, new_text)
		with Sys_error s -> Error s

module Config = struct
	type t = string Store.KV.t
	let key_value k v a = Store.KV.add k (String.trim v) a
end

let of_kv_file path =
	let open Text_parse in
	let subsyntaxes = Parsers.Key_value.[|
		(module Make (Config) : Parser.S with type t = Config.t); (module Make (Config)); |] in
	let of_string text acc =
		Parser.parse subsyntaxes { text; pos = 0; right_boundary = String.length text - 1 } acc in
	of_string (to_string @@ path) Store.KV.empty