X-Git-Url: https://git.xandkar.net/?p=khatus.git;a=blobdiff_plain;f=x3%2Fsrc%2Flib%2Fkhatus_cache.ml;fp=x3%2Fsrc%2Flib%2Fkhatus_cache.ml;h=64b407d54e152862fb4dc0777e6c31832b28365e;hp=0000000000000000000000000000000000000000;hb=499c58a269a00e031302938b5a8f006f23aae451;hpb=4c703fadbdc17d1753d16841582636598f862416

diff --git a/x3/src/lib/khatus_cache.ml b/x3/src/lib/khatus_cache.ml
new file mode 100644
index 0000000..64b407d
--- /dev/null
+++ b/x3/src/lib/khatus_cache.ml
@@ -0,0 +1,68 @@
+open Printf
+
+module Hashtbl = MoreLabels.Hashtbl
+
+module Msg  = Khatus_msg
+module Time = Khatus_time
+
+type t =
+  { values : ((string * string * string list), string) Hashtbl.t
+  ; mtimes : ((string * string * string list), Time.t) Hashtbl.t
+  }
+
+let create () =
+  { values = Hashtbl.create 256
+  ; mtimes = Hashtbl.create 256
+  }
+
+let update {values; mtimes} ~node ~modul ~key ~value:data ~time =
+  let key = (node, modul, key) in
+  Hashtbl.replace values ~key ~data;
+  Hashtbl.replace mtimes ~key ~data:time
+
+let dump_to_channel {values; mtimes} ~node ~modul ~oc =
+  Hashtbl.iter values ~f:(fun ~key ~data:value ->
+    let mtime =
+      match Hashtbl.find_opt mtimes key with
+      | Some mtime -> mtime
+      | None       -> assert false  (* Implies update was incorrect *)
+    in
+    let (node', modul', key) = key in
+    let msg =
+      Msg.(to_string
+          { node
+          ; modul
+          ; content = Cache {mtime; node = node'; modul = modul'; key; value}
+          }
+        )
+    in
+    output_string oc msg;
+    output_string oc "\n"
+  )
+
+let (/) = Filename.concat
+
+let mkdir_p dir =
+  match Sys.command("mkdir -p " ^ dir) with
+  | 0 -> ()
+  | n ->
+      failwith
+        (sprintf "Failed to create directory: %S. mkdir status: %d\n" dir n)
+
+let gzip path =
+  match Sys.command("gzip " ^ path) with
+  | 0 -> ()
+  | n ->
+      failwith
+        (sprintf "Failed to gzip path: %S. gzip status: %d\n" path n)
+
+let dump_to_dir t ~time ~node ~modul ~dir =
+  (* TODO: Just log the errors and keep it moving, instead of failing. *)
+  mkdir_p dir;
+  let dump_filename = dir / "khatus-cache-dump.psv.gz" in
+  let tmp_filename = "khatus-cache-dump-" ^ (Time.to_string time) in
+  let oc = open_out tmp_filename in
+  dump_to_channel t ~node ~modul ~oc;
+  close_out oc;
+  gzip tmp_filename;
+  Sys.rename (tmp_filename ^ ".gz") dump_filename