x3/src/lib/khatus_cache.ml

   1 open Printf
   2
   3 module Hashtbl = MoreLabels.Hashtbl
   4
   5 module Msg  = Khatus_msg
   6 module Time = Khatus_time
   7
   8 type t =
   9   { values : ((string * string * string list), string) Hashtbl.t
  10   ; mtimes : ((string * string * string list), Time.t) Hashtbl.t
  11   }
  12
  13 let create () =
  14   { values = Hashtbl.create 256
  15   ; mtimes = Hashtbl.create 256
  16   }
  17
  18 let update {values; mtimes} ~node ~modul ~key ~value:data ~time =
  19   let key = (node, modul, key) in
  20   Hashtbl.replace values ~key ~data;
  21   Hashtbl.replace mtimes ~key ~data:time
  22
  23 let dump_to_channel {values; mtimes} ~node ~modul ~oc =
  24   Hashtbl.iter values ~f:(fun ~key ~data:value ->
  25     let mtime =
  26       match Hashtbl.find_opt mtimes key with
  27       | Some mtime -> mtime
  28       | None       -> assert false  (* Implies update was incorrect *)
  29     in
  30     let (node', modul', key) = key in
  31     let msg =
  32       Msg.(to_string
  33           { node
  34           ; modul
  35           ; content = Cache {mtime; node = node'; modul = modul'; key; value}
  36           }
  37         )
  38     in
  39     output_string oc msg;
  40     output_string oc "\n"
  41   )
  42
  43 let (/) = Filename.concat
  44
  45 let mkdir_p dir =
  46   match Sys.command("mkdir -p " ^ dir) with
  47   | 0 -> ()
  48   | n ->
  49       failwith
  50         (sprintf "Failed to create directory: %S. mkdir status: %d\n" dir n)
  51
  52 let gzip path =
  53   match Sys.command("gzip " ^ path) with
  54   | 0 -> ()
  55   | n ->
  56       failwith
  57         (sprintf "Failed to gzip path: %S. gzip status: %d\n" path n)
  58
  59 let dump_to_dir t ~time ~node ~modul ~dir =
  60   (* TODO: Just log the errors and keep it moving, instead of failing. *)
  61   mkdir_p dir;
  62   let dump_filename = dir / "khatus-cache-dump.psv.gz" in
  63   let tmp_filename = "khatus-cache-dump-" ^ (Time.to_string time) in
  64   let oc = open_out tmp_filename in
  65   dump_to_channel t ~node ~modul ~oc;
  66   close_out oc;
  67   gzip tmp_filename;
  68   Sys.rename (tmp_filename ^ ".gz") dump_filename