From c6a7396ebc93cec32a1465d878ac9d36465dcb19 Mon Sep 17 00:00:00 2001 From: Siraaj Khandkar Date: Mon, 3 Sep 2018 15:47:12 -0400 Subject: [PATCH] Implement a basic cache dumper --- .gitignore | 6 +- Makefile | 16 +++++- sanity_check | 1 + src/ocaml/exe/khatus_cache_dumper.ml | 76 ++++++++++++++++++++++++++ src/ocaml/exe/khatus_cache_dumper.mli | 0 src/ocaml/lib/khatus.ml | 4 ++ src/ocaml/lib/khatus_cache.ml | 52 ++++++++++++++++++ src/ocaml/lib/khatus_cache.mli | 16 ++++++ src/ocaml/lib/khatus_msg.ml | 70 ++++++++++++++++++++++++ src/ocaml/lib/khatus_msg.mli | 20 +++++++ src/ocaml/lib/khatus_msg_parser.mli | 8 +++ src/ocaml/lib/khatus_msg_parser.mll | 79 +++++++++++++++++++++++++++ src/ocaml/lib/khatus_time.ml | 24 ++++++++ src/ocaml/lib/khatus_time.mli | 17 ++++++ 14 files changed, 386 insertions(+), 3 deletions(-) create mode 100644 src/ocaml/exe/khatus_cache_dumper.ml create mode 100644 src/ocaml/exe/khatus_cache_dumper.mli create mode 100644 src/ocaml/lib/khatus.ml create mode 100644 src/ocaml/lib/khatus_cache.ml create mode 100644 src/ocaml/lib/khatus_cache.mli create mode 100644 src/ocaml/lib/khatus_msg.ml create mode 100644 src/ocaml/lib/khatus_msg.mli create mode 100644 src/ocaml/lib/khatus_msg_parser.mli create mode 100644 src/ocaml/lib/khatus_msg_parser.mll create mode 100644 src/ocaml/lib/khatus_time.ml create mode 100644 src/ocaml/lib/khatus_time.mli diff --git a/.gitignore b/.gitignore index f01981c..7d4b4de 100644 --- a/.gitignore +++ b/.gitignore @@ -1,8 +1,9 @@ -data/ -bin/khatus_bar +_build/ bin/khatus_actuate_alert_to_notify_send bin/khatus_actuate_device_add_to_automount bin/khatus_actuate_status_bar_to_xsetroot_name +bin/khatus_bar +bin/khatus_dashboard bin/khatus_monitor_devices bin/khatus_monitor_energy bin/khatus_monitor_errors @@ -20,3 +21,4 @@ bin/khatus_parse_ps bin/khatus_parse_sys_block_stat bin/khatus_parse_udevadm_monitor_block bin/khatus_parse_upower +data/ diff --git a/Makefile b/Makefile index 1f39234..54353de 100644 --- a/Makefile +++ b/Makefile @@ -22,6 +22,8 @@ AWK_EXECUTABLES := \ bin/khatus_parse_sys_block_stat \ bin/khatus_parse_udevadm_monitor_block \ bin/khatus_parse_upower +OCAML_EXECUTABLES := \ + bin/khatus_dashboard define BUILD_AWK_EXE echo '#! $(PATH_TO_AWK) -f' > $@ && \ @@ -36,14 +38,18 @@ endef install \ clean -build: $(AWK_EXECUTABLES) +build: $(AWK_EXECUTABLES) $(OCAML_EXECUTABLES) install: $(foreach filename,$(wildcard bin/*),cp -p "$(filename)" "$(PREFIX)/$(filename)"; ) clean: rm -f $(AWK_EXECUTABLES) + rm -f $(OCAML_EXECUTABLES) +#----------------------------------------------------------------------------- +# AWK +#----------------------------------------------------------------------------- bin/khatus_bar: \ src/awk/exe/bar.awk \ src/awk/lib/cache.awk \ @@ -164,3 +170,11 @@ bin/khatus_parse_upower: \ src/awk/exe/parse_upower.awk \ src/awk/lib/msg_out.awk $(BUILD_AWK_EXE) + +#----------------------------------------------------------------------------- +# OCaml +#----------------------------------------------------------------------------- +bin/khatus_cache_dumper: src/ocaml/exe/khatus_cache_dumper.ml + ocamlbuild -cflags '-w A' -pkg unix -I src/ocaml/exe -I src/ocaml/lib khatus_cache_dumper.byte + mv _build/src/ocaml/exe/khatus_cache_dumper.byte bin/khatus_cache_dumper + rm -f khatus_cache_dumper.byte diff --git a/sanity_check b/sanity_check index 09fc142..8fb8a8a 100755 --- a/sanity_check +++ b/sanity_check @@ -13,6 +13,7 @@ -v Status_Args='@energy_percent,@memory_percent,@processes_count_all,@processes_count_r,@processes_count_d,@processes_count_t,@processes_count_i,@processes_count_z,@cpu_loadavg,@cpu_temp,@cpu_fan_speed,@disk_space,@disk_io_w,@disk_io_r,@net_wifi:wlp3s0,@net_io_w:wlp3s0,@net_io_r:wlp3s0,@bluetooth_power,@backlight_percent,@volume_pa_sink:0,@mpd,@weather_temp_f,@datetime' \ ) \ ) \ + >(stdbuf -o L ./bin/khatus_cache_dumper $(hostname) 5 "$PWD/data") \ >(stdbuf -o L ./bin/khatus_monitor_energy) \ >(stdbuf -o L ./bin/khatus_monitor_errors) \ >(stdbuf -o L ./bin/khatus_monitor_devices) \ diff --git a/src/ocaml/exe/khatus_cache_dumper.ml b/src/ocaml/exe/khatus_cache_dumper.ml new file mode 100644 index 0000000..e51243e --- /dev/null +++ b/src/ocaml/exe/khatus_cache_dumper.ml @@ -0,0 +1,76 @@ +open Printf +open Khatus + +let modul = __MODULE__ + +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 main ~node ~cache ~dump_interval:interval ~dump_directory = + mkdir_p dump_directory; + let dump_filename = dump_directory / "khatus-cache-dump.psv.gz" in + let rec loop ~time ~time_dumped = + (match read_line () with + | exception End_of_file -> + () + | line -> + (match Msg_parser.parse_msg (Lexing.from_string line) with + | Ok msg -> + let time = Msg.next_time msg ~node ~time in + Cache.update_if_data cache ~msg ~time; + if (Time.Span.is_gt_or_eq (Time.diff time_dumped time) interval) + then + ( + let (tmp_filename, oc) = + Filename.open_temp_file "khatus-cache" "dump" + in + Cache.dump cache ~node ~modul ~oc; + close_out oc; + gzip tmp_filename; + Sys.rename (tmp_filename ^ ".gz") dump_filename; + loop ~time ~time_dumped:time + ) + else + loop ~time ~time_dumped + | Error e -> + let e = + match e with + | `Bad_format_of_msg_head -> "Bad_format_of_msg_head" + | `Bad_format_of_msg_content -> "Bad_format_of_msg_content" + in + eprintf + "%s\n%!" + Msg.(to_string + { node + ; modul + ; content = Log + { location = "main:loop" + ; level = `error + ; msg = sprintf "Parse error %s in %s" e line + } + }); + loop ~time ~time_dumped + ) + ) + in + loop ~time:Time.init ~time_dumped:Time.init + +let () = + main + ~node:(Sys.argv.(1)) + ~dump_interval:(Time.Span.of_string Sys.argv.(2)) + ~dump_directory:(Sys.argv.(3)) + ~cache:(Cache.create ()) diff --git a/src/ocaml/exe/khatus_cache_dumper.mli b/src/ocaml/exe/khatus_cache_dumper.mli new file mode 100644 index 0000000..e69de29 diff --git a/src/ocaml/lib/khatus.ml b/src/ocaml/lib/khatus.ml new file mode 100644 index 0000000..bd01385 --- /dev/null +++ b/src/ocaml/lib/khatus.ml @@ -0,0 +1,4 @@ +module Cache = Khatus_cache +module Msg = Khatus_msg +module Msg_parser = Khatus_msg_parser +module Time = Khatus_time diff --git a/src/ocaml/lib/khatus_cache.ml b/src/ocaml/lib/khatus_cache.ml new file mode 100644 index 0000000..698d20b --- /dev/null +++ b/src/ocaml/lib/khatus_cache.ml @@ -0,0 +1,52 @@ +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 update_if_data t ~msg ~time = + match msg with + | Msg.({content = Data {key; value}; node; modul}) -> + update t ~node ~modul ~key ~value ~time + | {Msg.content = Msg.Alert _; _} + | {Msg.content = Msg.Cache _; _} + | {Msg.content = Msg.Error _; _} + | {Msg.content = Msg.Log _; _} + | {Msg.content = Msg.Status_bar _; _} + -> + () + +let dump {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 ^ "\n") + ) diff --git a/src/ocaml/lib/khatus_cache.mli b/src/ocaml/lib/khatus_cache.mli new file mode 100644 index 0000000..f6c951e --- /dev/null +++ b/src/ocaml/lib/khatus_cache.mli @@ -0,0 +1,16 @@ +type t + +val create : unit -> t + +val update + : t + -> node : string + -> modul : string + -> key : (string list) + -> value : string + -> time : Khatus_time.t + -> unit + +val update_if_data : t -> msg:Khatus_msg.t -> time:Khatus_time.t -> unit + +val dump : t -> node:string -> modul:string -> oc:out_channel -> unit diff --git a/src/ocaml/lib/khatus_msg.ml b/src/ocaml/lib/khatus_msg.ml new file mode 100644 index 0000000..cd9fd86 --- /dev/null +++ b/src/ocaml/lib/khatus_msg.ml @@ -0,0 +1,70 @@ +module Time = Khatus_time + +type content = + | Alert of {priority : [`low | `med | `hi]; subject : string; body : string} + | Data of {key : string list; value : string} + | Cache of + { mtime : Time.t + ; node : string + ; modul : string + ; key : string list + ; value : string + } + | Error of string + | Log of {location : string; level : [`info | `error]; msg : string} + | Status_bar of string + +type t = + {node : string; modul : string; content : content} + +let sep_1 = "|" +let sep_2 = ":" + +let to_string {node; modul; content} = + match content with + | Alert {priority; subject; body} -> + let priority = + match priority with + | `hi -> "hi" + | `med -> "med" + | `low -> "low" + in + String.concat sep_1 [node; modul; "alert"; priority; subject; body] + | Data {key; value} -> + let key = String.concat sep_2 key in + String.concat sep_1 [node; modul; "data"; key; value] + | Cache {mtime; node=node'; modul=modul'; key; value} -> + let key = String.concat sep_2 key in + let mtime = Time.to_string mtime in + String.concat + sep_1 + [node; modul; "cache"; mtime; node'; modul'; key; value] + | Error text -> + String.concat sep_1 [node; modul; "error"; text] + | Log {location; level; msg} -> + let level = + match level with + | `info -> "info" + | `error -> "error" + in + String.concat sep_1 [node; modul; "log"; location; level; msg] + | Status_bar text -> + String.concat sep_1 [node; modul; "status_bar"; text] + +let next_time t ~node ~time:time0 = + match t with + | { modul = "khatus_sensor_datetime" + ; content = Data {key = ["epoch"]; value = time1} + ; node = node' + } when node' = node -> + (* TODO: Going forawrd, perhaps throwing exceptions is the wrong way. *) + (* TODO: Should we check this one at msg parse time? *) + Time.of_string time1 + | {content = Data _; _} + | {content = Alert _; _} + | {content = Cache _; _} + | {content = Error _; _} + | {content = Log _; _} + | {content = Status_bar _; _} + -> + time0 diff --git a/src/ocaml/lib/khatus_msg.mli b/src/ocaml/lib/khatus_msg.mli new file mode 100644 index 0000000..7f89c2b --- /dev/null +++ b/src/ocaml/lib/khatus_msg.mli @@ -0,0 +1,20 @@ +type content = + | Alert of {priority : [`low | `med | `hi]; subject : string; body : string} + | Data of {key : string list; value : string} + | Cache of + { mtime : Khatus_time.t + ; node : string + ; modul : string + ; key : string list + ; value : string + } + | Error of string + | Log of {location : string; level : [`info | `error]; msg : string} + | Status_bar of string + +type t = + {node : string; modul : string; content : content} + +val to_string : t -> string + +val next_time : t -> node:string -> time:Khatus_time.t -> Khatus_time.t diff --git a/src/ocaml/lib/khatus_msg_parser.mli b/src/ocaml/lib/khatus_msg_parser.mli new file mode 100644 index 0000000..f177b28 --- /dev/null +++ b/src/ocaml/lib/khatus_msg_parser.mli @@ -0,0 +1,8 @@ +val parse_msg + : Lexing.lexbuf + -> + ( Khatus_msg.t + , [ `Bad_format_of_msg_head + | `Bad_format_of_msg_content + ] + ) result diff --git a/src/ocaml/lib/khatus_msg_parser.mll b/src/ocaml/lib/khatus_msg_parser.mll new file mode 100644 index 0000000..2015f77 --- /dev/null +++ b/src/ocaml/lib/khatus_msg_parser.mll @@ -0,0 +1,79 @@ +{ + module Msg = Khatus_msg + module Time = Khatus_time + let sep_2 = ':' +} + +let alphnumdash = ['a'-'z' 'A'-'Z' '0'-'9' '_' '-']+ +let snake = ['a'-'z' '_']+ + +let sep_1 = '|' +let node = alphnumdash +let modul = snake +let key = ['a'-'z' 'A'-'Z' '0'-'9' '_' '-' ':']+ +let level = ("info" | "error") +let priority = ("low" | "med" | "hi") +let subject = alphnumdash + +rule parse_msg = parse + | (node as node) sep_1 (modul as modul) sep_1 { + match parse_content lexbuf with + | Ok content -> Ok Msg.({node; modul; content : content}) + | (Error _) as e -> e + } + | _ { + parse_msg lexbuf + } + | eof { + Error (`Bad_format_of_msg_head) + } + +and parse_content = parse + | "status_bar" sep_1 { + Ok (Msg.Status_bar (tl lexbuf)) + } + | "cache" + sep_1 (['0'-'9']+ as mtime) + sep_1 (node as node) + sep_1 (modul as modul) + sep_1 (key as key) + sep_1 + { + let key = String.split_on_char sep_2 key in + let mtime = Time.of_string mtime in + Ok (Msg.Cache {mtime; node; modul; key; value = tl lexbuf}) + } + | "data" sep_1 (key as key) sep_1 { + Ok (Msg.Data {key = String.split_on_char sep_2 key; value = tl lexbuf}) + } + | "error" sep_1 { + Ok (Msg.Error (tl lexbuf)) + } + | "alert" sep_1 (priority as priority) (subject as subject) sep_1 { + let priority = + match priority with + | "low" -> `low + | "med" -> `med + | "hi" -> `hi + | _ -> assert false + in + Ok (Msg.Alert {priority; subject; body = tl lexbuf}) + } + | "log" sep_1 (snake as location) (level as level) sep_1 { + let level = + match level with + | "info" -> `info + | "error" -> `error + | _ -> assert false + in + Ok (Msg.Log {location; level; msg = tl lexbuf}) + } + | _ { + parse_content lexbuf + } + | eof { + Error (`Bad_format_of_msg_content) + } + +and tl = parse + | (_* as tail) eof {tail} diff --git a/src/ocaml/lib/khatus_time.ml b/src/ocaml/lib/khatus_time.ml new file mode 100644 index 0000000..cf6538a --- /dev/null +++ b/src/ocaml/lib/khatus_time.ml @@ -0,0 +1,24 @@ +module Span = struct + type t = float + + let of_string s = + float_of_string s + + let is_gt_or_eq t1 t2 = + t1 >= t2 +end + +type t = float + +let init = 0.0 + +let diff t0 t1 = + t1 -. t0 + +let to_string t = + Printf.sprintf "%f" t + |> String.split_on_char '.' + |> List.hd + +let of_string s = + float_of_string s diff --git a/src/ocaml/lib/khatus_time.mli b/src/ocaml/lib/khatus_time.mli new file mode 100644 index 0000000..9f930af --- /dev/null +++ b/src/ocaml/lib/khatus_time.mli @@ -0,0 +1,17 @@ +module Span : sig + type t + + val of_string : string -> t + + val is_gt_or_eq : t -> t -> bool +end + +type t + +val init : t + +val diff : t -> t -> Span.t + +val to_string : t -> string + +val of_string : string -> t -- 2.20.1