src/ocaml/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
  40       oc
  41       (msg ^ "\n")
  42   )
  43
  44 let (/) = Filename.concat
  45
  46 let mkdir_p dir =
  47   match Sys.command("mkdir -p " ^ dir) with
  48   | 0 -> ()
  49   | n ->
  50       failwith
  51         (sprintf "Failed to create directory: %S. mkdir status: %d\n" dir n)
  52
  53 let gzip path =
  54   match Sys.command("gzip " ^ path) with
  55   | 0 -> ()
  56   | n ->
  57       failwith
  58         (sprintf "Failed to gzip path: %S. gzip status: %d\n" path n)
  59
  60 let dump_to_dir t ~time ~node ~modul ~dir =
  61   (* TODO: Just log the errors and keep it moving, instead of failing. *)
  62   mkdir_p dir;
  63   let dump_filename = dir / "khatus-cache-dump.psv.gz" in
  64   let tmp_filename = "khatus-cache-dump-" ^ (Time.to_string time) in
  65   let oc = open_out tmp_filename in
  66   dump_to_channel t ~node ~modul ~oc;
  67   close_out oc;
  68   gzip tmp_filename;
  69   Sys.rename (tmp_filename ^ ".gz") dump_filename