diff --git a/README.md b/README.md index 8c63cc2f..6ddd75c7 100644 --- a/README.md +++ b/README.md @@ -35,7 +35,19 @@ To be able to run your benchmarks, current-bench assumes certain things about yo ⚠️ The benchmarks are run on a single core (for now), so either don't include parallel benchmarks, or don't take the results at face value. ### JSon format -To be able to draw graphs from your results, they need to follow this format: +To be able to draw graphs from your results, they need to follow a specific format. +You can automatically check that your output conforms to that format by calling `cb-check`: + + +```bash +opam pin -n cb-check git@github.com:ocurrent/current-bench.git +opam install cb-check +your_executable | cb-check +# OR, if your_executable writes in some_file.json +cb-check some_file.json +``` + +A description of that format is also specified below for convenience: ```json { diff --git a/cb-check.opam b/cb-check.opam new file mode 100644 index 00000000..82a7b637 --- /dev/null +++ b/cb-check.opam @@ -0,0 +1,30 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Json schema checker for current-bench" +maintainer: ["Ambre Austen Suhamy "] +authors: ["Ambre Austen Suhamy "] +homepage: "https://github.com/ocurrent/current-bench" +bug-reports: "https://github.com/ocurrent/current-bench/issues" +depends: [ + "dune" {>= "2.9"} + "ocaml" {>= "4.13.0"} + "yojson" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "--promote-install-files=false" + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] + ["dune" "install" "-p" name "--create-install-files" name] +] +dev-repo: "git+https://github.com/ocurrent/current-bench.git" diff --git a/cb-check/dune b/cb-check/dune new file mode 100644 index 00000000..2587192b --- /dev/null +++ b/cb-check/dune @@ -0,0 +1,9 @@ +(executable + (name main) + (package cb-check) + (public_name cb-check) + (libraries yojson)) + +(copy_files ../pipeline/cb-schema/*.ml) + +(copy_files ../pipeline/lib/json_parsing.ml) diff --git a/cb-check/main.ml b/cb-check/main.ml new file mode 100644 index 00000000..5a26aaaf --- /dev/null +++ b/cb-check/main.ml @@ -0,0 +1,51 @@ +let read_all ic = + let b = Buffer.create 80 in + let rec loop () = + let line = input_line ic in + Buffer.add_string b (line ^ "\n"); + loop () + in + try loop () + with End_of_file -> + close_in ic; + Buffer.contents b + +let pp = Yojson.Safe.pretty_print ~std:false + +let validate l = + let aux (str, _) = + match Yojson.Safe.from_string str with + | j -> ( + match Cb_schema.S.of_json j with + | s -> Some s + | exception Invalid_argument s -> + Format.eprintf + "Some valid json didn't conform to the schema with error: \ + %s@.The json: %a@." + s pp j; + None) + | exception Yojson.Json_error s -> + Format.eprintf "\x1b[91mJson parsing failure, please report: \x1b[0m%s" + s; + exit 1 + in + match List.filter_map aux l with + | [] -> + Format.printf "No schema-valid results were parsed.@."; + exit 1 + | validated -> + Format.printf "Correctly parsed some benchmarks:@."; + Cb_schema.S.merge [] validated + |> List.map Cb_schema.S.to_json + |> List.iter (fun j -> Format.printf "%a@." pp j) + +let () = + let ic = if Array.length Sys.argv >= 2 then open_in Sys.argv.(1) else stdin in + let contents = read_all ic in + match Json_parsing.full contents with + | [] -> + Format.eprintf + "\x1b[91mCouldn't parse anything, verify that you output correct \ + json.\x1b[0m@."; + exit 1 + | l -> validate (List.rev l) diff --git a/cobench/cobench.ml b/cobench/cobench.ml index 9fb5bfdd..efd9d5e4 100644 --- a/cobench/cobench.ml +++ b/cobench/cobench.ml @@ -1,6 +1,5 @@ open Bechamel -module C = Current_bench_json -module L = C.Latest +module L = Cb_schema.S module J = Yojson.Safe type value = L.value @@ -10,7 +9,8 @@ let list vs = L.Floats vs type metric = L.metric -let metric ~name ?(description = "") ?(units = "") ?(trend = "") value = +let metric ~name ?(description = "") ?(units = "") ?(trend = L.Unspecified) + value = { L.name; description; units; trend; value; lines = [] } type result = L.result diff --git a/cobench/cobench.mli b/cobench/cobench.mli index 2461002f..8b24845f 100644 --- a/cobench/cobench.mli +++ b/cobench/cobench.mli @@ -9,7 +9,7 @@ val metric : name:string -> ?description:string -> ?units:string -> - ?trend:string -> + ?trend:Cb_schema.S.trend -> value -> metric diff --git a/cobench/dune b/cobench/dune index 6994bb7a..8bdce62a 100644 --- a/cobench/dune +++ b/cobench/dune @@ -10,5 +10,4 @@ ptime.clock.os yojson)) -(rule - (copy ../pipeline/lib/current_bench_json.ml current_bench_json.ml)) +(copy_files ../pipeline/cb-schema/*.ml) diff --git a/dune-project b/dune-project index 13bff08c..55ec222f 100644 --- a/dune-project +++ b/dune-project @@ -74,3 +74,13 @@ (and (>= 1.0.0) :with-test)))) + +(package + (name cb-check) + (synopsis "Json schema checker for current-bench") + (authors "Ambre Austen Suhamy ") + (maintainers "Ambre Austen Suhamy ") + (depends + (ocaml + (>= 4.13.0)) + yojson)) diff --git a/frontend/Dockerfile b/frontend/Dockerfile index 92881572..05573e27 100644 --- a/frontend/Dockerfile +++ b/frontend/Dockerfile @@ -11,13 +11,14 @@ ENV VITE_CURRENT_BENCH_VERSION=$VITE_CURRENT_BENCH_VERSION RUN apt-get update \ && apt-get install --no-install-recommends --assume-yes \ - screen \ + screen \ && rm -r /var/lib/apt/lists /var/cache/apt # set working directory WORKDIR /app -COPY ./pipeline/lib/current_bench_json.ml /pipeline/lib/current_bench_json.ml +COPY ./pipeline/cb-schema/schema.ml /pipeline/cb-schema/schema.ml +COPY ./pipeline/cb-schema/json.ml /pipeline/cb-schema/json.ml # Build frontend code for production FROM dev AS builder diff --git a/frontend/src/App.res b/frontend/src/App.res index 235aab6b..1dc1a446 100644 --- a/frontend/src/App.res +++ b/frontend/src/App.res @@ -56,7 +56,7 @@ module Benchmark = { let decode = (result: BenchmarkMetrics.t) => { let metrics = yojson_of_result(result) - let metrics = Current_bench_json.Latest.of_json(metrics) + let metrics = Schema.of_json(metrics) let run_at = result.run_at->decodeRunAt->Belt.Option.getExn (result.commit, result.run_job_id, run_at, result.test_index, metrics) } @@ -69,7 +69,7 @@ module Benchmark = { } } - let toLineGraph = (value: Current_bench_json.Latest.value) => { + let toLineGraph = (value: Schema.value) => { switch value { | Float(x) => LineGraph.DataRow.single(x) | Floats(xs) => LineGraph.DataRow.many(Array.of_list(xs)) @@ -84,8 +84,8 @@ module Benchmark = { acc, (commit, run_job_id, run_at, test_index, item), ) => { - List.fold_left((acc, result: Current_bench_json.Latest.result) => { - List.fold_left((acc, metric: Current_bench_json.Latest.metric) => { + List.fold_left((acc, result: Schema.result) => { + List.fold_left((acc, metric: Schema.metric) => { BenchmarkData.add( acc, ~testName=result.test_name, diff --git a/frontend/src/BenchmarkDataHelpers.res b/frontend/src/BenchmarkDataHelpers.res index 294ca9bc..d1c51070 100644 --- a/frontend/src/BenchmarkDataHelpers.res +++ b/frontend/src/BenchmarkDataHelpers.res @@ -120,7 +120,7 @@ let addMissingComparisonMetrics = (comparisonBenchmarkDataByTestName, benchmarkD run_job_id: run_job_id, lines: []->Belt.List.fromArray, description: "", - trend: "", + trend: Schema.Unspecified, units: "", }) (ts, md) diff --git a/frontend/src/BenchmarkTest.res b/frontend/src/BenchmarkTest.res index 915a9a83..56fbe257 100644 --- a/frontend/src/BenchmarkTest.res +++ b/frontend/src/BenchmarkTest.res @@ -25,7 +25,7 @@ type metricRow = { delta: option, last_value: option, comparison_value: option, - trend: string, + trend: Schema.trend, } let getRowData = ( @@ -33,7 +33,7 @@ let getRowData = ( (timeseries, metadata: BenchmarkData.metadata), ) => { if Belt.Array.length(timeseries) == 0 { - let d = {delta: None, last_value: None, comparison_value: None, trend: ""} + let d = {delta: None, last_value: None, comparison_value: None, trend: Schema.Unspecified} d } else { let last_value = BeltHelpers.Array.lastExn(timeseries)->LineGraph.DataRow.toValue @@ -62,14 +62,9 @@ let getRowData = ( } let isFavourableDelta = row => { - let ascending = - row.trend == "higher-is-better" - ? Some(true) - : row.trend == "lower-is-better" - ? Some(false) - : None - switch (row.delta, ascending) { - | (Some(delta), Some(ascending)) => delta == 0. ? None : Some(delta > 0. == ascending) + switch (row.delta, row.trend) { + | (Some(delta), Schema.Higher_is_better) => delta == 0. ? None : Some(delta > 0.) + | (Some(delta), Schema.Lower_is_better) => delta == 0. ? None : Some(delta < 0.) | _ => None } } @@ -234,7 +229,7 @@ let make = ( let suffixes = isOverlayed ? names->Belt.Array.map(x => Js.String.split("/", x)[1]) : [metricName] - // FIXME: Validate that units are same on all the overlays? (ideally, in the current_bench_json.ml) + // FIXME: Validate that units are same on all the overlays? (ideally, in pipeline/cb-schema) let seriesArrays = names->Belt.Array.map(x => getSeriesArrays(dataByMetricName, comparison, x)) // FIXME: Filter out very small values (quick fix for demo, before we work on grouping stuff) diff --git a/frontend/src/DataHelpers.res b/frontend/src/DataHelpers.res index c9cbf49e..c98ba565 100644 --- a/frontend/src/DataHelpers.res +++ b/frontend/src/DataHelpers.res @@ -1,6 +1,6 @@ let trimCommit = commit => String.length(commit) > 7 ? String.sub(commit, 0, 7) : commit -let rec yojson_of_json = (json : Js.Json.t) : Current_bench_json.Json.t => { +let rec yojson_of_json = (json : Js.Json.t) : Json.t => { switch Js.Json.classify(json) { | JSONFalse => #Bool(false) | JSONTrue => #Bool(true) diff --git a/frontend/src/LineGraph.res b/frontend/src/LineGraph.res index ae3b9e7b..4f1f3a77 100644 --- a/frontend/src/LineGraph.res +++ b/frontend/src/LineGraph.res @@ -62,7 +62,7 @@ module DataRow = { runAt: Js.Date.t, units: units, description: string, - trend: string, + trend: Schema.trend, lines: list<(int, int)>, run_job_id: option, } diff --git a/frontend/src/current_bench_json.ml b/frontend/src/current_bench_json.ml deleted file mode 120000 index f5a2c24d..00000000 --- a/frontend/src/current_bench_json.ml +++ /dev/null @@ -1 +0,0 @@ -../../pipeline/lib/current_bench_json.ml \ No newline at end of file diff --git a/frontend/src/json.ml b/frontend/src/json.ml new file mode 120000 index 00000000..cd340275 --- /dev/null +++ b/frontend/src/json.ml @@ -0,0 +1 @@ +../../pipeline/cb-schema/json.ml \ No newline at end of file diff --git a/frontend/src/schema.ml b/frontend/src/schema.ml new file mode 120000 index 00000000..aaca5ca3 --- /dev/null +++ b/frontend/src/schema.ml @@ -0,0 +1 @@ +../../pipeline/cb-schema/schema.ml \ No newline at end of file diff --git a/pipeline/cb-schema/cb_schema.ml b/pipeline/cb-schema/cb_schema.ml new file mode 100644 index 00000000..2d6568f6 --- /dev/null +++ b/pipeline/cb-schema/cb_schema.ml @@ -0,0 +1,7 @@ +(* Warning: This library is used in the pipeline, the checker, AND the frontend. + * It must remain compatible with Rescript ~= OCaml 4.06 with a few missing stdlib modules + * and must have no external dependency. + *) + +module Json = Json +module S = Schema diff --git a/pipeline/cb-schema/dune b/pipeline/cb-schema/dune new file mode 100644 index 00000000..4c324961 --- /dev/null +++ b/pipeline/cb-schema/dune @@ -0,0 +1,3 @@ +(library + (name cb_schema) + (public_name cb-schema)) diff --git a/pipeline/cb-schema/json.ml b/pipeline/cb-schema/json.ml new file mode 100644 index 00000000..006bc068 --- /dev/null +++ b/pipeline/cb-schema/json.ml @@ -0,0 +1,47 @@ +type t = + (* Yojson.Safe.t = *) + [ `Null + | `Bool of bool + | `Int of int + | `Intlit of string + | `Float of float + | `String of string + | `Assoc of (string * t) list + | `List of t list + | `Tuple of t list + | `Variant of string * t option ] + +let error key value_type value = + match value with + | `Null -> invalid_arg @@ Format.sprintf "Mandatory key %S not found." key + | _ -> + invalid_arg + @@ Format.sprintf + "The value of key %S had an expected type of `%s`, but the value \ + didn't fit." + key value_type + +let get_opt key = function + | `Assoc obj -> ( + match List.assoc_opt key obj with None -> `Null | Some x -> x) + | _ -> `Null + +let to_string_option = function `String s -> Some s | _ -> None +let to_int_option = function `Int s -> Some s | _ -> None +let to_list_option = function `List xs -> Some xs | _ -> None +let to_list key = function `List xs -> xs | j -> error key "list" j + +let get ?(context = "") key j = + let err () = + error + (if context = "" then key else context ^ "/" ^ key) + "json object" `Null + in + match get_opt key j with `Null -> err () | x -> x + +let to_string key = function `String s -> s | j -> error key "string" j + +let to_float key = function + | `Float x -> x + | `Int x -> float_of_int x + | j -> error key "float" j diff --git a/pipeline/cb-schema/schema.ml b/pipeline/cb-schema/schema.ml new file mode 100644 index 00000000..7d171d4f --- /dev/null +++ b/pipeline/cb-schema/schema.ml @@ -0,0 +1,249 @@ +(* Added because it was introduced to stdlib in 4.10 *) +let rec list_find_map f = function + | [] -> raise Not_found + | x :: xs -> ( match f x with Some y -> y | None -> list_find_map f xs) + +(* Added because it was introduced to stdlib in 5.0 *) +let sscanf_opt fmt fn ~str = try Some (Scanf.sscanf str fmt fn) with _ -> None + +(* Added because it isn't available in reason for some reason *) +let option_value default = function None -> default | Some x -> x + +let longest_string s0 s1 = + if String.length s0 > String.length s1 then s0 else s1 + +let version = 3 + +type value = + | Float of float + | Floats of float list + | Assoc of (string * float) list + +type line_range = int * int +type trend = Higher_is_better | Lower_is_better | Unspecified + +type metric = { + name : string; + description : string; + value : value; + units : string; + trend : trend; + lines : line_range list; +} + +type result = { test_name : string; metrics : metric list } +type t = { benchmark_name : string option; results : result list } +type ts = t list + +let to_floats = function + | Float x -> [ x ] + | Floats xs -> xs + | Assoc lst -> List.map snd lst + +let merge_value v0 v1 = + match (v0, v1) with + | Assoc _, _ | _, Assoc _ -> + invalid_arg "Multiple metrics: merge is not possible on min/avg/max" + | _ -> Floats (to_floats v0 @ to_floats v1) + +let merge_trend t1 t2 = + match (t1, t2) with + | _ when t1 = t2 -> t1 + | x, Unspecified | Unspecified, x -> x + | _ -> invalid_arg "Multiple metrics: merge is not possible on trends" + +let merge_metric m0 m1 = + { + name = m0.name; + description = longest_string m0.description m1.description; + value = merge_value m0.value m1.value; + units = longest_string m0.units m1.units; + trend = merge_trend m0.trend m1.trend; + lines = m0.lines @ m1.lines; + } + +let rec add_metric ms m = + match ms with + | [] -> [ m ] + | m' :: ms when m'.name = m.name -> merge_metric m' m :: ms + | m' :: ms -> m' :: add_metric ms m + +let merge_result r0 r1 = + { r0 with metrics = List.fold_left add_metric r0.metrics r1.metrics } + +let rec add_results rs r = + match rs with + | [] -> [ r ] + | r' :: rs when r'.test_name = r.test_name -> merge_result r' r :: rs + | r' :: rs -> r' :: add_results rs r + +let merge_benchmark t0 t1 = + { t0 with results = List.fold_left add_results t0.results t1.results } + +let rec add ts t = + match ts with + | [] -> [ t ] + | t' :: ts when t'.benchmark_name = t.benchmark_name -> + merge_benchmark t' t :: ts + | t' :: ts -> t' :: add ts t + +let merge ts0 ts1 = List.fold_left add ts0 ts1 + +let value_of_json = function + | `Float x -> (x, "") + | `Int x -> (float_of_int x, "") + | `Intlit s -> (float_of_string s, "") + | `String str -> + list_find_map + (fun f -> f ~str) + [ + sscanf_opt "%fmin%fs" (fun min sec -> ((min *. 60.) +. sec, "s")); + sscanf_opt "%f%s" (fun x u -> (x, u)); + ] + | j -> Json.error "value" "int or float, with or without unit" j + +let value_of_json = function + | `List vs -> + let vs, units = List.split @@ List.map value_of_json vs in + (Floats vs, units) + | `Assoc vs -> + let vs, units = + let keys = List.map (fun (key, _) -> key) vs in + if not (List.mem "avg" keys) + then invalid_arg "V3: Missing key *avg* in value"; + List.split + @@ List.map + (fun (key, v) -> + let value, units = value_of_json v in + ((key, value), units)) + vs + in + (Assoc vs, units) + | v -> + let v, unit = value_of_json v in + (Float v, [ unit ]) + +let json_of_value = function + | Float f -> `Float f + | Floats fs -> `List (List.map (fun f -> `Float f) fs) + | Assoc fs -> `Assoc (List.map (fun (x, f) -> (x, `Float f)) fs) + +let rec find_units = function + | [] -> "" + | x :: _ when x <> "" -> x + | _ :: xs -> find_units xs + +let value_of_json ?(units = "") t = + let value, units_list = value_of_json t in + let units = find_units (units :: units_list) in + (value, units) + +let trend_of_json = function + | `String "higher-is-better" -> Higher_is_better + | `String "lower-is-better" -> Lower_is_better + | `String "" | `Null -> Unspecified + | _ -> + invalid_arg + @@ Format.sprintf + "\"trend\" should be lower-is-better, higher-is-better or not set." + +let metric_of_json i t lines = + let context = Format.sprintf "results/metrics.%d" i in + let lines = + match Json.get_opt "lines" t |> Json.to_list_option with + (* NOTE: The metric JSON could either have lines or not depending on whether the JSON is + - JSON saved in the DB using latest pipeline code, or + - coming from make bench output, or existing JSON saved in DB created using older pipeline *) + | Some t -> + List.map + (fun r -> + match r with + (* Frontend interprets every number as a Float, and Tuples become lists *) + | `List [ `Float start; `Float end_ ] -> + (int_of_float start, int_of_float end_) + | _ -> (-1, -1)) + t + (* Parsing JSON from DB *) + | None -> lines + (* When parsing JSON from make bench output or older JSON in DB*) + in + let units = + Json.get_opt "units" t |> Json.to_string_option |> option_value "" + in + let trend = Json.get_opt "trend" t |> trend_of_json in + let description = + Json.get_opt "description" t |> Json.to_string_option |> option_value "" + in + let value, units = value_of_json ~units (Json.get ~context "value" t) in + let name = Json.get ~context "name" t |> Json.to_string "name" in + { name; description; value; units; trend; lines } + +let metric_of_json_v1 (name, value) lines = + let value, units = value_of_json value in + let description = "" in + let trend = Unspecified in + { name; description; value; units; trend; lines } + +let json_of_range (start, end_) = `List [ `Int start; `Int end_ ] + +let json_of_trend = function + | Unspecified -> `String "" + | Higher_is_better -> `String "higher-is-better" + | Lower_is_better -> `String "lower-is-better" + +let json_of_metric m : Json.t = + `Assoc + [ + ("name", `String m.name); + ("description", `String m.description); + ("value", json_of_value m.value); + ("units", `String m.units); + ("trend", json_of_trend m.trend); + ("lines", `List (m.lines |> List.map json_of_range)); + ] + +let json_of_metrics metrics = `List (List.map json_of_metric metrics) + +let json_of_result m = + `Assoc + [ ("name", `String m.test_name); ("metrics", json_of_metrics m.metrics) ] + +let metrics_of_json lines = function + | `List lst -> List.mapi (fun i m -> metric_of_json i m lines) lst + | `Assoc lst -> List.map (fun m -> metric_of_json_v1 m lines) lst + | j -> Json.error "results/metrics" "list or object" j + +let result_of_json t lines = + { + test_name = + Json.get ~context:"results" "name" t |> Json.to_string "results/name"; + metrics = Json.get ~context:"results" "metrics" t |> metrics_of_json lines; + } + +let of_json t = + let lines = + match Json.get_opt "lines" t with + | `Tuple [ `Int start; `Int finish ] -> [ (start, finish) ] + | _ -> [] + in + { + benchmark_name = Json.get_opt "name" t |> Json.to_string_option; + results = + Json.get "results" t + |> Json.to_list "results" + |> List.map (fun r -> result_of_json r lines); + } + +let to_json { benchmark_name; results } = + let name = + match benchmark_name with None -> `Null | Some name -> `String name + in + `Assoc + [ ("name", name); ("results", `List (List.map json_of_result results)) ] + +let to_list ts = + List.map + (fun { benchmark_name; results } -> + let results = List.map json_of_result results in + (benchmark_name, version, results)) + ts diff --git a/pipeline/dune-project b/pipeline/dune-project index 700cd760..fe5ea720 100644 --- a/pipeline/dune-project +++ b/pipeline/dune-project @@ -1,3 +1,9 @@ (lang dune 2.9) (name pipeline) + +(package + (name pipeline)) + +(package + (name cb-schema)) diff --git a/pipeline/lib/api.ml b/pipeline/lib/api.ml index a79f554e..dd36881d 100644 --- a/pipeline/lib/api.ml +++ b/pipeline/lib/api.ml @@ -105,8 +105,8 @@ let make_benchmark_from_request ~conninfo ~body ~token = ignore (benchmarks |> List.map (fun bench -> - Json_stream.db_save ~conninfo benchmark - [ Current_bench_json.Latest.of_json bench ])); + Json_stream.db_save ~conninfo benchmark [ Cb_schema.S.of_json bench ]) + ); Storage.record_success ~conninfo ~serial_id let error_message msg = diff --git a/pipeline/lib/current_bench_json.ml b/pipeline/lib/current_bench_json.ml deleted file mode 100644 index 7c7918db..00000000 --- a/pipeline/lib/current_bench_json.ml +++ /dev/null @@ -1,302 +0,0 @@ -(* Warning: This file is used in the pipeline AND the frontend. - * It must remain compatible with Rescript ~= OCaml 4.06 with a few missing stdlib modules - * and must have no external dependency. - *) - -module Json = struct - type t = - (* Yojson.Safe.t = *) - [ `Null - | `Bool of bool - | `Int of int - | `Intlit of string - | `Float of float - | `String of string - | `Assoc of (string * t) list - | `List of t list - | `Tuple of t list - | `Variant of string * t option ] - - let rec pp () : t -> string = function - | `Null -> "null" - | `Bool b -> Format.sprintf "%b" b - | `Int i -> Format.sprintf "%d" i - | `Float f -> Format.sprintf "%f" f - | `Intlit s | `String s -> Format.sprintf "%s" s - | `Assoc l -> Format.sprintf "@[{%a}@]" pp_assoc l - | `List l -> Format.sprintf "@[[%a]@]" pp_list l - | `Tuple l -> Format.sprintf "@[(%a)@]" pp_tuple l - | `Variant (s, Some j) -> Format.sprintf "@[<%S:@ %a" s pp j - | `Variant (s, None) -> Format.sprintf "@[<%S>@]" s - - and pp_assoc () = function - | [] -> "" - | (s, x) :: xs -> Format.sprintf "%S: %a,@.%a" s pp x pp_assoc xs - - and pp_list () = function - | [] -> "" - | x :: xs -> Format.sprintf "%a;@ %a" pp x pp_list xs - - and pp_tuple () = function - | [] -> "" - | x :: xs -> Format.sprintf "%a,@ %a" pp x pp_tuple xs - - let error expected gotten = - invalid_arg - @@ Format.sprintf - "Json type error: the expected type was `%s`, but the value didn't \ - fit. If it is indeed the correct type, please report.@.The value \ - was: @[%a@]@." - expected pp gotten - - let member field = function - | `Assoc obj -> ( - match List.assoc_opt field obj with None -> `Null | Some x -> x) - | _ -> `Null - - let to_string_option = function `String s -> Some s | _ -> None - let to_int_option = function `Int s -> Some s | _ -> None - let to_list_option = function `List xs -> Some xs | _ -> None - let to_list = function `List xs -> xs | j -> error "list" j - let to_assoc = function `Assoc xs -> xs | j -> error "json object" j - let get = member - let to_string = function `String s -> s | j -> error "string" j - - let to_float = function - | `Float x -> x - | `Int x -> float_of_int x - | j -> error "float" j -end - -let default d = function None -> d | Some x -> x - -let rec list_find_map f = function - | [] -> raise Not_found - | x :: xs -> ( match f x with Some y -> y | None -> list_find_map f xs) - -let scanf fmt fn ~str = try Some (Scanf.sscanf str fmt fn) with _ -> None - -module V2 = struct - let version = 2 - - type value = - | Float of float - | Floats of float list - | Assoc of (string * float) list - - type line_range = int * int - - type metric = { - name : string; - description : string; - value : value; - units : string; - trend : string; - lines : line_range list; - } - - type result = { test_name : string; metrics : metric list } - type t = { benchmark_name : string option; results : result list } - type ts = t list - - let to_floats = function - | Float x -> [ x ] - | Floats xs -> xs - | Assoc lst -> List.map snd lst - - let merge_value v0 v1 = - match (v0, v1) with - | Assoc _, _ | _, Assoc _ -> - invalid_arg "Multiple metrics: merge is not possible on min/avg/max" - | _ -> Floats (to_floats v0 @ to_floats v1) - - let longest_string s0 s1 = - if String.length s0 > String.length s1 then s0 else s1 - - let merge_metric m0 m1 = - { - name = m0.name; - description = longest_string m0.description m1.description; - value = merge_value m0.value m1.value; - units = longest_string m0.units m1.units; - trend = longest_string m0.trend m1.trend; - lines = m0.lines @ m1.lines; - } - - let rec add_metric ms m = - match ms with - | [] -> [ m ] - | m' :: ms when m'.name = m.name -> merge_metric m' m :: ms - | m' :: ms -> m' :: add_metric ms m - - let merge_result r0 r1 = - { r0 with metrics = List.fold_left add_metric r0.metrics r1.metrics } - - let rec add_results rs r = - match rs with - | [] -> [ r ] - | r' :: rs when r'.test_name = r.test_name -> merge_result r' r :: rs - | r' :: rs -> r' :: add_results rs r - - let merge_benchmark t0 t1 = - { t0 with results = List.fold_left add_results t0.results t1.results } - - let rec add ts t = - match ts with - | [] -> [ t ] - | t' :: ts when t'.benchmark_name = t.benchmark_name -> - merge_benchmark t' t :: ts - | t' :: ts -> t' :: add ts t - - let merge ts0 ts1 = List.fold_left add ts0 ts1 - - let value_of_json = function - | `Float x -> (x, "") - | `Int x -> (float_of_int x, "") - | `Intlit s -> (float_of_string s, "") - | `String str -> - list_find_map - (fun f -> f ~str) - [ - scanf "%fmin%fs" (fun min sec -> ((min *. 60.) +. sec, "s")); - scanf "%f%s" (fun x u -> (x, u)); - ] - | _ -> failwith "V2: not a value" - - let value_of_json = function - | `List vs -> - let vs, units = List.split @@ List.map value_of_json vs in - (Floats vs, units) - | `Assoc vs -> - let vs, units = - let keys = List.map (fun (key, _) -> key) vs in - if not (List.mem "avg" keys) - then failwith "V2: Missing key *avg* in value"; - List.split - @@ List.map - (fun (key, v) -> - let value, units = value_of_json v in - ((key, value), units)) - vs - in - (Assoc vs, units) - | v -> - let v, unit = value_of_json v in - (Float v, [ unit ]) - - let json_of_value = function - | Float f -> `Float f - | Floats fs -> `List (List.map (fun f -> `Float f) fs) - | Assoc fs -> `Assoc (List.map (fun (x, f) -> (x, `Float f)) fs) - - let rec find_units = function - | [] -> "" - | x :: _ when x <> "" -> x - | _ :: xs -> find_units xs - - let value_of_json ?(units = "") t = - let value, units_list = value_of_json t in - let units = find_units (units :: units_list) in - (value, units) - - let metric_of_json t lines = - let lines = - match Json.get "lines" t |> Json.to_list_option with - (* NOTE: The metric JSON could either have lines or not depending on whether the JSON is - - JSON saved in the DB using latest pipeline code, or - - coming from make bench output, or existing JSON saved in DB created using older pipeline *) - | Some t -> - List.map - (fun r -> - match r with - (* Frontend interprets every number as a Float, and Tuples become lists *) - | `List [ `Float start; `Float end_ ] -> - (int_of_float start, int_of_float end_) - | _ -> (-1, -1)) - t - (* Parsing JSON from DB *) - | _ -> lines - (* When parsing JSON from make bench output or older JSON in DB*) - in - let units = Json.get "units" t |> Json.to_string_option |> default "" in - let trend = Json.get "trend" t |> Json.to_string_option |> default "" in - let description = - Json.get "description" t |> Json.to_string_option |> default "" - in - let value, units = value_of_json ~units (Json.get "value" t) in - let name = Json.get "name" t |> Json.to_string in - (match trend with - | "lower-is-better" | "higher-is-better" | "" -> () - | _ -> - failwith - @@ "V2: trend should be lower-is-better, higher-is-better or not set. " - ^ trend - ^ " is not valid."); - { name; description; value; units; trend; lines } - - let metric_of_json_v1 (name, value) lines = - let value, units = value_of_json value in - let description = "" in - let trend = "" in - { name; description; value; units; trend; lines } - - let json_of_range (start, end_) = `List [ `Int start; `Int end_ ] - - let json_of_metric m = - `Assoc - [ - ("name", `String m.name); - ("description", `String m.description); - ("value", json_of_value m.value); - ("units", `String m.units); - ("trend", `String m.trend); - ("lines", `List (m.lines |> List.map json_of_range)); - ] - - let json_of_metrics metrics = `List (List.map json_of_metric metrics) - - let json_of_result m = - `Assoc - [ ("name", `String m.test_name); ("metrics", json_of_metrics m.metrics) ] - - let metrics_of_json lines = function - | `List lst -> List.map (fun m -> metric_of_json m lines) lst - | `Assoc lst -> List.map (fun m -> metric_of_json_v1 m lines) lst - | j -> Json.error "list or object" j - - let result_of_json t lines = - { - test_name = Json.get "name" t |> Json.to_string; - metrics = Json.get "metrics" t |> metrics_of_json lines; - } - - let of_json t = - let lines = - match Json.get "lines" t with - | `Tuple [ `Int start; `Int finish ] -> [ (start, finish) ] - | _ -> [] - in - { - benchmark_name = Json.get "name" t |> Json.to_string_option; - results = - Json.get "results" t - |> Json.to_list - |> List.map (fun r -> result_of_json r lines); - } - - let to_json { benchmark_name; results } = - let name = - match benchmark_name with None -> `Null | Some name -> `String name - in - `Assoc - [ ("name", name); ("results", `List (List.map json_of_result results)) ] -end - -module Latest = V2 - -let to_list ts = - List.map - (fun { Latest.benchmark_name; results } -> - let results = List.map Latest.json_of_result results in - (benchmark_name, Latest.version, results)) - ts diff --git a/pipeline/lib/dune b/pipeline/lib/dune index f1d4f2c6..8c9088ce 100644 --- a/pipeline/lib/dune +++ b/pipeline/lib/dune @@ -1,7 +1,9 @@ (library (name pipeline) + (public_name pipeline) (libraries capnp-rpc-unix + cb-schema current current.fs current_docker diff --git a/pipeline/lib/json_parsing.ml b/pipeline/lib/json_parsing.ml new file mode 100644 index 00000000..27662ced --- /dev/null +++ b/pipeline/lib/json_parsing.ml @@ -0,0 +1,166 @@ +let is_whitespace = function '\n' | ' ' | '\t' | '\r' -> true | _ -> false + +type automata = + | BeforeID (** Curly brace received, waiting for a string id *) + | InArray (** Waiting for a value or a \] *) + | InString (** Inside the identifier: "foo" *) + | Escaped (** Right after a \ inside a string *) + | AfterID (** After string, waiting for a colon *) + | BeforeValue (** After colon, waiting for any value on the right side *) + | AfterValue (** After value, waiting for a comma or closing bracket *) + | Number of num_state + | Bool of bool_state + | Null of null_state + +and num_state = + | Sign (* After receiving a '-' sign *) + | LeadZero (* After receiving a leading 0 *) + | Num (* Standard numbers *) + | FracDot (* Received a '.' starting a decimal *) + | FracNum (* Decimals *) + | ExpE (* Received exponent 'e' *) + | ExpSign (* Received exponent sign *) + | ExpNum (* Exponents *) + +and bool_state = BT | BR | BU | BF | BA | BL | BS +and null_state = NN | NU | NL + +exception Finished_JSON +exception Invalid_JSON + +let json_step_aux stack chr = + if is_whitespace chr + then stack + else + match (stack, chr) with + (* Initial state *) + | [], '{' -> [ BeforeID ] + | [], _ -> [] + (* Bracket open or after a comma *) + | BeforeID :: st, '"' -> InString :: AfterID :: st + | [ BeforeID ], '}' -> raise Finished_JSON + | BeforeID :: st, '}' -> st + | BeforeID :: _, _ -> raise Invalid_JSON + (* Inside string *) + | InString :: _, '\\' -> Escaped :: stack + | Escaped :: st, _ -> st + | InString :: st, '"' -> st + | InString :: _, _ -> stack + (* After string *) + | AfterID :: st, ':' -> BeforeValue :: st + | AfterID :: _, _ -> raise Invalid_JSON + (* After value *) + | AfterValue :: InArray :: st, ']' -> AfterValue :: st + | AfterValue :: InArray :: st, ',' -> BeforeValue :: InArray :: st + | AfterValue :: InArray :: _, _ -> raise Invalid_JSON + | [ AfterValue ], '}' -> raise Finished_JSON + | AfterValue :: st, '}' -> st + | AfterValue :: st, ',' -> BeforeID :: st + | AfterValue :: _, _ -> raise Invalid_JSON + (* Before value *) + | BeforeValue :: st, '"' -> InString :: AfterValue :: st + | BeforeValue :: st, '{' -> BeforeID :: AfterValue :: st + (* Booleans + null *) + | BeforeValue :: st, 't' -> Bool BT :: st + | Bool BT :: st, 'r' -> Bool BR :: st + | Bool BR :: st, 'u' -> Bool BU :: st + | Bool BU :: st, 'e' -> AfterValue :: st + | BeforeValue :: st, 'f' -> Bool BF :: st + | Bool BF :: st, 'a' -> Bool BA :: st + | Bool BA :: st, 'l' -> Bool BL :: st + | Bool BL :: st, 's' -> Bool BS :: st + | Bool BS :: st, 'e' -> AfterValue :: st + | BeforeValue :: st, 'n' -> Null NN :: st + | Null NN :: st, 'u' -> Null NU :: st + | Null NU :: st, 'l' -> Null NL :: st + | Null NL :: st, 'l' -> AfterValue :: st + | Bool BT :: _, _ + | Bool BR :: _, _ + | Bool BU :: _, _ + | Bool BF :: _, _ + | Bool BA :: _, _ + | Bool BL :: _, _ + | Bool BS :: _, _ + | Null NN :: _, _ + | Null NU :: _, _ + | Null NL :: _, _ -> + raise Invalid_JSON + (* Arrays *) + | BeforeValue :: st, '[' -> BeforeValue :: InArray :: st + | BeforeValue :: InArray :: st, ']' -> AfterValue :: st + (* Impossible case *) + | InArray :: _, _ -> failwith "InArray shouldn't be on top of the stack" + (* Numbers *) + | BeforeValue :: st, '-' -> Number Sign :: st + | (BeforeValue | Number Sign) :: st, '0' -> Number LeadZero :: st + | (BeforeValue | Number Sign) :: st, '1' .. '9' -> Number Num :: st + | Number Num :: _, '0' .. '9' -> stack + | Number (LeadZero | Num) :: st, '.' -> Number FracDot :: st + | Number (FracDot | FracNum) :: st, '0' .. '9' -> Number FracNum :: st + | Number (LeadZero | Num | FracNum) :: st, ('e' | 'E') -> Number ExpE :: st + | Number ExpE :: st, ('+' | '-') -> Number ExpSign :: st + | Number (ExpE | ExpSign | ExpNum) :: st, '0' .. '9' -> Number ExpNum :: st + (* Finishing a number *) + | Number (LeadZero | Num | FracNum | ExpNum) :: InArray :: st, ']' -> + AfterValue :: st + | Number (LeadZero | Num | FracNum | ExpNum) :: InArray :: st, ',' -> + BeforeValue :: InArray :: st + | [ Number (LeadZero | Num | FracNum | ExpNum) ], '}' -> raise Finished_JSON + | Number (LeadZero | Num | FracNum | ExpNum) :: st, '}' -> st + | Number (LeadZero | Num | FracNum | ExpNum) :: st, ',' -> BeforeID :: st + (* Invalid states *) + | (BeforeValue | Number _) :: _, _ -> raise Invalid_JSON + +type json_parser = { + current : Buffer.t; + stack : automata list; + lines : int; + start_line : int; + carriage_seen : bool; +} + +let make_parser ?(lines = 1) ?(start_line = 1) () = + { + current = Buffer.create 16; + stack = []; + lines; + start_line; + carriage_seen = false; + } + +let json_step state chr = + let state = + match (chr, state.carriage_seen) with + | '\r', _ -> { state with lines = state.lines + 1; carriage_seen = true } + | '\n', false -> { state with lines = state.lines + 1 } + | _ -> { state with carriage_seen = false } + in + match json_step_aux state.stack chr with + | [] -> (None, { state with start_line = state.lines; stack = [] }) + | exception Invalid_JSON -> + (None, make_parser ~lines:state.lines ~start_line:state.start_line ()) + | exception Finished_JSON -> + Buffer.add_char state.current chr; + let str = Buffer.contents state.current in + (Some str, make_parser ~lines:state.lines ~start_line:state.start_line ()) + | hd :: _ as stack -> + if hd = InString || (chr <> '\n' && chr <> '\r') + then Buffer.add_char state.current chr; + (None, { state with stack }) + +let steps (parsed, state) str = + String.fold_left + (fun (parsed, state) chr -> + let opt_json, state = json_step state chr in + let parsed = + match opt_json with + | Some json -> (json, (state.start_line, state.lines)) :: parsed + | None -> parsed + in + (parsed, state)) + (parsed, state) str + +let full str = + let state = make_parser () in + let parsed, _ = steps ([], state) str in + parsed diff --git a/pipeline/lib/json_stream.ml b/pipeline/lib/json_stream.ml index 29f1f522..7e70e3ed 100644 --- a/pipeline/lib/json_stream.ml +++ b/pipeline/lib/json_stream.ml @@ -1,6 +1,6 @@ let db_save ~conninfo benchmark output = output - |> Current_bench_json.to_list + |> Cb_schema.S.to_list |> List.iter (fun (benchmark_name, version, results) -> results |> List.mapi (fun test_index res -> @@ -21,158 +21,6 @@ let read ~start path = let len = min max_log_chunk_size (len - start) in (really_input_string ch (Int64.to_int len), start + len) -let is_whitespace = function '\n' | ' ' | '\t' | '\r' -> true | _ -> false -let is_numeric = function '0' .. '9' | '-' | '.' | 'e' -> true | _ -> false - -type automata = - | BeforeID (** Curly brace received, waiting for a string id *) - | InArray (** Waiting for a value or a \] *) - | InString (** Inside the identifier: "foo" *) - | InNumber (** Parsing the full number *) - | Escaped (** Right after a \ inside a string *) - | AfterID (** After string, waiting for a colon *) - | BeforeValue (** After colon, waiting for any value on the right side *) - | AfterValue (** After value, waiting for a comma or closing bracket *) - | BoolT (** Ugly but seems necessary *) - | BoolR - | BoolU - | BoolF - | BoolA - | BoolL - | BoolS - | NullN - | NullU - | NullL - -exception Finished_JSON -exception Invalid_JSON - -type json_parser = { - current : Buffer.t; - stack : automata list; - lines : int; - start_line : int; - carriage_seen : bool; -} - -let json_step_aux stack chr = - if is_whitespace chr - then stack - else - match (stack, chr) with - (* Initial state *) - | [], '{' -> [ BeforeID ] - | [], _ -> [] - (* Bracket open or after a comma *) - | BeforeID :: st, '"' -> InString :: AfterID :: st - | [ BeforeID ], '}' -> raise Finished_JSON - | BeforeID :: st, '}' -> st - | BeforeID :: _, _ -> raise Invalid_JSON - (* Inside string *) - | InString :: _, '\\' -> Escaped :: stack - | Escaped :: st, _ -> st - | InString :: st, '"' -> st - | InString :: _, _ -> stack - (* After string *) - | AfterID :: st, ':' -> BeforeValue :: st - | AfterID :: _, _ -> raise Invalid_JSON - (* After value *) - | AfterValue :: InArray :: st, ']' -> AfterValue :: st - | AfterValue :: InArray :: st, ',' -> BeforeValue :: InArray :: st - | [ AfterValue ], '}' -> raise Finished_JSON - | AfterValue :: st, '}' -> st - | AfterValue :: st, ',' -> BeforeID :: st - | AfterValue :: _, _ -> raise Invalid_JSON - (* Before value *) - | BeforeValue :: st, '"' -> InString :: AfterValue :: st - | BeforeValue :: st, '{' -> BeforeID :: AfterValue :: st - (* Booleans + null *) - | BeforeValue :: st, 't' -> BoolT :: st - | BoolT :: st, 'r' -> BoolR :: st - | BoolR :: st, 'u' -> BoolU :: st - | BoolU :: st, 'e' -> AfterValue :: st - | BeforeValue :: st, 'f' -> BoolF :: st - | BoolF :: st, 'a' -> BoolA :: st - | BoolA :: st, 'l' -> BoolL :: st - | BoolL :: st, 's' -> BoolS :: st - | BoolS :: st, 'e' -> AfterValue :: st - | BeforeValue :: st, 'n' -> NullN :: st - | NullN :: st, 'u' -> NullU :: st - | NullU :: st, 'l' -> NullL :: st - | NullL :: st, 'l' -> AfterValue :: st - | BoolT :: _, _ - | BoolR :: _, _ - | BoolU :: _, _ - | BoolF :: _, _ - | BoolA :: _, _ - | BoolL :: _, _ - | BoolS :: _, _ - | NullN :: _, _ - | NullU :: _, _ - | NullL :: _, _ -> - raise Invalid_JSON - (* Arrays *) - | BeforeValue :: st, '[' -> BeforeValue :: InArray :: st - (* Impossible case *) - | InArray :: _, _ -> failwith "InArray shouldn't be on top of the stack" - (* Numbers *) - | BeforeValue :: st, chr when is_numeric chr -> InNumber :: st - | InNumber :: _, chr when is_numeric chr -> stack - | InNumber :: InArray :: st, ']' -> AfterValue :: st - | InNumber :: InArray :: st, ',' -> BeforeValue :: InArray :: st - | [ InNumber ], '}' -> raise Finished_JSON - | InNumber :: st, '}' -> st - | InNumber :: st, ',' -> BeforeID :: st - | InNumber :: _, _ -> raise Invalid_JSON - | BeforeValue :: _, _ -> raise Invalid_JSON - -let make_json_parser ?(lines = 1) ?(start_line = 1) () = - { - current = Buffer.create 16; - stack = []; - lines; - start_line; - carriage_seen = false; - } - -let json_step state chr = - let state = - match (chr, state.carriage_seen) with - | '\r', _ -> { state with lines = state.lines + 1; carriage_seen = true } - | '\n', false -> { state with lines = state.lines + 1 } - | _ -> { state with carriage_seen = false } - in - match json_step_aux state.stack chr with - | [] -> (None, { state with start_line = state.lines; stack = [] }) - | exception Invalid_JSON -> - (None, make_json_parser ~lines:state.lines ~start_line:state.start_line ()) - | exception Finished_JSON -> - Buffer.add_char state.current chr; - let str = Buffer.contents state.current in - ( Some str, - make_json_parser ~lines:state.lines ~start_line:state.start_line () ) - | hd :: _ as stack -> - if hd = InString || (chr <> '\n' && chr <> '\r') - then Buffer.add_char state.current chr; - (None, { state with stack }) - -let json_steps (parsed, state) str = - String.fold_left - (fun (parsed, state) chr -> - let opt_json, state = json_step state chr in - let parsed = - match opt_json with - | Some json -> (json, (state.start_line, state.lines)) :: parsed - | None -> parsed - in - (parsed, state)) - (parsed, state) str - -let json_full str = - let state = make_json_parser () in - let parsed, _ = json_steps ([], state) str in - parsed - let job_output_stream job_id = match Current.Job.log_path job_id with | Error (`Msg msg) -> @@ -180,7 +28,7 @@ let job_output_stream job_id = Lwt_stream.of_list [] | Ok path -> let position = ref 0L in - let state = ref (make_json_parser ()) in + let state = ref (Json_parsing.make_parser ()) in Lwt_stream.from (fun () -> let rec aux () = let start = !position in @@ -188,7 +36,7 @@ let job_output_stream job_id = | "", _ -> try_again () | data, next -> ( position := next; - let parsed, st = json_steps ([], !state) data in + let parsed, st = Json_parsing.steps ([], !state) data in state := st; match parsed with | [] -> try_again () @@ -238,7 +86,7 @@ module Save = struct failures in let cb_output = - let jsons = List.map Current_bench_json.Latest.to_json cb in + let jsons = List.map Cb_schema.S.to_json cb in "```" ^ Yojson.Safe.to_string (`List jsons) ^ "```" in String.concat "\n" ("" :: cb_output :: failures_output) @@ -266,14 +114,14 @@ module Save = struct ( json |> Yojson.Safe.from_string |> json_merge_lines range - |> Current_bench_json.Latest.of_json - |> Current_bench_json.Latest.add jsons, + |> Cb_schema.S.of_json + |> Cb_schema.S.add jsons, exns ) with exn -> (jsons, (json, range, Printexc.to_string exn) :: exns)) ([], []) in - let cb = Current_bench_json.Latest.merge cb jsons in + let cb = Cb_schema.S.merge cb jsons in let duration = Ptime.diff (Ptime_clock.now ()) run_at in let () = db_save ~conninfo diff --git a/pipeline/lib/metric.ml b/pipeline/lib/metric.ml index c9b61f0e..c41e7ba9 100644 --- a/pipeline/lib/metric.ml +++ b/pipeline/lib/metric.ml @@ -18,8 +18,7 @@ let parse_benchmark_data ~data = | _commit, benchmark_name, test_name, metrics -> metrics |> List.fold_left - (fun acc - ({ name; value; _ } : Current_bench_json.Latest.metric) -> + (fun acc ({ name; value; _ } : Cb_schema.S.metric) -> let key = (benchmark_name, test_name, name) in BenchmarksData.add key value acc) acc) @@ -40,7 +39,7 @@ let mean_float_list xs = let n = List.length xs in match n with 0 -> 0. | _ -> sum_float_list xs /. Float.of_int n -let avg_of_value (v : Current_bench_json.Latest.value) = +let avg_of_value (v : Cb_schema.S.value) = match v with | Float v -> v | Floats vs -> mean_float_list vs @@ -64,8 +63,8 @@ type change = Change of float | New let find_changed_metrics ~metrics ~compare_metrics = BenchmarksData.merge - (fun _ (value : Current_bench_json.Latest.value option) - (compare_value : Current_bench_json.Latest.value option) -> + (fun _ (value : Cb_schema.S.value option) + (compare_value : Cb_schema.S.value option) -> match (value, compare_value) with | Some value, Some compare_value -> let delta = diff --git a/pipeline/lib/storage.ml b/pipeline/lib/storage.ml index fd52cf68..cf1701c1 100644 --- a/pipeline/lib/storage.ml +++ b/pipeline/lib/storage.ml @@ -14,7 +14,7 @@ let setup_metadata ~repository ~worker ~docker_image let docker_image = Db_util.string docker_image in let query = (* - When setting up metadata, we are only insert the details that we know at th + When setting up metadata, we only insert the details that we know at the beginning. If we see a conflict here, that means we have started running the benchmarks again for this repo and commit, so we reset the build_job_id and the run_job_id. @@ -154,9 +154,8 @@ let parse_result result = ( commit, bench_name, test_name, - metrics - |> Yojson.Safe.from_string - |> Current_bench_json.Latest.metrics_of_json [] ) + metrics |> Yojson.Safe.from_string |> Cb_schema.S.metrics_of_json [] + ) | _ -> failwith "Unexpected format of query result") result diff --git a/pipeline/tests/dune b/pipeline/tests/dune index 98623f29..27ed066f 100644 --- a/pipeline/tests/dune +++ b/pipeline/tests/dune @@ -4,6 +4,7 @@ alcotest alcotest-lwt capnp-rpc-unix + cb-schema current current.fs current_docker diff --git a/pipeline/tests/json_stream_test.ml b/pipeline/tests/json_parsing_test.ml similarity index 87% rename from pipeline/tests/json_stream_test.ml rename to pipeline/tests/json_parsing_test.ml index 0c90ec43..675397fd 100644 --- a/pipeline/tests/json_stream_test.ml +++ b/pipeline/tests/json_parsing_test.ml @@ -2,11 +2,8 @@ let parsed_location = let module M = struct type t = string * (int * int) - let pp ppf s = - match s with - | s, (beg, end_) -> - Format.pp_print_string ppf - (Printf.sprintf "(%s, (%d, %d))" s beg end_) + let pp fmt (s, (start, finish)) = + Format.fprintf fmt "(%s, (%d, %d))" s start finish let equal x y = x = y end in @@ -26,8 +23,8 @@ let parse_one = "..."; ] in - let state = Json_stream.make_json_parser () in - let parsed, _state = Json_stream.json_steps ([], state) str in + let state = Json_parsing.make_parser () in + let parsed, _state = Json_parsing.steps ([], state) str in let expect = [ ({|{"ok": ["yes"]}|}, (8, 8)); ({|{"json": true}|}, (3, 3)) ] in @@ -38,12 +35,12 @@ let parse_two = let str = String.concat "\n" [ {|{"json": true}|}; "ignore"; "this"; {|{"ok|} ] in - let state = Json_stream.make_json_parser () in - let parsed, state = Json_stream.json_steps ([], state) str in + let state = Json_parsing.make_parser () in + let parsed, state = Json_parsing.steps ([], state) str in let expect = [ ({|{"json": true}|}, (1, 1)) ] in Alcotest.(check (list parsed_location)) "jsons" expect parsed; let str = String.concat "\n" [ {|": {"more":|}; {| "is coming"}}|}; "{" ] in - let parsed, _state = Json_stream.json_steps ([], state) str in + let parsed, _state = Json_parsing.steps ([], state) str in let expect = [ ({|{"ok": {"more": "is coming"}}|}, (4, 5)) ] in Alcotest.(check (list parsed_location)) "jsons" expect parsed; () @@ -51,7 +48,7 @@ let parse_two = let parse_wrong = Alcotest_lwt.test_case_sync "parse json: invalid" `Quick @@ fun () -> let str = "{{{ this isn't json }}}" in - let parsed = Json_stream.json_full str in + let parsed = Json_parsing.full str in let expect = [] in Alcotest.(check (list parsed_location)) "jsons" expect parsed; () @@ -68,7 +65,7 @@ let parse_wrong_longer = end); }|} in - let parsed = Json_stream.json_full str in + let parsed = Json_parsing.full str in let expect = [] in Alcotest.(check (list parsed_location)) "jsons" expect parsed; () @@ -112,7 +109,7 @@ let parse_real_log = Job succeeded 2022-05-03 10:02.42: Job succeeded|} in - let parsed = Json_stream.json_full str in + let parsed = Json_parsing.full str in let expect = [ ( {|{"results": [{"name": "eqaf", "metrics": [{"name": "divmod", "value": 1}]}]}|}, @@ -128,7 +125,7 @@ let parse_exponents = Alcotest_lwt.test_case_sync "parse json: with exponent in numbers" `Quick @@ fun () -> let str = {|{"name": "foo", "value": 3.1415926535e-09}|} in - let parsed = Json_stream.json_full str in + let parsed = Json_parsing.full str in let expect = [ ({|{"name": "foo", "value": 3.1415926535e-09}|}, (1, 1)) ] in Alcotest.(check (list parsed_location)) "jsons" expect parsed; () @@ -140,7 +137,7 @@ let parse_non_last_num = "pi": 3.14, "phi": 1.618 }|} in - let parsed = Json_stream.json_full str in + let parsed = Json_parsing.full str in let expect = [ ({|{ "pi": 3.14, "phi": 1.618 }|}, (2, 5)) ] in Alcotest.(check (list parsed_location)) "jsons" expect parsed; () @@ -152,7 +149,7 @@ let parse_wrong_then_right = "you're an all star", {"get your game on": "go play"} }|} in - let parsed = Json_stream.json_full str in + let parsed = Json_parsing.full str in let expect = [ ({|{"get your game on": "go play"}|}, (2, 2)) ] in Alcotest.(check (list parsed_location)) "jsons" expect parsed; () @@ -174,7 +171,7 @@ let exec_command cmd = let parse_local_test = Alcotest_lwt.test_case_sync "parse json: local test repo" `Quick @@ fun () -> let str = exec_command "cd ../../../../local-repos/test; make bench" in - let parsed = Json_stream.json_full str in + let parsed = Json_parsing.full str in let yojsoned = List.map (fun (str, _) -> Yojson.Safe.from_string str) parsed in diff --git a/pipeline/tests/test.ml b/pipeline/tests/test.ml index 667ebdd1..e8444f2a 100644 --- a/pipeline/tests/test.ml +++ b/pipeline/tests/test.ml @@ -1,4 +1,4 @@ let () = Lwt_main.run @@ Alcotest_lwt.run "pipeline" - [ ("api", Api_test.tests); ("json_stream", Json_stream_test.tests) ] + [ ("api", Api_test.tests); ("json parsing", Json_parsing_test.tests) ]