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

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