source: code/trunk/lib/file_store.ml@ 5

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

let extension = ".txt"
let def_dir = try Sys.getenv "LOGARION_DIR" with Not_found -> "."

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

(* 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_id ?(r=false) ?(dir=def_dir) id =
        let matched acc path =
                match to_text path with
                | Error x -> prerr_endline x; acc
                | Ok text when text.Text.id <> 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 ~r dir)

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