Improve overview and experiment naming

[khatus.git] / x3 / src / lib / khatus_msg_parser.mll

diff --git a/x3/src/lib/khatus_msg_parser.mll b/x3/src/lib/khatus_msg_parser.mll
new file mode 100644 (file)
index 0000000..b7f6418
--- /dev/null
+++ b/x3/src/lib/khatus_msg_parser.mll
@@ -0,0 +1,85 @@
+{
+  module Msg  = Khatus_msg
+  module Time = Khatus_time
+
+  type error =
+    [ `Bad_format_of_msg_head
+    | `Bad_format_of_msg_content
+    ]
+
+  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}