64b407d54e152862fb4dc0777e6c31832b28365e
[khatus.git] / 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
This page took 0.073049 seconds and 4 git commands to generate.