logarion/lib/file_store.ml

145 lines
5.2 KiB
OCaml
Raw Normal View History

type t = string
type item_t = t list
type record_t = Text.t * item_t
let extension = ".txt"
let def_dir () =
let share = Sys.getenv "HOME" ^ "/.local/share/texts/" in
try Sys.getenv "txtdir" with Not_found ->
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