| 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 |