logarion/lib/file_store.ml
orbifx 22fe21326f Samhain 21
Converter
- type selection
- subdir conversion
- htm extension

Gemini
- index.gmi
- topics and latest
- gmi.atom feed

Add pull (http(s)) operation
- peers.pub.conf and peers.priv.conf

HTML5 format & fixes by Novaburst
Phony target (thanks Gergely)

May

Basic unit renamed from Note to Text.
New modular text-parser, internal to Logarion, for generic notation parsing. The default input format is now a much plainer text.
Logarion created texts have part of the UUID in filename.
Logarion's index re-written in Messagepack format. Removed `indices` command. They are generated during `convert`.
2021-11-03 22:29:57 +00:00

166 lines
5.4 KiB
OCaml

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