From bd364b9c9691d8dae76eeea7ff1224927abea4c3 Mon Sep 17 00:00:00 2001 From: Marcus Granado Date: Fri, 22 Mar 2019 17:50:06 +0000 Subject: [PATCH 01/36] use http basic authentication when fetching url data Signed-off-by: Marcus Granado --- src/brief_handler.ml | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index d161bae..e8f9639 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -1,6 +1,21 @@ open Core.Std open Utils +let config_file = Sys.argv.(2) + +let config = + In_channel.(with_file config_file ~f:input_lines) + |> List.map ~f:(fun line -> Scanf.sscanf line "%s@=%s" (fun k v -> (k,v)) ) + |> String.Table.of_alist_exn + +let get_config key = + match String.Table.find config key with + | None -> debug (sprintf "Fatal error: Could not find config key '%s' in %s" key config_file); raise Not_found + | Some x -> x + +let rage_username = get_config "rage_username" +let rage_password = get_config "rage_password" + (* types of the url input arguments *) type cols_t = (string * string list) list list with sexp type rows_t = (string * string list) list list with sexp @@ -82,6 +97,8 @@ let t ~args = object (self) let conn = Curl.init() and write_buff = Buffer.create 16384 in Curl.set_writefunction conn (fun x->Buffer.add_string write_buff x; String.length x); Curl.set_url conn url; + Curl.set_username conn rage_username; + Curl.set_password conn rage_password; Curl.perform conn; Curl.global_cleanup(); Buffer.contents write_buff; From 27307ed5fedadc513401164573116a6a42db04a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 29 Apr 2019 13:13:07 +0100 Subject: [PATCH 02/36] fix brief report link MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It wants an `&` at the end, otherwise the javascript interprets `#brief_report_analysis` as part of whatever ends up as the last parameter. Signed-off-by: Edwin Török --- src/brief_handler.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index e8f9639..af66483 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -937,7 +937,7 @@ let t ~args = object (self) ( (* rage is not generic enough to receive an arbirary number of soms in a link, pick just the first one *) let som_id=match List.find_exn ctx ~f:(fun (k,_)->k="soms") with |(k,v)->List.hd_exn v in - (sprintf "graph" (Utils.server_name ()) som_id + (sprintf "graph" (Utils.server_name ()) som_id (* xaxis *) (List.fold_left link_xaxis ~init:"" ~f:(fun acc x->sprintf "%s%s" acc (sprintf "&xaxis=%s" x))) (* preset values *) @@ -1032,7 +1032,7 @@ let t ~args = object (self) )) ) in - let brief_name = if is_digit brief_id then "jim #"^brief_id else sprintf "from %s" brief_id brief_id in + let brief_name = if is_digit brief_id then "jim #"^brief_id else sprintf "from %s" brief_id brief_id in printf "

Brief RAGE Report %s: %s

\n" brief_name (title_of_id brief_id); printf "%s" "
  • Numbers reported at 95% confidence level from the data of existing runs\n"; printf "%s" "
  • (x) indicates number of samples\n"; From 7a8e811ed2a52e0e40262a92c8a15533607676c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 21 Aug 2019 18:09:29 +0100 Subject: [PATCH 03/36] CP-30677: expand variables from XenRT suite files MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit XenRT suite files can contain '' to include variable definitions from another file. The filename itself can be a variable, usually ${PRODUCT_VERSION}. Read PRODUCT_VERSION default from the configuration file (in our case /etc/rage_passwd). Fetch and parse the include file for any parameters, and make upper-case parameters available for substitution. The suite files can also contain RAGE's own lisp-like language which has lower-case variables, so keep lower-case variables as is for expansion later by the lisp-like interpreter. Once we have the substitutions apply them to each row we read from the suite file. RAGE still runs on OCaml 4.01, and OMake, so this is using the Str module for regexes. Should replace this some day with newer OCaml version and 're' module. Tested by copying to /var/www/rage-test-edvint on rage, and opening http://rage.uk.xensource.com/test-edvint.cgi?p=brief&id=https://info.citrite.net/display/~svcacct_ragebot/RAGE+report+test Signed-off-by: Edwin Török --- src/brief_handler.ml | 53 ++++++++++++++++++++++++++++++++++++++------ 1 file changed, 46 insertions(+), 7 deletions(-) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index af66483..9bda0e1 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -15,6 +15,7 @@ let get_config key = let rage_username = get_config "rage_username" let rage_password = get_config "rage_password" +let product_version = get_config "product_version" (* types of the url input arguments *) type cols_t = (string * string list) list list with sexp @@ -119,18 +120,56 @@ let t ~args = object (self) let query = sprintf "select brief_params from briefs where brief_id='%s'" id in (Sql.exec_exn ~conn ~query)#get_all.(0).(0) in - let fetch_brief_params_from_suite ?(branch="refs/heads/master") id = + let fetch_suite id branch = let url = sprintf "https://code.citrite.net/projects/XRT/repos/xenrt/raw/suites/%s?at=%s" id (Uri.pct_encode branch) in debug (sprintf "Fetching from suite %s" url); - let html = html_of_url url in + html_of_url url, url in + let fetch_parameters_from inc ~branch = + let b = Buffer.create 80 in + let lookup var = + debug ("Lookup include variable: " ^ var); + match var with + | "PRODUCT_VERSION" -> product_version + | other -> "_" + in + Buffer.add_substitute b lookup inc; + let inc = Buffer.contents b in + let html, _ = fetch_suite inc branch in + let pattern = Str.regexp "\\([^=]+\\)=\\([^<]+\\)" in + let rage_str = ref [] in + let f str = rage_str := (Str.matched_group 1 str, Str.matched_group 2 str) :: !rage_str; "" in + ignore (Str.global_substitute pattern f html); + List.rev !rage_str + in + let fetch_brief_params_from_suite ?(branch="refs/heads/master") id = + let html, url = fetch_suite id branch in let html = Str.global_replace (Str.regexp "\n") "" html in (*remove newlines from html*) + let find_matches rex = + let rage_str = ref [] in + let f str = rage_str := (Str.matched_group 1 str) :: !rage_str; "" in + ignore (Str.global_substitute rex f html); + List.rev !rage_str + in (* Look for comments and concatenate their contents *) - let rage_str = ref [] in - let f str = rage_str := (Str.matched_group 1 str) :: !rage_str; "" in let pattern = Str.regexp "" in - ignore (Str.global_substitute pattern f html); - let rows = List.rev !rage_str |> String.concat ~sep:"\n" in - "rows=(" ^ rows ^ ")" + let rows = find_matches pattern |> String.concat ~sep:"\n" in + let include_rex = Str.regexp " List.map ~f:(fetch_parameters_from ~branch) |> List.concat in + debug (sprintf "include parameters: %s" + (List.map ~f:(fun (k,v) -> sprintf "%s=%s" k v) includes |> String.concat ~sep:",")); + let lookup k = + if String.uppercase k = k then + match List.Assoc.find includes k with + | Some v -> v + | None -> + failwith (Printf.sprintf "Cannot resolve variable '%s' in %s" k url) + else "$" ^ k + in + let b = Buffer.create (String.length rows) in + Buffer.add_string b "rows=("; + Buffer.add_substitute b lookup rows; + Buffer.add_string b ")"; + Buffer.contents b in let fetch_brief_params_from id = let xs = if is_digit id then fetch_brief_params_from_db id From c6f416873c204289de6a193530955b78ec5764f8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 21 Aug 2019 19:03:20 +0100 Subject: [PATCH 04/36] Clean up Curl connections MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- src/brief_handler.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index 9bda0e1..bcd85d1 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -101,6 +101,7 @@ let t ~args = object (self) Curl.set_username conn rage_username; Curl.set_password conn rage_password; Curl.perform conn; + Curl.cleanup conn; Curl.global_cleanup(); Buffer.contents write_buff; with _ -> sprintf "error fetching url %s" url From ec01f3204e8b75a61662066a36d8a70378360bca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 29 Nov 2019 17:04:07 +0000 Subject: [PATCH 05/36] Update to OCaml 4.08.1, Core v0.13, and Dune build system MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Polymorphic comparison is not visible by default now, the default comparison operators are for int. Have to locally open the module for the appropriate type, or use Polymorphic_compare.(a = b) if none is available. Similarly all List lookup functions take an ~equal parameter now. List.sort and List.dedup_and_sort take a ~compare parameter (there is no dedup without sorting anymore). Be careful with comparing NULL values when deduping and sorting (NULL) fails the int_of_string which could cause List.dedup_and_sort to loose 1 value as it considered it identical to NULL if the `cmp` function was used for comparison. Make sure to use the String.compare function as the original could would implicitly use. Signed-off-by: Edwin Török --- .gitignore | 3 + OMakefile => Makefile | 30 ++-- OMakeroot | 14 -- dune-project | 16 +++ rage.opam | 31 +++++ src/brief_handler.ml | 230 +++++++++++++++---------------- src/create_tiny_url_handler.ml | 2 +- src/default_handler.ml | 2 +- src/dune | 8 ++ src/handler.ml | 8 +- src/html_handler.ml | 2 +- src/import_jobs_handler.ml | 2 +- src/import_page_handler.ml | 2 +- src/json_handler.ml | 2 +- src/main.ml | 5 +- src/ocaml-sql | 2 +- src/place.ml | 2 +- src/redirect_tiny_url_handler.ml | 2 +- src/som_data_handler.ml | 30 ++-- src/som_page_handler.ml | 4 +- src/soms_handler.ml | 2 +- src/std_axes_handler.ml | 2 +- src/utils.ml | 28 ++-- 23 files changed, 232 insertions(+), 197 deletions(-) rename OMakefile => Makefile (55%) delete mode 100644 OMakeroot create mode 100644 dune-project create mode 100644 rage.opam create mode 100644 src/dune diff --git a/.gitignore b/.gitignore index 53c8081..5d1a04c 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,6 @@ .omakedb.lock distro rage +_build +.merlin +*.install diff --git a/OMakefile b/Makefile similarity index 55% rename from OMakefile rename to Makefile index 362de3a..2dee165 100644 --- a/OMakefile +++ b/Makefile @@ -1,42 +1,32 @@ -SHELL=/bin/bash -SRC=src -PROGRAM=rage CONFIG=/usr/groups/perfeng/rage/config RAGE_DB=$(shell grep "^rage_db=" $(CONFIG) | awk -F '=' '{print $$2}') RAGE_HOST=$(shell grep "^rage_host=" $(CONFIG) | awk -F '=' '{print $$2}') RAGE_USER=$(shell grep "^rage_user=" $(CONFIG) | awk -F '=' '{print $$2}') RAGE_PASS=$(shell grep "^rage_pass=" $(CONFIG) | awk -F '=' '{print $$2}') -SETTINGS="host=$(RAGE_HOST) user=$(RAGE_USER) password=$(RAGE_PASS) dbname=$(RAGE_DB)" -RUN_CMD=OCAMLRUNPARAM='b1' ./$(PROGRAM) "$(SETTINGS)" +SETTINGS=host=$(RAGE_HOST) user=$(RAGE_USER) password=$(RAGE_PASS) dbname=$(RAGE_DB) +PROGRAM=rage +RUN_CMD=OCAMLRUNPARAM='b1' ./$(PROGRAM) "$(SETTINGS)" /etc/rage_passwd WWW_DIR=/var/www CGI_SCRIPT=index.cgi STATIC_DIR=static -README=README.markdown DISTRO_DIR=distro MODE=775 INSTALL=install -m $(MODE) -.PHONY: readme build distro run install log clean -.DEFAULT: build +.PHONY: build clean distro install log +build: + dune build --profile=release @install -.SUBDIRS: $(SRC) +clean: + dune clean distro: build - rsync -avpL $(STATIC_DIR)/ $(SRC)/$(PROGRAM) $(DISTRO_DIR) - printf '#!/bin/bash\n\n$(RUN_CMD)' > $(DISTRO_DIR)/$(CGI_SCRIPT) + rsync -avpL $(STATIC_DIR)/ _build/install/default/bin/$(PROGRAM) $(DISTRO_DIR) + printf '#!/bin/bash\n\n$(RUN_CMD)\n' > $(DISTRO_DIR)/$(CGI_SCRIPT) chmod $(MODE) $(DISTRO_DIR)/$(CGI_SCRIPT) -run: distro - $(DISTRO_DIR)/$(RUN_CMD) - install: distro cp $(DISTRO_DIR)/* $(WWW_DIR) -clean: - rm -rf $(DISTRO_DIR) *.omc - -readme: - markdown $(README) - log: sudo tail -F /var/log/apache2/error.log diff --git a/OMakeroot b/OMakeroot deleted file mode 100644 index 8b6ba9e..0000000 --- a/OMakeroot +++ /dev/null @@ -1,14 +0,0 @@ -include $(STDLIB)/build/Common -include $(STDLIB)/build/OCaml -DefineCommandVars(.) - -# Use Camlp4 -UseCamlp4(packs, files) = - OCAMLPACKS += $(packs) - OCAMLFINDFLAGS += -syntax camlp4o - $(addsuffix .cmx, $(files)): - $(addsuffix .o, $(files)): - $(addsuffix .cmi, $(files)): - $(addsuffix .cmo, $(files)): - -.SUBDIRS: . diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..8315396 --- /dev/null +++ b/dune-project @@ -0,0 +1,16 @@ +(lang dune 2.0) +(generate_opam_files) +(name rage) +(source (github perf101/rage)) +(license BSD3) +(package + (name rage) + (synopsis "RAGE, Results And Graphing Engine") + (depends + (core (>= v0.13)) + (async (>= v0.13)) + (postgresql (>= 4.5.2)) + (ocurl (>= 0.9.0)) + ppx_sexp_conv + re + uri)) diff --git a/rage.opam b/rage.opam new file mode 100644 index 0000000..136b4a8 --- /dev/null +++ b/rage.opam @@ -0,0 +1,31 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "RAGE, Results And Graphing Engine" +license: "BSD3" +homepage: "https://github.com/perf101/rage" +bug-reports: "https://github.com/perf101/rage/issues" +depends: [ + "dune" {>= "2.0"} + "core" {>= "v0.13"} + "async" {>= "v0.13"} + "postgresql" {>= "4.5.2"} + "ocurl" {>= "0.9.0"} + "ppx_sexp_conv" + "re" + "uri" +] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/perf101/rage.git" diff --git a/src/brief_handler.ml b/src/brief_handler.ml index bcd85d1..04292e0 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -1,4 +1,4 @@ -open Core.Std +open Core open Utils let config_file = Sys.argv.(2) @@ -18,14 +18,14 @@ let rage_password = get_config "rage_password" let product_version = get_config "product_version" (* types of the url input arguments *) -type cols_t = (string * string list) list list with sexp -type rows_t = (string * string list) list list with sexp -type base_t = (string * string list) list with sexp -type baseline_t = int with sexp -type ctx_t = (string * string list) list with sexp -type str_lst_t = string list with sexp -type out_t = [`Html | `Wiki] with sexp -type sort_by_col_t = int with sexp +type cols_t = (string * string list) list list [@@deriving sexp] +type rows_t = (string * string list) list list [@@deriving sexp] +type base_t = (string * string list) list [@@deriving sexp] +type baseline_t = int [@@deriving sexp] +type ctx_t = (string * string list) list [@@deriving sexp] +type str_lst_t = string list [@@deriving sexp] +type out_t = [`Html | `Wiki] [@@deriving sexp] +type sort_by_col_t = int [@@deriving sexp] type result_t = Avg of float | Range of float * float * float @@ -44,14 +44,14 @@ let t ~args = object (self) method private write_body = let page_start_time = Unix.gettimeofday () in - let show_jobids = try bool_of_string (List.Assoc.find_exn params "show_jobids") with _ -> false in - let no_rounding = try bool_of_string (List.Assoc.find_exn params "no_rounding") with _ -> false in + let show_jobids = try bool_of_string (List.Assoc.find_exn ~equal:String.equal params "show_jobids") with _ -> false in + let no_rounding = try bool_of_string (List.Assoc.find_exn ~equal:String.equal params "no_rounding") with _ -> false in let progress str = debug str in (* === input === *) - let brief_id = try List.Assoc.find_exn params "id" with |_->"" in + let brief_id = try List.Assoc.find_exn ~equal:String.equal params "id" with |_->"" in let url_decode url0 = (* todo: find a more complete version in some lib *) let rec loop url_in = @@ -133,7 +133,7 @@ let t ~args = object (self) | "PRODUCT_VERSION" -> product_version | other -> "_" in - Buffer.add_substitute b lookup inc; + Caml.Buffer.add_substitute b lookup inc; let inc = Buffer.contents b in let html, _ = fetch_suite inc branch in let pattern = Str.regexp "\\([^=]+\\)=\\([^<]+\\)" in @@ -159,8 +159,8 @@ let t ~args = object (self) debug (sprintf "include parameters: %s" (List.map ~f:(fun (k,v) -> sprintf "%s=%s" k v) includes |> String.concat ~sep:",")); let lookup k = - if String.uppercase k = k then - match List.Assoc.find includes k with + if String.(uppercase k = k) then + match List.Assoc.find ~equal:String.equal includes k with | Some v -> v | None -> failwith (Printf.sprintf "Cannot resolve variable '%s' in %s" k url) @@ -168,7 +168,7 @@ let t ~args = object (self) in let b = Buffer.create (String.length rows) in Buffer.add_string b "rows=("; - Buffer.add_substitute b lookup rows; + Caml.Buffer.add_substitute b lookup rows; Buffer.add_string b ")"; Buffer.contents b in @@ -201,13 +201,13 @@ let t ~args = object (self) let rec get_input_values args = - let params_cols=(try url_decode (List.Assoc.find_exn args "cols") with |_-> "") in - let params_rows=(try url_decode (List.Assoc.find_exn args "rows") with |_-> "") in - let params_base=(try url_decode (List.Assoc.find_exn args "base") with |_-> "") in - let params_baseline=(try url_decode (List.Assoc.find_exn args "baseline") with |_-> "") in - let params_out=(try url_decode (List.Assoc.find_exn args "out") with |_-> "") in - let params_sort_by_col=(try url_decode (List.Assoc.find_exn args "sort_by_col") with |_-> "") in - let params_add_rows_from=(try url_decode (List.Assoc.find_exn args k_add_rows_from) with |_-> "") in + let params_cols=(try url_decode (List.Assoc.find_exn ~equal:String.equal args "cols") with |_-> "") in + let params_rows=(try url_decode (List.Assoc.find_exn ~equal:String.equal args "rows") with |_-> "") in + let params_base=(try url_decode (List.Assoc.find_exn ~equal:String.equal args "base") with |_-> "") in + let params_baseline=(try url_decode (List.Assoc.find_exn ~equal:String.equal args "baseline") with |_-> "") in + let params_out=(try url_decode (List.Assoc.find_exn ~equal:String.equal args "out") with |_-> "") in + let params_sort_by_col=(try url_decode (List.Assoc.find_exn ~equal:String.equal args "sort_by_col") with |_-> "") in + let params_add_rows_from=(try url_decode (List.Assoc.find_exn ~equal:String.equal args k_add_rows_from) with |_-> "") in let attempt ~f a = try f() @@ -220,7 +220,7 @@ let t ~args = object (self) (* eg.: input_cols_sexp="(((machine_name(xrtuk-08-02 xrtuk-08-04))(active_session_count(1)))((machine_name(xrtuk-08-02 xrtuk-08-04)))((machine_name(xrtuk-08-02 xrtuk-08-04))(active_session_count(2 3)))((machine_name(xrtuk-08-02 xrtuk-08-04))(active_session_count(1 2 3))(soms(288))))" *) let input_cols = - if params_cols <> "" then + if String.(params_cols <> "") then attempt ~f:(fun ()->cols_t_of_sexp (Sexp.of_string params_cols) ) "cols" else (*default value *) [] @@ -229,7 +229,7 @@ let t ~args = object (self) printf "\n" (html_encode params_rows); let input_rows = - if params_rows <> "" then + if String.(params_rows <> "") then attempt ~f:(fun ()->rows_t_of_sexp (Sexp.of_string params_rows)) "rows" else (*default value *) [] @@ -253,7 +253,7 @@ let t ~args = object (self) TODO: use intersection between base_context and input_cols and input_rows *) let input_base_context = - if params_base <> "" then + if String.(params_base <> "") then attempt ~f:(fun ()->base_t_of_sexp (Sexp.of_string params_base)) "base" else (*default value *) [] @@ -261,7 +261,7 @@ let t ~args = object (self) printf "\n" (Sexp.to_string (sexp_of_base_t input_base_context)); let baseline_col_idx = - if params_baseline <> "" then + if String.(params_baseline <> "") then attempt ~f:(fun ()->baseline_t_of_sexp (Sexp.of_string params_baseline)) "baseline" else (*default value *) 0 @@ -269,7 +269,7 @@ let t ~args = object (self) printf "\n" (Sexp.to_string (sexp_of_baseline_t baseline_col_idx)); let out = - if params_out <> "" then + if String.(params_out <> "") then attempt ~f:(fun ()->out_t_of_sexp (Sexp.of_string (String.capitalize params_out))) "out" else (*default value *) `Html @@ -277,7 +277,7 @@ let t ~args = object (self) printf "\n" (params_out) (Sexp.to_string (sexp_of_out_t out)); let sort_by_col = - if params_sort_by_col <> "" then + if String.(params_sort_by_col <> "") then Some (attempt ~f:(fun ()->sort_by_col_t_of_sexp (Sexp.of_string (String.capitalize params_sort_by_col))) "sort_by_col") else (*default value *) None @@ -286,16 +286,16 @@ let t ~args = object (self) in let args = - if brief_id = "" then params + if String.(brief_id = "") then params else let replace params default_params= List.fold_left (* if params present, use it preferrably over the default params *) (parse_url default_params) ~init:[] - ~f:(fun acc (k,v)->match List.find params ~f:(fun (ko,_)->k=ko) with|None->(k,v)::acc|Some o->o::acc) + ~f:(fun acc (k,v)->match List.find params ~f:(fun (ko,_)->String.(k=ko)) with|None->(k,v)::acc|Some o->o::acc) in List.fold_left params ~init:(replace params (fetch_brief_params_from brief_id)) ~f:(fun acc (k,v)-> - match List.find acc ~f:(fun (ka,_)->k=ka) with + match List.find acc ~f:(fun (ka,_)->String.(k=ka)) with |None->(k,v)::acc (* if params contains a k not in the db, add this k to args *) |Some _->acc ) @@ -333,7 +333,7 @@ let t ~args = object (self) let unit_of_som som_id = (rec_of_som som_id).(3) in let has_table table_name = let query = sprintf "select table_name from information_schema.tables where table_schema='public' and table_name='%s'" table_name in - (Array.to_list (Sql.exec_exn ~conn ~query)#get_all) <> [] + not @@ List.is_empty (Array.to_list (Sql.exec_exn ~conn ~query)#get_all) in let columns_of_table table_name = let query = sprintf "select column_name from information_schema.columns where table_name='%s'" table_name in @@ -342,19 +342,19 @@ let t ~args = object (self) let contexts_of_som_id som_id = (List.filter (columns_of_table (sprintf "som_config_%s" som_id)) - ~f:(fun e->e<>"som_config_id") + ~f:(fun e->String.(e<>"som_config_id")) ) in let contexts_of_tc_fqn tc_fqn = (List.filter (columns_of_table (sprintf "tc_config_%s" tc_fqn)) - ~f:(fun e->e<>"tc_config_id") + ~f:(fun e->String.(e<>"tc_config_id")) ) in let contexts_of_tc = (List.filter (columns_of_table "tc_config") - ~f:(fun e->not (List.mem ["tc_fqn";"tc_config_id";"machine_id"] e)) + ~f:(fun e->not (List.mem ~equal:String.equal ["tc_fqn";"tc_config_id";"machine_id"] e)) ) in let url_of_t t = @@ -366,7 +366,7 @@ let t ~args = object (self) let tc_contexts = (List.filter (columns_of_table "tc_config") - ~f:(fun e->not (List.mem e ["tc_fqn";"tc_config_id";"machine_id"])) + ~f:(fun e->not (List.mem ~equal:String.equal e ["tc_fqn";"tc_config_id";"machine_id"])) )@ (List.filter (columns_of_table (sprintf "tc_config_%d" tc_fqn)) @@ -378,9 +378,9 @@ let t ~args = object (self) ~f:(fun som_contexts->tc_contexts @ som_contexts) in *) - let contexts_of_machine = List.filter (columns_of_table "machines") ~f:(fun e->e<>"machine_id") in - let contexts_of_build = List.filter (columns_of_table "builds") ~f:(fun e->e<>"build_id") in - let values_of cs ~at:cs_f = List.filter cs ~f:(fun (k,v)->List.mem cs_f k) in + let contexts_of_machine = List.filter (columns_of_table "machines") ~f:(fun e->String.(e<>"machine_id")) in + let contexts_of_build = List.filter (columns_of_table "builds") ~f:(fun e->String.(e<>"build_id")) in + let values_of cs ~at:cs_f = List.filter cs ~f:(fun (k,v)->List.mem ~equal:String.equal cs_f k) in (* let latest_build_of_branch branch = @@ -402,7 +402,7 @@ let t ~args = object (self) then raise an error indicating that probably there's a typo in the context element *) let measurements_of_cell context = - let get e ctx = match List.find_exn ctx ~f:(fun (k,v)->e=k) with |k,v->v in + let get e ctx = match List.find_exn ctx ~f:(fun (k,v)->String.(e=k)) with |k,v->v in let measurements_of_som som_id = let has_table_som_id som_id = has_table (sprintf "som_config_%s" som_id) in let tc_fqn = tc_of_som som_id in @@ -469,11 +469,11 @@ let t ~args = object (self) let context_of base row col = (* we use intersection to obtain the result when the same context is present in more than one input source *) List.fold_left (base @ row @ col) ~init:[] ~f:(fun acc (ck,cv)-> - let x,ys = List.partition_tf ~f:(fun (k,v)->k=ck) acc in + let x,ys = List.partition_tf ~f:(fun (k,v)->String.(k=ck)) acc in match x with |(k,v)::[]->(* context already in acc, intersect the values *) - if k<>ck then (failwith (sprintf "k=%s <> ck=%s" k ck)); - (k, List.filter cv ~f:(fun x->List.mem v x))::ys + if String.(k<>ck) then (failwith (sprintf "k=%s <> ck=%s" k ck)); + (k, List.filter cv ~f:(fun x->List.mem ~equal:String.equal v x))::ys |[]->(* context not in acc, just add it *) (ck,cv)::ys |x->(* error *) @@ -484,7 +484,7 @@ let t ~args = object (self) let k_branch = "branch" in let k_build_number = "build_number" in let v_latest_in_branch = "latest_in_branch" in - match List.find ~f:(fun (k,vs)->k=k_branch) c_kvs with + match List.find ~f:(fun (k,vs)->String.(k=k_branch)) c_kvs with | None -> [c_kvs] | Some (_,branches) -> if List.length branches < 1 @@ -498,7 +498,7 @@ let t ~args = object (self) *) let has_v_latest_in_branch = - List.exists c_kvs ~f:(fun (k,vs) -> k=k_build_number && List.exists vs ~f:(fun v->v=v_latest_in_branch)) + List.exists c_kvs ~f:(fun (k,vs) -> String.(k=k_build_number) && List.exists vs ~f:(fun v->String.(v=v_latest_in_branch))) in (* if 'latest_in_branch' value is present, expand ctx into many ctxs, one for each build; otherwise, return the ctx intact *) if not has_v_latest_in_branch then [c_kvs] @@ -510,9 +510,9 @@ let t ~args = object (self) List.map builds_of_branches ~f:(fun bs-> List.map c_kvs ~f:(fun (k,vs) -> - if k<>k_build_number then (k,vs) + if String.(k<>k_build_number) then (k,vs) else k,(List.map vs ~f:(fun v-> - if v<>v_latest_in_branch then v else bs + if String.(v<>v_latest_in_branch) then v else bs )) ) )) @@ -526,18 +526,18 @@ let t ~args = object (self) (List.filter items (*filter special keys*) ~f:(fun (k,v)-> (* starts with "v_" or "som" *) - ( k="som" || + ( String.(k="som") || try Str.search_forward (Str.regexp "v_.*") k 0 = 0 with Not_found->false ) && (*and doesn't have 'ALL' as a value*) - v<>"ALL" + String.(v<>"ALL") ) ) ~f:(fun (k,v)-> (*apply some mappings to remaining keys and values *) (* remove "v_" from beginning of k *) let new_key = Str.replace_first (Str.regexp "v_") "" k in let new_value = url_decode v in - ((if new_key="som" then "soms" else new_key), new_value) + ((if String.(new_key="som") then "soms" else new_key), new_value) ) in @@ -557,7 +557,7 @@ let t ~args = object (self) in let expand_tiny_urls c_kvs = let k_tiny_url = "t" in - let tiny_url = List.find c_kvs ~f:(fun (k,_) -> k=k_tiny_url) in + let tiny_url = List.find c_kvs ~f:(fun (k,_) -> String.(k=k_tiny_url)) in let x = match tiny_url with | None -> [c_kvs] | Some (_,[t]) -> @@ -566,7 +566,7 @@ let t ~args = object (self) ~init:c_kvs (* c_kvs kvs have priority over the ones in c_kvs_of_tiny_url *) x (* obtain url from tiny_url id, parse it and return a c_kvs *) ~f:(fun acc (k,vs)-> - if List.exists c_kvs ~f:(fun(_k,_)->k=_k) + if List.exists c_kvs ~f:(fun(_k,_)->String.(k=_k)) then (*prefer the one already in c_kvs, ie. do not add (k,vs) to acc*) acc else (*(k,vs) not already in c_kvs, add it *) @@ -604,7 +604,7 @@ let t ~args = object (self) let apply_definitions row = List.map row ~f:(fun (k,vs) -> let new_vs = List.map vs ~f:(fun v -> - match List.Assoc.find !deflists v with + match List.Assoc.find ~equal:String.equal!deflists v with | None -> [v] | Some exp -> exp ) |> List.concat in @@ -640,7 +640,7 @@ let t ~args = object (self) (* Create a modified row applying this set of substitutions *) List.map row ~f:(fun (k,vs) -> let new_vs = List.map vs ~f:(fun v -> - match List.filter sub ~f:(fun (v',_)->v'=v) |> List.map ~f:(fun (_,v)->v) with + match List.filter sub ~f:(fun (v',_)->String.(v'=v)) |> List.map ~f:(fun (_,v)->v) with | [] -> [v] | sub_vs -> sub_vs ) |> List.concat @@ -654,23 +654,23 @@ let t ~args = object (self) ~f:(fun acc r-> let resolve_keywords_in_row acc r = - if List.exists r ~f:(fun (k,v)->k="tcs") then (* expand tcs into soms *) + if List.exists r ~f:(fun (k,v)->String.(k="tcs")) then (* expand tcs into soms *) let r_expanded = List.concat (List.map r ~f:(fun (k,v)->match k with - | _ when k="tcs" -> List.concat (List.map v ~f:(fun tc->List.map (soms_of_tc tc) ~f:(fun som->("soms",[som])))) + | _ when String.(k="tcs") -> List.concat (List.map v ~f:(fun tc->List.map (soms_of_tc tc) ~f:(fun som->("soms",[som])))) | _ -> (k,v)::[] ) ) in - let soms,no_soms = List.partition_tf r_expanded ~f:(fun (k,v)->k="soms") in - let soms = List.sort soms ~cmp:(fun (xk,xv) (yk,yv)->(int_of_string(List.hd_exn xv)) - (int_of_string(List.hd_exn yv))) in + let soms,no_soms = List.partition_tf r_expanded ~f:(fun (k,v)->String.(k="soms")) in + let soms = List.sort soms ~compare:(fun (xk,xv) (yk,yv)->(int_of_string(List.hd_exn xv)) - (int_of_string(List.hd_exn yv))) in acc @ (List.map soms ~f:(fun som->[som] @ no_soms)) - else if List.exists r ~f:(fun (k,v)->k="t") then (* expand tiny links into rows kvs *) + else if List.exists r ~f:(fun (k,v)->String.(k="t")) then (* expand tiny links into rows kvs *) List.hd_exn (expand_tiny_urls r) :: acc - else if List.exists r ~f:(fun (k,_)->k=k_add_rows_from) then (* add rows from other brief ids *) - let bs = List.filter r ~f:(fun (k,_)->k=k_add_rows_from) in (* use all references. TODO: what to do with non-references in the same row??? *) + else if List.exists r ~f:(fun (k,_)->String.(k=k_add_rows_from)) then (* add rows from other brief ids *) + let bs = List.filter r ~f:(fun (k,_)->String.(k=k_add_rows_from)) in (* use all references. TODO: what to do with non-references in the same row??? *) acc @ List.concat ( List.map bs ~f:(fun (k,vs)-> (* map one r into many potential rows *) List.concat ( @@ -686,9 +686,9 @@ let t ~args = object (self) ) ) - else if List.exists r ~f:(fun (k,_)->k=k_for) then (* it's a for-loop! *) + else if List.exists r ~f:(fun (k,_)->String.(k=k_for)) then (* it's a for-loop! *) begin - let bs = List.filter r ~f:(fun (k,_)->k=k_for) in + let bs = List.filter r ~f:(fun (k,_)->String.(k=k_for)) in List.iter bs ~f:(fun (_,v) -> let key = List.hd_exn v in let values = List.tl_exn v in @@ -698,9 +698,9 @@ let t ~args = object (self) acc end - else if List.exists r ~f:(fun (k,_)->k=k_endfor) then (* it's the end of a for-loop! *) + else if List.exists r ~f:(fun (k,_)->String.(k=k_endfor)) then (* it's the end of a for-loop! *) begin - let bs = List.filter r ~f:(fun (k,_)->k=k_endfor) in + let bs = List.filter r ~f:(fun (k,_)->String.(k=k_endfor)) in List.iter bs ~f:(fun (_,v) -> substitions := match v with | [] -> @@ -715,7 +715,7 @@ let t ~args = object (self) begin progress (sprintf "unmapping '%s'" v); match !substitions with - | (hk,hvs)::tl -> if hk=v then tl else failwith (sprintf "tried to pop variable '%s' but top of stack was '%s'" v hk) + | (hk,hvs)::tl -> if String.(hk=v) then tl else failwith (sprintf "tried to pop variable '%s' but top of stack was '%s'" v hk) | _ -> failwith (sprintf "tried to pop variable '%s' from empty stack" v) (* check the most recent 'for' variable has this name and pop it *) end @@ -725,14 +725,14 @@ let t ~args = object (self) acc end - else if List.exists r ~f:(fun (k,_)->k=k_deflist) then (* it's a deflist *) + else if List.exists r ~f:(fun (k,_)->String.(k=k_deflist)) then (* it's a deflist *) begin - let bs = List.filter r ~f:(fun (k,_)->k=k_deflist) in + let bs = List.filter r ~f:(fun (k,_)->String.(k=k_deflist)) in List.iter bs ~f:(fun (_,v) -> let key = List.hd_exn v in let values = List.tl_exn v in progress (sprintf "definition: name '%s' means array [%s]" key (String.concat ~sep:", " values)); - deflists := List.Assoc.add !deflists key values + deflists := List.Assoc.add ~equal:String.equal !deflists key values ); acc end @@ -748,7 +748,7 @@ let t ~args = object (self) progress (sprintf "table: %d lines: " (List.length rs)); let ctx_and_measurements_of_1st_cell_with_data expand_f ctx = let ctxs = expand_f ctx in - let measurements_of_cells = List.find_map ctxs ~f:(fun c->let ms=measurements_of_cell c in if ms=[] then None else (Some (c,ms))) in + let measurements_of_cells = List.find_map ctxs ~f:(fun c->let ms=measurements_of_cell c in if List.is_empty ms then None else (Some (c,ms))) in match measurements_of_cells with None->ctx,[]|Some (c,ms)->c,ms in let measurements_of_table = @@ -787,13 +787,13 @@ let t ~args = object (self) (* round value f to the optimal decimal place according to magnitude of its stddev *) let round f stddev = - if Float.abs (Float.(/) stddev f) < 0.00000001 (* stddev = 0.0 doesn't work because of rounding errors in the float representation *) + if Float.(abs (Float.(/) stddev f) < 0.00000001) (* stddev = 0.0 doesn't work because of rounding errors in the float representation *) then (sprintf "%f" f), f else (* 0. compute magnitude of stddev relative to f *) let f_abs = Float.abs f in let magnitude = (log stddev) /. (log 10.0) in - let newdotpos = (if is_valid magnitude then Float.to_int (if magnitude < 0.0 then Float.round_down (magnitude) else (Float.round_down magnitude) +. 1.0) else 1) in + let newdotpos = (if is_valid magnitude then Float.to_int (if Float.(magnitude < 0.0) then Float.round_down (magnitude) else (Float.round_down magnitude) +. 1.0) else 1) in let f_str = sprintf "%f" f_abs in let dotpos = (String.index_exn f_str '.') in let cutpos = (dotpos - newdotpos) in @@ -804,7 +804,7 @@ let t ~args = object (self) let dig_from s pos = (String.sub s ~pos:(pos+1) ~len:1) in let dig=dig_from f_str cutpos in let rounddigit,roundpos = (* round last significant value using the next digit value *) - if dig="." + if String.(dig=".") then (int_of_string (dig_from f_str (cutpos+1)),newdotpos-1) else (int_of_string dig,if newdotpos<0 then newdotpos else newdotpos-1) in @@ -812,7 +812,7 @@ let t ~args = object (self) (* 2. print only significant digits *) let f_result = ( let f_str_rounded = sprintf "%f" f_rounded in - let f_abs_str_rounded = (if (f_rounded<1.0) + let f_abs_str_rounded = (if Float.(f_rounded<1.0) then (* print the rounded value up to its last significant digit *) String.sub f_str_rounded ~pos:0 ~len:(cutpos+1) else (* print the rounded value up to its last significant digit and fill the rest with 0s *) @@ -821,7 +821,7 @@ let t ~args = object (self) (String.sub f_str_rounded ~pos:0 ~len:(cutpos+1)) (if dotposr-(cutpos+1)>0 then (String.make (dotposr-(cutpos+1)) '0') else "") ) in - (sprintf "%s%s" (if f<0.0 then if f_abs_str_rounded <> "0" then "-" else "" else "") f_abs_str_rounded) + (sprintf "%s%s" (if Float.(f<0.0) then if String.(f_abs_str_rounded <> "0") then "-" else "" else "") f_abs_str_rounded) ) in ( @@ -836,9 +836,9 @@ let t ~args = object (self) else let lower = avg -. 2.0 *. stddev in (* 2-sigma = 95% confidence assuming normal distribution *) let upper = avg +. 2.0 *. stddev in - if (Float.abs avg) < Float.min_value + if Float.(abs avg < min_value) then f0 () - else if stddev /. avg < 0.05 (* see if the relative std error is <5% *) + else if Float.(stddev /. avg < 0.05) (* see if the relative std error is <5% *) then f1 (round avg stddev) (* 95% confidence *) else f2 (round lower stddev) (round avg stddev) (round upper stddev) (* 95% confidence *) in @@ -860,16 +860,16 @@ let t ~args = object (self) let is_green baseline value more_is_better = if more_is_better then match baseline, value with - |Avg b, Avg v-> (v>=b) - |Avg b, Range (vl, va, vu)-> (va>=b) - |Range (bl, ba, bu), Avg v-> (v>=ba) - |Range (bl, ba, bu), Range (vl,va,vu)-> (va>=ba) + |Avg b, Avg v-> Float.(v>=b) + |Avg b, Range (vl, va, vu)-> Float.(va>=b) + |Range (bl, ba, bu), Avg v-> Float.(v>=ba) + |Range (bl, ba, bu), Range (vl,va,vu)-> Float.(va>=ba) else (* less is better *) match baseline, value with - |Avg b, Avg v-> (v<=b) - |Avg b, Range (vl, va, vu)-> (va<=b) - |Range (bl, ba, bu), Avg v-> (v<=ba) - |Range (bl, ba, bu), Range (vl,va,vu)-> (va<=ba) + |Avg b, Avg v-> Float.(v<=b) + |Avg b, Range (vl, va, vu)-> Float.(va<=b) + |Range (bl, ba, bu), Avg v-> Float.(v<=ba) + |Range (bl, ba, bu), Range (vl,va,vu)-> Float.(va<=ba) in let delta baseline value more_is_better = match baseline, value with @@ -910,14 +910,14 @@ let t ~args = object (self) ) in List.sort (mt_xs) (* rows with at least one measurement *) - ~cmp:(fun (r1,cs1) (r2,cs2) -> + ~compare:(fun (r1,cs1) (r2,cs2) -> let ms cs = let _,_,_,cmp_ms = List.nth_exn cs compare_col_idx in let _,_,_,base_ms = List.nth_exn cs baseline_col_idx in proportion (val_stddev_of (vals_of_ms base_ms)) (val_stddev_of (vals_of_ms cmp_ms)) None in let ms1, ms2 = (Float.abs (ms cs1)),(Float.abs (ms cs2)) in - if ms1 > ms2 then -1 else if ms2 > ms1 then 1 else 0 (* decreasing order *) + if Float.(ms1 > ms2) then -1 else if Float.(ms2 > ms1) then 1 else 0 (* decreasing order *) ) @ mt_0s (* rows with no measurements stay at the end *) in @@ -927,11 +927,11 @@ let t ~args = object (self) (* eg.: http://perf/?som=41&xaxis=numvms&show_dist=on&f_branch=1&v_build_tag=&v_dom0_memory_static_max=752&v_dom0_memory_target=(NULL)&v_cc_restrictions=f&v_memsize=256&v_vmtype=dom0 *) let link_ctx_of_row ctxs = List.fold_left ctxs ~init:[] ~f:(fun acc (ck,cv)-> - let x,ys = List.partition_tf ~f:(fun (k,v)->k=ck) acc in + let x,ys = List.partition_tf ~f:(fun (k,v)->String.(k=ck)) acc in match x with |(k,v)::[]->(* context already in acc, union the values *) - if k<>ck then (failwith (sprintf "link: k=%s <> ck=%s" k ck)); - (k, List.dedup (cv @ v))::ys + if String.(k<>ck) then (failwith (sprintf "link: k=%s <> ck=%s" k ck)); + (k, List.dedup_and_sort ~compare:String.compare (cv @ v))::ys |[]->(* context not in acc, just add it *) (ck,cv)::ys |x->(* error *) @@ -939,8 +939,8 @@ let t ~args = object (self) ) in let link_ctxs = (List.map (sort_table measurements_of_table) ~f:(fun (r,cs)->link_ctx_of_row (List.concat (List.map cs ~f:(fun (_,_,ctx,_)->ctx))))) in - let link_xaxis = List.dedup (List.concat (List.map cs ~f:(fun c-> List.map c ~f:(fun (x,_)->x)))) in - let link_xaxis = List.filter link_xaxis ~f:(fun x -> x <> "label") in + let link_xaxis = List.dedup_and_sort ~compare:String.compare (List.concat (List.map cs ~f:(fun c-> List.map c ~f:(fun (x,_)->x)))) in + let link_xaxis = List.filter link_xaxis ~f:(fun x -> String.(x <> "label")) in (* writers *) @@ -956,7 +956,7 @@ let t ~args = object (self) let html_writer table = - let str_of_values vs=List.fold_left vs ~init:"" ~f:(fun acc v->if acc="" then "\""^v^"\"" else acc^", \""^v^"\"") in + let str_of_values vs=List.fold_left vs ~init:"" ~f:(fun acc v->if String.(acc="") then "\""^v^"\"" else acc^", \""^v^"\"") in let str_of_ctxs ?(txtonly=false) kvs = List.fold_left kvs ~init:"" ~f:(fun acc (k,v)-> (sprintf "%s %s=(%s)%s\n" acc k (str_of_values v) (if txtonly then "" else "
    ") ) @@ -964,10 +964,10 @@ let t ~args = object (self) in let str_desc_of_ctxs kvs = List.fold_left kvs ~init:"" ~f:(fun acc (k,vs)-> - if k<>"soms" then acc else + if String.(k<>"soms") then acc else (sprintf "%s %s
    \n" acc (List.fold_left vs ~init:"" ~f:(fun acc2 som-> - let s=sprintf "%s: %s (%s%s)" (tc_of_som som) (name_of_som som) (let u=unit_of_som som in if u="" then u else u^", ") (sprintf "%s is better" (let mb=more_is_better_of_som som in if mb="" then "none" else if mb="f" then "less" else "more")) in - if acc="" then s else acc^","^s + let s=sprintf "%s: %s (%s%s)" (tc_of_som som) (name_of_som som) (let u=unit_of_som som in if String.(u="") then u else u^", ") (sprintf "%s is better" (let mb=more_is_better_of_som som in if String.(mb="") then "none" else if String.(mb="f") then "less" else "more")) in + if String.(acc="") then s else acc^","^s )) ) ) @@ -976,7 +976,7 @@ let t ~args = object (self) (* link *) ( (* rage is not generic enough to receive an arbirary number of soms in a link, pick just the first one *) - let som_id=match List.find_exn ctx ~f:(fun (k,_)->k="soms") with |(k,v)->List.hd_exn v in + let som_id=match List.find_exn ctx ~f:(fun (k,_)->String.(k="soms")) with |(k,v)->List.hd_exn v in (sprintf "graph" (Utils.server_name ()) som_id (* xaxis *) (List.fold_left link_xaxis ~init:"" ~f:(fun acc x->sprintf "%s%s" acc (sprintf "&xaxis=%s" x))) @@ -988,18 +988,18 @@ let t ~args = object (self) )) in let is_more_is_better ctx = - match List.find ctx ~f:(fun (k,_)->k="soms") with + match List.find ctx ~f:(fun (k,_)->String.(k="soms")) with |None->None |Some (k,_vs)->( let rec is_mb acc vs = (match vs with - |[]->if acc=None then None else acc + |[]->if Option.is_none acc then None else acc |v::vs->(let mb = more_is_better_of_som v in - if mb="" then is_mb acc vs (* ignore more_is_better if not defined in db *) + if String.(mb="") then is_mb acc vs (* ignore more_is_better if not defined in db *) else - let mbtf = match mb with m when m="f"->false|_->true in + let mbtf = match mb with m when String.(m="f")->false|_->true in match acc with |None->is_mb (Some mbtf) vs - |Some _mbtf->if _mbtf=mbtf + |Some _mbtf->if Bool.(_mbtf=mbtf) then is_mb (Some mbtf) vs (* more_is_better values agree between soms *) else None (* more_is_better values disagree between soms *) ) @@ -1046,7 +1046,7 @@ let t ~args = object (self) let number = List.length ms in let number_str = if show_jobids then - sprintf "[%s]" (String.concat ~sep:"; " (List.map ~f:string_of_int (List.dedup (jobs_of_ms ms)))) + sprintf "[%s]" (String.concat ~sep:"; " (List.map ~f:string_of_int (List.dedup_and_sort ~compare:Int.compare (jobs_of_ms ms)))) else sprintf "(%d)" number in @@ -1106,7 +1106,7 @@ let t ~args = object (self) let wiki_writer table = - let str_of_values vs=List.fold_left vs ~init:"" ~f:(fun acc v->if acc="" then "\""^v^"\"" else acc^", \""^v^"\"") in + let str_of_values vs=List.fold_left vs ~init:"" ~f:(fun acc v->if String.(acc="") then "\""^v^"\"" else acc^", \""^v^"\"") in let str_of_ctxs ?(txtonly=false) kvs = List.fold_left kvs ~init:"" ~f:(fun acc (k,v)-> (sprintf "%s %s=(%s)%s " acc k (str_of_values v) (if txtonly then "" else "\\\\") ) @@ -1114,10 +1114,10 @@ let t ~args = object (self) in let str_desc_of_ctxs kvs = List.fold_left kvs ~init:"" ~f:(fun acc (k,vs)-> - if k<>"soms" then acc else + if String.(k<>"soms") then acc else (sprintf "%s %s \\\\" acc (List.fold_left vs ~init:"" ~f:(fun acc2 som-> - let s=sprintf "%s: *%s* (%s%s)" (tc_of_som som) (name_of_som som) (let u=unit_of_som som in if u="" then u else u^", ") (sprintf "%s is better" (let mb=more_is_better_of_som som in if mb="" then "none" else if mb="f" then "less" else "more")) in - if acc="" then s else acc^","^s + let s=sprintf "%s: *%s* (%s%s)" (tc_of_som som) (name_of_som som) (let u=unit_of_som som in if String.(u="") then u else u^", ") (sprintf "%s is better" (let mb=more_is_better_of_som som in if String.(mb="") then "none" else if String.(mb="f") then "less" else "more")) in + if String.(acc="") then s else acc^","^s )) ) ) @@ -1126,7 +1126,7 @@ let t ~args = object (self) (* link *) ( (* rage is not generic enough to receive an arbirary number of soms in a link, pick just the first one *) - let som_id=match List.find_exn ctx ~f:(fun (k,_)->k="soms") with |(k,v)->List.hd_exn v in + let som_id=match List.find_exn ctx ~f:(fun (k,_)->String.(k="soms")) with |(k,v)->List.hd_exn v in (sprintf "[graph|http://%s/?som=%s&show_dist=on%s%s]" (Utils.server_name ()) som_id (* xaxis *) (List.fold_left link_xaxis ~init:"" ~f:(fun acc x->sprintf "%s%s" acc (sprintf "&xaxis=%s" x))) @@ -1138,18 +1138,18 @@ let t ~args = object (self) )) in let is_more_is_better ctx = - match List.find ctx ~f:(fun (k,_)->k="soms") with + match List.find ctx ~f:(fun (k,_)->String.(k="soms")) with |None->None |Some (k,_vs)->( let rec is_mb acc vs = (match vs with - |[]->if acc=None then None else acc + |[]->if Option.is_none acc then None else acc |v::vs->(let mb = more_is_better_of_som v in - if mb="" then is_mb acc vs (* ignore more_is_better if not defined in db *) + if String.(mb="") then is_mb acc vs (* ignore more_is_better if not defined in db *) else - let mbtf = match mb with m when m="f"->false|_->true in + let mbtf = match mb with m when String.(m="f")->false|_->true in match acc with |None->is_mb (Some mbtf) vs - |Some _mbtf->if _mbtf=mbtf + |Some _mbtf->if Bool.(_mbtf=mbtf) then is_mb (Some mbtf) vs (* more_is_better values agree between soms *) else None (* more_is_better values disagree between soms *) ) @@ -1215,7 +1215,7 @@ let t ~args = object (self) in printf "%s" "
    ";
           printf "%s" "h1. Brief Rage Report\n\n";
    -      printf "- [live html version, with parameters %s |http://%s/?%s]\n" (List.fold_left params ~init:"" ~f:(fun acc (k,v)->if k="out" then acc else if acc="" then (sprintf "%s=%s" k v) else (sprintf "%s, %s=%s" acc k (url_decode v)))) (Utils.server_name ()) (List.fold_left params ~init:"" ~f:(fun acc (k,v)->if k="out" then acc else sprintf "%s&%s=%s" acc k (url_decode v)));
    +      printf "- [live html version, with parameters %s |http://%s/?%s]\n" (List.fold_left params ~init:"" ~f:(fun acc (k,v)->if String.(k="out") then acc else if String.(acc="") then (sprintf "%s=%s" k v) else (sprintf "%s, %s=%s" acc k (url_decode v)))) (Utils.server_name ()) (List.fold_left params ~init:"" ~f:(fun acc (k,v)->if String.(k="out") then acc else sprintf "%s&%s=%s" acc k (url_decode v)));
           printf "%s" "- Numbers reported at 95% confidence level from the data of existing runs\n";
           printf "%s" "- \\(x) indicates number of samples\n";
           printf "%s" "- \\(x%) indicates difference with baseline column\n";
    diff --git a/src/create_tiny_url_handler.ml b/src/create_tiny_url_handler.ml
    index 8a32105..3d32873 100644
    --- a/src/create_tiny_url_handler.ml
    +++ b/src/create_tiny_url_handler.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     
     let t ~args = object (self)
       inherit Json_handler.t ~args
    diff --git a/src/default_handler.ml b/src/default_handler.ml
    index f1cbd65..c3dddf8 100644
    --- a/src/default_handler.ml
    +++ b/src/default_handler.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     
     let t ~args = object (self)
       inherit Html_handler.t ~args
    diff --git a/src/dune b/src/dune
    new file mode 100644
    index 0000000..0436a76
    --- /dev/null
    +++ b/src/dune
    @@ -0,0 +1,8 @@
    +(executable
    + (public_name rage)
    + (name main)
    + (flags
    +  (:standard -principal -short-paths))
    + (preprocess
    +  (pps ppx_sexp_conv ppx_let))
    + (libraries threads.posix core postgresql curl async sql uri str))
    diff --git a/src/handler.ml b/src/handler.ml
    index da11e8a..b155eda 100644
    --- a/src/handler.ml
    +++ b/src/handler.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     open Utils
     
     type args = {
    @@ -37,13 +37,13 @@ object (self)
         if not html_header_written then self#write_html_header;
         failwith msg
     
    -  method private get_param key = List.Assoc.find params key
    +  method private get_param key = List.Assoc.find ~equal:String.equal params key
     
    -  method private get_param_exn key = List.Assoc.find_exn params key
    +  method private get_param_exn key = List.Assoc.find_exn ~equal:String.equal params key
     
       method private get_params_gen ~params key =
         List.fold params ~init:[]
    -      ~f:(fun acc (k, v) -> if k = key then v::acc else acc)
    +      ~f:(fun acc (k, v) -> if String.(k = key) then v::acc else acc)
     
       method private get_params key = self#get_params_gen ~params key
     
    diff --git a/src/html_handler.ml b/src/html_handler.ml
    index ae2e7fb..f58a160 100644
    --- a/src/html_handler.ml
    +++ b/src/html_handler.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     
     class t = fun ~args ->
     object (self)
    diff --git a/src/import_jobs_handler.ml b/src/import_jobs_handler.ml
    index 60c53a7..4d99f71 100644
    --- a/src/import_jobs_handler.ml
    +++ b/src/import_jobs_handler.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     open Utils
     
     let importer = "/usr/groups/perfeng/bin/importer-xenrt"
    diff --git a/src/import_page_handler.ml b/src/import_page_handler.ml
    index 9f1f598..ba27e21 100644
    --- a/src/import_page_handler.ml
    +++ b/src/import_page_handler.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     
     let t ~args = object (self)
       inherit Html_handler.t ~args
    diff --git a/src/json_handler.ml b/src/json_handler.ml
    index ef56007..3698413 100644
    --- a/src/json_handler.ml
    +++ b/src/json_handler.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     
     class t = fun ~args ->
     object (self)
    diff --git a/src/main.ml b/src/main.ml
    index 3f0e147..c8bad8e 100644
    --- a/src/main.ml
    +++ b/src/main.ml
    @@ -1,11 +1,11 @@
    -open! Core.Std
    +open Core
     open Utils
     
     (** Combines GET and POST parameters. *)
     let get_params_of_request () =
       let get_req = Sys.getenv_exn "QUERY_STRING" in
       let post_req = In_channel.input_all In_channel.stdin in
    -  let req = get_req ^ (if post_req = "" then "" else "&" ^ post_req) in
    +  let req = get_req ^ (if String.(post_req = "") then "" else "&" ^ post_req) in
       let parts = String.split req ~on:'&' in
       let opt_split part =
         Option.value ~default:(part, "") (String.lsplit2 part ~on:'=') in
    @@ -16,6 +16,7 @@ let get_params_of_request () =
     let place_of_params ~params =
       let open List.Assoc in
       let open Place in
    +  let find = find ~equal:String.equal in
       match find params "p" with Some p -> Place.of_string p | None ->
       match find params "t" with Some _ -> RedirectTinyUrl | None ->
       match find params "som" with Some _ -> SomPage | None ->
    diff --git a/src/ocaml-sql b/src/ocaml-sql
    index dba2815..53ab8e3 160000
    --- a/src/ocaml-sql
    +++ b/src/ocaml-sql
    @@ -1 +1 @@
    -Subproject commit dba2815b0886f6c902e277860258ff937cccd8bd
    +Subproject commit 53ab8e3820b4e3f3d6bb1b3519bc3170c9153525
    diff --git a/src/place.ml b/src/place.ml
    index 1b59d0a..248444e 100644
    --- a/src/place.ml
    +++ b/src/place.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     
     type t =
       | CreateTinyUrl
    diff --git a/src/redirect_tiny_url_handler.ml b/src/redirect_tiny_url_handler.ml
    index 198dde3..addc53f 100644
    --- a/src/redirect_tiny_url_handler.ml
    +++ b/src/redirect_tiny_url_handler.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     
     let t ~args = object (self)
       inherit Html_handler.t ~args
    diff --git a/src/som_data_handler.ml b/src/som_data_handler.ml
    index 552ed6e..9205538 100644
    --- a/src/som_data_handler.ml
    +++ b/src/som_data_handler.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     open Fn
     open Utils
     
    @@ -14,15 +14,15 @@ let t ~args = object (self)
     
       method private values_for_key ?(default=[]) key =
         let xs = List.fold params ~init:[]
    -      ~f:(fun acc (k, v) -> if k = key then v::acc else acc) in
    -    if xs = [] then default else xs
    +      ~f:(fun acc (k, v) -> if String.(k = key) then v::acc else acc) in
    +    if List.is_empty xs then default else xs
     
       method private get_first_val k d =
         Option.value ~default:d (List.hd (self#values_for_key k))
     
       method private select_params ?(value=None) prefix =
         List.filter_map params ~f:(fun (k, v) ->
    -      if String.is_prefix k ~prefix && (Option.is_none value || Some v = value)
    +      if String.is_prefix k ~prefix && (Option.is_none value || Option.equal String.equal (Some v) value)
           then String.chop_prefix k ~prefix else None
         )
     
    @@ -52,16 +52,16 @@ let t ~args = object (self)
             try
               compare (int_of_string a) (int_of_string b)
             with Failure _ ->
    -          compare a b
    +          String.compare a b
           else
    -        compare a b
    +        String.compare a b
         in
     
         if not (self#should_sort_alphabetically col_types col_name force_as_seq force_as_num)
         then None else
         let col_data = Array.to_list (Array.map ~f:(fun row -> row.(col)) rows) in
    -    let uniques = List.dedup col_data in
    -    let sorted = List.sort ~cmp:sort_seq_numeric uniques in
    +    let uniques = List.dedup_and_sort ~compare:String.compare col_data in
    +    let sorted = List.sort ~compare:sort_seq_numeric uniques in
         Some (List.mapi sorted ~f:(fun i x -> (i+1, x)))
     
       method private strings_to_numbers rows col col_name col_types label
    @@ -74,7 +74,7 @@ let t ~args = object (self)
         printf "\"%s\":{%s}," label mapping_str;
         let i_to_string_map = List.Assoc.inverse mapping in
         let i_from_string row =
    -      match List.Assoc.find i_to_string_map row.(col) with
    +      match List.Assoc.find ~equal:String.equal i_to_string_map row.(col) with
           | None -> failwith ("NOT IN TRANSLATION MAP: " ^ row.(col) ^ "\n")
           | Some i -> row.(col) <- string_of_int i
         in Array.iter rows ~f:i_from_string
    @@ -96,7 +96,7 @@ let t ~args = object (self)
         let yaxis = self#get_first_val "yaxis" "result" in
         let compose_keys ~xaxis ~yaxis ~rest =
           let deduped = List.stable_dedup rest in
    -      let filter_cond = non (List.mem (yaxis::xaxis)) in
    +      let filter_cond = non (List.mem ~equal:String.equal (yaxis::xaxis)) in
           List.filter ~f:filter_cond deduped
         in
         let restkeys =
    @@ -115,14 +115,14 @@ let t ~args = object (self)
         (* obtain SOM meta-data *)
         let query = sprintf "SELECT positive FROM soms WHERE som_id=%d" som_id in
         let metadata = Sql.exec_exn ~conn ~query in
    -    let positive = (Sql.get_first_entry_exn ~result:metadata) = "t" in
    +    let positive = String.(Sql.get_first_entry_exn ~result:metadata = "t") in
         (* obtain data from database *)
         let query =
           "SELECT " ^
           (String.concat ~sep:"||','||" xaxisfqns) ^ ", " ^ (* x-axis *)
           yaxisfqns ^ ", " ^ (* y-axis *)
           (String.concat ~sep:", " xaxisfqns) ^ (* components of x-axis, needed in case we split by one of them *)
    -      (if restfqns = [] then " " else sprintf ", %s " (String.concat ~sep:", " restfqns)) ^
    +      (if List.is_empty restfqns then " " else sprintf ", %s " (String.concat ~sep:", " restfqns)) ^
           (sprintf "FROM %s " (String.concat ~sep:", " tbls)) ^
           (sprintf "WHERE measurements_2.tc_config_id=%s.tc_config_id "
                    tc_config_tbl) ^
    @@ -167,9 +167,9 @@ let t ~args = object (self)
         printf "\"part\":%s," (self#get_first_val "part" "1");
         printf "\"xaxis\":\"%s\"," xaxis_str;
         printf "\"yaxis\":\"%s\"," yaxis;
    -    let x_as_seq = ("on" = self#get_first_val "x_as_seq" "off") in
    -    let y_as_seq = ("on" = self#get_first_val "y_as_seq" "off") in
    -    let x_as_num = ("on" = self#get_first_val "x_as_num" "off") in
    +    let x_as_seq = String.("on" = self#get_first_val "x_as_seq" "off") in
    +    let y_as_seq = String.("on" = self#get_first_val "y_as_seq" "off") in
    +    let x_as_num = String.("on" = self#get_first_val "x_as_num" "off") in
         self#strings_to_numbers rows 0 xaxis col_types "x_labels" x_as_seq x_as_num;
         self#strings_to_numbers rows 1 [yaxis] col_types "y_labels" y_as_seq false;
         let num_other_keys = List.length keys - 2 in
    diff --git a/src/som_page_handler.ml b/src/som_page_handler.ml
    index 21a4e5e..d2c11f6 100644
    --- a/src/som_page_handler.ml
    +++ b/src/som_page_handler.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     open Utils
     
     let jira_hostname = "jira.uk.xensource.com"
    @@ -74,7 +74,7 @@ let t ~args = object (self)
         List.iter ~f:print_table_for (List.zip_exn labels options_lst)
     
       method private write_body =
    -    let som_id = int_of_string (List.Assoc.find_exn params "som") in
    +    let som_id = int_of_string (List.Assoc.find_exn ~equal:String.equal params "som") in
         let _, tc_config_tbl = get_tc_config_tbl_name conn som_id in
         let query =
           sprintf "SELECT * FROM soms WHERE som_id=%d" som_id in
    diff --git a/src/soms_handler.ml b/src/soms_handler.ml
    index c311d72..34efa58 100644
    --- a/src/soms_handler.ml
    +++ b/src/soms_handler.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     open Utils
     
     let t ~args = object (self)
    diff --git a/src/std_axes_handler.ml b/src/std_axes_handler.ml
    index 7a982eb..acd1c1e 100644
    --- a/src/std_axes_handler.ml
    +++ b/src/std_axes_handler.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     
     let t ~args = object (self)
       inherit Json_handler.t ~args
    diff --git a/src/utils.ml b/src/utils.ml
    index 2a363ae..1895a88 100644
    --- a/src/utils.ml
    +++ b/src/utils.ml
    @@ -1,4 +1,4 @@
    -open! Core.Std
    +open Core
     
     let debug msg =
       output_string stderr (msg ^ "\n");
    @@ -7,7 +7,7 @@ let debug msg =
     let index l x =
       let rec aux i = function
         | [] -> failwith "index []"
    -    | x'::xs -> if x = x' then i else aux (i+1) xs
    +    | x'::xs -> if String.(x = x') then i else aux (i+1) xs
       in aux 0 l
     
     let concat ?(sep = ",") l =
    @@ -29,7 +29,7 @@ let concat_array ?(sep = ",") a =
     let merge_table_into src dst =
       String.Table.merge_into ~src ~dst
         ~f:(fun ~key:_ src_v dst_v_opt ->
    -      match dst_v_opt with None -> Some src_v | vo -> vo)
    +      match dst_v_opt with None -> Set_to src_v | Some vo -> Set_to vo)
     
     let cat filename =
       print_string (In_channel.with_file ~f:In_channel.input_all filename)
    @@ -54,7 +54,7 @@ let get_column_fqns conn tbl =
       let nameToFqn = String.Table.create () in
       let process_column name =
         let fqn = tbl ^ "." ^ name in
    -    String.Table.replace nameToFqn ~key:name ~data:fqn
    +    String.Table.set nameToFqn ~key:name ~data:fqn
       in List.iter col_names ~f:process_column;
       nameToFqn
     
    @@ -89,7 +89,7 @@ let extract_filter col_fqns col_types params key_prefix =
       let update_m v vs_opt =
         let vs = Option.value vs_opt ~default:[] in Some (v::vs) in
       let filter_insert (k, v) =
    -    if v = "ALL" then () else
    +    if String.equal v "ALL" then () else
         if String.is_prefix k ~prefix:key_prefix then begin
           let k2 = String.chop_prefix_exn k ~prefix:key_prefix in
           String.Table.change m k2 (update_m v)
    @@ -99,8 +99,8 @@ let extract_filter col_fqns col_types params key_prefix =
       let conds = List.map l
         ~f:(fun (k, vs) ->
           let vs = List.map vs ~f:decode_html in
    -      let has_null = List.mem vs "(NULL)" in
    -      let vs = if has_null then List.filter vs ~f:((<>) "(NULL)") else vs in
    +      let has_null = List.mem ~equal:String.equal vs "(NULL)" in
    +      let vs = if has_null then List.filter vs ~f:(String.(<>) "(NULL)") else vs in
           let ty = String.Table.find_exn col_types k in
           let quote = Sql.Type.is_quoted ty in
           let vs_oq =
    @@ -119,13 +119,13 @@ let extract_filter col_fqns col_types params key_prefix =
     
     let print_select ?(td=false) ?(label="") ?(selected=[]) ?(attrs=[]) options =
       if td then printf "\n";
    -  if label <> "" then printf "%s:\n" label;
    +  if String.(label <> "") then printf "%s:\n" label;
       printf " printf " %s='%s'" k v);
       printf ">\n";
       let print_option (l, v) =
         printf "\n" l
       in List.iter options ~f:print_option;
       printf "\n";
    @@ -144,14 +144,14 @@ let get_options_for_field db_result ~data col =
             if db_result#getisnull i col then "(NULL)" else data.(i).(col)
           in aux (elem::acc) (i-1)
       in
    -  let cmp x y =
    +  let compare x y =
         try
    -      if ftype = Postgresql.INT4
    +      if Poly.(ftype = Postgresql.INT4)
           then compare (int_of_string x) (int_of_string y)
    -      else compare x y
    +      else String.compare x y
         with _ -> 0
       in
    -  List.sort ~cmp (List.dedup (aux [] nRows))
    +  List.sort ~compare (List.dedup_and_sort ~compare (aux [] nRows))
     
     let get_options_for_field_once db_result col =
       let data = db_result#get_all in
    @@ -159,7 +159,7 @@ let get_options_for_field_once db_result col =
     
     let get_options_for_field_once_byname db_result col_name =
       let col_names = db_result#get_fnames_lst in
    -  let col = match List.findi ~f:(fun _ c -> c = col_name) col_names with
    +  let col = match List.findi ~f:(fun _ c -> String.(c = col_name)) col_names with
           | Some (i, _) -> i
           | _ -> failwith (sprintf "could not find column '%s' amongst [%s]" col_name (String.concat ~sep:"; " col_names))
       in
    
    From f16d7b61c50946c6cdf669a6f5767923a377c164 Mon Sep 17 00:00:00 2001
    From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= 
    Date: Fri, 29 Nov 2019 18:13:04 +0000
    Subject: [PATCH 06/36] decode &45; to - for --
    MIME-Version: 1.0
    Content-Type: text/plain; charset=UTF-8
    Content-Transfer-Encoding: 8bit
    
    -- is not allowed inside XML tags.
    
    Some phoronix tests have -- in tc_arguments now.
    
    Signed-off-by: Edwin Török 
    ---
     src/brief_handler.ml | 1 +
     1 file changed, 1 insertion(+)
    
    diff --git a/src/brief_handler.ml b/src/brief_handler.ml
    index 04292e0..2f9915a 100644
    --- a/src/brief_handler.ml
    +++ b/src/brief_handler.ml
    @@ -64,6 +64,7 @@ let t ~args = object (self)
                ("%25","%");("+"," ");    ("%3E",">"); ("%3C","<");
                ("%3A",":");("&","&");(""","\"");
                (">",">");("<","<");
    +           ("&45;","-")
               ]
               ~init:url_in
               ~f:(fun acc (f,t)->(Str.global_replace (Str.regexp f) t acc)) (* f->t *)
    
    From 5745fe39d656e421a2c374a1f5d9fab05f91293e Mon Sep 17 00:00:00 2001
    From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= 
    Date: Fri, 22 Nov 2019 11:12:20 +0000
    Subject: [PATCH 07/36] Add bootmode precedence
    MIME-Version: 1.0
    Content-Type: text/plain; charset=UTF-8
    Content-Transfer-Encoding: 8bit
    
    This is BIOS, UEFI, etc. which could matter when comparing results.
    
    Signed-off-by: Edwin Török 
    ---
     sql/schema.sql | 1 +
     src/utils.ml   | 1 +
     2 files changed, 2 insertions(+)
    
    diff --git a/sql/schema.sql b/sql/schema.sql
    index 3cdbd75..73ca6ad 100755
    --- a/sql/schema.sql
    +++ b/sql/schema.sql
    @@ -108,6 +108,7 @@ create table tc_config (
       dom0_vcpus integer not null,
       host_pcpus integer not null,
       host_type varchar(16) not null,
    +  bootmode_precedence varchar(32) not null,
     
       foreign key (job_id) references jobs(job_id),
       foreign key (tc_fqn) references test_cases(tc_fqn),
    diff --git a/src/utils.ml b/src/utils.ml
    index 1895a88..9cd2b7e 100644
    --- a/src/utils.ml
    +++ b/src/utils.ml
    @@ -216,6 +216,7 @@ let tc_config_fields = [
       "host_pcpus";
       "live_patching";
       "host_type";
    +  "bootmode_precedence"
     ]
     
     let build_fields = [
    
    From 85c44f5981efcbe7bd62857304049dc4a651b00d Mon Sep 17 00:00:00 2001
    From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= 
    Date: Fri, 29 Nov 2019 18:15:02 +0000
    Subject: [PATCH 08/36] Escaping for +
    MIME-Version: 1.0
    Content-Type: text/plain; charset=UTF-8
    Content-Transfer-Encoding: 8bit
    
    Again, some Phoronix tests use this.
    
    Signed-off-by: Edwin Török 
    ---
     src/brief_handler.ml | 2 +-
     1 file changed, 1 insertion(+), 1 deletion(-)
    
    diff --git a/src/brief_handler.ml b/src/brief_handler.ml
    index 2f9915a..af800d7 100644
    --- a/src/brief_handler.ml
    +++ b/src/brief_handler.ml
    @@ -64,7 +64,7 @@ let t ~args = object (self)
                ("%25","%");("+"," ");    ("%3E",">"); ("%3C","<");
                ("%3A",":");("&","&");(""","\"");
                (">",">");("<","<");
    -           ("&45;","-")
    +           ("&45;","-");("+","%2b")
               ]
               ~init:url_in
               ~f:(fun acc (f,t)->(Str.global_replace (Str.regexp f) t acc)) (* f->t *)
    
    From f73dec2a332015782beb731ba0c784bf18cbff05 Mon Sep 17 00:00:00 2001
    From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= 
    Date: Mon, 25 Nov 2019 23:31:23 +0000
    Subject: [PATCH 09/36] Show patches_applied, and build_is_release axes
    MIME-Version: 1.0
    Content-Type: text/plain; charset=UTF-8
    Content-Transfer-Encoding: 8bit
    
    patches_applied is a simplified form of what hotfixes have been applied,
    e.g XS80E{001-006}, and most importantly the empty string when testing
    an RTM release. This allows to create performance comparisons with RTM
    releases easily.
    (RTM releases have the 'all_hotfixes' build_tag with 0 patches applied,
     so previously we couldn't filter them)
    
    build_is_release tries to determine whether a hotfix was a dev-signed
    test, or a release-signed hotfix test. Release-signed doesn't
    necessarily mean we released it, but if we remove all the dev-signed
    ones we'll have less noise in our results.
    Also unreleased hotfixes can (and in fact) have performance regressions
    that were caught and fixed before a release. We do not want the same
    performance regressions to go unnoticed in master.
    
    Once a hotfix is released a cronjob could go through previous tests that
    were imported and blacklist them, but for now this is a good
    approximation.
    
    Signed-off-by: Edwin Török 
    ---
     sql/schema.sql          | 6 ++++--
     src/std_axes_handler.ml | 2 +-
     src/utils.ml            | 2 ++
     3 files changed, 7 insertions(+), 3 deletions(-)
    
    diff --git a/sql/schema.sql b/sql/schema.sql
    index 73ca6ad..61bc6ca 100755
    --- a/sql/schema.sql
    +++ b/sql/schema.sql
    @@ -23,11 +23,13 @@ create table builds (
       product varchar(128) not null,
       branch varchar(128) not null,
       build_number integer not null,
    -  build_tag varchar(128) null,
    +  build_tag varchar(2048) null,
       build_date varchar(32) null,
    +  build_is_release boolean null,
    +  patches_applied varchar(1024) not null,
     
       primary key (build_id),
    -  constraint builds_unique_keys unique (product, branch, build_number, build_tag)
    +  constraint builds_unique_keys unique (product, branch, build_number, build_tag, build_is_release, patches_applied)
     );
     grant select on builds to "www-data";
     
    diff --git a/src/std_axes_handler.ml b/src/std_axes_handler.ml
    index acd1c1e..0cef147 100644
    --- a/src/std_axes_handler.ml
    +++ b/src/std_axes_handler.ml
    @@ -6,7 +6,7 @@ let t ~args = object (self)
       method private get_std_xy_choices =
         let machine_field_lst =
           List.tl_exn (Sql.get_col_names ~conn ~tbl:"machines") in
    -    "branch" :: "build_number" :: "build_tag" ::
    +    "branch" :: "build_number" :: "build_tag" :: "patches_applied" :: "build_is_release" ::
         "dom0_memory_static_max" :: "dom0_memory_target" ::
         "cc_restrictions" :: "redo_log" ::
         machine_field_lst
    diff --git a/src/utils.ml b/src/utils.ml
    index 9cd2b7e..e43ea41 100644
    --- a/src/utils.ml
    +++ b/src/utils.ml
    @@ -225,6 +225,8 @@ let build_fields = [
       "build_number";
       "build_date";
       "build_tag";
    +  "patches_applied";
    +  "build_is_release"
     ]
     
     let job_fields = [
    
    From 3639eabc07788e2f201fa02968a51eb332d532d9 Mon Sep 17 00:00:00 2001
    From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= 
    Date: Fri, 29 Nov 2019 18:33:28 +0000
    Subject: [PATCH 10/36] Fix some Dune warnings
    MIME-Version: 1.0
    Content-Type: text/plain; charset=UTF-8
    Content-Transfer-Encoding: 8bit
    
    Signed-off-by: Edwin Török 
    ---
     src/brief_handler.ml       |  2 +-
     src/handler.ml             |  2 +-
     src/import_jobs_handler.ml | 14 ++++----------
     src/main.ml                |  2 +-
     src/utils.ml               | 10 +++++-----
     5 files changed, 12 insertions(+), 18 deletions(-)
    
    diff --git a/src/brief_handler.ml b/src/brief_handler.ml
    index af800d7..5943cc6 100644
    --- a/src/brief_handler.ml
    +++ b/src/brief_handler.ml
    @@ -1,7 +1,7 @@
     open Core
     open Utils
     
    -let config_file = Sys.argv.(2)
    +let config_file = Sys.(get_argv ()).(2)
     
     let config =
       In_channel.(with_file config_file ~f:input_lines)
    diff --git a/src/handler.ml b/src/handler.ml
    index b155eda..07b37cb 100644
    --- a/src/handler.ml
    +++ b/src/handler.ml
    @@ -12,7 +12,7 @@ object (self)
       val params = args.params
     
       val base_path : string =
    -    let exe = Sys.argv.(0) in
    +    let exe = (Sys.get_argv ()).(0) in
         String.sub exe ~pos:0 ~len:((String.rindex_exn exe '/') + 1)
     
       val mutable html_header_written : bool = false
    diff --git a/src/import_jobs_handler.ml b/src/import_jobs_handler.ml
    index 4d99f71..e559bac 100644
    --- a/src/import_jobs_handler.ml
    +++ b/src/import_jobs_handler.ml
    @@ -20,17 +20,11 @@ let import_job job_ids =
       let cmd = Printf.sprintf "%s -jobs %s -ignoreseenjobs 2>&1" importer job_ids in
       Printf.printf "" cmd;
       let ic = Unix.open_process_in cmd in
    -  begin
    -  try
    -    while true do
    -      let input = input_line ic in
    +  In_channel.iter_lines ic ~f:(fun input ->
           Printf.printf "%s\n" input;
    -      Printf.eprintf "[import_jobs_handler|%s] %s\n" job_ids input
    -    done
    -  with End_of_file ->
    -    Printf.eprintf "[import_jobs_handler|%s] EOF\n" job_ids;
    -    ignore (Unix.close_process_in ic)
    -  end;
    +      Printf.eprintf "[import_jobs_handler|%s] %s\n" job_ids input);
    +  Printf.eprintf "[import_jobs_handler|%s] EOF\n" job_ids;
    +  ignore (Unix.close_process_in ic);
       Printf.eprintf "[import_jobs_handler|%s] Finished\n" job_ids
     
     let t ~args = object (self)
    diff --git a/src/main.ml b/src/main.ml
    index c8bad8e..20c8aec 100644
    --- a/src/main.ml
    +++ b/src/main.ml
    @@ -26,7 +26,7 @@ let handle_request () =
       let start_time = Unix.gettimeofday () in
       let params = get_params_of_request () in
       let place = place_of_params ~params in
    -  let conn = new Postgresql.connection ~conninfo:Sys.argv.(1) () in
    +  let conn = new Postgresql.connection ~conninfo:Sys.(get_argv()).(1) () in
       let args = let open Handler in {conn; params} in
       let open Place in
       let handler = begin match place with
    diff --git a/src/utils.ml b/src/utils.ml
    index e43ea41..faf7ede 100644
    --- a/src/utils.ml
    +++ b/src/utils.ml
    @@ -1,8 +1,8 @@
     open Core
     
     let debug msg =
    -  output_string stderr (msg ^ "\n");
    -  flush stderr
    +  Out_channel.output_string stderr (msg ^ "\n");
    +  Out_channel.flush stderr
     
     let index l x =
       let rec aux i = function
    @@ -92,7 +92,7 @@ let extract_filter col_fqns col_types params key_prefix =
         if String.equal v "ALL" then () else
         if String.is_prefix k ~prefix:key_prefix then begin
           let k2 = String.chop_prefix_exn k ~prefix:key_prefix in
    -      String.Table.change m k2 (update_m v)
    +      String.Table.change m k2 ~f:(update_m v)
         end in
       List.iter params ~f:filter_insert;
       let l = String.Table.to_alist m in
    @@ -255,10 +255,10 @@ let print_axis_choice ?(multiselect=false) label id choices =
       print_select_list ~label ~attrs:attrs choices;
       printf "\n"
     
    -let print_empty_x_axis_choice ~conn =
    +let print_empty_x_axis_choice ~conn:_ =
       print_axis_choice "X axis" "xaxis" [] ~multiselect:true
     
    -let print_empty_y_axis_choice ~conn =
    +let print_empty_y_axis_choice ~conn:_ =
       print_axis_choice "Y axis" "yaxis" []
     
     let print_x_axis_choice ~conn configs som_configs_opt =
    
    From e45cbe6630d8cbb6ff0a4f44b53f7a5537d50b45 Mon Sep 17 00:00:00 2001
    From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= 
    Date: Wed, 21 Aug 2019 19:04:10 +0100
    Subject: [PATCH 11/36] Memoize the result of some Sql queries: we've been
     repeating the same query thousands of times
    MIME-Version: 1.0
    Content-Type: text/plain; charset=UTF-8
    Content-Transfer-Encoding: 8bit
    
    This reduces brief report load time to ~6s from ~10s for 90 rows (the full report contains thousands)
    
    Signed-off-by: Edwin Török 
    ---
     src/brief_handler.ml | 4 ++++
     1 file changed, 4 insertions(+)
    
    diff --git a/src/brief_handler.ml b/src/brief_handler.ml
    index 5943cc6..56c9718 100644
    --- a/src/brief_handler.ml
    +++ b/src/brief_handler.ml
    @@ -324,10 +324,12 @@ let t ~args = object (self)
           let query = sprintf "select som_id from soms where tc_fqn='%s'" tc_fqn in
           Array.to_list (Array.map (Sql.exec_exn ~conn ~query)#get_all ~f:(fun x->x.(0)))
         in
    +    let soms_of_tc = Memo.general soms_of_tc in
         let rec_of_som som_id =
           let query = sprintf "select som_name,tc_fqn,more_is_better,units,positive from soms where som_id='%s'" som_id in
           (Sql.exec_exn ~conn ~query)#get_all.(0)
         in
    +    let rec_of_som = Memo.general rec_of_som in
         let name_of_som som_id = (rec_of_som som_id).(0) in
         let tc_of_som som_id   = (rec_of_som som_id).(1) in
         let more_is_better_of_som som_id = (rec_of_som som_id).(2) in
    @@ -336,10 +338,12 @@ let t ~args = object (self)
           let query = sprintf "select table_name from information_schema.tables where table_schema='public' and table_name='%s'" table_name in
           not @@ List.is_empty (Array.to_list (Sql.exec_exn ~conn ~query)#get_all)
         in
    +    let has_table = Memo.general has_table in
         let columns_of_table table_name =
           let query = sprintf "select column_name from information_schema.columns where table_name='%s'" table_name in
           Array.to_list (Array.map (Sql.exec_exn ~conn ~query)#get_all ~f:(fun x->x.(0)))
         in
    +    let columns_of_table = Memo.general columns_of_table in
         let contexts_of_som_id som_id =
           (List.filter
             (columns_of_table (sprintf "som_config_%s" som_id))
    
    From e337897ce7b2cbaf8c091b331240e096eabd9bd2 Mon Sep 17 00:00:00 2001
    From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= 
    Date: Fri, 29 Nov 2019 19:02:13 +0000
    Subject: [PATCH 12/36] Async postgres queries
    MIME-Version: 1.0
    Content-Type: text/plain; charset=UTF-8
    Content-Transfer-Encoding: 8bit
    
    Use a Deferred monad for performing queries.
    This is similar to Lwt: instead of getting a response we get a
    promise/future that we can evaluate later when the answer is available.
    
    This'll allow us to do things like List.map and run bunch of queries in
    parallel.
    
    I simply run the postgresql query in a different thread on its own
    connection (limited to number of cores/machine).
    
    It would be possible to avoid using multiple threads and use
    multiplexing via epoll and non-blocking reads/writes but libpq is
    difficult to use: it will reconnect and change the file descriptor
    behing your back which will cause epoll to fail because it is no longer
    registered for epoll.
    
    Signed-off-by: Edwin Török 
    ---
     src/postgresql_async.ml  | 65 ++++++++++++++++++++++++++++++++++++++++
     src/postgresql_async.mli |  5 ++++
     2 files changed, 70 insertions(+)
     create mode 100644 src/postgresql_async.ml
     create mode 100644 src/postgresql_async.mli
    
    diff --git a/src/postgresql_async.ml b/src/postgresql_async.ml
    new file mode 100644
    index 0000000..316a6b8
    --- /dev/null
    +++ b/src/postgresql_async.ml
    @@ -0,0 +1,65 @@
    +open Core
    +open Async
    +
    +(* [in_thread ~name f] runs the blocking function [f] in a worker thread *)
    +let in_thread ~name f =
    +  In_thread.run ~name (fun () -> Or_error.try_with ~backtrace:true f)
    +
    +let connect ~conninfo =
    +  in_thread ~name:"Postgresql connect" (fun () ->
    +      new Postgresql.connection ~conninfo ())
    +
    +let close c =
    +  in_thread ~name:"Postgresql close connection" (fun () -> c#finish)
    +
    +let exec_exn ~(conn : Postgresql.connection) ~query =
    +  in_thread ~name:"Postgresql query" (fun () ->
    +      (* previous invocation might've left the connection in a bad state *)
    +      conn#try_reset ; Sql.exec_exn ~conn ~query)
    +
    +module Lazy_pooled_resource = struct
    +  type 'a t = 'a Or_error.t Lazy_deferred.t Throttle.t
    +
    +  (** [create ~acquire ~release ~limit] creates a lazily initialized resource pool.
    +   * This pool has at most [n] resources, acquired on demand.
    +   * *)
    +  let create ~acquire ~release ~limit : 'a t =
    +    let pool =
    +      limit
    +      |> List.init ~f:(fun _ -> Lazy_deferred.create acquire)
    +      |> Throttle.create_with ~continue_on_error:false
    +    in
    +    Throttle.at_kill pool (fun c ->
    +        match c |> Lazy_deferred.peek_exn |> Option.bind ~f:Or_error.ok with
    +        | None ->
    +            return ()
    +        | Some conn ->
    +            conn |> release |> Deferred.Or_error.ok_exn) ;
    +    pool
    +
    +  let destroy pool = Throttle.kill pool ; Throttle.cleaned pool
    +
    +  (** [with_ pool ~f] acquires a resource from [pool] and runs [f].
    +   * If all resources in [pool] are in use then a new one is created,
    +   * as long as the total number of resources in the pool is below the limit
    +   * specified at creation time. *)
    +  let with_ (pool : 'a t) ~f =
    +    Throttle.enqueue pool (fun conn ->
    +        Deferred.Or_error.bind (conn |> Lazy_deferred.force_exn) ~f)
    +end
    +
    +let cores =
    +  (Linux_ext.cores |> Result.ok |> Option.value ~default:(fun () -> 1)) ()
    +
    +type t = Postgresql.connection Lazy_pooled_resource.t
    +
    +let connect_pool ~conninfo =
    +  let acquire () = connect ~conninfo in
    +  let release = close in
    +  Lazy_pooled_resource.create ~acquire ~release ~limit:cores
    +
    +let destroy_pool = Lazy_pooled_resource.destroy
    +
    +let exec_exn ~conn ~query =
    +  Lazy_pooled_resource.with_ conn ~f:(fun conn -> exec_exn ~conn ~query)
    +  |> Deferred.Or_error.ok_exn
    diff --git a/src/postgresql_async.mli b/src/postgresql_async.mli
    new file mode 100644
    index 0000000..78f7337
    --- /dev/null
    +++ b/src/postgresql_async.mli
    @@ -0,0 +1,5 @@
    +open Async
    +type t
    +val connect_pool: conninfo:string -> t
    +val destroy_pool: t -> unit Deferred.t
    +val exec_exn: conn:t -> query:string -> Postgresql.result Deferred.t
    
    From 51ee3c858306051796f0b4a446e5b0185ac7e6a3 Mon Sep 17 00:00:00 2001
    From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= 
    Date: Sun, 1 Dec 2019 10:54:47 +0000
    Subject: [PATCH 13/36] async wip
    
    ---
     src/postgresql_async.ml  | 3 +++
     src/postgresql_async.mli | 1 +
     2 files changed, 4 insertions(+)
    
    diff --git a/src/postgresql_async.ml b/src/postgresql_async.ml
    index 316a6b8..be1c953 100644
    --- a/src/postgresql_async.ml
    +++ b/src/postgresql_async.ml
    @@ -63,3 +63,6 @@ let destroy_pool = Lazy_pooled_resource.destroy
     let exec_exn ~conn ~query =
       Lazy_pooled_resource.with_ conn ~f:(fun conn -> exec_exn ~conn ~query)
       |> Deferred.Or_error.ok_exn
    +
    +let exec_exn_get_all ~conn ~query =
    +  exec_exn ~conn ~query >>| fun r -> r#get_all
    diff --git a/src/postgresql_async.mli b/src/postgresql_async.mli
    index 78f7337..8be16e1 100644
    --- a/src/postgresql_async.mli
    +++ b/src/postgresql_async.mli
    @@ -3,3 +3,4 @@ type t
     val connect_pool: conninfo:string -> t
     val destroy_pool: t -> unit Deferred.t
     val exec_exn: conn:t -> query:string -> Postgresql.result Deferred.t
    +val exec_exn_get_all: conn:t -> query:string -> string array array Deferred.t
    
    From 4dcb9a940904d6f88c1dc864c09fae70b1f139ba Mon Sep 17 00:00:00 2001
    From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= 
    Date: Sun, 1 Dec 2019 16:43:31 +0000
    Subject: [PATCH 14/36] Convert queries to asynchronous queries
    MIME-Version: 1.0
    Content-Type: text/plain; charset=UTF-8
    Content-Transfer-Encoding: 8bit
    
    Using the ppx syntax extension:
    `let%map y = f x in ...` is equivalent to `f x >>| fun y -> ..`
    `let%bind y = f x in ...` is equivalent to `f x >>= fun y -> ...`
    
    Except these also allow you to do parallel binds, which is tedious to
    accomplish "manually".
    
    Signed-off-by: Edwin Török 
    ---
     src/brief_handler.ml             | 181 ++++++++++++++++++-------------
     src/create_tiny_url_handler.ml   |   3 +-
     src/default_handler.ml           |   2 +
     src/handler.ml                   |   7 +-
     src/import_jobs_handler.ml       |   3 +-
     src/import_page_handler.ml       |   2 +
     src/javascript_only_handler.ml   |   2 +-
     src/postgresql_async.ml          |  15 +--
     src/postgresql_async.mli         |   1 +
     src/redirect_tiny_url_handler.ml |   3 +-
     src/som_data_handler.ml          |  16 +--
     src/som_page_handler.ml          |  38 ++++---
     src/soms_handler.ml              |   8 +-
     src/std_axes_handler.ml          |  17 ++-
     src/utils.ml                     |  31 ++++--
     15 files changed, 193 insertions(+), 136 deletions(-)
    
    diff --git a/src/brief_handler.ml b/src/brief_handler.ml
    index 56c9718..d595749 100644
    --- a/src/brief_handler.ml
    +++ b/src/brief_handler.ml
    @@ -1,4 +1,5 @@
     open Core
    +open Async.Deferred.Let_syntax
     open Utils
     
     let config_file = Sys.(get_argv ()).(2)
    @@ -120,7 +121,7 @@ let t ~args = object (self)
         in
         let fetch_brief_params_from_db id =
           let query = sprintf "select brief_params from briefs where brief_id='%s'" id in
    -      (Sql.exec_exn ~conn ~query)#get_all.(0).(0)
    +      let%map r = Postgresql_async.exec_exn_get_all ~conn ~query in r.(0).(0)
         in
         let fetch_suite id branch =
           let url = sprintf "https://code.citrite.net/projects/XRT/repos/xenrt/raw/suites/%s?at=%s" id (Uri.pct_encode branch) in
    @@ -175,7 +176,7 @@ let t ~args = object (self)
         in
         let fetch_brief_params_from id =
           let xs = if is_digit id then fetch_brief_params_from_db id
    -        else if String.is_prefix id ~prefix:"TC-" then (
    +        else return @@ if String.is_prefix id ~prefix:"TC-" then (
               match String.split ~on:'#' id with
               | [id; branch] -> fetch_brief_params_from_suite ~branch id
               | [id] -> fetch_brief_params_from_suite id
    @@ -188,15 +189,15 @@ let t ~args = object (self)
         let title_of_id id =
           if is_digit id then
             let query = sprintf "select brief_desc from briefs where brief_id='%s'" id in
    -        (Sql.exec_exn ~conn ~query)#get_all.(0).(0)
    +        let%map r = Postgresql_async.exec_exn_get_all ~conn ~query in r.(0).(0)
           else
    -        ""
    +        return ""
         in
     
         let get_input_rows_from_id id fn =
    -      let brief_params_from = fetch_brief_params_from id in
    +      let%bind brief_params_from = fetch_brief_params_from id in
           let args = parse_url brief_params_from in
    -      let _,_input_rows,_,_,_,_ = fn args in
    +      let%map _,_input_rows,_,_,_,_ = fn args in
           _input_rows
         in
     
    @@ -236,9 +237,9 @@ let t ~args = object (self)
               []
           in
           printf "\n" (html_encode (Sexp.to_string (sexp_of_rows_t input_rows)));
    -      let extra_input_rows_from = (* list of rows_t *)
    +      let%map extra_input_rows_from = (* list of rows_t *)
             let ids = Str.split (Str.regexp ",") params_add_rows_from in
    -        List.map ids ~f:(fun id-> get_input_rows_from_id id get_input_values)
    +        Async.Deferred.List.map ids ~f:(fun id-> get_input_rows_from_id id get_input_values)
           in
     (*
           printf "\n" (html_encode (List.fold_left extra_input_rows_from ~init:"" ~f:(fun extra_input_row->(Sexp.to_string (sexp_of_rows_t extra_input_row)))));
    @@ -286,8 +287,8 @@ let t ~args = object (self)
           (input_cols, input_rows, input_base_context, baseline_col_idx, out, sort_by_col)
         in
     
    -    let args =
    -      if String.(brief_id = "") then params
    +    let%bind args =
    +      if String.(brief_id = "") then return params
           else
             let replace params default_params=
               List.fold_left (* if params present, use it preferrably over the default params *)
    @@ -295,7 +296,8 @@ let t ~args = object (self)
                 ~init:[]
                 ~f:(fun acc (k,v)->match List.find params ~f:(fun (ko,_)->String.(k=ko)) with|None->(k,v)::acc|Some o->o::acc)
             in
    -        List.fold_left params ~init:(replace params (fetch_brief_params_from brief_id)) ~f:(fun acc (k,v)->
    +        let%map brief_params = fetch_brief_params_from brief_id in
    +        List.fold_left params ~init:(replace params brief_params) ~f:(fun acc (k,v)->
               match List.find acc ~f:(fun (ka,_)->String.(k=ka)) with
               |None->(k,v)::acc (* if params contains a k not in the db, add this k to args *)
               |Some _->acc
    @@ -303,7 +305,7 @@ let t ~args = object (self)
         in
     
         (* === process === *)
    -    let input_cols, input_rows, input_base_context, baseline_col_idx, out, sort_by_col =
    +    let%bind input_cols, input_rows, input_base_context, baseline_col_idx, out, sort_by_col =
           get_input_values args
         in
     
    @@ -322,49 +324,54 @@ let t ~args = object (self)
     
         let soms_of_tc tc_fqn =
           let query = sprintf "select som_id from soms where tc_fqn='%s'" tc_fqn in
    -      Array.to_list (Array.map (Sql.exec_exn ~conn ~query)#get_all ~f:(fun x->x.(0)))
    +      let%map a = Postgresql_async.exec_exn_get_all ~conn ~query in
    +      Array.to_list (Array.map a ~f:(fun x->x.(0)))
         in
    -    let soms_of_tc = Memo.general soms_of_tc in
    +    let soms_of_tc = Async.Deferred.Memo.general (module String) soms_of_tc in
         let rec_of_som som_id =
           let query = sprintf "select som_name,tc_fqn,more_is_better,units,positive from soms where som_id='%s'" som_id in
    -      (Sql.exec_exn ~conn ~query)#get_all.(0)
    +      let%map r = Postgresql_async.exec_exn_get_all ~conn ~query in r.(0)
         in
    -    let rec_of_som = Memo.general rec_of_som in
    -    let name_of_som som_id = (rec_of_som som_id).(0) in
    -    let tc_of_som som_id   = (rec_of_som som_id).(1) in
    -    let more_is_better_of_som som_id = (rec_of_som som_id).(2) in
    -    let unit_of_som som_id = (rec_of_som som_id).(3) in
    +    let rec_of_som = Async.Deferred.Memo.general (module String) rec_of_som in
    +    let rec_of_som_id_n som_id n =
    +      let%map r = unstage(rec_of_som) som_id in r.(n) in
    +    let name_of_som som_id = rec_of_som_id_n som_id 0 in
    +    let tc_of_som som_id   = rec_of_som_id_n som_id 1 in
    +    let more_is_better_of_som som_id = rec_of_som_id_n som_id 2 in
    +    let unit_of_som som_id = rec_of_som_id_n som_id 3 in
         let has_table table_name =
           let query = sprintf "select table_name from information_schema.tables where table_schema='public' and table_name='%s'" table_name in
    -      not @@ List.is_empty (Array.to_list (Sql.exec_exn ~conn ~query)#get_all)
    +      let%map a = Postgresql_async.exec_exn_get_all ~conn ~query in
    +      not @@ List.is_empty (Array.to_list a)
         in
    -    let has_table = Memo.general has_table in
    +    let has_table = Async.Deferred.Memo.general (module String) has_table in
         let columns_of_table table_name =
           let query = sprintf "select column_name from information_schema.columns where table_name='%s'" table_name in
    -      Array.to_list (Array.map (Sql.exec_exn ~conn ~query)#get_all ~f:(fun x->x.(0)))
    +      let%map a = Postgresql_async.exec_exn_get_all ~conn ~query in
    +      Array.to_list (Array.map a ~f:(fun x->x.(0)))
         in
    -    let columns_of_table = Memo.general columns_of_table in
    +    let columns_of_table = Async.Deferred.Memo.general (module String) columns_of_table in
         let contexts_of_som_id som_id =
    -      (List.filter
    -        (columns_of_table (sprintf "som_config_%s" som_id))
    +      let%map cols = unstage(columns_of_table) (sprintf "som_config_%s" som_id) in
    +      (List.filter cols
             ~f:(fun e->String.(e<>"som_config_id"))
           )
         in
         let contexts_of_tc_fqn tc_fqn =
    -      (List.filter
    -        (columns_of_table (sprintf "tc_config_%s" tc_fqn))
    +      let%map cols = unstage(columns_of_table) (sprintf "tc_config_%s" tc_fqn) in
    +      (List.filter cols
             ~f:(fun e->String.(e<>"tc_config_id"))
           )
         in
    -    let contexts_of_tc =
    -      (List.filter
    -        (columns_of_table "tc_config")
    +    let%bind contexts_of_tc =
    +      let%map cols = unstage(columns_of_table) "tc_config" in
    +      (List.filter cols
             ~f:(fun e->not (List.mem ~equal:String.equal ["tc_fqn";"tc_config_id";"machine_id"] e))
           )
         in
         let url_of_t t =
           let query = sprintf "select url from tiny_urls where key=%s" t in
    -      (Sql.exec_exn ~conn ~query)#get_all.(0).(0)
    +      let%map r = Postgresql_async.exec_exn_get_all ~conn ~query in r.(0).(0)
         in
         (*
         let all_contexts_of_tc tc_fqn =
    @@ -383,37 +390,46 @@ let t ~args = object (self)
             ~f:(fun som_contexts->tc_contexts @ som_contexts)
         in
         *)
    -    let contexts_of_machine = List.filter (columns_of_table "machines") ~f:(fun e->String.(e<>"machine_id")) in
    -    let contexts_of_build = List.filter (columns_of_table "builds") ~f:(fun e->String.(e<>"build_id")) in
    +    let%bind contexts_of_machine =
    +      let%map cols = unstage(columns_of_table) "machines" in
    +      List.filter cols
    +      ~f:(fun e->String.(e<>"machine_id")) in
    +    let%bind contexts_of_build =
    +      let%map cols = unstage(columns_of_table) "builds" in
    +      List.filter cols
    +      ~f:(fun e->String.(e<>"build_id")) in
         let values_of cs ~at:cs_f = List.filter cs ~f:(fun (k,v)->List.mem ~equal:String.equal cs_f k) in
     
     (*
         let latest_build_of_branch branch =
           let query = sprintf "select max(build_number) from builds where branch='%s'" branch in
    -      (Sql.exec_exn ~conn ~query)#get_all.(0).(0)
    +      (Postgresql_async.exec_exn_get_all ~conn ~query).(0).(0)
         in
     *)
         let builds_of_branch branch =
           let query = sprintf "select distinct build_number from builds where branch='%s' order by build_number desc" branch in
    -      List.map (Array.to_list ((Sql.exec_exn ~conn ~query)#get_all)) ~f:(fun x->x.(0))
    +      let%map a = Postgresql_async.exec_exn_get_all ~conn ~query in
    +      List.map (Array.to_list a) ~f:(fun x->x.(0))
         in
     (*  this query is better than builds_of_branch but it is too slow so cannot be used 
         let latest_build_in_branch branch =
           let query = sprintf "select max(build_number) from builds,measurements,jobs where branch='%s' and measurements.job_id = jobs.job_id and jobs.build_id = builds.build_id" branch in
    -      (Sql.exec_exn ~conn ~query)#get_all.(0).(0)
    +      (Postgresql_async.exec_exn_get_all ~conn ~query).(0).(0)
         in
     *)
         (*TODO: touch each element of the context when it is used; if an element is not used at the end of this function,
                 then raise an error indicating that probably there's a typo in the context element
          *) 
         let measurements_of_cell context = 
    -       let get e ctx = match List.find_exn ctx ~f:(fun (k,v)->String.(e=k)) with |k,v->v in
    +       let get e ctx = List.Assoc.find ~equal:String.equal ctx e in
            let measurements_of_som som_id =
    -         let has_table_som_id som_id = has_table (sprintf "som_config_%s" som_id) in
    -         let tc_fqn = tc_of_som som_id in 
    +         let%bind has_table_som_id = unstage(has_table) (sprintf "som_config_%s" som_id) in
    +         let%bind tc_fqn = tc_of_som som_id in
    +         let%bind contexts_of_this_som_id = contexts_of_som_id som_id in
    +         let%bind contexts_of_this_tc_fqn = contexts_of_tc_fqn tc_fqn in
              let query = "select sj.job_id, m.result from measurements_2 m join soms_jobs sj on m.som_job_id=sj.id "
                ^(sprintf "join tc_config_%s on m.tc_config_id=tc_config_%s.tc_config_id " tc_fqn tc_fqn)
    -           ^(if has_table_som_id som_id then
    +           ^(if has_table_som_id then
                   (sprintf "join som_config_%s on m.som_config_id=som_config_%s.som_config_id " som_id som_id)
                  else ""
                 )
    @@ -430,8 +446,8 @@ let t ~args = object (self)
                     sprintf "%s%smachines.%s='%s' " acc2 (match acc2 with |""->""|_->"or ") k v
                   ))
                 ))
    -           ^(if has_table_som_id som_id then
    -             (List.fold_left (values_of context ~at:(contexts_of_som_id som_id)) ~init:"" ~f:(fun acc (k,vs)->
    +           ^(if has_table_som_id then
    +             (List.fold_left (values_of context ~at:contexts_of_this_som_id) ~init:"" ~f:(fun acc (k,vs)->
                   match vs with []->acc|_->
                   sprintf "%s and (%s) " acc 
                   (List.fold_left vs ~init:"" ~f:(fun acc2 v->
    @@ -440,7 +456,7 @@ let t ~args = object (self)
                 ))
                  else ""
                 )
    -           ^(List.fold_left (values_of context ~at:(contexts_of_tc_fqn tc_fqn)) ~init:"" ~f:(fun acc (k,vs)->
    +           ^(List.fold_left (values_of context ~at:contexts_of_this_tc_fqn) ~init:"" ~f:(fun acc (k,vs)->
                   match vs with []->acc|_->
                   sprintf "%s and (%s) " acc
                   (List.fold_left vs ~init:"" ~f:(fun acc2 v->
    @@ -462,12 +478,15 @@ let t ~args = object (self)
                   ))
                 ))
               in
    -          Array.to_list (Array.map (Sql.exec_exn ~conn ~query)#get_all ~f:(fun x->{job=int_of_string x.(0); value=x.(1)}))
    +          let%map a = Postgresql_async.exec_exn_get_all ~conn ~query in
    +          Array.to_list (Array.map a ~f:(fun x->{job=int_of_string x.(0); value=x.(1)}))
             in
             (* add measurements for each one of the soms in the cell *)
    -        try
    -          List.concat (List.map ~f:measurements_of_som (get "soms" context))
    -        with Not_found ->
    +        match get "soms" context with
    +        | Some som ->
    +          let%map r = Async.Deferred.List.map ~f:measurements_of_som som in
    +          List.concat r
    +        | None ->
               failwith (sprintf "Could not find 'soms' in context; keys are [%s]" (List.map ~f:fst context |> String.concat ~sep:", "));
         in
     
    @@ -490,11 +509,11 @@ let t ~args = object (self)
           let k_build_number = "build_number" in
           let v_latest_in_branch = "latest_in_branch" in
           match List.find ~f:(fun (k,vs)->String.(k=k_branch)) c_kvs with
    -      | None -> [c_kvs]
    +      | None -> return [c_kvs]
           | Some (_,branches) ->
           if List.length branches < 1
           then
    -          [] (* no branches provided, no results *)
    +          return [] (* no branches provided, no results *)
           else
           (* list of all builds in all branches provided *)
     
    @@ -506,10 +525,10 @@ let t ~args = object (self)
             List.exists c_kvs ~f:(fun (k,vs) -> String.(k=k_build_number) && List.exists vs ~f:(fun v->String.(v=v_latest_in_branch)))
           in
           (* if 'latest_in_branch' value is present, expand ctx into many ctxs, one for each build; otherwise, return the ctx intact *)
    -      if not has_v_latest_in_branch then [c_kvs]
    +      if not has_v_latest_in_branch then return [c_kvs]
           else (
             (* brute-force way to find the max build with measurements, to work around the slowness in the query in latest_build_in_branch *)
    -        let builds = builds_of_branch (List.nth_exn branches 0) in (*TODO: handle >1 branch in context*)
    +        let%map builds = builds_of_branch (List.nth_exn branches 0) in (*TODO: handle >1 branch in context*)
             let builds_of_branches = List.slice builds 0 (min 100 (List.length builds)) in (* take up to 100 elements in the list *)
             debug (sprintf "builds_of_branches=%s" (List.fold_left ~init:"" builds_of_branches ~f:(fun acc b->acc ^","^b)));
     
    @@ -523,7 +542,8 @@ let t ~args = object (self)
           ))
         in
         let c_kvs_of_tiny_url t =
    -      let url = url_decode (url_of_t t) in
    +      let%map url = url_of_t t in
    +      let url = url_decode url in
           debug (sprintf "expanded tiny url t=%s => %s" t url);
           (* parse and add "v_"k=value patterns in url *)
           let items = parse_url url in
    @@ -564,9 +584,9 @@ let t ~args = object (self)
           let k_tiny_url = "t" in
           let tiny_url = List.find c_kvs ~f:(fun (k,_) -> String.(k=k_tiny_url)) in
           let x = match tiny_url with
    -      | None         -> [c_kvs]
    +      | None         -> return [c_kvs]
           | Some (_,[t]) ->
    -        let x = c_kvs_of_tiny_url t in
    +        let%map x = c_kvs_of_tiny_url t in
             [List.fold_left
               ~init:c_kvs           (* c_kvs kvs have priority over the ones in c_kvs_of_tiny_url *)
               x                     (* obtain url from tiny_url id, parse it and return a c_kvs *)
    @@ -660,12 +680,13 @@ let t ~args = object (self)
            let resolve_keywords_in_row acc r =
     
             if List.exists r ~f:(fun (k,v)->String.(k="tcs")) then (* expand tcs into soms *)
    -          let r_expanded = List.concat (List.map r 
    +          let%map r_expanded = Async.Deferred.List.concat_map r 
                 ~f:(fun (k,v)->match k with 
    -              | _ when String.(k="tcs") -> List.concat (List.map v ~f:(fun tc->List.map (soms_of_tc tc) ~f:(fun som->("soms",[som]))))
    -              | _ -> (k,v)::[] 
    +              | _ when String.(k="tcs") -> (Async.Deferred.List.concat_map v ~f:(fun tc->
    +                  let%map r = unstage(soms_of_tc) tc in
    +                  List.map r ~f:(fun som->("soms",[som]))))
    +              | _ -> (k,v)::[] |> return
                 )
    -          )
               in
               let soms,no_soms = List.partition_tf r_expanded ~f:(fun (k,v)->String.(k="soms")) in
               let soms = List.sort soms ~compare:(fun (xk,xv) (yk,yv)->(int_of_string(List.hd_exn xv)) - (int_of_string(List.hd_exn yv))) in
    @@ -753,17 +774,17 @@ let t ~args = object (self)
         progress (sprintf "table: %d lines: " (List.length rs));
         let ctx_and_measurements_of_1st_cell_with_data expand_f ctx =
           let ctxs = expand_f ctx in
    -      let measurements_of_cells = List.find_map ctxs ~f:(fun c->let ms=measurements_of_cell c in if List.is_empty ms then None else (Some (c,ms))) in
    -      match measurements_of_cells with None->ctx,[]|Some (c,ms)->c,ms
    +      let measurements_of_cells = Async.Deferred.List.find_map ctxs ~f:(fun c->let%map ms=measurements_of_cell c in if List.is_empty ms then None else (Some (c,ms))) in
    +      match%map measurements_of_cells with None->ctx,[]|Some (c,ms)->c,ms
         in
    -    let measurements_of_table = 
    +    let%bind measurements_of_table = 
           let rs_len = List.length rs in
    -      List.mapi rs ~f:(fun i r->
    +      Async.Deferred.List.mapi rs ~f:(fun i r->
             progress (sprintf "row %d of %d..." i rs_len);
    -        r, (List.map cs ~f:(fun c->
    -          let ctx, ms = ctx_and_measurements_of_1st_cell_with_data expand (context_of b r c) in
    +        let%map csr = Async.Deferred.List.map cs ~f:(fun c->
    +          let%map ctx, ms = ctx_and_measurements_of_1st_cell_with_data expand (context_of b r c) in
               (r, c, ctx,  ms)
    -        ))
    +        ) in r, csr
           )
         in
     
    @@ -994,11 +1015,11 @@ let t ~args = object (self)
               in
           let is_more_is_better ctx =
             match List.find ctx ~f:(fun (k,_)->String.(k="soms")) with
    -        |None->None
    +        |None->return None
             |Some (k,_vs)->(
               let rec is_mb acc vs = (match vs with
    -          |[]->if Option.is_none acc then None else acc
    -          |v::vs->(let mb = more_is_better_of_som v in
    +          |[]-> return @@ if Option.is_none acc then None else acc
    +          |v::vs->(let%bind mb = more_is_better_of_som v in
                 if String.(mb="") then is_mb acc vs (* ignore more_is_better if not defined in db *)
                 else
                   let mbtf = match mb with m when String.(m="f")->false|_->true in
    @@ -1006,7 +1027,7 @@ let t ~args = object (self)
                   |None->is_mb (Some mbtf) vs
                   |Some _mbtf->if Bool.(_mbtf=mbtf)
                   then is_mb (Some mbtf) vs  (* more_is_better values agree between soms *)
    -              else None                  (* more_is_better values disagree between soms *)
    +              else return None                  (* more_is_better values disagree between soms *)
                 )
               ) in
               is_mb None _vs
    @@ -1055,18 +1076,18 @@ let t ~args = object (self)
                     else
                       sprintf "(%d)" number
                   in
    -              let colour = 
    -                (if number = 0 || baseline_col_idx = i then "" else
    -                 match is_more_is_better ctx with
    +              let%bind colour = 
    +                (if number = 0 || baseline_col_idx = i then return "" else
    +                 match%map is_more_is_better ctx with
                      |None->""
                      |Some mb->
                          if (List.length baseline_ms) < 1 then "black" else
                          if is_green (val_stddev_of (vals_of_ms baseline_ms)) (val_stddev_of (vals_of_ms ms)) mb then "green" else "red"
                     ) in
                   let avg = str_stddev_of (vals_of_ms ms) in
    -              let diff = 
    -                (if number = 0 || baseline_col_idx = i || (List.length baseline_ms < 1) then "" else
    -                 match is_more_is_better ctx with
    +              let%map diff = 
    +                (if number = 0 || baseline_col_idx = i || (List.length baseline_ms < 1) then return "" else
    +                 match%map is_more_is_better ctx with
                      |None->""
                      |Some mb->sprintf "(%+.0f%%)" (100.0 *. (proportion (val_stddev_of (vals_of_ms baseline_ms)) (val_stddev_of (vals_of_ms ms)) mb))
                     ) in
    @@ -1078,7 +1099,8 @@ let t ~args = object (self)
           )
           in
           let brief_name = if is_digit brief_id then "jim #"^brief_id else sprintf "from %s" brief_id brief_id in
    -      printf "

    Brief RAGE Report %s: %s

    \n" brief_name (title_of_id brief_id); + let%map title = title_of_id brief_id in + printf "

    Brief RAGE Report %s: %s

    \n" brief_name title; printf "%s" "
    • Numbers reported at 95% confidence level from the data of existing runs\n"; printf "%s" "
    • (x) indicates number of samples\n"; printf "%s" "
    • (x%) indicates difference with baseline column\n"; @@ -1121,7 +1143,10 @@ let t ~args = object (self) List.fold_left kvs ~init:"" ~f:(fun acc (k,vs)-> if String.(k<>"soms") then acc else (sprintf "%s %s \\\\" acc (List.fold_left vs ~init:"" ~f:(fun acc2 som-> - let s=sprintf "%s: *%s* (%s%s)" (tc_of_som som) (name_of_som som) (let u=unit_of_som som in if String.(u="") then u else u^", ") (sprintf "%s is better" (let mb=more_is_better_of_som som in if String.(mb="") then "none" else if String.(mb="f") then "less" else "more")) in + let%map mbstr = + let%map mb=more_is_better_of_som som in if String.(mb="") then "none" else if String.(mb="f") then "less" else "more" + in + let s=sprintf "%s: *%s* (%s%s)" (tc_of_som som) (name_of_som som) (let u=unit_of_som som in if String.(u="") then u else u^", ") (sprintf "%s is better" mbstr) in if String.(acc="") then s else acc^","^s )) ) diff --git a/src/create_tiny_url_handler.ml b/src/create_tiny_url_handler.ml index 3d32873..e922bba 100644 --- a/src/create_tiny_url_handler.ml +++ b/src/create_tiny_url_handler.ml @@ -1,4 +1,5 @@ open Core +open Async let t ~args = object (self) inherit Json_handler.t ~args @@ -6,6 +7,6 @@ let t ~args = object (self) method private write_body = let url = self#get_param_exn "url" in let tuples = [("url", url)] in - let id = Sql.ensure_inserted_get_id ~conn ~tbl:"tiny_urls" ~tuples in + let%map id = Postgresql_async.wrap_sql ~conn (Sql.ensure_inserted_get_id ~tbl:"tiny_urls" ~tuples) in printf "{\"id\":%d}" id end diff --git a/src/default_handler.ml b/src/default_handler.ml index c3dddf8..97fa6c5 100644 --- a/src/default_handler.ml +++ b/src/default_handler.ml @@ -1,4 +1,5 @@ open Core +open Async let t ~args = object (self) inherit Html_handler.t ~args @@ -8,4 +9,5 @@ let t ~args = object (self) printf "
    • Scales of Measure
    • \n"; printf "
    • Import Jobs
    • \n"; printf "
    \n"; + return () end diff --git a/src/handler.ml b/src/handler.ml index 07b37cb..f05ea77 100644 --- a/src/handler.ml +++ b/src/handler.ml @@ -1,8 +1,9 @@ open Core +open Async open Utils type args = { - conn : Postgresql.connection; + conn : Postgresql_async.t; params : (string * string) list; } @@ -19,13 +20,13 @@ object (self) method private write_header = () - method private write_body = () + method private write_body = return () method private write_footer = () method handle = self#write_header; - self#write_body; + let%map () = self#write_body in self#write_footer method private write_html_header = diff --git a/src/import_jobs_handler.ml b/src/import_jobs_handler.ml index e559bac..d91dd82 100644 --- a/src/import_jobs_handler.ml +++ b/src/import_jobs_handler.ml @@ -41,6 +41,7 @@ let t ~args = object (self) Printf.printf "
    ";
         import_job job_ids;
         Printf.printf "
    "; - Printf.printf "Finished." + Printf.printf "Finished."; + Async.return () end diff --git a/src/import_page_handler.ml b/src/import_page_handler.ml index ba27e21..7b27537 100644 --- a/src/import_page_handler.ml +++ b/src/import_page_handler.ml @@ -1,4 +1,5 @@ open Core +open Async let t ~args = object (self) inherit Html_handler.t ~args @@ -14,5 +15,6 @@ let t ~args = object (self) printf "\n"; printf ""; printf ""; + return () end diff --git a/src/javascript_only_handler.ml b/src/javascript_only_handler.ml index 260f085..cadaeeb 100644 --- a/src/javascript_only_handler.ml +++ b/src/javascript_only_handler.ml @@ -1,5 +1,5 @@ let t ~args = object (self) inherit Html_handler.t ~args - method private write_body = Printf.printf "" + method private write_body = Printf.printf ""; Async.return () end diff --git a/src/postgresql_async.ml b/src/postgresql_async.ml index be1c953..2ea3964 100644 --- a/src/postgresql_async.ml +++ b/src/postgresql_async.ml @@ -12,11 +12,6 @@ let connect ~conninfo = let close c = in_thread ~name:"Postgresql close connection" (fun () -> c#finish) -let exec_exn ~(conn : Postgresql.connection) ~query = - in_thread ~name:"Postgresql query" (fun () -> - (* previous invocation might've left the connection in a bad state *) - conn#try_reset ; Sql.exec_exn ~conn ~query) - module Lazy_pooled_resource = struct type 'a t = 'a Or_error.t Lazy_deferred.t Throttle.t @@ -60,9 +55,15 @@ let connect_pool ~conninfo = let destroy_pool = Lazy_pooled_resource.destroy +let wrap_sql ~(conn:t) f = + Lazy_pooled_resource.with_ conn ~f:(fun conn -> + in_thread ~name:"Postgresql query" (fun () -> + (* previous invocation might've left the connection in a bad state *) + conn#try_reset ; f ~conn)) + |> Deferred.Or_error.ok_exn + let exec_exn ~conn ~query = - Lazy_pooled_resource.with_ conn ~f:(fun conn -> exec_exn ~conn ~query) - |> Deferred.Or_error.ok_exn + wrap_sql ~conn (Sql.exec_exn ~query) let exec_exn_get_all ~conn ~query = exec_exn ~conn ~query >>| fun r -> r#get_all diff --git a/src/postgresql_async.mli b/src/postgresql_async.mli index 8be16e1..065860c 100644 --- a/src/postgresql_async.mli +++ b/src/postgresql_async.mli @@ -4,3 +4,4 @@ val connect_pool: conninfo:string -> t val destroy_pool: t -> unit Deferred.t val exec_exn: conn:t -> query:string -> Postgresql.result Deferred.t val exec_exn_get_all: conn:t -> query:string -> string array array Deferred.t +val wrap_sql: conn:t -> (conn:Postgresql.connection -> 'a) -> 'a Deferred.t diff --git a/src/redirect_tiny_url_handler.ml b/src/redirect_tiny_url_handler.ml index addc53f..9bbd1e8 100644 --- a/src/redirect_tiny_url_handler.ml +++ b/src/redirect_tiny_url_handler.ml @@ -1,4 +1,5 @@ open Core +open Async let t ~args = object (self) inherit Html_handler.t ~args @@ -6,7 +7,7 @@ let t ~args = object (self) method handle = let id = int_of_string (self#get_param_exn "t") in let query = sprintf "SELECT url FROM tiny_urls WHERE key=%d" id in - let result = Sql.exec_exn ~conn ~query in + let%map result = Postgresql_async.exec_exn ~conn ~query in match result#ntuples with | 1 -> self#javascript_redirect (Sql.get_first_entry_exn ~result) | _ -> self#write_404 diff --git a/src/som_data_handler.ml b/src/som_data_handler.ml index 9205538..b1bc305 100644 --- a/src/som_data_handler.ml +++ b/src/som_data_handler.ml @@ -1,4 +1,5 @@ open Core +open Async open Fn open Utils @@ -81,14 +82,14 @@ let t ~args = object (self) method private write_body = let som_id = int_of_string (self#get_param_exn "id") in - let tc_fqn, tc_config_tbl = get_tc_config_tbl_name conn som_id in - let som_config_tbl, som_tbl_exists = som_config_tbl_exists ~conn som_id in + let%bind tc_fqn, tc_config_tbl = get_tc_config_tbl_name conn som_id in + let%bind som_config_tbl, som_tbl_exists = som_config_tbl_exists ~conn som_id in (* determine filter columns and their types *) let tbls = ["measurements_2"; "soms_jobs"; "jobs"; "builds"; "tc_config"; "machines"; tc_config_tbl] @ (if som_tbl_exists then [som_config_tbl] else []) in - let col_fqns = get_column_fqns_many conn tbls in - let col_types = get_column_types_many conn tbls in + let%bind col_fqns = get_column_fqns_many conn tbls in + let%bind col_types = get_column_types_many conn tbls in (* Get axes selections. xaxis may be multi-valued; yaxis is single value. *) let xaxis = self#values_for_key "xaxis" ~default:["branch"] in (* xaxis could be ["one"; "two"] or ["one%2Ctwo"] -- both are equivalent *) @@ -114,7 +115,7 @@ let t ~args = object (self) let filter = extract_filter col_fqns col_types params values_prefix in (* obtain SOM meta-data *) let query = sprintf "SELECT positive FROM soms WHERE som_id=%d" som_id in - let metadata = Sql.exec_exn ~conn ~query in + let%bind metadata = Postgresql_async.exec_exn ~conn ~query in let positive = String.(Sql.get_first_entry_exn ~result:metadata = "t") in (* obtain data from database *) let query = @@ -140,7 +141,7 @@ let t ~args = object (self) (if not (String.is_empty filter) then sprintf " AND %s" filter else "") ^ (sprintf " LIMIT %d" limit_rows) in - let data = Sql.exec_exn ~conn ~query in + let%bind data = Postgresql_async.exec_exn ~conn ~query in let rows = data#get_all in debug (sprintf "The query returned %d rows" (Array.length rows)); (if Array.length rows = limit_rows then debug (sprintf "WARNING: truncation of data -- we are only returning the first %d rows" limit_rows)); @@ -200,5 +201,6 @@ let t ~args = object (self) printf "]}" in List.iteri (Hashtbl.Poly.to_alist all_series) ~f:process_series; - printf "]}" + printf "]}"; + return () end diff --git a/src/som_page_handler.ml b/src/som_page_handler.ml index d2c11f6..cca05d1 100644 --- a/src/som_page_handler.ml +++ b/src/som_page_handler.ml @@ -1,4 +1,5 @@ open Core +open Async open Utils let jira_hostname = "jira.uk.xensource.com" @@ -42,9 +43,9 @@ let t ~args = object (self) let machine_options_lst = options_lst_of_dbresult machines in - let config_options_lst = List.map config_column_names ~f:(fun config_name -> + let%map config_options_lst = Deferred.List.map config_column_names ~f:(fun config_name -> let query = sprintf "SELECT DISTINCT %s FROM %s ORDER BY %s" config_name tc_config_tbl config_name in - let configs = Sql.exec_exn ~conn ~query in + let%map configs = Postgresql_async.exec_exn ~conn ~query in get_options_for_field_once configs 0 ) in @@ -75,39 +76,41 @@ let t ~args = object (self) method private write_body = let som_id = int_of_string (List.Assoc.find_exn ~equal:String.equal params "som") in - let _, tc_config_tbl = get_tc_config_tbl_name conn som_id in + let%bind _, tc_config_tbl = get_tc_config_tbl_name conn som_id in let query = sprintf "SELECT * FROM soms WHERE som_id=%d" som_id in - let som_info = Sql.exec_exn ~conn ~query in + let%bind som_info = + Postgresql_async.exec_exn ~conn ~query in let query = "SELECT * FROM " ^ tc_config_tbl ^ " LIMIT 0" in - let config_columns = Sql.exec_exn ~conn ~query in + let%bind config_columns = Postgresql_async.exec_exn ~conn ~query in let job_fields = String.concat ~sep:", " Utils.job_fields in let query = "SELECT DISTINCT " ^ job_fields ^ " FROM soms_jobs WHERE " ^ (sprintf "som_id=%d" som_id) in - let job_ids = Sql.exec_exn ~conn ~query in + let%bind job_ids = Postgresql_async.exec_exn ~conn ~query in let build_fields = String.concat ~sep:", " Utils.build_fields in let query = "SELECT DISTINCT " ^ build_fields ^ " " ^ (sprintf "FROM builds AS b, jobs AS j, (select distinct job_id from soms_jobs where som_id=%d) AS m " som_id) ^ "WHERE m.job_id=j.job_id AND j.build_id=b.build_id " in - let builds = Sql.exec_exn ~conn ~query in + let%bind builds = Postgresql_async.exec_exn ~conn ~query in let query = "SELECT DISTINCT " ^ (String.concat ~sep:", " Utils.tc_config_fields) ^ " " ^ (sprintf "FROM tc_config AS c, jobs AS j, (select distinct job_id from soms_jobs where som_id=%d) AS m " som_id) ^ "WHERE m.job_id=j.job_id AND j.job_id=c.job_id " in - let job_attributes = Sql.exec_exn ~conn ~query in - let som_config_tbl, som_tbl_exists = som_config_tbl_exists ~conn som_id in - let som_configs_opt = - if not som_tbl_exists then None else + let%bind job_attributes = Postgresql_async.exec_exn ~conn ~query in + let%bind som_config_tbl, som_tbl_exists = som_config_tbl_exists ~conn som_id in + let%bind som_configs_opt = + if not som_tbl_exists then return None else let query = sprintf "SELECT * FROM %s" som_config_tbl in - Some (Sql.exec_exn ~conn ~query) in + let%map r = Postgresql_async.exec_exn ~conn ~query in Some r + in let query = "SELECT DISTINCT machine_name, machine_type, cpu_model, number_of_cpus " ^ (sprintf "FROM machines AS mn, tc_config AS c, (select distinct job_id from soms_jobs where som_id=%d) AS mr " som_id) ^ "WHERE mn.machine_id=c.machine_id AND c.job_id=mr.job_id " in - let machines = Sql.exec_exn ~conn ~query in + let%bind machines = Postgresql_async.exec_exn ~conn ~query in printf "
    \n"; printf "\n\n
    \n"; self#write_som_info som_info; @@ -118,8 +121,8 @@ let t ~args = object (self) printf ""; printf "
    "; printf "
    "; - print_x_axis_choice ~conn config_columns som_configs_opt; - print_y_axis_choice ~conn config_columns som_configs_opt; + let%bind () = print_x_axis_choice ~conn config_columns som_configs_opt in + let%bind () = print_y_axis_choice ~conn config_columns som_configs_opt in printf "
    \n"; let checkbox name caption = printf "
    \n" name; @@ -147,8 +150,8 @@ let t ~args = object (self) printf "
    \n"; printf "
    \n"; printf "
    "; - self#write_filter_table job_ids builds job_attributes config_columns tc_config_tbl - som_configs_opt machines; + let%bind() = self#write_filter_table job_ids builds job_attributes config_columns tc_config_tbl + som_configs_opt machines in printf "
    "; printf "
    \n"; printf "
    \n"; @@ -174,4 +177,5 @@ let t ~args = object (self) printf "
    "; printf "
    "; self#include_javascript; + return () end diff --git a/src/soms_handler.ml b/src/soms_handler.ml index 34efa58..46a8eae 100644 --- a/src/soms_handler.ml +++ b/src/soms_handler.ml @@ -1,4 +1,5 @@ open Core +open Async open Utils let t ~args = object (self) @@ -6,14 +7,15 @@ let t ~args = object (self) method private write_body = let query = "SELECT tc_fqn,description FROM test_cases ORDER BY tc_fqn" in - let tcs = Sql.exec_exn ~conn ~query in + let%bind tcs = Postgresql_async.exec_exn ~conn ~query in let json_of_tc tc = sprintf "\"%s\":{\"desc\":\"%s\"}" tc.(0) tc.(1) in let tcs_json = concat_array (Array.map ~f:json_of_tc tcs#get_all) in let query = "SELECT som_id,som_name,tc_fqn FROM soms ORDER BY som_id" in - let soms = Sql.exec_exn ~conn ~query in + let%bind soms = Postgresql_async.exec_exn ~conn ~query in let json_of_som som = sprintf "\"%s\":{\"name\":\"%s\",\"tc\":\"%s\"}" som.(0) som.(1) som.(2) in let soms_json = concat_array (Array.map ~f:json_of_som soms#get_all) in - printf "{\"tcs\":{%s},\"soms\":{%s}}" tcs_json soms_json + printf "{\"tcs\":{%s},\"soms\":{%s}}" tcs_json soms_json; + return () end diff --git a/src/std_axes_handler.ml b/src/std_axes_handler.ml index 0cef147..90fd0ba 100644 --- a/src/std_axes_handler.ml +++ b/src/std_axes_handler.ml @@ -1,11 +1,13 @@ open Core +open Async let t ~args = object (self) inherit Json_handler.t ~args method private get_std_xy_choices = - let machine_field_lst = - List.tl_exn (Sql.get_col_names ~conn ~tbl:"machines") in + let%map machine_field_lst = + let%map r = Postgresql_async.wrap_sql ~conn (Sql.get_col_names ~tbl:"machines") in + List.tl_exn r in "branch" :: "build_number" :: "build_tag" :: "patches_applied" :: "build_is_release" :: "dom0_memory_static_max" :: "dom0_memory_target" :: "cc_restrictions" :: "redo_log" :: @@ -13,11 +15,13 @@ let t ~args = object (self) method private get_std_x_choices = self#get_std_xy_choices - method private get_std_y_choices = "result" :: self#get_std_xy_choices + method private get_std_y_choices = + let%map r = self#get_std_xy_choices in + "result" :: r method private write_body = - let std_x_axes = self#get_std_x_choices in - let std_y_axes = self#get_std_y_choices in + let%bind std_x_axes = self#get_std_x_choices in + let%bind std_y_axes = self#get_std_y_choices in let string_of_axes choices = let quoted = List.map ~f:(fun c -> "\"" ^ c ^ "\"") choices in sprintf "[%s]" (String.concat ~sep:"," quoted) @@ -25,5 +29,6 @@ let t ~args = object (self) printf "{"; printf "\"std_x_axes\": %s," (string_of_axes std_x_axes); printf "\"std_y_axes\": %s" (string_of_axes std_y_axes); - printf "}" + printf "}"; + return () end diff --git a/src/utils.ml b/src/utils.ml index faf7ede..9c85ea1 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -1,4 +1,5 @@ open Core +open Async let debug msg = Out_channel.output_string stderr (msg ^ "\n"); @@ -41,16 +42,19 @@ let get_value r row col null_val = let combine_maps conn tbls f = let m = String.Table.create () in - List.iter tbls ~f:(fun t -> merge_table_into (f conn t) m); + let%map () = Deferred.List.iter tbls ~f:(fun t -> + let%map r = f conn t in + merge_table_into r m) in m let get_column_types conn tbl = - String.Table.of_alist_exn (Sql.get_col_types_lst ~conn ~tbl) + let%map r = Postgresql_async.wrap_sql ~conn (Sql.get_col_types_lst ~tbl) in + String.Table.of_alist_exn r let get_column_types_many conn tbls = combine_maps conn tbls get_column_types let get_column_fqns conn tbl = - let col_names = Sql.get_col_names ~conn ~tbl in + let%map col_names = Postgresql_async.wrap_sql ~conn (Sql.get_col_names ~tbl) in let nameToFqn = String.Table.create () in let process_column name = let fqn = tbl ^ "." ^ name in @@ -185,7 +189,7 @@ let print_options_for_field namespace db_result col = let print_options_for_fields conn tbl namespace = let query = "SELECT * FROM " ^ tbl in - let result = Sql.exec_exn ~conn ~query in + let%map result = Postgresql_async.exec_exn ~conn ~query in List.iter ~f:(print_options_for_field namespace result) (List.range 1 result#nfields); printf "
    \n" @@ -235,18 +239,22 @@ let job_fields = [ let som_config_tbl_exists ~conn som_id = let som_config_tbl = sprintf "som_config_%d" som_id in - som_config_tbl, Sql.tbl_exists ~conn ~tbl:som_config_tbl + let%map r = Postgresql_async.wrap_sql ~conn (Sql.tbl_exists ~tbl:som_config_tbl) in + som_config_tbl, r let get_std_xy_choices ~conn = + let%map colnames = Postgresql_async.wrap_sql ~conn (Sql.get_col_names ~tbl:"machines") in let machine_field_lst = - List.tl_exn (Sql.get_col_names ~conn ~tbl:"machines") in + List.tl_exn colnames in job_fields @ build_fields @ tc_config_fields @ machine_field_lst let get_xy_choices ~conn configs som_configs_opt = let som_configs_lst = match som_configs_opt with | None -> [] | Some som_configs -> List.tl_exn som_configs#get_fnames_lst - in get_std_xy_choices ~conn @ configs#get_fnames_lst @ som_configs_lst + in + let%map r = get_std_xy_choices ~conn in + r @ configs#get_fnames_lst @ som_configs_lst let print_axis_choice ?(multiselect=false) label id choices = printf "
    \n" id; @@ -262,17 +270,18 @@ let print_empty_y_axis_choice ~conn:_ = print_axis_choice "Y axis" "yaxis" [] let print_x_axis_choice ~conn configs som_configs_opt = - print_axis_choice "X axis" "xaxis" ~multiselect:true - (get_xy_choices ~conn configs som_configs_opt) + let%map r = get_xy_choices ~conn configs som_configs_opt in + print_axis_choice "X axis" "xaxis" ~multiselect:true r let print_y_axis_choice ~conn configs som_configs_opt = + let%map r = get_xy_choices ~conn configs som_configs_opt in print_axis_choice "Y axis" "yaxis" - ("result" :: (get_xy_choices ~conn configs som_configs_opt)) + ("result" :: r) let get_tc_config_tbl_name conn som_id = let query = "SELECT tc_fqn FROM soms " ^ "WHERE som_id = " ^ (string_of_int som_id) in - let result = Sql.exec_exn ~conn ~query in + let%map result = Postgresql_async.exec_exn ~conn ~query in let tc_fqn = String.lowercase (result#getvalue 0 0) in (tc_fqn, "tc_config_" ^ tc_fqn) From 98478d9dd7f09825fe53b97c71e871c1dae2cfeb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Sun, 1 Dec 2019 17:56:02 +0000 Subject: [PATCH 15/36] Convert more queries to asynchronous ones MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Also use Deferred.List.map instead of List.map Signed-off-by: Edwin Török --- src/brief_handler.ml | 1215 +++++++++++++++++++++--------------------- src/main.ml | 21 +- 2 files changed, 629 insertions(+), 607 deletions(-) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index d595749..7822371 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -58,17 +58,17 @@ let t ~args = object (self) let rec loop url_in = let decode_once_more = Str.string_match (Str.regexp "%25") url_in 0 in let url_out = List.fold_left - [ - ("%20"," ");("%22","\""); ("%28","("); ("%29",")"); (* unescape http params *) - ("%2B"," ");("%2C",","); - ("%2F","/");("%3F","?" ); ("%3D","="); ("%26","&"); - ("%25","%");("+"," "); ("%3E",">"); ("%3C","<"); - ("%3A",":");("&","&");(""","\""); - (">",">");("<","<"); - ("&45;","-");("+","%2b") - ] - ~init:url_in - ~f:(fun acc (f,t)->(Str.global_replace (Str.regexp f) t acc)) (* f->t *) + [ + ("%20"," ");("%22","\""); ("%28","("); ("%29",")"); (* unescape http params *) + ("%2B"," ");("%2C",","); + ("%2F","/");("%3F","?" ); ("%3D","="); ("%26","&"); + ("%25","%");("+"," "); ("%3E",">"); ("%3C","<"); + ("%3A",":");("&","&");(""","\""); + (">",">");("<","<"); + ("&45;","-");("+","%2b") + ] + ~init:url_in + ~f:(fun acc (f,t)->(Str.global_replace (Str.regexp f) t acc)) (* f->t *) in (* loop once more if a %25 was found *) if decode_once_more then loop url_out else url_out @@ -77,36 +77,36 @@ let t ~args = object (self) in let html_encode html = (* todo: find a more complete version in some lib *) List.fold_left - [ - (">",">");("<","<"); (* escape html text *) - ] - ~init:html + [ + (">",">");("<","<"); (* escape html text *) + ] + ~init:html ~f:(fun acc (f,t)->(Str.global_replace (Str.regexp f) t acc)) (* f->t *) in let parse_url args = let key k = Str.replace_first (Str.regexp "/\\?") "" k in List.map ~f:(fun p -> - match String.split ~on:'=' p with - | k::vs -> (key k), (String.concat ~sep:"=" vs) - | [] -> failwith "k should be present") - (String.split ~on:'&' (url_decode args)) + match String.split ~on:'=' p with + | k::vs -> (key k), (String.concat ~sep:"=" vs) + | [] -> failwith "k should be present") + (String.split ~on:'&' (url_decode args)) in (* extra input from urls *) let is_digit id = Str.string_match (Str.regexp "[0-9]+") id 0 in let html_of_url url = - try - let conn = Curl.init() and write_buff = Buffer.create 16384 in - Curl.set_writefunction conn (fun x->Buffer.add_string write_buff x; String.length x); - Curl.set_url conn url; - Curl.set_username conn rage_username; - Curl.set_password conn rage_password; - Curl.perform conn; - Curl.cleanup conn; - Curl.global_cleanup(); - Buffer.contents write_buff; - with _ -> sprintf "error fetching url %s" url + try + let conn = Curl.init() and write_buff = Buffer.create 16384 in + Curl.set_writefunction conn (fun x->Buffer.add_string write_buff x; String.length x); + Curl.set_url conn url; + Curl.set_username conn rage_username; + Curl.set_password conn rage_password; + Curl.perform conn; + Curl.cleanup conn; + Curl.global_cleanup(); + Buffer.contents write_buff; + with _ -> sprintf "error fetching url %s" url in let fetch_brief_params_from_url url = (* simple fetch using confluence page with brief_params inside the "code block" macro in the page *) @@ -114,10 +114,10 @@ let t ~args = object (self) let html = Str.global_replace (Str.regexp "\n") "" html in (*remove newlines from html*) let has_match = Str.string_match (Str.regexp ".*
    ]*>\\([^<]+\\)<") html 0 in (*find the "code block" in the page*)
           if not has_match
    -        then (Printf.printf "Error: no '{code}' block found in %s" url; raise Not_found)
    -        else
    -          try Str.matched_group 1 html
    -          with Not_found -> (debug "not found"; raise Not_found)
    +      then (Printf.printf "Error: no '{code}' block found in %s" url; raise Not_found)
    +      else
    +        try Str.matched_group 1 html
    +        with Not_found -> (debug "not found"; raise Not_found)
         in
         let fetch_brief_params_from_db id =
           let query = sprintf "select brief_params from briefs where brief_id='%s'" id in
    @@ -159,12 +159,12 @@ let t ~args = object (self)
           let include_rex = Str.regexp " List.map ~f:(fetch_parameters_from ~branch) |> List.concat in
           debug (sprintf "include parameters: %s"
    -        (List.map ~f:(fun (k,v) -> sprintf "%s=%s" k v) includes |> String.concat ~sep:","));
    +               (List.map ~f:(fun (k,v) -> sprintf "%s=%s" k v) includes |> String.concat ~sep:","));
           let lookup k =
             if String.(uppercase k = k) then
    -        match List.Assoc.find ~equal:String.equal includes k with
    -        | Some v -> v
    -        | None ->
    +          match List.Assoc.find ~equal:String.equal includes k with
    +          | Some v -> v
    +          | None ->
                 failwith (Printf.sprintf "Cannot resolve variable '%s' in %s" k url)
             else "$" ^ k
           in
    @@ -177,11 +177,11 @@ let t ~args = object (self)
         let fetch_brief_params_from id =
           let xs = if is_digit id then fetch_brief_params_from_db id
             else return @@ if String.is_prefix id ~prefix:"TC-" then (
    -          match String.split ~on:'#' id with
    -          | [id; branch] -> fetch_brief_params_from_suite ~branch id
    -          | [id] -> fetch_brief_params_from_suite id
    -          | _ -> failwith (sprintf "unparseable id '%s'" id)
    -        ) else fetch_brief_params_from_url id
    +            match String.split ~on:'#' id with
    +            | [id; branch] -> fetch_brief_params_from_suite ~branch id
    +            | [id] -> fetch_brief_params_from_suite id
    +            | _ -> failwith (sprintf "unparseable id '%s'" id)
    +          ) else fetch_brief_params_from_url id
           in
           (*printf "fetch_brief_params_from %s =
    %s" id xs;*) xs @@ -241,19 +241,19 @@ let t ~args = object (self) let ids = Str.split (Str.regexp ",") params_add_rows_from in Async.Deferred.List.map ids ~f:(fun id-> get_input_rows_from_id id get_input_values) in -(* + (* printf "\n" (html_encode (List.fold_left extra_input_rows_from ~init:"" ~f:(fun extra_input_row->(Sexp.to_string (sexp_of_rows_t extra_input_row))))); -*) + *) let input_rows = List.concat (input_rows :: extra_input_rows_from) in printf "\n" (html_encode (Sexp.to_string (sexp_of_rows_t input_rows))); (* base context is used to fill any context gap not expressed in row and column contexts eg. [("build_number",[44543;55432]);("job_id",[1000;4000]);("number_of_cpus",[1]);...] -- append (OR) the results of each element in the list - TODO: is base context restrictive or conjuntive, ie does it restrict possible contexts in - the cells or does it contribute to them with lower-priority than rows and col contexts? - TODO: use intersection between base_context and input_cols and input_rows - *) + TODO: is base context restrictive or conjuntive, ie does it restrict possible contexts in + the cells or does it contribute to them with lower-priority than rows and col contexts? + TODO: use intersection between base_context and input_cols and input_rows + *) let input_base_context = if String.(params_base <> "") then attempt ~f:(fun ()->base_t_of_sexp (Sexp.of_string params_base)) "base" @@ -263,26 +263,26 @@ let t ~args = object (self) printf "\n" (Sexp.to_string (sexp_of_base_t input_base_context)); let baseline_col_idx = - if String.(params_baseline <> "") then - attempt ~f:(fun ()->baseline_t_of_sexp (Sexp.of_string params_baseline)) "baseline" - else (*default value *) - 0 + if String.(params_baseline <> "") then + attempt ~f:(fun ()->baseline_t_of_sexp (Sexp.of_string params_baseline)) "baseline" + else (*default value *) + 0 in printf "\n" (Sexp.to_string (sexp_of_baseline_t baseline_col_idx)); let out = - if String.(params_out <> "") then - attempt ~f:(fun ()->out_t_of_sexp (Sexp.of_string (String.capitalize params_out))) "out" - else (*default value *) - `Html + if String.(params_out <> "") then + attempt ~f:(fun ()->out_t_of_sexp (Sexp.of_string (String.capitalize params_out))) "out" + else (*default value *) + `Html in printf "\n" (params_out) (Sexp.to_string (sexp_of_out_t out)); let sort_by_col = - if String.(params_sort_by_col <> "") then - Some (attempt ~f:(fun ()->sort_by_col_t_of_sexp (Sexp.of_string (String.capitalize params_sort_by_col))) "sort_by_col") - else (*default value *) - None + if String.(params_sort_by_col <> "") then + Some (attempt ~f:(fun ()->sort_by_col_t_of_sexp (Sexp.of_string (String.capitalize params_sort_by_col))) "sort_by_col") + else (*default value *) + None in (input_cols, input_rows, input_base_context, baseline_col_idx, out, sort_by_col) in @@ -298,10 +298,10 @@ let t ~args = object (self) in let%map brief_params = fetch_brief_params_from brief_id in List.fold_left params ~init:(replace params brief_params) ~f:(fun acc (k,v)-> - match List.find acc ~f:(fun (ka,_)->String.(k=ka)) with - |None->(k,v)::acc (* if params contains a k not in the db, add this k to args *) - |Some _->acc - ) + match List.find acc ~f:(fun (ka,_)->String.(k=ka)) with + |None->(k,v)::acc (* if params contains a k not in the db, add this k to args *) + |Some _->acc + ) in (* === process === *) @@ -318,8 +318,8 @@ let t ~args = object (self) match sort_by_col with | None -> () | Some sort_by_col -> - if sort_by_col >= List.length input_cols then - failwith (sprintf "Sort-by column is %d but there are only %d columns" sort_by_col (List.length input_cols)); + if sort_by_col >= List.length input_cols then + failwith (sprintf "Sort-by column is %d but there are only %d columns" sort_by_col (List.length input_cols)); end; let soms_of_tc tc_fqn = @@ -354,19 +354,19 @@ let t ~args = object (self) let contexts_of_som_id som_id = let%map cols = unstage(columns_of_table) (sprintf "som_config_%s" som_id) in (List.filter cols - ~f:(fun e->String.(e<>"som_config_id")) + ~f:(fun e->String.(e<>"som_config_id")) ) in let contexts_of_tc_fqn tc_fqn = let%map cols = unstage(columns_of_table) (sprintf "tc_config_%s" tc_fqn) in (List.filter cols - ~f:(fun e->String.(e<>"tc_config_id")) + ~f:(fun e->String.(e<>"tc_config_id")) ) in let%bind contexts_of_tc = let%map cols = unstage(columns_of_table) "tc_config" in (List.filter cols - ~f:(fun e->not (List.mem ~equal:String.equal ["tc_fqn";"tc_config_id";"machine_id"] e)) + ~f:(fun e->not (List.mem ~equal:String.equal ["tc_fqn";"tc_config_id";"machine_id"] e)) ) in let url_of_t t = @@ -384,117 +384,117 @@ let t ~args = object (self) (columns_of_table (sprintf "tc_config_%d" tc_fqn)) ~f:(fun e->e<>"tc_config_id") ) - in + in List.map (List.map (soms_of_tc tc_id) ~f:contexts_of_som) ~f:(fun som_contexts->tc_contexts @ som_contexts) - in +in *) let%bind contexts_of_machine = let%map cols = unstage(columns_of_table) "machines" in List.filter cols - ~f:(fun e->String.(e<>"machine_id")) in + ~f:(fun e->String.(e<>"machine_id")) in let%bind contexts_of_build = let%map cols = unstage(columns_of_table) "builds" in List.filter cols - ~f:(fun e->String.(e<>"build_id")) in + ~f:(fun e->String.(e<>"build_id")) in let values_of cs ~at:cs_f = List.filter cs ~f:(fun (k,v)->List.mem ~equal:String.equal cs_f k) in -(* + (* let latest_build_of_branch branch = let query = sprintf "select max(build_number) from builds where branch='%s'" branch in - (Postgresql_async.exec_exn_get_all ~conn ~query).(0).(0) - in +(Postgresql_async.exec_exn_get_all ~conn ~query).(0).(0) +in *) let builds_of_branch branch = let query = sprintf "select distinct build_number from builds where branch='%s' order by build_number desc" branch in let%map a = Postgresql_async.exec_exn_get_all ~conn ~query in List.map (Array.to_list a) ~f:(fun x->x.(0)) in -(* this query is better than builds_of_branch but it is too slow so cannot be used - let latest_build_in_branch branch = - let query = sprintf "select max(build_number) from builds,measurements,jobs where branch='%s' and measurements.job_id = jobs.job_id and jobs.build_id = builds.build_id" branch in - (Postgresql_async.exec_exn_get_all ~conn ~query).(0).(0) - in -*) + (* this query is better than builds_of_branch but it is too slow so cannot be used + let latest_build_in_branch branch = + let query = sprintf "select max(build_number) from builds,measurements,jobs where branch='%s' and measurements.job_id = jobs.job_id and jobs.build_id = builds.build_id" branch in + (Postgresql_async.exec_exn_get_all ~conn ~query).(0).(0) + in + *) (*TODO: touch each element of the context when it is used; if an element is not used at the end of this function, - then raise an error indicating that probably there's a typo in the context element - *) + then raise an error indicating that probably there's a typo in the context element + *) let measurements_of_cell context = - let get e ctx = List.Assoc.find ~equal:String.equal ctx e in - let measurements_of_som som_id = - let%bind has_table_som_id = unstage(has_table) (sprintf "som_config_%s" som_id) in - let%bind tc_fqn = tc_of_som som_id in - let%bind contexts_of_this_som_id = contexts_of_som_id som_id in - let%bind contexts_of_this_tc_fqn = contexts_of_tc_fqn tc_fqn in - let query = "select sj.job_id, m.result from measurements_2 m join soms_jobs sj on m.som_job_id=sj.id " - ^(sprintf "join tc_config_%s on m.tc_config_id=tc_config_%s.tc_config_id " tc_fqn tc_fqn) - ^(if has_table_som_id then - (sprintf "join som_config_%s on m.som_config_id=som_config_%s.som_config_id " som_id som_id) - else "" - ) - ^"join tc_config on sj.job_id=tc_config.job_id " - ^"join machines on tc_config.machine_id=machines.machine_id " - ^"join jobs on tc_config.job_id=jobs.job_id " - ^"join builds on jobs.build_id=builds.build_id " - ^"where " - ^(sprintf "sj.som_id=%s " som_id) - ^(List.fold_left (values_of context ~at:contexts_of_machine) ~init:"" ~f:(fun acc (k,vs)-> - match vs with []->acc|_-> - sprintf "%s and (%s) " acc - (List.fold_left vs ~init:"" ~f:(fun acc2 v-> - sprintf "%s%smachines.%s='%s' " acc2 (match acc2 with |""->""|_->"or ") k v - )) - )) - ^(if has_table_som_id then - (List.fold_left (values_of context ~at:contexts_of_this_som_id) ~init:"" ~f:(fun acc (k,vs)-> - match vs with []->acc|_-> - sprintf "%s and (%s) " acc - (List.fold_left vs ~init:"" ~f:(fun acc2 v-> - sprintf "%s%ssom_config_%s.%s='%s' " acc2 (match acc2 with |""->""|_->"or ") som_id k v - )) - )) - else "" - ) - ^(List.fold_left (values_of context ~at:contexts_of_this_tc_fqn) ~init:"" ~f:(fun acc (k,vs)-> - match vs with []->acc|_-> - sprintf "%s and (%s) " acc - (List.fold_left vs ~init:"" ~f:(fun acc2 v-> - sprintf "%s%stc_config_%s.%s='%s' " acc2 (match acc2 with |""->""|_->"or ") tc_fqn k v - )) - )) - ^(List.fold_left (values_of context ~at:(contexts_of_tc)) ~init:"" ~f:(fun acc (k,vs)-> - match vs with []->acc|_-> - sprintf "%s and (%s) " acc - (List.fold_left vs ~init:"" ~f:(fun acc2 v-> - sprintf "%s%stc_config.%s='%s' " acc2 (match acc2 with |""->""|_->"or ") k v - )) - )) - ^(List.fold_left (values_of context ~at:(contexts_of_build)) ~init:"" ~f:(fun acc (k,vs)-> - match vs with []->acc|_-> - sprintf "%s and (%s) " acc - (List.fold_left vs ~init:"" ~f:(fun acc2 v-> - sprintf "%s%sbuilds.%s='%s' " acc2 (match acc2 with |""->""|_->"or ") k v - )) - )) - in - let%map a = Postgresql_async.exec_exn_get_all ~conn ~query in - Array.to_list (Array.map a ~f:(fun x->{job=int_of_string x.(0); value=x.(1)})) + let get e ctx = List.Assoc.find ~equal:String.equal ctx e in + let measurements_of_som som_id = + let%bind has_table_som_id = unstage(has_table) (sprintf "som_config_%s" som_id) in + let%bind tc_fqn = tc_of_som som_id in + let%bind contexts_of_this_som_id = contexts_of_som_id som_id in + let%bind contexts_of_this_tc_fqn = contexts_of_tc_fqn tc_fqn in + let query = "select sj.job_id, m.result from measurements_2 m join soms_jobs sj on m.som_job_id=sj.id " + ^(sprintf "join tc_config_%s on m.tc_config_id=tc_config_%s.tc_config_id " tc_fqn tc_fqn) + ^(if has_table_som_id then + (sprintf "join som_config_%s on m.som_config_id=som_config_%s.som_config_id " som_id som_id) + else "" + ) + ^"join tc_config on sj.job_id=tc_config.job_id " + ^"join machines on tc_config.machine_id=machines.machine_id " + ^"join jobs on tc_config.job_id=jobs.job_id " + ^"join builds on jobs.build_id=builds.build_id " + ^"where " + ^(sprintf "sj.som_id=%s " som_id) + ^(List.fold_left (values_of context ~at:contexts_of_machine) ~init:"" ~f:(fun acc (k,vs)-> + match vs with []->acc|_-> + sprintf "%s and (%s) " acc + (List.fold_left vs ~init:"" ~f:(fun acc2 v-> + sprintf "%s%smachines.%s='%s' " acc2 (match acc2 with |""->""|_->"or ") k v + )) + )) + ^(if has_table_som_id then + (List.fold_left (values_of context ~at:contexts_of_this_som_id) ~init:"" ~f:(fun acc (k,vs)-> + match vs with []->acc|_-> + sprintf "%s and (%s) " acc + (List.fold_left vs ~init:"" ~f:(fun acc2 v-> + sprintf "%s%ssom_config_%s.%s='%s' " acc2 (match acc2 with |""->""|_->"or ") som_id k v + )) + )) + else "" + ) + ^(List.fold_left (values_of context ~at:contexts_of_this_tc_fqn) ~init:"" ~f:(fun acc (k,vs)-> + match vs with []->acc|_-> + sprintf "%s and (%s) " acc + (List.fold_left vs ~init:"" ~f:(fun acc2 v-> + sprintf "%s%stc_config_%s.%s='%s' " acc2 (match acc2 with |""->""|_->"or ") tc_fqn k v + )) + )) + ^(List.fold_left (values_of context ~at:(contexts_of_tc)) ~init:"" ~f:(fun acc (k,vs)-> + match vs with []->acc|_-> + sprintf "%s and (%s) " acc + (List.fold_left vs ~init:"" ~f:(fun acc2 v-> + sprintf "%s%stc_config.%s='%s' " acc2 (match acc2 with |""->""|_->"or ") k v + )) + )) + ^(List.fold_left (values_of context ~at:(contexts_of_build)) ~init:"" ~f:(fun acc (k,vs)-> + match vs with []->acc|_-> + sprintf "%s and (%s) " acc + (List.fold_left vs ~init:"" ~f:(fun acc2 v-> + sprintf "%s%sbuilds.%s='%s' " acc2 (match acc2 with |""->""|_->"or ") k v + )) + )) in - (* add measurements for each one of the soms in the cell *) - match get "soms" context with - | Some som -> - let%map r = Async.Deferred.List.map ~f:measurements_of_som som in - List.concat r - | None -> - failwith (sprintf "Could not find 'soms' in context; keys are [%s]" (List.map ~f:fst context |> String.concat ~sep:", ")); + let%map a = Postgresql_async.exec_exn_get_all ~conn ~query in + Array.to_list (Array.map a ~f:(fun x->{job=int_of_string x.(0); value=x.(1)})) + in + (* add measurements for each one of the soms in the cell *) + match get "soms" context with + | Some som -> + let%map r = Async.Deferred.List.map ~f:measurements_of_som som in + List.concat r + | None -> + failwith (sprintf "Could not find 'soms' in context; keys are [%s]" (List.map ~f:fst context |> String.concat ~sep:", ")); in let context_of base row col = (* we use intersection to obtain the result when the same context is present in more than one input source *) List.fold_left (base @ row @ col) ~init:[] ~f:(fun acc (ck,cv)-> - let x,ys = List.partition_tf ~f:(fun (k,v)->String.(k=ck)) acc in - match x with + let x,ys = List.partition_tf ~f:(fun (k,v)->String.(k=ck)) acc in + match x with |(k,v)::[]->(* context already in acc, intersect the values *) if String.(k<>ck) then (failwith (sprintf "k=%s <> ck=%s" k ck)); (k, List.filter cv ~f:(fun x->List.mem ~equal:String.equal v x))::ys @@ -502,7 +502,7 @@ let t ~args = object (self) (ck,cv)::ys |x->(* error *) failwith (sprintf "More than one element with the same context") - ) + ) in let expand_latest_build_of_branch c_kvs = let k_branch = "branch" in @@ -511,35 +511,35 @@ let t ~args = object (self) match List.find ~f:(fun (k,vs)->String.(k=k_branch)) c_kvs with | None -> return [c_kvs] | Some (_,branches) -> - if List.length branches < 1 - then + if List.length branches < 1 + then return [] (* no branches provided, no results *) - else - (* list of all builds in all branches provided *) + else + (* list of all builds in all branches provided *) - (* this is the most straightforward way of obtaining the max build of a branch but this query is too slow and cannot be used - let builds_of_branches = [latest_build_in_branch (List.nth_exn branches 0)] in (*TODO: handle >1 branches in context*) - *) + (* this is the most straightforward way of obtaining the max build of a branch but this query is too slow and cannot be used + let builds_of_branches = [latest_build_in_branch (List.nth_exn branches 0)] in (*TODO: handle >1 branches in context*) + *) - let has_v_latest_in_branch = - List.exists c_kvs ~f:(fun (k,vs) -> String.(k=k_build_number) && List.exists vs ~f:(fun v->String.(v=v_latest_in_branch))) - in - (* if 'latest_in_branch' value is present, expand ctx into many ctxs, one for each build; otherwise, return the ctx intact *) - if not has_v_latest_in_branch then return [c_kvs] - else ( - (* brute-force way to find the max build with measurements, to work around the slowness in the query in latest_build_in_branch *) - let%map builds = builds_of_branch (List.nth_exn branches 0) in (*TODO: handle >1 branch in context*) - let builds_of_branches = List.slice builds 0 (min 100 (List.length builds)) in (* take up to 100 elements in the list *) - debug (sprintf "builds_of_branches=%s" (List.fold_left ~init:"" builds_of_branches ~f:(fun acc b->acc ^","^b))); - - List.map builds_of_branches ~f:(fun bs-> - List.map c_kvs ~f:(fun (k,vs) -> - if String.(k<>k_build_number) then (k,vs) - else k,(List.map vs ~f:(fun v-> - if String.(v<>v_latest_in_branch) then v else bs - )) - ) - )) + let has_v_latest_in_branch = + List.exists c_kvs ~f:(fun (k,vs) -> String.(k=k_build_number) && List.exists vs ~f:(fun v->String.(v=v_latest_in_branch))) + in + (* if 'latest_in_branch' value is present, expand ctx into many ctxs, one for each build; otherwise, return the ctx intact *) + if not has_v_latest_in_branch then return [c_kvs] + else ( + (* brute-force way to find the max build with measurements, to work around the slowness in the query in latest_build_in_branch *) + let%map builds = builds_of_branch (List.nth_exn branches 0) in (*TODO: handle >1 branch in context*) + let builds_of_branches = List.slice builds 0 (min 100 (List.length builds)) in (* take up to 100 elements in the list *) + debug (sprintf "builds_of_branches=%s" (List.fold_left ~init:"" builds_of_branches ~f:(fun acc b->acc ^","^b))); + + List.map builds_of_branches ~f:(fun bs-> + List.map c_kvs ~f:(fun (k,vs) -> + if String.(k<>k_build_number) then (k,vs) + else k,(List.map vs ~f:(fun v-> + if String.(v<>v_latest_in_branch) then v else bs + )) + ) + )) in let c_kvs_of_tiny_url t = let%map url = url_of_t t in @@ -548,22 +548,22 @@ let t ~args = object (self) (* parse and add "v_"k=value patterns in url *) let items = parse_url url in let kv = List.map - (List.filter items (*filter special keys*) - ~f:(fun (k,v)-> - (* starts with "v_" or "som" *) - ( String.(k="som") || - try Str.search_forward (Str.regexp "v_.*") k 0 = 0 with Not_found->false - ) - && (*and doesn't have 'ALL' as a value*) - String.(v<>"ALL") + (List.filter items (*filter special keys*) + ~f:(fun (k,v)-> + (* starts with "v_" or "som" *) + ( String.(k="som") || + try Str.search_forward (Str.regexp "v_.*") k 0 = 0 with Not_found->false + ) + && (*and doesn't have 'ALL' as a value*) + String.(v<>"ALL") + ) ) - ) - ~f:(fun (k,v)-> (*apply some mappings to remaining keys and values *) - (* remove "v_" from beginning of k *) - let new_key = Str.replace_first (Str.regexp "v_") "" k in - let new_value = url_decode v in - ((if String.(new_key="som") then "soms" else new_key), new_value) - ) + ~f:(fun (k,v)-> (*apply some mappings to remaining keys and values *) + (* remove "v_" from beginning of k *) + let new_key = Str.replace_first (Str.regexp "v_") "" k in + let new_value = url_decode v in + ((if String.(new_key="som") then "soms" else new_key), new_value) + ) in (* map (k_i,v_i) and (k_j,v_j) to (k_i,[v_i,v_j,...]) when k_i=k_j *) @@ -572,10 +572,10 @@ let t ~args = object (self) let ks_tbl = Hashtbl.create 128 in List.iter kv ~f:(fun (k,v)-> - if Hashtbl.mem ks_tbl k + if Hashtbl.mem ks_tbl k then Hashtbl.replace ks_tbl k (v::(Hashtbl.find ks_tbl k)) (* add new v to existing k *) else Hashtbl.add ks_tbl k [v] (* add initial v to non-existing k *) - ); + ); Hashtbl.fold (fun k vs acc->(k,vs)::acc) ks_tbl [] in kvs @@ -584,28 +584,30 @@ let t ~args = object (self) let k_tiny_url = "t" in let tiny_url = List.find c_kvs ~f:(fun (k,_) -> String.(k=k_tiny_url)) in let x = match tiny_url with - | None -> return [c_kvs] - | Some (_,[t]) -> - let%map x = c_kvs_of_tiny_url t in - [List.fold_left - ~init:c_kvs (* c_kvs kvs have priority over the ones in c_kvs_of_tiny_url *) - x (* obtain url from tiny_url id, parse it and return a c_kvs *) - ~f:(fun acc (k,vs)-> - if List.exists c_kvs ~f:(fun(_k,_)->String.(k=_k)) - then (*prefer the one already in c_kvs, ie. do not add (k,vs) to acc*) - acc - else (*(k,vs) not already in c_kvs, add it *) - (k,vs)::acc - ) - ] - | Some (_,_) -> - failwith (sprintf "tiny url: only one tiny url value supported for each t") + | None -> return [c_kvs] + | Some (_,[t]) -> + let%map x = c_kvs_of_tiny_url t in + [List.fold_left + ~init:c_kvs (* c_kvs kvs have priority over the ones in c_kvs_of_tiny_url *) + x (* obtain url from tiny_url id, parse it and return a c_kvs *) + ~f:(fun acc (k,vs)-> + if List.exists c_kvs ~f:(fun(_k,_)->String.(k=_k)) + then (*prefer the one already in c_kvs, ie. do not add (k,vs) to acc*) + acc + else (*(k,vs) not already in c_kvs, add it *) + (k,vs)::acc + ) + ] + | Some (_,_) -> + failwith (sprintf "tiny url: only one tiny url value supported for each t") in x in let expand ctx = (*expand cell context into all possible context after expanding ctx templates into values*) - List.fold_left ~init:[ctx] - ~f:(fun rets expand_fn->List.fold_left rets ~init:[] ~f:(fun acc ret->acc@(expand_fn ret))) + Async.Deferred.List.fold ~init:[ctx] + ~f:(fun rets expand_fn -> + Async.Deferred.List.fold rets ~init:[] ~f:(fun acc ret-> + let%map r = expand_fn ret in acc@r)) [ expand_latest_build_of_branch; (* 1. value template: latest_in_branch *) (* expand_tiny_urls;*) (* 2. key template: t -- to use a tiny link value -- already expanded in row *) @@ -628,13 +630,13 @@ let t ~args = object (self) (* Expand any variables defined as lists *) let apply_definitions row = List.map row ~f:(fun (k,vs) -> - let new_vs = List.map vs ~f:(fun v -> - match List.Assoc.find ~equal:String.equal!deflists v with - | None -> [v] - | Some exp -> exp - ) |> List.concat in - (k, new_vs) - ) in + let new_vs = List.map vs ~f:(fun v -> + match List.Assoc.find ~equal:String.equal!deflists v with + | None -> [v] + | Some exp -> exp + ) |> List.concat in + (k, new_vs) + ) in let remove_quotes s = let quote_re = Str.regexp "'" in @@ -648,144 +650,142 @@ let t ~args = object (self) let apply_substitions row = let all_subs = transform !substitions in List.map all_subs ~f:(fun sub -> - (* First expand any compound variables, e.g. ("a,b", "0,A") into [("a","0"); ("b","A")] *) - let sub = List.map sub ~f:(fun (k,v) -> - let k_split = String.split ~on:',' k in - let v_split = String.split ~on:',' v in - List.mapi k_split ~f:(fun i k' -> - let v' = List.nth_exn v_split i in - match has_quotes v' with - | true -> v' |> remove_quotes |> fun v' -> [(k', v')] (* inside quotes ': use as it is *) - | false -> v' |> String.split ~on:' ' |> List.map ~f:(fun v'' -> (k', v'')) (* outside quotes ': spaces delimit items *) - ) |> List.concat - ) |> List.concat in - - progress (sprintf "current substitions: [%s]" (String.concat ~sep:", " (List.map ~f:(fun (k,v) -> sprintf "(%s, %s)" k v) sub))); - - (* Create a modified row applying this set of substitutions *) - List.map row ~f:(fun (k,vs) -> - let new_vs = List.map vs ~f:(fun v -> - match List.filter sub ~f:(fun (v',_)->String.(v'=v)) |> List.map ~f:(fun (_,v)->v) with - | [] -> [v] - | sub_vs -> sub_vs - ) |> List.concat - in - (k, new_vs) + (* First expand any compound variables, e.g. ("a,b", "0,A") into [("a","0"); ("b","A")] *) + let sub = List.map sub ~f:(fun (k,v) -> + let k_split = String.split ~on:',' k in + let v_split = String.split ~on:',' v in + List.mapi k_split ~f:(fun i k' -> + let v' = List.nth_exn v_split i in + match has_quotes v' with + | true -> v' |> remove_quotes |> fun v' -> [(k', v')] (* inside quotes ': use as it is *) + | false -> v' |> String.split ~on:' ' |> List.map ~f:(fun v'' -> (k', v'')) (* outside quotes ': spaces delimit items *) + ) |> List.concat + ) |> List.concat in + + progress (sprintf "current substitions: [%s]" (String.concat ~sep:", " (List.map ~f:(fun (k,v) -> sprintf "(%s, %s)" k v) sub))); + + (* Create a modified row applying this set of substitutions *) + List.map row ~f:(fun (k,vs) -> + let new_vs = List.map vs ~f:(fun v -> + match List.filter sub ~f:(fun (v',_)->String.(v'=v)) |> List.map ~f:(fun (_,v)->v) with + | [] -> [v] + | sub_vs -> sub_vs + ) |> List.concat + in + (k, new_vs) + ) ) - ) in - List.fold_left ~init:[] rows (* expand special row keys *) (*todo: this should also apply to columns *) - ~f:(fun acc r-> - let resolve_keywords_in_row acc r = - - if List.exists r ~f:(fun (k,v)->String.(k="tcs")) then (* expand tcs into soms *) - let%map r_expanded = Async.Deferred.List.concat_map r - ~f:(fun (k,v)->match k with - | _ when String.(k="tcs") -> (Async.Deferred.List.concat_map v ~f:(fun tc-> - let%map r = unstage(soms_of_tc) tc in - List.map r ~f:(fun som->("soms",[som])))) - | _ -> (k,v)::[] |> return - ) - in - let soms,no_soms = List.partition_tf r_expanded ~f:(fun (k,v)->String.(k="soms")) in - let soms = List.sort soms ~compare:(fun (xk,xv) (yk,yv)->(int_of_string(List.hd_exn xv)) - (int_of_string(List.hd_exn yv))) in - acc @ (List.map soms ~f:(fun som->[som] @ no_soms)) - - else if List.exists r ~f:(fun (k,v)->String.(k="t")) then (* expand tiny links into rows kvs *) - List.hd_exn (expand_tiny_urls r) :: acc - - else if List.exists r ~f:(fun (k,_)->String.(k=k_add_rows_from)) then (* add rows from other brief ids *) - let bs = List.filter r ~f:(fun (k,_)->String.(k=k_add_rows_from)) in (* use all references. TODO: what to do with non-references in the same row??? *) - acc @ List.concat ( - List.map bs ~f:(fun (k,vs)-> (* map one r into many potential rows *) - List.concat ( - List.map vs ~f:(fun v-> (* map one vs into many potential rows *) - let xs = get_input_rows_from_id v get_input_values in (* resolve each new row recursively if necessary *) - let ys = resolve_keywords xs in -(* + Async.Deferred.List.fold ~init:[] rows (* expand special row keys *) (*todo: this should also apply to columns *) + ~f:(fun acc r-> + let resolve_keywords_in_row acc r = + + if List.exists r ~f:(fun (k,v)->String.(k="tcs")) then (* expand tcs into soms *) + let%map r_expanded = Async.Deferred.List.concat_map r + ~f:(fun (k,v)->match k with + | _ when String.(k="tcs") -> (Async.Deferred.List.concat_map v ~f:(fun tc-> + let%map r = unstage(soms_of_tc) tc in + List.map r ~f:(fun som->("soms",[som])))) + | _ -> (k,v)::[] |> return + ) + in + let soms,no_soms = List.partition_tf r_expanded ~f:(fun (k,v)->String.(k="soms")) in + let soms = List.sort soms ~compare:(fun (xk,xv) (yk,yv)->(int_of_string(List.hd_exn xv)) - (int_of_string(List.hd_exn yv))) in + acc @ (List.map soms ~f:(fun som->[som] @ no_soms)) + + else if List.exists r ~f:(fun (k,v)->String.(k="t")) then (* expand tiny links into rows kvs *) + let%map lst = expand_tiny_urls r in + List.hd_exn lst :: acc + + else if List.exists r ~f:(fun (k,_)->String.(k=k_add_rows_from)) then (* add rows from other brief ids *) + let bs = List.filter r ~f:(fun (k,_)->String.(k=k_add_rows_from)) in (* use all references. TODO: what to do with non-references in the same row??? *) + let%map r = Async.Deferred.List.concat_map bs ~f:(fun (k,vs)-> (* map one r into many potential rows *) + Async.Deferred.List.concat_map vs ~f:(fun v-> (* map one vs into many potential rows *) + let%bind xs = get_input_rows_from_id v get_input_values in (* resolve each new row recursively if necessary *) + let%map ys = resolve_keywords xs in + (* printf "
    v=%s
    xs=%s
    r=%s
    acc=%s
    ys=%s" v (Sexp.to_string (sexp_of_rows_t xs)) (Sexp.to_string (sexp_of_ctx_t r)) (Sexp.to_string (sexp_of_cols_t acc)) (Sexp.to_string (sexp_of_rows_t ys)); -*) - ys - ) - ) - ) - ) - - else if List.exists r ~f:(fun (k,_)->String.(k=k_for)) then (* it's a for-loop! *) - begin - let bs = List.filter r ~f:(fun (k,_)->String.(k=k_for)) in - List.iter bs ~f:(fun (_,v) -> - let key = List.hd_exn v in - let values = List.tl_exn v in - progress (sprintf "mapping: key '%s' becomes each of [%s]" key (String.concat ~sep:", " values)); - substitions := (key, values) :: !substitions - ); - acc - end - - else if List.exists r ~f:(fun (k,_)->String.(k=k_endfor)) then (* it's the end of a for-loop! *) - begin - let bs = List.filter r ~f:(fun (k,_)->String.(k=k_endfor)) in - List.iter bs ~f:(fun (_,v) -> - substitions := match v with - | [] -> - begin - progress ("unmapping unspecified variable"); - (* just pop the most recent 'for' variable *) - match !substitions with - | _::tl -> tl - | _ -> failwith ("tried to pop (unspecified) variable from empty stack") - end - | [v] -> - begin - progress (sprintf "unmapping '%s'" v); - match !substitions with - | (hk,hvs)::tl -> if String.(hk=v) then tl else failwith (sprintf "tried to pop variable '%s' but top of stack was '%s'" v hk) - | _ -> failwith (sprintf "tried to pop variable '%s' from empty stack" v) - (* check the most recent 'for' variable has this name and pop it *) - end - | _ -> - failwith "endfor can have either zero or one parameter" - ); - acc - end - - else if List.exists r ~f:(fun (k,_)->String.(k=k_deflist)) then (* it's a deflist *) - begin - let bs = List.filter r ~f:(fun (k,_)->String.(k=k_deflist)) in - List.iter bs ~f:(fun (_,v) -> - let key = List.hd_exn v in - let values = List.tl_exn v in - progress (sprintf "definition: name '%s' means array [%s]" key (String.concat ~sep:", " values)); - deflists := List.Assoc.add ~equal:String.equal !deflists key values - ); - acc - end - - else (* nothing to resolve, carry on *) - (r |> apply_substitions |> List.map ~f:apply_definitions) @ acc + *) + ys + ) + ) in + acc @ r + + else if List.exists r ~f:(fun (k,_)->String.(k=k_for)) then (* it's a for-loop! *) + begin + let bs = List.filter r ~f:(fun (k,_)->String.(k=k_for)) in + List.iter bs ~f:(fun (_,v) -> + let key = List.hd_exn v in + let values = List.tl_exn v in + progress (sprintf "mapping: key '%s' becomes each of [%s]" key (String.concat ~sep:", " values)); + substitions := (key, values) :: !substitions + ); + return acc + end + + else if List.exists r ~f:(fun (k,_)->String.(k=k_endfor)) then (* it's the end of a for-loop! *) + begin + let bs = List.filter r ~f:(fun (k,_)->String.(k=k_endfor)) in + List.iter bs ~f:(fun (_,v) -> + substitions := match v with + | [] -> + begin + progress ("unmapping unspecified variable"); + (* just pop the most recent 'for' variable *) + match !substitions with + | _::tl -> tl + | _ -> failwith ("tried to pop (unspecified) variable from empty stack") + end + | [v] -> + begin + progress (sprintf "unmapping '%s'" v); + match !substitions with + | (hk,hvs)::tl -> if String.(hk=v) then tl else failwith (sprintf "tried to pop variable '%s' but top of stack was '%s'" v hk) + | _ -> failwith (sprintf "tried to pop variable '%s' from empty stack" v) + (* check the most recent 'for' variable has this name and pop it *) + end + | _ -> + failwith "endfor can have either zero or one parameter" + ); + return acc + end + + else if List.exists r ~f:(fun (k,_)->String.(k=k_deflist)) then (* it's a deflist *) + begin + let bs = List.filter r ~f:(fun (k,_)->String.(k=k_deflist)) in + List.iter bs ~f:(fun (_,v) -> + let key = List.hd_exn v in + let values = List.tl_exn v in + progress (sprintf "definition: name '%s' means array [%s]" key (String.concat ~sep:", " values)); + deflists := List.Assoc.add ~equal:String.equal !deflists key values + ); + return acc + end + + else (* nothing to resolve, carry on *) + return @@ (r |> apply_substitions |> List.map ~f:apply_definitions) @ acc - in - resolve_keywords_in_row acc r - ) + in + resolve_keywords_in_row acc r + ) in - let rs = resolve_keywords input_rows in + let%bind rs = resolve_keywords input_rows in progress (sprintf "table: %d lines: " (List.length rs)); let ctx_and_measurements_of_1st_cell_with_data expand_f ctx = - let ctxs = expand_f ctx in + let%bind ctxs = expand_f ctx in let measurements_of_cells = Async.Deferred.List.find_map ctxs ~f:(fun c->let%map ms=measurements_of_cell c in if List.is_empty ms then None else (Some (c,ms))) in match%map measurements_of_cells with None->ctx,[]|Some (c,ms)->c,ms in - let%bind measurements_of_table = + let%bind measurements_of_table = let rs_len = List.length rs in Async.Deferred.List.mapi rs ~f:(fun i r-> - progress (sprintf "row %d of %d..." i rs_len); - let%map csr = Async.Deferred.List.map cs ~f:(fun c-> - let%map ctx, ms = ctx_and_measurements_of_1st_cell_with_data expand (context_of b r c) in - (r, c, ctx, ms) - ) in r, csr - ) + progress (sprintf "row %d of %d..." i rs_len); + let%map csr = Async.Deferred.List.map cs ~f:(fun c-> + let%map ctx, ms = ctx_and_measurements_of_1st_cell_with_data expand (context_of b r c) in + (r, c, ctx, ms) + ) in r, csr + ) in (* === output === *) @@ -816,55 +816,55 @@ let t ~args = object (self) if Float.(abs (Float.(/) stddev f) < 0.00000001) (* stddev = 0.0 doesn't work because of rounding errors in the float representation *) then (sprintf "%f" f), f else - (* 0. compute magnitude of stddev relative to f *) - let f_abs = Float.abs f in - let magnitude = (log stddev) /. (log 10.0) in - let newdotpos = (if is_valid magnitude then Float.to_int (if Float.(magnitude < 0.0) then Float.round_down (magnitude) else (Float.round_down magnitude) +. 1.0) else 1) in - let f_str = sprintf "%f" f_abs in - let dotpos = (String.index_exn f_str '.') in - let cutpos = (dotpos - newdotpos) in - if cutpos < 0 - then ("0",0.0) (* stddev magnitude is larger then value f *) - else - (* 1. round for the computed magnitude of stddev *) - let dig_from s pos = (String.sub s ~pos:(pos+1) ~len:1) in - let dig=dig_from f_str cutpos in - let rounddigit,roundpos = (* round last significant value using the next digit value *) - if String.(dig=".") + (* 0. compute magnitude of stddev relative to f *) + let f_abs = Float.abs f in + let magnitude = (log stddev) /. (log 10.0) in + let newdotpos = (if is_valid magnitude then Float.to_int (if Float.(magnitude < 0.0) then Float.round_down (magnitude) else (Float.round_down magnitude) +. 1.0) else 1) in + let f_str = sprintf "%f" f_abs in + let dotpos = (String.index_exn f_str '.') in + let cutpos = (dotpos - newdotpos) in + if cutpos < 0 + then ("0",0.0) (* stddev magnitude is larger then value f *) + else + (* 1. round for the computed magnitude of stddev *) + let dig_from s pos = (String.sub s ~pos:(pos+1) ~len:1) in + let dig=dig_from f_str cutpos in + let rounddigit,roundpos = (* round last significant value using the next digit value *) + if String.(dig=".") then (int_of_string (dig_from f_str (cutpos+1)),newdotpos-1) else (int_of_string dig,if newdotpos<0 then newdotpos else newdotpos-1) - in - let f_rounded = if rounddigit < 5 then f_abs else f_abs +. 10.0 ** (Float.of_int roundpos) in - (* 2. print only significant digits *) - let f_result = ( - let f_str_rounded = sprintf "%f" f_rounded in - let f_abs_str_rounded = (if Float.(f_rounded<1.0) - then (* print the rounded value up to its last significant digit *) - String.sub f_str_rounded ~pos:0 ~len:(cutpos+1) - else (* print the rounded value up to its last significant digit and fill the rest with 0s *) - let dotposr = String.index_exn f_str_rounded '.' in - sprintf "%s%s" - (String.sub f_str_rounded ~pos:0 ~len:(cutpos+1)) - (if dotposr-(cutpos+1)>0 then (String.make (dotposr-(cutpos+1)) '0') else "") - ) in - (sprintf "%s%s" (if Float.(f<0.0) then if String.(f_abs_str_rounded <> "0") then "-" else "" else "") f_abs_str_rounded) - ) - in - ( - (*sprintf "f_str=%s stddev=%f magnitude=%f cutpos=%d dotpos=%d newdotpos=%d dig=%s rounddigit=%d roundpos=%d f_rounded=%f f=%f %s" f_str stddev magnitude cutpos dotpos newdotpos dig rounddigit roundpos f_rounded f*) - f_result, Float.of_string f_result - ) + in + let f_rounded = if rounddigit < 5 then f_abs else f_abs +. 10.0 ** (Float.of_int roundpos) in + (* 2. print only significant digits *) + let f_result = ( + let f_str_rounded = sprintf "%f" f_rounded in + let f_abs_str_rounded = (if Float.(f_rounded<1.0) + then (* print the rounded value up to its last significant digit *) + String.sub f_str_rounded ~pos:0 ~len:(cutpos+1) + else (* print the rounded value up to its last significant digit and fill the rest with 0s *) + let dotposr = String.index_exn f_str_rounded '.' in + sprintf "%s%s" + (String.sub f_str_rounded ~pos:0 ~len:(cutpos+1)) + (if dotposr-(cutpos+1)>0 then (String.make (dotposr-(cutpos+1)) '0') else "") + ) in + (sprintf "%s%s" (if Float.(f<0.0) then if String.(f_abs_str_rounded <> "0") then "-" else "" else "") f_abs_str_rounded) + ) + in + ( + (*sprintf "f_str=%s stddev=%f magnitude=%f cutpos=%d dotpos=%d newdotpos=%d dig=%s rounddigit=%d roundpos=%d f_rounded=%f f=%f %s" f_str stddev magnitude cutpos dotpos newdotpos dig rounddigit roundpos f_rounded f*) + f_result, Float.of_string f_result + ) in let of_round avg stddev ~f0 ~f1 ~f2 = if no_rounding then f1 (Float.to_string avg, avg) else - let lower = avg -. 2.0 *. stddev in (* 2-sigma = 95% confidence assuming normal distribution *) - let upper = avg +. 2.0 *. stddev in - if Float.(abs avg < min_value) - then f0 () - else if Float.(stddev /. avg < 0.05) (* see if the relative std error is <5% *) + let lower = avg -. 2.0 *. stddev in (* 2-sigma = 95% confidence assuming normal distribution *) + let upper = avg +. 2.0 *. stddev in + if Float.(abs avg < min_value) + then f0 () + else if Float.(stddev /. avg < 0.05) (* see if the relative std error is <5% *) then f1 (round avg stddev) (* 95% confidence *) else f2 (round lower stddev) (round avg stddev) (round upper stddev) (* 95% confidence *) in @@ -890,7 +890,7 @@ let t ~args = object (self) |Avg b, Range (vl, va, vu)-> Float.(va>=b) |Range (bl, ba, bu), Avg v-> Float.(v>=ba) |Range (bl, ba, bu), Range (vl,va,vu)-> Float.(va>=ba) - else (* less is better *) + else (* less is better *) match baseline, value with |Avg b, Avg v-> Float.(v<=b) |Avg b, Range (vl, va, vu)-> Float.(va<=b) @@ -899,16 +899,16 @@ let t ~args = object (self) in let delta baseline value more_is_better = match baseline, value with - |Avg b, Avg v-> v -. b - |Avg b, Range (vl, va, vu)-> va -. b - |Range (bl, ba, bu), Avg v-> v -. ba - |Range (bl, ba, bu), Range (vl,va,vu)-> va -. ba + |Avg b, Avg v-> v -. b + |Avg b, Range (vl, va, vu)-> va -. b + |Range (bl, ba, bu), Avg v-> v -. ba + |Range (bl, ba, bu), Range (vl,va,vu)-> va -. ba in let proportion baseline value more_is_better = (delta baseline value more_is_better) /. (match baseline with - |Avg b-> Float.abs b - |Range (bl, ba, bu)-> Float.abs ba) + |Avg b-> Float.abs b + |Range (bl, ba, bu)-> Float.abs ba) in (* pretty print a list of values as average and stddev *) let str_stddev_of ?f1_fmt ?f2_fmt xs = @@ -929,22 +929,22 @@ let t ~args = object (self) |None->mt |Some compare_col_idx-> let mt_xs, mt_0s = List.partition_tf mt - ~f:(fun (r,cs)-> - let _,_,_,cmp_ms=List.nth_exn cs compare_col_idx in - let _,_,_,base_ms=List.nth_exn cs baseline_col_idx in - (List.length cmp_ms > 0) && (List.length base_ms > 0) - ) + ~f:(fun (r,cs)-> + let _,_,_,cmp_ms=List.nth_exn cs compare_col_idx in + let _,_,_,base_ms=List.nth_exn cs baseline_col_idx in + (List.length cmp_ms > 0) && (List.length base_ms > 0) + ) in List.sort (mt_xs) (* rows with at least one measurement *) ~compare:(fun (r1,cs1) (r2,cs2) -> - let ms cs = - let _,_,_,cmp_ms = List.nth_exn cs compare_col_idx in - let _,_,_,base_ms = List.nth_exn cs baseline_col_idx in - proportion (val_stddev_of (vals_of_ms base_ms)) (val_stddev_of (vals_of_ms cmp_ms)) None - in - let ms1, ms2 = (Float.abs (ms cs1)),(Float.abs (ms cs2)) in - if Float.(ms1 > ms2) then -1 else if Float.(ms2 > ms1) then 1 else 0 (* decreasing order *) - ) @ mt_0s (* rows with no measurements stay at the end *) + let ms cs = + let _,_,_,cmp_ms = List.nth_exn cs compare_col_idx in + let _,_,_,base_ms = List.nth_exn cs baseline_col_idx in + proportion (val_stddev_of (vals_of_ms base_ms)) (val_stddev_of (vals_of_ms cmp_ms)) None + in + let ms1, ms2 = (Float.abs (ms cs1)),(Float.abs (ms cs2)) in + if Float.(ms1 > ms2) then -1 else if Float.(ms2 > ms1) then 1 else 0 (* decreasing order *) + ) @ mt_0s (* rows with no measurements stay at the end *) in (* compute link to rage graph *) @@ -953,8 +953,8 @@ let t ~args = object (self) (* eg.: http://perf/?som=41&xaxis=numvms&show_dist=on&f_branch=1&v_build_tag=&v_dom0_memory_static_max=752&v_dom0_memory_target=(NULL)&v_cc_restrictions=f&v_memsize=256&v_vmtype=dom0 *) let link_ctx_of_row ctxs = List.fold_left ctxs ~init:[] ~f:(fun acc (ck,cv)-> - let x,ys = List.partition_tf ~f:(fun (k,v)->String.(k=ck)) acc in - match x with + let x,ys = List.partition_tf ~f:(fun (k,v)->String.(k=ck)) acc in + match x with |(k,v)::[]->(* context already in acc, union the values *) if String.(k<>ck) then (failwith (sprintf "link: k=%s <> ck=%s" k ck)); (k, List.dedup_and_sort ~compare:String.compare (cv @ v))::ys @@ -962,7 +962,7 @@ let t ~args = object (self) (ck,cv)::ys |x->(* error *) failwith (sprintf "link: More than one element with the same context") - ) + ) in let link_ctxs = (List.map (sort_table measurements_of_table) ~f:(fun (r,cs)->link_ctx_of_row (List.concat (List.map cs ~f:(fun (_,_,ctx,_)->ctx))))) in let link_xaxis = List.dedup_and_sort ~compare:String.compare (List.concat (List.map cs ~f:(fun c-> List.map c ~f:(fun (x,_)->x)))) in @@ -973,10 +973,10 @@ let t ~args = object (self) let rage_encode url = List.fold_left - [ - (" ","+"); (* escape http params according to what rage expects *) - ] - ~init:url + [ + (" ","+"); (* escape http params according to what rage expects *) + ] + ~init:url ~f:(fun acc (f,t)->(Str.global_replace (Str.regexp f) t acc)) (* f->t *) in @@ -985,118 +985,123 @@ let t ~args = object (self) let str_of_values vs=List.fold_left vs ~init:"" ~f:(fun acc v->if String.(acc="") then "\""^v^"\"" else acc^", \""^v^"\"") in let str_of_ctxs ?(txtonly=false) kvs = List.fold_left kvs ~init:"" ~f:(fun acc (k,v)-> - (sprintf "%s %s=(%s)%s\n" acc k (str_of_values v) (if txtonly then "" else "
    ") ) - ) + (sprintf "%s %s=(%s)%s\n" acc k (str_of_values v) (if txtonly then "" else "
    ") ) + ) in let str_desc_of_ctxs kvs = - List.fold_left kvs ~init:"" ~f:(fun acc (k,vs)-> - if String.(k<>"soms") then acc else - (sprintf "%s %s
    \n" acc (List.fold_left vs ~init:"" ~f:(fun acc2 som-> - let s=sprintf "%s: %s (%s%s)" (tc_of_som som) (name_of_som som) (let u=unit_of_som som in if String.(u="") then u else u^", ") (sprintf "%s is better" (let mb=more_is_better_of_som som in if String.(mb="") then "none" else if String.(mb="f") then "less" else "more")) in - if String.(acc="") then s else acc^","^s - )) + Async.Deferred.List.fold kvs ~init:"" ~f:(fun acc (k,vs)-> + if String.(k<>"soms") then return acc else + let%map r = Async.Deferred.List.fold vs ~init:"" ~f:(fun acc2 som-> + let%bind tc = tc_of_som som in + let%bind u = unit_of_som som in + let%bind mb = more_is_better_of_som som in + let%map name = name_of_som som in + let s=sprintf "%s: %s (%s%s)" tc name (if String.(u="") then u else u^", ") (sprintf "%s is better" (if String.(mb="") then "none" else if String.(mb="f") then "less" else "more")) in + if String.(acc="") then s else acc^","^s + ) in + (sprintf "%s %s
    \n" acc r) ) - ) in - let link ctx = - (* link *) - ( + let link ctx = + (* link *) + ( (* rage is not generic enough to receive an arbirary number of soms in a link, pick just the first one *) let som_id=match List.find_exn ctx ~f:(fun (k,_)->String.(k="soms")) with |(k,v)->List.hd_exn v in (sprintf "graph" (Utils.server_name ()) som_id - (* xaxis *) - (List.fold_left link_xaxis ~init:"" ~f:(fun acc x->sprintf "%s%s" acc (sprintf "&xaxis=%s" x))) - (* preset values *) - (List.fold_left ctx ~init:"" ~f:(fun acc (k,vs)->sprintf "%s%s" acc - (List.fold_left vs ~init:"" ~f:(fun acc2 v->sprintf "%s&v_%s=%s" acc2 k (rage_encode v)) - ) - )) + (* xaxis *) + (List.fold_left link_xaxis ~init:"" ~f:(fun acc x->sprintf "%s%s" acc (sprintf "&xaxis=%s" x))) + (* preset values *) + (List.fold_left ctx ~init:"" ~f:(fun acc (k,vs)->sprintf "%s%s" acc + (List.fold_left vs ~init:"" ~f:(fun acc2 v->sprintf "%s&v_%s=%s" acc2 k (rage_encode v)) + ) + )) )) - in + in let is_more_is_better ctx = match List.find ctx ~f:(fun (k,_)->String.(k="soms")) with |None->return None |Some (k,_vs)->( - let rec is_mb acc vs = (match vs with - |[]-> return @@ if Option.is_none acc then None else acc - |v::vs->(let%bind mb = more_is_better_of_som v in - if String.(mb="") then is_mb acc vs (* ignore more_is_better if not defined in db *) - else - let mbtf = match mb with m when String.(m="f")->false|_->true in - match acc with - |None->is_mb (Some mbtf) vs - |Some _mbtf->if Bool.(_mbtf=mbtf) - then is_mb (Some mbtf) vs (* more_is_better values agree between soms *) - else return None (* more_is_better values disagree between soms *) - ) - ) in - is_mb None _vs - ) + let rec is_mb acc vs = (match vs with + |[]-> return @@ if Option.is_none acc then None else acc + |v::vs->(let%bind mb = more_is_better_of_som v in + if String.(mb="") then is_mb acc vs (* ignore more_is_better if not defined in db *) + else + let mbtf = match mb with m when String.(m="f")->false|_->true in + match acc with + |None->is_mb (Some mbtf) vs + |Some _mbtf->if Bool.(_mbtf=mbtf) + then is_mb (Some mbtf) vs (* more_is_better values agree between soms *) + else return None (* more_is_better values disagree between soms *) + ) + ) in + is_mb None _vs + ) in let num_columns = (List.length cs) + 3 in + let%bind cells = List.map2_exn table link_ctxs ~f:(fun (r,cs) lnkctx -> + let%bind str_desc = str_desc_of_ctxs r in + let%map lst = + Async.Deferred.List.mapi cs ~f:(fun i (r,c,ctx,ms)-> + let _,_,_,baseline_ms = List.nth_exn cs baseline_col_idx in + let debug_r = Sexp.to_string (sexp_of_ctx_t r) + and debug_c = Sexp.to_string (sexp_of_ctx_t c) + and context = str_of_ctxs ctx ~txtonly:true + and debug_ms = Sexp.to_string (sexp_of_str_lst_t (vals_of_ms ms)) in + let number = List.length ms in + let number_str = if show_jobids + then + sprintf "[%s]" (String.concat ~sep:"; " (List.map ~f:string_of_int (List.dedup_and_sort ~compare:Int.compare (jobs_of_ms ms)))) + else + sprintf "(%d)" number + in + let%bind colour = + (if number = 0 || baseline_col_idx = i then return "" else + match%map is_more_is_better ctx with + |None->"" + |Some mb-> + if (List.length baseline_ms) < 1 then "black" else + if is_green (val_stddev_of (vals_of_ms baseline_ms)) (val_stddev_of (vals_of_ms ms)) mb then "green" else "red" + ) in + let avg = str_stddev_of (vals_of_ms ms) in + let%map diff = + (if number = 0 || baseline_col_idx = i || (List.length baseline_ms < 1) then return "" else + match%map is_more_is_better ctx with + |None->"" + |Some mb->sprintf "(%+.0f%%)" (100.0 *. (proportion (val_stddev_of (vals_of_ms baseline_ms)) (val_stddev_of (vals_of_ms ms)) mb)) + ) in + let text = sprintf "%s
    %s %s
    " colour avg number_str diff in + sprintf "
    %s
    " debug_r debug_c context debug_ms text + ) in + let cells = List.fold_left ~init:"" ~f:(fun acc c_ms->(sprintf "%s %s \n" acc c_ms)) lst in + sprintf " %s %s %s %s \n\n" + (* row id/title *) + (str_of_ctxs r) + (* row description *) + str_desc + (* graph link *) + (link lnkctx) + (* cells to the right *) + cells + ) |> Async.Deferred.List.all in let html_table = - sprintf " %s\n%s%s%s" - num_columns - (* print the base context *) - (str_of_ctxs b) - (* print the header *) - (sprintf " id Description View %s " - (List.foldi cs ~init:"" ~f:(fun i acc _ -> - sprintf "%s %s" acc (if i=baseline_col_idx then "Baseline" else (sprintf "Comparison %d" i)) - )) - ) - (* print the columns *) - (sprintf "%s" - (List.fold_left ~init:"" - ~f:(fun acc cs->sprintf "%s %s " acc (str_of_ctxs cs)) cs - ) - ) - (* print the cells *) - (List.fold_left ~init:"" ~f:(fun acc r_ms->acc^r_ms) - (List.map2_exn table link_ctxs ~f:(fun (r,cs) lnkctx -> - sprintf " %s %s %s %s \n\n" - (* row id/title *) - (str_of_ctxs r) - (* row description *) - (str_desc_of_ctxs r) - (* graph link *) - (link lnkctx) - (* cells to the right *) - (List.fold_left ~init:"" ~f:(fun acc c_ms->(sprintf "%s %s \n" acc c_ms)) - (List.mapi cs ~f:(fun i (r,c,ctx,ms)-> - let _,_,_,baseline_ms = List.nth_exn cs baseline_col_idx in - let debug_r = Sexp.to_string (sexp_of_ctx_t r) - and debug_c = Sexp.to_string (sexp_of_ctx_t c) - and context = str_of_ctxs ctx ~txtonly:true - and debug_ms = Sexp.to_string (sexp_of_str_lst_t (vals_of_ms ms)) in - let number = List.length ms in - let number_str = if show_jobids - then - sprintf "[%s]" (String.concat ~sep:"; " (List.map ~f:string_of_int (List.dedup_and_sort ~compare:Int.compare (jobs_of_ms ms)))) - else - sprintf "(%d)" number - in - let%bind colour = - (if number = 0 || baseline_col_idx = i then return "" else - match%map is_more_is_better ctx with - |None->"" - |Some mb-> - if (List.length baseline_ms) < 1 then "black" else - if is_green (val_stddev_of (vals_of_ms baseline_ms)) (val_stddev_of (vals_of_ms ms)) mb then "green" else "red" - ) in - let avg = str_stddev_of (vals_of_ms ms) in - let%map diff = - (if number = 0 || baseline_col_idx = i || (List.length baseline_ms < 1) then return "" else - match%map is_more_is_better ctx with - |None->"" - |Some mb->sprintf "(%+.0f%%)" (100.0 *. (proportion (val_stddev_of (vals_of_ms baseline_ms)) (val_stddev_of (vals_of_ms ms)) mb)) - ) in - let text = sprintf "%s
    %s %s
    " colour avg number_str diff in - sprintf "
    %s
    " debug_r debug_c context debug_ms text - )) + sprintf " %s\n%s%s%s" + num_columns + (* print the base context *) + (str_of_ctxs b) + (* print the header *) + (sprintf " id Description View %s " + (List.foldi cs ~init:"" ~f:(fun i acc _ -> + sprintf "%s %s" acc (if i=baseline_col_idx then "Baseline" else (sprintf "Comparison %d" i)) + )) ) - )) - ) + (* print the columns *) + (sprintf "%s" + (List.fold_left ~init:"" + ~f:(fun acc cs->sprintf "%s %s " acc (str_of_ctxs cs)) cs + ) + ) + (* print the cells *) + (String.concat ~sep:"" cells) in let brief_name = if is_digit brief_id then "jim #"^brief_id else sprintf "from %s" brief_id brief_id in let%map title = title_of_id brief_id in @@ -1136,112 +1141,120 @@ let t ~args = object (self) let str_of_values vs=List.fold_left vs ~init:"" ~f:(fun acc v->if String.(acc="") then "\""^v^"\"" else acc^", \""^v^"\"") in let str_of_ctxs ?(txtonly=false) kvs = List.fold_left kvs ~init:"" ~f:(fun acc (k,v)-> - (sprintf "%s %s=(%s)%s " acc k (str_of_values v) (if txtonly then "" else "\\\\") ) - ) + (sprintf "%s %s=(%s)%s " acc k (str_of_values v) (if txtonly then "" else "\\\\") ) + ) in let str_desc_of_ctxs kvs = - List.fold_left kvs ~init:"" ~f:(fun acc (k,vs)-> - if String.(k<>"soms") then acc else - (sprintf "%s %s \\\\" acc (List.fold_left vs ~init:"" ~f:(fun acc2 som-> - let%map mbstr = - let%map mb=more_is_better_of_som som in if String.(mb="") then "none" else if String.(mb="f") then "less" else "more" + Async.Deferred.List.fold kvs ~init:"" ~f:(fun acc (k,vs)-> + if String.(k<>"soms") then return acc else + let%map r = + Async.Deferred.List.fold vs ~init:"" ~f:(fun acc2 som-> + let%bind tc = tc_of_som som in + let%bind name = name_of_som som in + let%bind u = unit_of_som som in + let%map mbstr = + let%map mb=more_is_better_of_som som in if String.(mb="") then "none" else if String.(mb="f") then "less" else "more" + in + let s=sprintf "%s: *%s* (%s%s)" tc name (if String.(u="") then u else u^", ") (sprintf "%s is better" mbstr) in + if String.(acc="") then s else acc^","^s + ) in - let s=sprintf "%s: *%s* (%s%s)" (tc_of_som som) (name_of_som som) (let u=unit_of_som som in if String.(u="") then u else u^", ") (sprintf "%s is better" mbstr) in - if String.(acc="") then s else acc^","^s - )) + sprintf "%s %s \\\\" acc r ) - ) in - let link ctx = - (* link *) - ( + let link ctx = + (* link *) + ( (* rage is not generic enough to receive an arbirary number of soms in a link, pick just the first one *) let som_id=match List.find_exn ctx ~f:(fun (k,_)->String.(k="soms")) with |(k,v)->List.hd_exn v in (sprintf "[graph|http://%s/?som=%s&show_dist=on%s%s]" (Utils.server_name ()) som_id - (* xaxis *) - (List.fold_left link_xaxis ~init:"" ~f:(fun acc x->sprintf "%s%s" acc (sprintf "&xaxis=%s" x))) - (* preset values *) - (List.fold_left ctx ~init:"" ~f:(fun acc (k,vs)->sprintf "%s%s" acc - (List.fold_left vs ~init:"" ~f:(fun acc2 v->sprintf "%s&v_%s=%s" acc2 k (rage_encode v)) - ) - )) + (* xaxis *) + (List.fold_left link_xaxis ~init:"" ~f:(fun acc x->sprintf "%s%s" acc (sprintf "&xaxis=%s" x))) + (* preset values *) + (List.fold_left ctx ~init:"" ~f:(fun acc (k,vs)->sprintf "%s%s" acc + (List.fold_left vs ~init:"" ~f:(fun acc2 v->sprintf "%s&v_%s=%s" acc2 k (rage_encode v)) + ) + )) )) - in + in let is_more_is_better ctx = match List.find ctx ~f:(fun (k,_)->String.(k="soms")) with - |None->None + |None->return None |Some (k,_vs)->( - let rec is_mb acc vs = (match vs with - |[]->if Option.is_none acc then None else acc - |v::vs->(let mb = more_is_better_of_som v in - if String.(mb="") then is_mb acc vs (* ignore more_is_better if not defined in db *) - else - let mbtf = match mb with m when String.(m="f")->false|_->true in - match acc with - |None->is_mb (Some mbtf) vs - |Some _mbtf->if Bool.(_mbtf=mbtf) - then is_mb (Some mbtf) vs (* more_is_better values agree between soms *) - else None (* more_is_better values disagree between soms *) - ) - ) in - is_mb None _vs - ) + let rec is_mb acc vs = (match vs with + |[]-> return @@ if Option.is_none acc then None else acc + |v::vs->(let%bind mb = more_is_better_of_som v in + if String.(mb="") then is_mb acc vs (* ignore more_is_better if not defined in db *) + else + let mbtf = match mb with m when String.(m="f")->false|_->true in + match acc with + |None->is_mb (Some mbtf) vs + |Some _mbtf->if Bool.(_mbtf=mbtf) + then is_mb (Some mbtf) vs (* more_is_better values agree between soms *) + else return None (* more_is_better values disagree between soms *) + ) + ) in + is_mb None _vs + ) in - let wiki_table = - sprintf "| %s|\n%s%s\n%s" - (* print the base context *) - (str_of_ctxs b) - (* print the header *) - (sprintf "||id|| Description || View || %s \n" - (List.foldi cs ~init:"" ~f:(fun i acc _ -> - sprintf "%s %s ||" acc (if i=baseline_col_idx then "Baseline" else (sprintf "Comparison %d" i)) - )) - ) - (* print the columns *) - (sprintf "|| || || || %s" - (List.fold_left ~init:"" - ~f:(fun acc cs->sprintf "%s %s || " acc (str_of_ctxs cs)) cs - ) - ) - (* print the cells *) - (List.fold_left ~init:"" ~f:(fun acc r_ms->acc^r_ms) - (List.map2_exn table link_ctxs ~f:(fun (r,cs) lnkctx -> - sprintf "| %s | %s | %s | %s \n" - (* row id/title *) - (str_of_ctxs r) - (* row description *) - (str_desc_of_ctxs r) - (* graph link *) - (link lnkctx) - (* cells to the right *) - (List.fold_left ~init:"" ~f:(fun acc c_ms->(sprintf "%s %s | " acc c_ms)) - (List.mapi cs ~f:(fun i (r,c,ctx,ms)-> - let _,_,_,baseline_ms = List.nth_exn cs baseline_col_idx in -(* + let%map cells = + (List.map2_exn table link_ctxs ~f:(fun (r,cs) lnkctx -> + let%bind str_desc = str_desc_of_ctxs r in + let%map cells = + Async.Deferred.List.mapi cs ~f:(fun i (r,c,ctx,ms)-> + let _,_,_,baseline_ms = List.nth_exn cs baseline_col_idx in + let%map is_mb = is_more_is_better ctx in + (* sprintf "
    %s
    " (Sexp.to_string (sexp_of_ctx_t r)) - (Sexp.to_string (sexp_of_ctx_t c)) - (str_of_ctxs ctx ~txtonly:true) - (Sexp.to_string (sexp_of_str_lst_t (vals_of_ms ms))) -*) - (sprintf "{color:%s} %s %s %s {color}" - (if baseline_col_idx = i then "" else - match is_more_is_better ctx with - |None->"" - |Some mb->if is_green (val_stddev_of (vals_of_ms baseline_ms)) (val_stddev_of (vals_of_ms ms)) mb then "green" else "red" - ) - (str_stddev_of (vals_of_ms ms) ~f2_fmt:"\\\\[%s, %s, %s\\\\]") - (sprintf "~(%d)~" (List.length ms)) - (if baseline_col_idx = i then "" else - match is_more_is_better ctx with - |None->"" - |Some mb->sprintf "~(%+.0f%%)~" (100.0 *. (proportion (val_stddev_of (vals_of_ms baseline_ms)) (val_stddev_of (vals_of_ms ms)) mb)) - ) - ) - )) + (Sexp.to_string (sexp_of_ctx_t c)) + (str_of_ctxs ctx ~txtonly:true) + (Sexp.to_string (sexp_of_str_lst_t (vals_of_ms ms))) + *) + (sprintf "{color:%s} %s %s %s {color}" + (if baseline_col_idx = i then "" else + match is_mb with + |None->"" + |Some mb->if is_green (val_stddev_of (vals_of_ms baseline_ms)) (val_stddev_of (vals_of_ms ms)) mb then "green" else "red" + ) + (str_stddev_of (vals_of_ms ms) ~f2_fmt:"\\\\[%s, %s, %s\\\\]") + (sprintf "~(%d)~" (List.length ms)) + (if baseline_col_idx = i then "" else + match is_mb with + |None->"" + |Some mb->sprintf "~(%+.0f%%)~" (100.0 *. (proportion (val_stddev_of (vals_of_ms baseline_ms)) (val_stddev_of (vals_of_ms ms)) mb)) + ))) + in + sprintf "| %s | %s | %s | %s \n" + (* row id/title *) + (str_of_ctxs r) + (* row description *) + str_desc + (* graph link *) + (link lnkctx) + (* cells to the right *) + (List.fold_left ~init:"" ~f:(fun acc c_ms->(sprintf "%s %s | " acc c_ms)) cells) + )) + |> Async.Deferred.List.all + in + let wiki_table = + sprintf "| %s|\n%s%s\n%s" + (* print the base context *) + (str_of_ctxs b) + (* print the header *) + (sprintf "||id|| Description || View || %s \n" + (List.foldi cs ~init:"" ~f:(fun i acc _ -> + sprintf "%s %s ||" acc (if i=baseline_col_idx then "Baseline" else (sprintf "Comparison %d" i)) + )) ) - )) - ) + (* print the columns *) + (sprintf "|| || || || %s" + (List.fold_left ~init:"" + ~f:(fun acc cs->sprintf "%s %s || " acc (str_of_ctxs cs)) cs + ) + ) + (* print the cells *) + (String.concat ~sep:"" cells) in printf "%s" "
    ";
           printf "%s" "h1. Brief Rage Report\n\n";
    diff --git a/src/main.ml b/src/main.ml
    index 20c8aec..c66c49e 100644
    --- a/src/main.ml
    +++ b/src/main.ml
    @@ -1,4 +1,5 @@
     open Core
    +open Async
     open Utils
     
     (** Combines GET and POST parameters. *)
    @@ -26,7 +27,7 @@ let handle_request () =
       let start_time = Unix.gettimeofday () in
       let params = get_params_of_request () in
       let place = place_of_params ~params in
    -  let conn = new Postgresql.connection ~conninfo:Sys.(get_argv()).(1) () in
    +  let conn = Postgresql_async.connect_pool ~conninfo:Sys.(get_argv()).(1) in
       let args = let open Handler in {conn; params} in
       let open Place in
       let handler = begin match place with
    @@ -41,8 +42,9 @@ let handle_request () =
         | Brief -> Brief_handler.t
         | ImportPage -> Import_page_handler.t
         | ImportJobs -> Import_jobs_handler.t
    -  end in (handler ~args)#handle;
    -  conn#finish;
    +  end in
    +  let%bind () = (handler ~args)#handle in
    +  let%map () = Postgresql_async.destroy_pool conn in
       let elapsed_time = Unix.gettimeofday () -. start_time in
       debug (sprintf "==========> '%s': %fs." (Place.string_of place) elapsed_time)
     
    @@ -53,7 +55,14 @@ let bind_modules () =
       Sql.ignore_limit_0 := true;
       Sql.mode := Sql.Live
     
    -let _ =
    +let () =
       bind_modules ();
    -  try handle_request ()
    -  with Failure msg -> Printexc.print_backtrace stderr; printf "%s" msg
    +  don't_wait_for @@ Monitor.handle_errors handle_request
    +  (fun e ->
    +    Printexc.print_backtrace stderr;
    +    let msg = match e with
    +    | Failure msg -> msg
    +    | _ -> Exn.to_string e in
    +    printf "%s" msg)
    +
    +let () = never_returns (Scheduler.go ())
    
    From a8a905227e905410fe3ec751760968234505f08a Mon Sep 17 00:00:00 2001
    From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= 
    Date: Sun, 1 Dec 2019 18:35:54 +0000
    Subject: [PATCH 16/36] Shut down the async loop when done
    MIME-Version: 1.0
    Content-Type: text/plain; charset=UTF-8
    Content-Transfer-Encoding: 8bit
    
    RAGE is not a long running daemon, it is a CGI, so stop the async
    scheduler when done.
    
    Signed-off-by: Edwin Török 
    ---
     src/html_handler.ml            |  1 +
     src/import_jobs_handler.ml     | 11 ++++++-----
     src/javascript_only_handler.ml |  3 ++-
     src/json_handler.ml            |  1 +
     src/main.ml                    |  6 ++++--
     5 files changed, 14 insertions(+), 8 deletions(-)
    
    diff --git a/src/html_handler.ml b/src/html_handler.ml
    index f58a160..e037a03 100644
    --- a/src/html_handler.ml
    +++ b/src/html_handler.ml
    @@ -1,4 +1,5 @@
     open Core
    +open Async
     
     class t = fun ~args ->
     object (self)
    diff --git a/src/import_jobs_handler.ml b/src/import_jobs_handler.ml
    index d91dd82..ae3296a 100644
    --- a/src/import_jobs_handler.ml
    +++ b/src/import_jobs_handler.ml
    @@ -1,4 +1,5 @@
     open Core
    +open Async
     open Utils
     
     let importer = "/usr/groups/perfeng/bin/importer-xenrt"
    @@ -18,14 +19,14 @@ let import_job job_ids =
       if not (Str.string_match (Str.regexp "^[0-9,\\-]*$") job_ids 0) then failwith (sprintf "expected '<n>' or '<n>-<n>' or '<n>,<n>,...'; got '%s'" job_ids);
     
       let cmd = Printf.sprintf "%s -jobs %s -ignoreseenjobs 2>&1" importer job_ids in
    -  Printf.printf "" cmd;
    +  printf "" cmd;
       let ic = Unix.open_process_in cmd in
       In_channel.iter_lines ic ~f:(fun input ->
    -      Printf.printf "%s\n" input;
    -      Printf.eprintf "[import_jobs_handler|%s] %s\n" job_ids input);
    -  Printf.eprintf "[import_jobs_handler|%s] EOF\n" job_ids;
    +      printf "%s\n" input;
    +      eprintf "[import_jobs_handler|%s] %s\n" job_ids input);
    +  eprintf "[import_jobs_handler|%s] EOF\n" job_ids;
       ignore (Unix.close_process_in ic);
    -  Printf.eprintf "[import_jobs_handler|%s] Finished\n" job_ids
    +  eprintf "[import_jobs_handler|%s] Finished\n" job_ids
     
     let t ~args = object (self)
       inherit Html_handler.t ~args
    diff --git a/src/javascript_only_handler.ml b/src/javascript_only_handler.ml
    index cadaeeb..d9ee63b 100644
    --- a/src/javascript_only_handler.ml
    +++ b/src/javascript_only_handler.ml
    @@ -1,5 +1,6 @@
    +open Async
     let t ~args = object (self)
       inherit Html_handler.t ~args
     
    -  method private write_body = Printf.printf ""; Async.return ()
    +  method private write_body = printf ""; return ()
     end
    diff --git a/src/json_handler.ml b/src/json_handler.ml
    index 3698413..3b1b22b 100644
    --- a/src/json_handler.ml
    +++ b/src/json_handler.ml
    @@ -1,4 +1,5 @@
     open Core
    +open Async
     
     class t = fun ~args ->
     object (self)
    diff --git a/src/main.ml b/src/main.ml
    index c66c49e..af3f283 100644
    --- a/src/main.ml
    +++ b/src/main.ml
    @@ -46,7 +46,8 @@ let handle_request () =
       let%bind () = (handler ~args)#handle in
       let%map () = Postgresql_async.destroy_pool conn in
       let elapsed_time = Unix.gettimeofday () -. start_time in
    -  debug (sprintf "==========> '%s': %fs." (Place.string_of place) elapsed_time)
    +  debug (sprintf "==========> '%s': %fs." (Place.string_of place) elapsed_time);
    +  Shutdown.shutdown 0
     
     let bind_modules () =
       Sql.debug_fn := None; (* Some debug; *)
    @@ -63,6 +64,7 @@ let () =
         let msg = match e with
         | Failure msg -> msg
         | _ -> Exn.to_string e in
    -    printf "%s" msg)
    +    printf "%s" msg;
    +    Shutdown.shutdown 1)
     
     let () = never_returns (Scheduler.go ())
    
    From 85d690bafbbf023dc3d4c57b0cce6d02a4aa8b03 Mon Sep 17 00:00:00 2001
    From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= 
    Date: Sun, 1 Dec 2019 18:35:54 +0000
    Subject: [PATCH 17/36] Cleanup some async handling
    
    ---
     src/OMakefile        | 41 ----------------------------------
     src/brief_handler.ml | 52 ++++++++++++++++++++++----------------------
     2 files changed, 26 insertions(+), 67 deletions(-)
     delete mode 100644 src/OMakefile
    
    diff --git a/src/OMakefile b/src/OMakefile
    deleted file mode 100644
    index 662a7d1..0000000
    --- a/src/OMakefile
    +++ /dev/null
    @@ -1,41 +0,0 @@
    -NATIVE_ENABLED=true
    -USE_OCAMLFIND=true
    -OCAMLINCLUDES+=ocaml-sql
    -OCAMLPACKS=core,postgresql,str,curl,uri
    -OCAMLFLAGS=-g -thread -linkpkg -w +a-4-7-13-27 -principal
    -HANDLERS=\
    -  create_tiny_url_handler \
    -  default_handler \
    -  handler \
    -  html_handler \
    -  javascript_only_handler \
    -  json_handler \
    -  redirect_tiny_url_handler \
    -  soms_handler \
    -  som_data_handler \
    -  som_page_handler \
    -  std_axes_handler \
    -  brief_handler \
    -  import_page_handler \
    -  import_jobs_handler
    -FILES=\
    -  ocaml-sql/sql \
    -  $(HANDLERS) \
    -  main \
    -  place \
    -  utils
    -
    -.SUBDIRS: ocaml-sql
    -	OCAMLINCLUDES=.
    -	UseCamlp4(sexplib.syntax, sql)
    -	clean:
    -		make -C $(ROOT)/src/ocaml-sql clean
    -
    -UseCamlp4(sexplib.syntax, brief_handler)
    -
    -OCamlProgram($(PROGRAM), $(FILES))
    -
    -build: $(PROGRAM)
    -
    -clean:
    -	rm -f $(PROGRAM) *.{cmi,cmx,o,omc,opt}
    diff --git a/src/brief_handler.ml b/src/brief_handler.ml
    index 7822371..50a9c6c 100644
    --- a/src/brief_handler.ml
    +++ b/src/brief_handler.ml
    @@ -1,5 +1,5 @@
     open Core
    -open Async.Deferred.Let_syntax
    +open Async
     open Utils
     
     let config_file = Sys.(get_argv ()).(2)
    @@ -114,7 +114,7 @@ let t ~args = object (self)
           let html = Str.global_replace (Str.regexp "\n") "" html in (*remove newlines from html*)
           let has_match = Str.string_match (Str.regexp ".*
    ]*>\\([^<]+\\)<") html 0 in (*find the "code block" in the page*)
           if not has_match
    -      then (Printf.printf "Error: no '{code}' block found in %s" url; raise Not_found)
    +      then (printf "Error: no '{code}' block found in %s" url; raise Not_found)
           else
             try Str.matched_group 1 html
             with Not_found -> (debug "not found"; raise Not_found)
    @@ -239,7 +239,7 @@ let t ~args = object (self)
           printf "\n" (html_encode (Sexp.to_string (sexp_of_rows_t input_rows)));
           let%map extra_input_rows_from = (* list of rows_t *)
             let ids = Str.split (Str.regexp ",") params_add_rows_from in
    -        Async.Deferred.List.map ids ~f:(fun id-> get_input_rows_from_id id get_input_values)
    +        Deferred.List.map ids ~f:(fun id-> get_input_rows_from_id id get_input_values)
           in
             (*
           printf "\n" (html_encode (List.fold_left extra_input_rows_from ~init:"" ~f:(fun extra_input_row->(Sexp.to_string (sexp_of_rows_t extra_input_row)))));
    @@ -327,12 +327,12 @@ let t ~args = object (self)
           let%map a = Postgresql_async.exec_exn_get_all ~conn ~query in
           Array.to_list (Array.map a ~f:(fun x->x.(0)))
         in
    -    let soms_of_tc = Async.Deferred.Memo.general (module String) soms_of_tc in
    +    let soms_of_tc = Deferred.Memo.general (module String) soms_of_tc in
         let rec_of_som som_id =
           let query = sprintf "select som_name,tc_fqn,more_is_better,units,positive from soms where som_id='%s'" som_id in
           let%map r = Postgresql_async.exec_exn_get_all ~conn ~query in r.(0)
         in
    -    let rec_of_som = Async.Deferred.Memo.general (module String) rec_of_som in
    +    let rec_of_som = Deferred.Memo.general (module String) rec_of_som in
         let rec_of_som_id_n som_id n =
           let%map r = unstage(rec_of_som) som_id in r.(n) in
         let name_of_som som_id = rec_of_som_id_n som_id 0 in
    @@ -344,13 +344,13 @@ let t ~args = object (self)
           let%map a = Postgresql_async.exec_exn_get_all ~conn ~query in
           not @@ List.is_empty (Array.to_list a)
         in
    -    let has_table = Async.Deferred.Memo.general (module String) has_table in
    +    let has_table = Deferred.Memo.general (module String) has_table in
         let columns_of_table table_name =
           let query = sprintf "select column_name from information_schema.columns where table_name='%s'" table_name in
           let%map a = Postgresql_async.exec_exn_get_all ~conn ~query in
           Array.to_list (Array.map a ~f:(fun x->x.(0)))
         in
    -    let columns_of_table = Async.Deferred.Memo.general (module String) columns_of_table in
    +    let columns_of_table = Deferred.Memo.general (module String) columns_of_table in
         let contexts_of_som_id som_id =
           let%map cols = unstage(columns_of_table) (sprintf "som_config_%s" som_id) in
           (List.filter cols
    @@ -484,7 +484,7 @@ in
           (* add measurements for each one of the soms in the cell *)
           match get "soms" context with
           | Some som ->
    -        let%map r = Async.Deferred.List.map ~f:measurements_of_som som in
    +        let%map r = Deferred.List.map ~f:measurements_of_som som in
             List.concat r
           | None ->
             failwith (sprintf "Could not find 'soms' in context; keys are [%s]" (List.map ~f:fst context |> String.concat ~sep:", "));
    @@ -604,9 +604,9 @@ in
           x
         in
         let expand ctx = (*expand cell context into all possible context after expanding ctx templates into values*)
    -      Async.Deferred.List.fold ~init:[ctx]
    +      Deferred.List.fold ~init:[ctx]
             ~f:(fun rets expand_fn ->
    -            Async.Deferred.List.fold rets ~init:[] ~f:(fun acc ret->
    +            Deferred.List.fold rets ~init:[] ~f:(fun acc ret->
                     let%map r = expand_fn ret in acc@r))
             [
               expand_latest_build_of_branch; (* 1. value template: latest_in_branch *)
    @@ -677,14 +677,14 @@ in
               )
           in
     
    -      Async.Deferred.List.fold ~init:[] rows (* expand special row keys *) (*todo: this should also apply to columns *)
    +      Deferred.List.fold ~init:[] rows (* expand special row keys *) (*todo: this should also apply to columns *)
             ~f:(fun acc r-> 
                 let resolve_keywords_in_row acc r =
     
                   if List.exists r ~f:(fun (k,v)->String.(k="tcs")) then (* expand tcs into soms *)
    -                let%map r_expanded = Async.Deferred.List.concat_map r 
    +                let%map r_expanded = Deferred.List.concat_map r 
                         ~f:(fun (k,v)->match k with 
    -                        | _ when String.(k="tcs") -> (Async.Deferred.List.concat_map v ~f:(fun tc->
    +                        | _ when String.(k="tcs") -> (Deferred.List.concat_map v ~f:(fun tc->
                                 let%map r = unstage(soms_of_tc) tc in
                                 List.map r ~f:(fun som->("soms",[som]))))
                             | _ -> (k,v)::[] |> return
    @@ -700,8 +700,8 @@ in
     
                   else if List.exists r ~f:(fun (k,_)->String.(k=k_add_rows_from)) then (* add rows from other brief ids *)
                     let bs = List.filter r ~f:(fun (k,_)->String.(k=k_add_rows_from)) in (* use all references. TODO: what to do with non-references in the same row??? *)
    -                let%map r = Async.Deferred.List.concat_map bs ~f:(fun (k,vs)-> (* map one r into many potential rows *)
    -                    Async.Deferred.List.concat_map vs ~f:(fun v->  (* map one vs into many potential rows *)
    +                let%map r = Deferred.List.concat_map bs ~f:(fun (k,vs)-> (* map one r into many potential rows *)
    +                    Deferred.List.concat_map vs ~f:(fun v->  (* map one vs into many potential rows *)
                             let%bind xs = get_input_rows_from_id v get_input_values in (* resolve each new row recursively if necessary *)
                             let%map ys = resolve_keywords xs in
                 (*
    @@ -774,14 +774,14 @@ in
         progress (sprintf "table: %d lines: " (List.length rs));
         let ctx_and_measurements_of_1st_cell_with_data expand_f ctx =
           let%bind ctxs = expand_f ctx in
    -      let measurements_of_cells = Async.Deferred.List.find_map ctxs ~f:(fun c->let%map ms=measurements_of_cell c in if List.is_empty ms then None else (Some (c,ms))) in
    +      let measurements_of_cells = Deferred.List.find_map ctxs ~f:(fun c->let%map ms=measurements_of_cell c in if List.is_empty ms then None else (Some (c,ms))) in
           match%map measurements_of_cells with None->ctx,[]|Some (c,ms)->c,ms
         in
         let%bind measurements_of_table =
           let rs_len = List.length rs in
    -      Async.Deferred.List.mapi rs ~f:(fun i r->
    +      Deferred.List.mapi rs ~f:(fun i r->
               progress (sprintf "row %d of %d..." i rs_len);
    -          let%map csr = Async.Deferred.List.map cs ~f:(fun c->
    +          let%map csr = Deferred.List.map cs ~f:(fun c->
                   let%map ctx, ms = ctx_and_measurements_of_1st_cell_with_data expand (context_of b r c) in
                   (r, c, ctx,  ms)
                 ) in r, csr
    @@ -989,9 +989,9 @@ in
               )
           in
           let str_desc_of_ctxs kvs =
    -        Async.Deferred.List.fold kvs ~init:"" ~f:(fun acc (k,vs)->
    +        Deferred.List.fold kvs ~init:"" ~f:(fun acc (k,vs)->
                 if String.(k<>"soms") then return acc else
    -              let%map r = Async.Deferred.List.fold vs ~init:"" ~f:(fun acc2 som->
    +              let%map r = Deferred.List.fold vs ~init:"" ~f:(fun acc2 som->
                       let%bind tc = tc_of_som som in
                       let%bind u = unit_of_som som in
                       let%bind mb = more_is_better_of_som som in
    @@ -1041,7 +1041,7 @@ in
           let%bind cells = List.map2_exn table link_ctxs ~f:(fun (r,cs) lnkctx ->
               let%bind str_desc = str_desc_of_ctxs r in
               let%map lst =
    -            Async.Deferred.List.mapi cs ~f:(fun i (r,c,ctx,ms)->
    +            Deferred.List.mapi cs ~f:(fun i (r,c,ctx,ms)->
                     let _,_,_,baseline_ms = List.nth_exn cs baseline_col_idx in
                     let debug_r = Sexp.to_string (sexp_of_ctx_t r)
                     and debug_c = Sexp.to_string (sexp_of_ctx_t c)
    @@ -1082,7 +1082,7 @@ in
                 (link lnkctx)
                 (* cells to the right *)
                 cells
    -        ) |> Async.Deferred.List.all in
    +        ) |> Deferred.List.all in
           let html_table =
             sprintf " %s\n%s%s%s"
               num_columns
    @@ -1145,10 +1145,10 @@ in
               )
           in
           let str_desc_of_ctxs kvs =
    -        Async.Deferred.List.fold kvs ~init:"" ~f:(fun acc (k,vs)->
    +        Deferred.List.fold kvs ~init:"" ~f:(fun acc (k,vs)->
                 if String.(k<>"soms") then return acc else
                   let%map r =
    -                Async.Deferred.List.fold vs ~init:"" ~f:(fun acc2 som->
    +                Deferred.List.fold vs ~init:"" ~f:(fun acc2 som->
                         let%bind tc = tc_of_som som in
                         let%bind name = name_of_som som in
                         let%bind u = unit_of_som som in
    @@ -1201,7 +1201,7 @@ in
             (List.map2_exn table link_ctxs ~f:(fun (r,cs) lnkctx ->
                  let%bind str_desc = str_desc_of_ctxs r in
                  let%map cells =
    -               Async.Deferred.List.mapi cs ~f:(fun i (r,c,ctx,ms)->
    +               Deferred.List.mapi cs ~f:(fun i (r,c,ctx,ms)->
                        let _,_,_,baseline_ms = List.nth_exn cs baseline_col_idx in
                        let%map is_mb = is_more_is_better ctx in
                   (*
    @@ -1235,7 +1235,7 @@ in
                    (* cells to the right *)
                    (List.fold_left ~init:"" ~f:(fun acc c_ms->(sprintf "%s %s | " acc c_ms)) cells)
                ))
    -        |> Async.Deferred.List.all
    +        |> Deferred.List.all
           in
           let wiki_table =
             sprintf "| %s|\n%s%s\n%s"
    
    From e81d0b7a0f6482d27d47bc98e379c0010e0a737e Mon Sep 17 00:00:00 2001
    From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= 
    Date: Sun, 1 Dec 2019 18:56:56 +0000
    Subject: [PATCH 18/36] Handle nested includes from suite definitions
    MIME-Version: 1.0
    Content-Type: text/plain; charset=UTF-8
    Content-Transfer-Encoding: 8bit
    
    a suite can include quebec.inc, which includes perf_release.inc.
    The latter defines the debian/centos distro that we use, so we must
    expand nested includes.
    
    Signed-off-by: Edwin Török 
    ---
     src/brief_handler.ml | 32 +++++++++++++++++++-------------
     src/dune             |  2 +-
     2 files changed, 20 insertions(+), 14 deletions(-)
    
    diff --git a/src/brief_handler.ml b/src/brief_handler.ml
    index 50a9c6c..52e1348 100644
    --- a/src/brief_handler.ml
    +++ b/src/brief_handler.ml
    @@ -127,7 +127,15 @@ let t ~args = object (self)
           let url = sprintf "https://code.citrite.net/projects/XRT/repos/xenrt/raw/suites/%s?at=%s" id (Uri.pct_encode branch) in
           debug (sprintf "Fetching from suite %s" url);
           html_of_url url, url in
    -    let fetch_parameters_from inc ~branch =
    +    let pattern = Str.regexp "\\([^=]+\\)=\\([^<]+\\)" in
    +    let include_rex = Str.regexp "\\([^=]+\\)=\\([^<]+\\)" in
    +      let includes = includes html ~branch in
           let rage_str = ref [] in
           let f str = rage_str := (Str.matched_group 1 str, Str.matched_group 2 str) :: !rage_str; "" in
           ignore (Str.global_substitute pattern f html);
    -      List.rev !rage_str
    +      List.rev !rage_str |> List.append includes
    +    and includes html ~branch =
    +      let r = find_matches html include_rex |> List.map ~f:(fetch_parameters_from ~branch) |>
    +      List.concat in
    +      debug (sprintf "include parameters: %s"
    +               (List.map ~f:(fun (k,v) -> sprintf "%s=%s" k v) r |> String.concat ~sep:","));
    +      r
         in
         let fetch_brief_params_from_suite ?(branch="refs/heads/master") id =
           let html, url = fetch_suite id branch in
           let html = Str.global_replace (Str.regexp "\n") "" html in (*remove newlines from html*)
    -      let find_matches rex =
    -        let rage_str = ref [] in
    -        let f str = rage_str := (Str.matched_group 1 str) :: !rage_str; "" in
    -        ignore (Str.global_substitute rex f html);
    -        List.rev !rage_str
    -      in
    +      let find_matches = find_matches html in
           (* Look for  comments and concatenate their contents *)
           let pattern = Str.regexp "" in
           let rows = find_matches pattern |> String.concat ~sep:"\n" in
    -      let include_rex = Str.regexp " List.map ~f:(fetch_parameters_from ~branch) |> List.concat in
    -      debug (sprintf "include parameters: %s"
    -               (List.map ~f:(fun (k,v) -> sprintf "%s=%s" k v) includes |> String.concat ~sep:","));
    +      let includes = includes html ~branch in
           let lookup k =
             if String.(uppercase k = k) then
               match List.Assoc.find ~equal:String.equal includes k with
    diff --git a/src/dune b/src/dune
    index 0436a76..2365eed 100644
    --- a/src/dune
    +++ b/src/dune
    @@ -5,4 +5,4 @@
       (:standard -principal -short-paths))
      (preprocess
       (pps ppx_sexp_conv ppx_let))
    - (libraries threads.posix core postgresql curl async sql uri str))
    + (libraries threads.posix core postgresql curl async sql uri str re))
    
    From 2130144a221e9f1350b080d8b16129f6508743ea Mon Sep 17 00:00:00 2001
    From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= 
    Date: Sun, 1 Dec 2019 19:21:26 +0000
    Subject: [PATCH 19/36] Parallelize more queries
    MIME-Version: 1.0
    Content-Type: text/plain; charset=UTF-8
    Content-Transfer-Encoding: 8bit
    
    Signed-off-by: Edwin Török 
    ---
     src/brief_handler.ml       | 83 ++++++++++++++------------------------
     src/import_jobs_handler.ml |  1 -
     src/som_data_handler.ml    | 68 ++++++++++++++++---------------
     src/som_page_handler.ml    | 57 ++++++++++++++------------
     src/std_axes_handler.ml    |  4 +-
     5 files changed, 98 insertions(+), 115 deletions(-)
    
    diff --git a/src/brief_handler.ml b/src/brief_handler.ml
    index 52e1348..f1c79c5 100644
    --- a/src/brief_handler.ml
    +++ b/src/brief_handler.ml
    @@ -133,8 +133,8 @@ let t ~args = object (self)
           let rage_str = ref [] in
           let f str = rage_str := (Str.matched_group 1 str) :: !rage_str; "" in
           ignore (Str.global_substitute rex f html);
    -        List.rev !rage_str
    -      in
    +      List.rev !rage_str
    +    in
         let rec fetch_parameters_from inc ~branch =
           let b = Buffer.create 80 in
           let lookup var =
    @@ -153,7 +153,7 @@ let t ~args = object (self)
           List.rev !rage_str |> List.append includes
         and includes html ~branch =
           let r = find_matches html include_rex |> List.map ~f:(fetch_parameters_from ~branch) |>
    -      List.concat in
    +              List.concat in
           debug (sprintf "include parameters: %s"
                    (List.map ~f:(fun (k,v) -> sprintf "%s=%s" k v) r |> String.concat ~sep:","));
           r
    @@ -245,7 +245,7 @@ let t ~args = object (self)
           printf "\n" (html_encode (Sexp.to_string (sexp_of_rows_t input_rows)));
           let%map extra_input_rows_from = (* list of rows_t *)
             let ids = Str.split (Str.regexp ",") params_add_rows_from in
    -        Deferred.List.map ids ~f:(fun id-> get_input_rows_from_id id get_input_values)
    +        Deferred.List.map ~how:`Parallel ids ~f:(fun id-> get_input_rows_from_id id get_input_values)
           in
             (*
           printf "\n" (html_encode (List.fold_left extra_input_rows_from ~init:"" ~f:(fun extra_input_row->(Sexp.to_string (sexp_of_rows_t extra_input_row)))));
    @@ -369,38 +369,20 @@ let t ~args = object (self)
              ~f:(fun e->String.(e<>"tc_config_id"))
           )
         in
    +    let url_of_t t =
    +      let query = sprintf "select url from tiny_urls where key=%s" t in
    +      let%map r = Postgresql_async.exec_exn_get_all ~conn ~query in r.(0).(0)
    +    in
         let%bind contexts_of_tc =
           let%map cols = unstage(columns_of_table) "tc_config" in
           (List.filter cols
              ~f:(fun e->not (List.mem ~equal:String.equal ["tc_fqn";"tc_config_id";"machine_id"] e))
           )
    -    in
    -    let url_of_t t =
    -      let query = sprintf "select url from tiny_urls where key=%s" t in
    -      let%map r = Postgresql_async.exec_exn_get_all ~conn ~query in r.(0).(0)
    -    in
    -    (*
    -    let all_contexts_of_tc tc_fqn =
    -      let tc_contexts = 
    -        (List.filter
    -          (columns_of_table "tc_config")
    -          ~f:(fun e->not (List.mem ~equal:String.equal e ["tc_fqn";"tc_config_id";"machine_id"]))
    -        )@
    -        (List.filter
    -          (columns_of_table (sprintf "tc_config_%d" tc_fqn))
    -          ~f:(fun e->e<>"tc_config_id")
    -        )
    -    in
    -      List.map
    -        (List.map (soms_of_tc tc_id) ~f:contexts_of_som)
    -        ~f:(fun som_contexts->tc_contexts @ som_contexts)
    -in
    -    *)
    -    let%bind contexts_of_machine =
    +    and contexts_of_machine =
           let%map cols = unstage(columns_of_table) "machines" in
           List.filter cols
    -        ~f:(fun e->String.(e<>"machine_id")) in
    -    let%bind contexts_of_build =
    +        ~f:(fun e->String.(e<>"machine_id"))
    +    and contexts_of_build =
           let%map cols = unstage(columns_of_table) "builds" in
           List.filter cols
             ~f:(fun e->String.(e<>"build_id")) in
    @@ -429,9 +411,9 @@ in
         let measurements_of_cell context = 
           let get e ctx = List.Assoc.find ~equal:String.equal ctx e in
           let measurements_of_som som_id =
    -        let%bind has_table_som_id = unstage(has_table) (sprintf "som_config_%s" som_id) in
    -        let%bind tc_fqn = tc_of_som som_id in
    -        let%bind contexts_of_this_som_id = contexts_of_som_id som_id in
    +        let%bind has_table_som_id = unstage(has_table) (sprintf "som_config_%s" som_id)
    +        and tc_fqn = tc_of_som som_id
    +        and contexts_of_this_som_id = contexts_of_som_id som_id in
             let%bind contexts_of_this_tc_fqn = contexts_of_tc_fqn tc_fqn in
             let query = "select sj.job_id, m.result from measurements_2 m join soms_jobs sj on m.som_job_id=sj.id "
                         ^(sprintf "join tc_config_%s on m.tc_config_id=tc_config_%s.tc_config_id " tc_fqn tc_fqn)
    @@ -490,8 +472,7 @@ in
           (* add measurements for each one of the soms in the cell *)
           match get "soms" context with
           | Some som ->
    -        let%map r = Deferred.List.map ~f:measurements_of_som som in
    -        List.concat r
    +        Deferred.List.concat_map ~how:`Parallel ~f:measurements_of_som som
           | None ->
             failwith (sprintf "Could not find 'soms' in context; keys are [%s]" (List.map ~f:fst context |> String.concat ~sep:", "));
         in
    @@ -709,11 +690,7 @@ in
                     let%map r = Deferred.List.concat_map bs ~f:(fun (k,vs)-> (* map one r into many potential rows *)
                         Deferred.List.concat_map vs ~f:(fun v->  (* map one vs into many potential rows *)
                             let%bind xs = get_input_rows_from_id v get_input_values in (* resolve each new row recursively if necessary *)
    -                        let%map ys = resolve_keywords xs in
    -            (*
    -                 printf "
    v=%s
    xs=%s
    r=%s
    acc=%s
    ys=%s" v (Sexp.to_string (sexp_of_rows_t xs)) (Sexp.to_string (sexp_of_ctx_t r)) (Sexp.to_string (sexp_of_cols_t acc)) (Sexp.to_string (sexp_of_rows_t ys)); - *) - ys + resolve_keywords xs ) ) in acc @ r @@ -785,9 +762,9 @@ in in let%bind measurements_of_table = let rs_len = List.length rs in - Deferred.List.mapi rs ~f:(fun i r-> + Deferred.List.mapi ~how:`Parallel rs ~f:(fun i r-> progress (sprintf "row %d of %d..." i rs_len); - let%map csr = Deferred.List.map cs ~f:(fun c-> + let%map csr = Deferred.List.map ~how:`Parallel cs ~f:(fun c-> let%map ctx, ms = ctx_and_measurements_of_1st_cell_with_data expand (context_of b r c) in (r, c, ctx, ms) ) in r, csr @@ -998,10 +975,10 @@ in Deferred.List.fold kvs ~init:"" ~f:(fun acc (k,vs)-> if String.(k<>"soms") then return acc else let%map r = Deferred.List.fold vs ~init:"" ~f:(fun acc2 som-> - let%bind tc = tc_of_som som in - let%bind u = unit_of_som som in - let%bind mb = more_is_better_of_som som in - let%map name = name_of_som som in + let%map tc = tc_of_som som + and u = unit_of_som som + and mb = more_is_better_of_som som + and name = name_of_som som in let s=sprintf "%s: %s (%s%s)" tc name (if String.(u="") then u else u^", ") (sprintf "%s is better" (if String.(mb="") then "none" else if String.(mb="f") then "less" else "more")) in if String.(acc="") then s else acc^","^s ) in @@ -1045,9 +1022,9 @@ in in let num_columns = (List.length cs) + 3 in let%bind cells = List.map2_exn table link_ctxs ~f:(fun (r,cs) lnkctx -> - let%bind str_desc = str_desc_of_ctxs r in - let%map lst = - Deferred.List.mapi cs ~f:(fun i (r,c,ctx,ms)-> + let%map str_desc = str_desc_of_ctxs r + and lst = + Deferred.List.mapi ~how:`Parallel cs ~f:(fun i (r,c,ctx,ms)-> let _,_,_,baseline_ms = List.nth_exn cs baseline_col_idx in let debug_r = Sexp.to_string (sexp_of_ctx_t r) and debug_c = Sexp.to_string (sexp_of_ctx_t c) @@ -1155,10 +1132,10 @@ in if String.(k<>"soms") then return acc else let%map r = Deferred.List.fold vs ~init:"" ~f:(fun acc2 som-> - let%bind tc = tc_of_som som in - let%bind name = name_of_som som in - let%bind u = unit_of_som som in - let%map mbstr = + let%map tc = tc_of_som som + and name = name_of_som som + and u = unit_of_som som + and mbstr = let%map mb=more_is_better_of_som som in if String.(mb="") then "none" else if String.(mb="f") then "less" else "more" in let s=sprintf "%s: *%s* (%s%s)" tc name (if String.(u="") then u else u^", ") (sprintf "%s is better" mbstr) in @@ -1207,7 +1184,7 @@ in (List.map2_exn table link_ctxs ~f:(fun (r,cs) lnkctx -> let%bind str_desc = str_desc_of_ctxs r in let%map cells = - Deferred.List.mapi cs ~f:(fun i (r,c,ctx,ms)-> + Deferred.List.mapi ~how:`Parallel cs ~f:(fun i (r,c,ctx,ms)-> let _,_,_,baseline_ms = List.nth_exn cs baseline_col_idx in let%map is_mb = is_more_is_better ctx in (* diff --git a/src/import_jobs_handler.ml b/src/import_jobs_handler.ml index ae3296a..21b58ec 100644 --- a/src/import_jobs_handler.ml +++ b/src/import_jobs_handler.ml @@ -1,5 +1,4 @@ open Core -open Async open Utils let importer = "/usr/groups/perfeng/bin/importer-xenrt" diff --git a/src/som_data_handler.ml b/src/som_data_handler.ml index b1bc305..aa03e07 100644 --- a/src/som_data_handler.ml +++ b/src/som_data_handler.ml @@ -82,14 +82,14 @@ let t ~args = object (self) method private write_body = let som_id = int_of_string (self#get_param_exn "id") in - let%bind tc_fqn, tc_config_tbl = get_tc_config_tbl_name conn som_id in - let%bind som_config_tbl, som_tbl_exists = som_config_tbl_exists ~conn som_id in + let%bind tc_fqn, tc_config_tbl = get_tc_config_tbl_name conn som_id + and som_config_tbl, som_tbl_exists = som_config_tbl_exists ~conn som_id in (* determine filter columns and their types *) let tbls = ["measurements_2"; "soms_jobs"; "jobs"; "builds"; "tc_config"; "machines"; tc_config_tbl] @ (if som_tbl_exists then [som_config_tbl] else []) in - let%bind col_fqns = get_column_fqns_many conn tbls in - let%bind col_types = get_column_types_many conn tbls in + let%bind col_fqns = get_column_fqns_many conn tbls + and col_types = get_column_types_many conn tbls in (* Get axes selections. xaxis may be multi-valued; yaxis is single value. *) let xaxis = self#values_for_key "xaxis" ~default:["branch"] in (* xaxis could be ["one"; "two"] or ["one%2Ctwo"] -- both are equivalent *) @@ -113,38 +113,40 @@ let t ~args = object (self) let xaxis_str = String.concat ~sep:"," xaxis in let keys = xaxis_str :: [yaxis] @ xaxis @ restkeys in let filter = extract_filter col_fqns col_types params values_prefix in - (* obtain SOM meta-data *) - let query = sprintf "SELECT positive FROM soms WHERE som_id=%d" som_id in - let%bind metadata = Postgresql_async.exec_exn ~conn ~query in - let positive = String.(Sql.get_first_entry_exn ~result:metadata = "t") in - (* obtain data from database *) - let query = - "SELECT " ^ - (String.concat ~sep:"||','||" xaxisfqns) ^ ", " ^ (* x-axis *) - yaxisfqns ^ ", " ^ (* y-axis *) - (String.concat ~sep:", " xaxisfqns) ^ (* components of x-axis, needed in case we split by one of them *) - (if List.is_empty restfqns then " " else sprintf ", %s " (String.concat ~sep:", " restfqns)) ^ - (sprintf "FROM %s " (String.concat ~sep:", " tbls)) ^ - (sprintf "WHERE measurements_2.tc_config_id=%s.tc_config_id " - tc_config_tbl) ^ - (sprintf "AND soms_jobs.som_id=%d " som_id) ^ - "AND soms_jobs.job_id=jobs.job_id " ^ - "AND measurements_2.som_job_id=soms_jobs.id "^ - "AND jobs.build_id=builds.build_id " ^ - "AND tc_config.job_id=jobs.job_id " ^ - (sprintf "AND tc_config.tc_fqn='%s' " tc_fqn) ^ - "AND tc_config.tc_config_id=measurements_2.tc_config_id " ^ - "AND tc_config.machine_id=machines.machine_id" ^ - (if som_tbl_exists - then sprintf " AND measurements_2.som_config_id=%s.som_config_id" - som_config_tbl else "") ^ - (if not (String.is_empty filter) then sprintf " AND %s" filter else "") ^ - (sprintf " LIMIT %d" limit_rows) - in - let%bind data = Postgresql_async.exec_exn ~conn ~query in + let%bind metadata = + (* obtain SOM meta-data *) + let query = sprintf "SELECT positive FROM soms WHERE som_id=%d" som_id in + Postgresql_async.exec_exn ~conn ~query + and data = + (* obtain data from database *) + let query = + "SELECT " ^ + (String.concat ~sep:"||','||" xaxisfqns) ^ ", " ^ (* x-axis *) + yaxisfqns ^ ", " ^ (* y-axis *) + (String.concat ~sep:", " xaxisfqns) ^ (* components of x-axis, needed in case we split by one of them *) + (if List.is_empty restfqns then " " else sprintf ", %s " (String.concat ~sep:", " restfqns)) ^ + (sprintf "FROM %s " (String.concat ~sep:", " tbls)) ^ + (sprintf "WHERE measurements_2.tc_config_id=%s.tc_config_id " + tc_config_tbl) ^ + (sprintf "AND soms_jobs.som_id=%d " som_id) ^ + "AND soms_jobs.job_id=jobs.job_id " ^ + "AND measurements_2.som_job_id=soms_jobs.id "^ + "AND jobs.build_id=builds.build_id " ^ + "AND tc_config.job_id=jobs.job_id " ^ + (sprintf "AND tc_config.tc_fqn='%s' " tc_fqn) ^ + "AND tc_config.tc_config_id=measurements_2.tc_config_id " ^ + "AND tc_config.machine_id=machines.machine_id" ^ + (if som_tbl_exists + then sprintf " AND measurements_2.som_config_id=%s.som_config_id" + som_config_tbl else "") ^ + (if not (String.is_empty filter) then sprintf " AND %s" filter else "") ^ + (sprintf " LIMIT %d" limit_rows) + in + Postgresql_async.exec_exn ~conn ~query in let rows = data#get_all in debug (sprintf "The query returned %d rows" (Array.length rows)); (if Array.length rows = limit_rows then debug (sprintf "WARNING: truncation of data -- we are only returning the first %d rows" limit_rows)); + let positive = String.(Sql.get_first_entry_exn ~result:metadata = "t") in (* filter data into groups based on "SPLIT BY"-s *) let split_bys = self#select_params filter_prefix ~value:(Some filter_by_value) in diff --git a/src/som_page_handler.ml b/src/som_page_handler.ml index cca05d1..7f3e6cc 100644 --- a/src/som_page_handler.ml +++ b/src/som_page_handler.ml @@ -43,7 +43,7 @@ let t ~args = object (self) let machine_options_lst = options_lst_of_dbresult machines in - let%map config_options_lst = Deferred.List.map config_column_names ~f:(fun config_name -> + let%map config_options_lst = Deferred.List.map ~how:`Parallel config_column_names ~f:(fun config_name -> let query = sprintf "SELECT DISTINCT %s FROM %s ORDER BY %s" config_name tc_config_tbl config_name in let%map configs = Postgresql_async.exec_exn ~conn ~query in get_options_for_field_once configs 0 @@ -76,41 +76,46 @@ let t ~args = object (self) method private write_body = let som_id = int_of_string (List.Assoc.find_exn ~equal:String.equal params "som") in - let%bind _, tc_config_tbl = get_tc_config_tbl_name conn som_id in - let query = - sprintf "SELECT * FROM soms WHERE som_id=%d" som_id in - let%bind som_info = - Postgresql_async.exec_exn ~conn ~query in - let query = "SELECT * FROM " ^ tc_config_tbl ^ " LIMIT 0" in - let%bind config_columns = Postgresql_async.exec_exn ~conn ~query in - let job_fields = String.concat ~sep:", " Utils.job_fields in - let query = "SELECT DISTINCT " ^ job_fields ^ " FROM soms_jobs WHERE " ^ + let%bind _, tc_config_tbl = get_tc_config_tbl_name conn som_id + and som_info = + let query = + sprintf "SELECT * FROM soms WHERE som_id=%d" som_id in + Postgresql_async.exec_exn ~conn ~query + and job_ids = + let job_fields = String.concat ~sep:", " Utils.job_fields in + let query = "SELECT DISTINCT " ^ job_fields ^ " FROM soms_jobs WHERE " ^ (sprintf "som_id=%d" som_id) in - let%bind job_ids = Postgresql_async.exec_exn ~conn ~query in - let build_fields = String.concat ~sep:", " Utils.build_fields in - let query = - "SELECT DISTINCT " ^ build_fields ^ " " ^ + Postgresql_async.exec_exn ~conn ~query + and builds = + let build_fields = String.concat ~sep:", " Utils.build_fields in + let query = + "SELECT DISTINCT " ^ build_fields ^ " " ^ (sprintf "FROM builds AS b, jobs AS j, (select distinct job_id from soms_jobs where som_id=%d) AS m " som_id) ^ "WHERE m.job_id=j.job_id AND j.build_id=b.build_id " - in - let%bind builds = Postgresql_async.exec_exn ~conn ~query in - let query = "SELECT DISTINCT " ^ (String.concat ~sep:", " Utils.tc_config_fields) ^ " " ^ + in + Postgresql_async.exec_exn ~conn ~query + and job_attributes = + let query = "SELECT DISTINCT " ^ (String.concat ~sep:", " Utils.tc_config_fields) ^ " " ^ (sprintf "FROM tc_config AS c, jobs AS j, (select distinct job_id from soms_jobs where som_id=%d) AS m " som_id) ^ "WHERE m.job_id=j.job_id AND j.job_id=c.job_id " - in - let%bind job_attributes = Postgresql_async.exec_exn ~conn ~query in - let%bind som_config_tbl, som_tbl_exists = som_config_tbl_exists ~conn som_id in + in + Postgresql_async.exec_exn ~conn ~query + and som_config_tbl, som_tbl_exists = som_config_tbl_exists ~conn som_id + and machines = + let query = + "SELECT DISTINCT machine_name, machine_type, cpu_model, number_of_cpus " ^ + (sprintf "FROM machines AS mn, tc_config AS c, (select distinct job_id from soms_jobs where som_id=%d) AS mr " som_id) ^ + "WHERE mn.machine_id=c.machine_id AND c.job_id=mr.job_id " + in + Postgresql_async.exec_exn ~conn ~query in let%bind som_configs_opt = if not som_tbl_exists then return None else let query = sprintf "SELECT * FROM %s" som_config_tbl in let%map r = Postgresql_async.exec_exn ~conn ~query in Some r + and config_columns = + let query = "SELECT * FROM " ^ tc_config_tbl ^ " LIMIT 0" in + Postgresql_async.exec_exn ~conn ~query in - let query = - "SELECT DISTINCT machine_name, machine_type, cpu_model, number_of_cpus " ^ - (sprintf "FROM machines AS mn, tc_config AS c, (select distinct job_id from soms_jobs where som_id=%d) AS mr " som_id) ^ - "WHERE mn.machine_id=c.machine_id AND c.job_id=mr.job_id " - in - let%bind machines = Postgresql_async.exec_exn ~conn ~query in printf "
    \n"; printf "\n
    \n"; self#write_som_info som_info; diff --git a/src/std_axes_handler.ml b/src/std_axes_handler.ml index 90fd0ba..7dff9b6 100644 --- a/src/std_axes_handler.ml +++ b/src/std_axes_handler.ml @@ -20,8 +20,8 @@ let t ~args = object (self) "result" :: r method private write_body = - let%bind std_x_axes = self#get_std_x_choices in - let%bind std_y_axes = self#get_std_y_choices in + let%bind std_x_axes = self#get_std_x_choices + and std_y_axes = self#get_std_y_choices in let string_of_axes choices = let quoted = List.map ~f:(fun c -> "\"" ^ c ^ "\"") choices in sprintf "[%s]" (String.concat ~sep:"," quoted) From 2210dd4fc27c50be4de430b92910c111cde2ab58 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Sun, 1 Dec 2019 20:04:21 +0000 Subject: [PATCH 20/36] Parallelize more queries MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- src/brief_handler.ml | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index f1c79c5..b458b99 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -974,15 +974,13 @@ in let str_desc_of_ctxs kvs = Deferred.List.fold kvs ~init:"" ~f:(fun acc (k,vs)-> if String.(k<>"soms") then return acc else - let%map r = Deferred.List.fold vs ~init:"" ~f:(fun acc2 som-> + let%map lst = Deferred.List.map ~how:`Parallel vs ~f:(fun som-> let%map tc = tc_of_som som and u = unit_of_som som and mb = more_is_better_of_som som and name = name_of_som som in - let s=sprintf "%s: %s (%s%s)" tc name (if String.(u="") then u else u^", ") (sprintf "%s is better" (if String.(mb="") then "none" else if String.(mb="f") then "less" else "more")) in - if String.(acc="") then s else acc^","^s - ) in - (sprintf "%s %s
    \n" acc r) + sprintf "%s: %s (%s%s)" tc name (if String.(u="") then u else u^", ") (sprintf "%s is better" (if String.(mb="") then "none" else if String.(mb="f") then "less" else "more"))) in + (sprintf "%s %s
    \n" acc (String.concat ~sep:"," lst)) ) in let link ctx = From cfaab552a58a0acf5b8ac7a0692e80a26ca710af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Sun, 1 Dec 2019 20:24:16 +0000 Subject: [PATCH 21/36] parallelize more queries and https queries too MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Especially with nested includes we need to fetch quite a few files, so parallelize where possible. OpenSSL is not thread safe by default, so we have to initialize threading mode before using it. (We don't use it directly, but through curl) Signed-off-by: Edwin Török --- dune-project | 1 + rage.opam | 1 + src/brief_handler.ml | 59 ++++++++++++++++++++++++-------------------- src/dune | 2 +- 4 files changed, 35 insertions(+), 28 deletions(-) diff --git a/dune-project b/dune-project index 8315396..9c347e7 100644 --- a/dune-project +++ b/dune-project @@ -11,6 +11,7 @@ (async (>= v0.13)) (postgresql (>= 4.5.2)) (ocurl (>= 0.9.0)) + ssl ppx_sexp_conv re uri)) diff --git a/rage.opam b/rage.opam index 136b4a8..a288f6e 100644 --- a/rage.opam +++ b/rage.opam @@ -10,6 +10,7 @@ depends: [ "async" {>= "v0.13"} "postgresql" {>= "4.5.2"} "ocurl" {>= "0.9.0"} + "ssl" "ppx_sexp_conv" "re" "uri" diff --git a/src/brief_handler.ml b/src/brief_handler.ml index b458b99..e6f6f37 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -2,6 +2,12 @@ open Core open Async open Utils +let () = Ssl_threads.init () +let () = + Shutdown.at_shutdown (fun () -> + Curl.global_cleanup(); + return ()) + let config_file = Sys.(get_argv ()).(2) let config = @@ -96,21 +102,21 @@ let t ~args = object (self) (* extra input from urls *) let is_digit id = Str.string_match (Str.regexp "[0-9]+") id 0 in let html_of_url url = - try - let conn = Curl.init() and write_buff = Buffer.create 16384 in - Curl.set_writefunction conn (fun x->Buffer.add_string write_buff x; String.length x); - Curl.set_url conn url; - Curl.set_username conn rage_username; - Curl.set_password conn rage_password; - Curl.perform conn; - Curl.cleanup conn; - Curl.global_cleanup(); - Buffer.contents write_buff; - with _ -> sprintf "error fetching url %s" url + In_thread.run ~name:"Fetch url" (fun () -> + try + let conn = Curl.init() and write_buff = Buffer.create 16384 in + Curl.set_writefunction conn (fun x->Buffer.add_string write_buff x; String.length x); + Curl.set_url conn url; + Curl.set_username conn rage_username; + Curl.set_password conn rage_password; + Curl.perform conn; + Curl.cleanup conn; + Buffer.contents write_buff; + with _ -> sprintf "error fetching url %s" url) in let fetch_brief_params_from_url url = (* simple fetch using confluence page with brief_params inside the "code block" macro in the page *) - let html = html_of_url url in + let%map html = html_of_url url in let html = Str.global_replace (Str.regexp "\n") "" html in (*remove newlines from html*) let has_match = Str.string_match (Str.regexp ".*
    ]*>\\([^<]+\\)<") html 0 in (*find the "code block" in the page*)
           if not has_match
    @@ -126,7 +132,7 @@ let t ~args = object (self)
         let fetch_suite id branch =
           let url = sprintf "https://code.citrite.net/projects/XRT/repos/xenrt/raw/suites/%s?at=%s" id (Uri.pct_encode branch) in
           debug (sprintf "Fetching from suite %s" url);
    -      html_of_url url, url in
    +      let%map r = html_of_url url in r, url in
         let pattern = Str.regexp "\\([^=]+\\)=\\([^<]+\\)" in
         let include_rex = Str.regexp " List.append includes
         and includes html ~branch =
    -      let r = find_matches html include_rex |> List.map ~f:(fetch_parameters_from ~branch) |>
    -              List.concat in
    +      let%map r = find_matches html include_rex
    +                  |> Deferred.List.concat_map ~how:`Parallel ~f:(fetch_parameters_from ~branch) in
           debug (sprintf "include parameters: %s"
                    (List.map ~f:(fun (k,v) -> sprintf "%s=%s" k v) r |> String.concat ~sep:","));
           r
         in
         let fetch_brief_params_from_suite ?(branch="refs/heads/master") id =
    -      let html, url = fetch_suite id branch in
    +      let%bind html, url = fetch_suite id branch in
           let html = Str.global_replace (Str.regexp "\n") "" html in (*remove newlines from html*)
           let find_matches = find_matches html in
           (* Look for  comments and concatenate their contents *)
           let pattern = Str.regexp "" in
           let rows = find_matches pattern |> String.concat ~sep:"\n" in
    -      let includes = includes html ~branch in
    +      let%map includes = includes html ~branch in
           let lookup k =
             if String.(uppercase k = k) then
               match List.Assoc.find ~equal:String.equal includes k with
    @@ -182,12 +188,12 @@ let t ~args = object (self)
         in
         let fetch_brief_params_from id =
           let xs = if is_digit id then fetch_brief_params_from_db id
    -        else return @@ if String.is_prefix id ~prefix:"TC-" then (
    -            match String.split ~on:'#' id with
    -            | [id; branch] -> fetch_brief_params_from_suite ~branch id
    -            | [id] -> fetch_brief_params_from_suite id
    -            | _ -> failwith (sprintf "unparseable id '%s'" id)
    -          ) else fetch_brief_params_from_url id
    +        else if String.is_prefix id ~prefix:"TC-" then (
    +          match String.split ~on:'#' id with
    +          | [id; branch] -> fetch_brief_params_from_suite ~branch id
    +          | [id] -> fetch_brief_params_from_suite id
    +          | _ -> failwith (sprintf "unparseable id '%s'" id)
    +        ) else fetch_brief_params_from_url id
           in
           (*printf "fetch_brief_params_from %s =
    %s" id xs;*) xs @@ -593,8 +599,7 @@ in let expand ctx = (*expand cell context into all possible context after expanding ctx templates into values*) Deferred.List.fold ~init:[ctx] ~f:(fun rets expand_fn -> - Deferred.List.fold rets ~init:[] ~f:(fun acc ret-> - let%map r = expand_fn ret in acc@r)) + Deferred.List.concat_map rets ~how:`Parallel ~f:expand_fn) [ expand_latest_build_of_branch; (* 1. value template: latest_in_branch *) (* expand_tiny_urls;*) (* 2. key template: t -- to use a tiny link value -- already expanded in row *) diff --git a/src/dune b/src/dune index 2365eed..67df187 100644 --- a/src/dune +++ b/src/dune @@ -5,4 +5,4 @@ (:standard -principal -short-paths)) (preprocess (pps ppx_sexp_conv ppx_let)) - (libraries threads.posix core postgresql curl async sql uri str re)) + (libraries threads.posix core postgresql curl async sql uri str re ssl)) From 51b1d9ca9638468d8bbc1e635d6ab9a1b0045490 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 2 Dec 2019 14:33:39 +0000 Subject: [PATCH 22/36] Show more accurate median statistics MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The median is only the n/2 indexed element when there are an odd number of elements, otherwise have to interpolate. Also calculate the Tukey Fences, defined as Q1-1.5*IQR, Q3+1.5*IQR with IQR=Q3-Q1. Useful for spotting outliers, or non-normal distributions. We usually have a small number of data points, and no guarantees that the data is normally distributed, so using median and quantile statistics is probably the right choice since they are more robust to outliers. (e.g. due to caching effects the 1st data point in a VM boot time could be significantly larger than the rest, although still valid) Signed-off-by: Edwin Török --- static/rage.js | 32 +++++++++++++++++++++++--------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/static/rage.js b/static/rage.js index 13d4c16..5653c0e 100644 --- a/static/rage.js +++ b/static/rage.js @@ -571,11 +571,22 @@ function GraphObject() { function get_distribution_lines(data) { // var avgs = [], min_maxs = [], std_devs = []; - var medians = [], prc40to60s = [], prc25to75s = [], prc15to85s = []; + var medians = [], prc25to75s = [], fences = []; var plus = function(acc, x) {return acc + x;}; var plus_sq = function(acc, x) {return acc + x*x;}; var min = function(acc, x) {return acc < x ? acc : x;}; var max = function(acc, x) {return acc < x ? x : acc;}; + var interpolate = function(ys, n) { + var idx = Math.floor(n); + var d = n - idx; + if (d < Number.EPSILON) + return ys[idx]; + else + return (1-d)*ys[idx] + d*ys[idx+1]; + }; + var quantile = function(ys, q) { + return interpolate(ys, q * ys.length) + }; $.each(group_by_x(data), function(i, x_ys) { var x = x_ys[0], ys = x_ys[1]; numerical_sort(ys); @@ -585,14 +596,18 @@ function GraphObject() { // min_maxs.push([x, ys.reduce(max, -Infinity), ys.reduce(min, Infinity)]); // var std_dev = Math.sqrt(ys.reduce(plus_sq) / n - avg*avg); // std_devs.push([x, avg + std_dev, avg - std_dev]); - medians.push([x, ys[n / 2], ys[n / 2]]); - prc40to60s.push([x, ys[Math.floor(n * 0.60)], ys[Math.floor(n * 0.40)]]); - prc25to75s.push([x, ys[Math.floor(n * 0.75)], ys[Math.floor(n * 0.25)]]); - prc15to85s.push([x, ys[Math.floor(n * 0.85)], ys[Math.floor(n * 0.15)]]); + var median = quantile(ys, 0.5); + medians.push([x, median, median]); + var q1 = quantile(ys, 0.25); + var q3 = quantile(ys, 0.75); + prc25to75s.push([x, q3, q1]); + // Tukey fences + var iqr = q3 - q1 + fences.push([x, q3 + 1.5*iqr, q1-1.5*iqr]); }); return { // min_max: min_maxs, std_dev: std_devs, - median: medians, prc40to60: prc40to60s, prc25to75: prc25to75s, - prc15to85: prc15to85s}; + median: medians, prc25to75: prc25to75s, fences: fences + }; } function draw_graph(o, cb) { //will call callback function and pass in the time that plotting started @@ -622,9 +637,8 @@ function GraphObject() { label: null, points: {show: false}, lines: {show: true, lineWidth: 0, fill: fill}}); }; - add_percentile(i, dist.prc15to85, 0.2); + add_percentile(i, dist.fences, 0.2); add_percentile(i, dist.prc25to75, 0.4); - add_percentile(i, dist.prc40to60, 0.6); var label_shown = is_checked("show_points") || is_checked("show_avgs"); series.push({color: point_series[i].color, data: dist.median, label: label_shown ? null : point_series[i].label, From 8f90a178a8f1476cf3cf3860b31523762c992b95 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 10 Dec 2019 14:42:35 +0000 Subject: [PATCH 23/36] ssl0.5.7 for older openssl version MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- dune-project | 2 +- rage.opam | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/dune-project b/dune-project index 9c347e7..f1fddc2 100644 --- a/dune-project +++ b/dune-project @@ -11,7 +11,7 @@ (async (>= v0.13)) (postgresql (>= 4.5.2)) (ocurl (>= 0.9.0)) - ssl + (ssl (= 0.5.7)) ppx_sexp_conv re uri)) diff --git a/rage.opam b/rage.opam index a288f6e..852228c 100644 --- a/rage.opam +++ b/rage.opam @@ -10,7 +10,7 @@ depends: [ "async" {>= "v0.13"} "postgresql" {>= "4.5.2"} "ocurl" {>= "0.9.0"} - "ssl" + "ssl" {= "0.5.7"} "ppx_sexp_conv" "re" "uri" From c038cacc05306d18d5491e1a8cb3390e62b5cef6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 10 Dec 2019 14:42:45 +0000 Subject: [PATCH 24/36] fix url decoding of - MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- src/brief_handler.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index e6f6f37..2010b4f 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -70,6 +70,7 @@ let t ~args = object (self) ("%2F","/");("%3F","?" ); ("%3D","="); ("%26","&"); ("%25","%");("+"," "); ("%3E",">"); ("%3C","<"); ("%3A",":");("&","&");(""","\""); + ("%2d","-"); (">",">");("<","<"); ("&45;","-");("+","%2b") ] From ceb86d31289368931ec88a7e98a75d2e0e1520a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 10 Dec 2019 15:52:14 +0000 Subject: [PATCH 25/36] Disable forcing of Y from/to zero and split by build_is_release MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- static/rage.js | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/static/rage.js b/static/rage.js index 5653c0e..bc3fa3b 100644 --- a/static/rage.js +++ b/static/rage.js @@ -2,7 +2,7 @@ Invariants (also reflected on server side): - Default value for field "xaxis" is "branch". - Default value for field "yaxis" is "result". -- show_points, show_avgs, y_fromto_zero is selected by default. +- show_points, show_avgs is selected by default. - All other checkboxes are not selected by default. - "SHOW FOR" is the first (default) option for filters ("f_"). - "ALL" is the first (default) option for filter values ("v_"). @@ -10,7 +10,7 @@ Invariants (also reflected on server side): // === GLOBAL VARIABLES --- start === var autofetch = false; // if false, the following triggers have no effect -var checkboxes_on_by_default = ["show_points", "show_avgs", "y_fromto_zero"]; +var checkboxes_on_by_default = ["show_points", "show_avgs"]; //defaults for all drop-down selection options above filter boxes var graph_selection_defaults = { xaxis: ["branch"], //multiselect defaults of length > 1 will always show up in the url @@ -844,6 +844,11 @@ const setPresetBriefReport = () => { // Select SW legend position, our interesting data is usually NE select('legend_position', 'sw'); + // Split by build_is_release + unselectAll('v_build_is_release'); + select('v_build_is_release', 'ALL'); + select('f_build_is_release', 1); + // Enable autodraw - jquery to trigger its jquery change event $('input[name=auto_redraw]').prop('checked', true); redraw_graph(); From f34d89f572b87ffef6537eb85ba0db5a69271150 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 19 Dec 2019 17:32:16 +0000 Subject: [PATCH 26/36] Add Travis CI build script MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- .travis.yml | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..534afda --- /dev/null +++ b/.travis.yml @@ -0,0 +1,12 @@ +language: c +sudo: required +service: docker +install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh +script: + - bash -ex .travis-docker.sh +env: + global: + - OCAML_VERSION="4.08" + - DISTRO="debian-unstable" + - PACKAGE="xapi-xenopsd" + - PINS="rage:." From 90803463381ebc560e420c582e51bbb2e190dacc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 16 Dec 2019 17:44:17 +0000 Subject: [PATCH 27/36] Use simpler roundoff rules MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit I used to like rounding based on significant figures, until I read [1], which highlights some problems with it. It is better to report 2 numbers: the value and percentage or stdev. RAGE does this most of the time, except when stdev is <5% in which case it reports only 1 value. The value we report can be rounded, but the rounding shouldn't be based on the standard deviation: a simple rule that rounds to a fixed number of significant digits is better. The uncertainty is already expressed in the 2nd number, so there is no need to introduce additional errors by rounding the 1st number. NIST [2] also recommends reporting 2 numbers. Also use the unrounded numbers for further calculations, only round off what gets displayed to the user. [1] https://www.av8n.com/physics/uncertainty.htm [2] https://physics.nist.gov/cuu/Uncertainty/examples.html Signed-off-by: Edwin Török --- src/brief_handler.ml | 50 +++++--------------------------------------- 1 file changed, 5 insertions(+), 45 deletions(-) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index 2010b4f..45b0551 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -801,49 +801,9 @@ in ignore (relative_std_error []); (* round value f to the optimal decimal place according to magnitude of its stddev *) - let round f stddev = - if Float.(abs (Float.(/) stddev f) < 0.00000001) (* stddev = 0.0 doesn't work because of rounding errors in the float representation *) - then (sprintf "%f" f), f - else - (* 0. compute magnitude of stddev relative to f *) - let f_abs = Float.abs f in - let magnitude = (log stddev) /. (log 10.0) in - let newdotpos = (if is_valid magnitude then Float.to_int (if Float.(magnitude < 0.0) then Float.round_down (magnitude) else (Float.round_down magnitude) +. 1.0) else 1) in - let f_str = sprintf "%f" f_abs in - let dotpos = (String.index_exn f_str '.') in - let cutpos = (dotpos - newdotpos) in - if cutpos < 0 - then ("0",0.0) (* stddev magnitude is larger then value f *) - else - (* 1. round for the computed magnitude of stddev *) - let dig_from s pos = (String.sub s ~pos:(pos+1) ~len:1) in - let dig=dig_from f_str cutpos in - let rounddigit,roundpos = (* round last significant value using the next digit value *) - if String.(dig=".") - then (int_of_string (dig_from f_str (cutpos+1)),newdotpos-1) - else (int_of_string dig,if newdotpos<0 then newdotpos else newdotpos-1) - in - let f_rounded = if rounddigit < 5 then f_abs else f_abs +. 10.0 ** (Float.of_int roundpos) in - (* 2. print only significant digits *) - let f_result = ( - let f_str_rounded = sprintf "%f" f_rounded in - let f_abs_str_rounded = (if Float.(f_rounded<1.0) - then (* print the rounded value up to its last significant digit *) - String.sub f_str_rounded ~pos:0 ~len:(cutpos+1) - else (* print the rounded value up to its last significant digit and fill the rest with 0s *) - let dotposr = String.index_exn f_str_rounded '.' in - sprintf "%s%s" - (String.sub f_str_rounded ~pos:0 ~len:(cutpos+1)) - (if dotposr-(cutpos+1)>0 then (String.make (dotposr-(cutpos+1)) '0') else "") - ) in - (sprintf "%s%s" (if Float.(f<0.0) then if String.(f_abs_str_rounded <> "0") then "-" else "" else "") f_abs_str_rounded) - ) - in - ( - (*sprintf "f_str=%s stddev=%f magnitude=%f cutpos=%d dotpos=%d newdotpos=%d dig=%s rounddigit=%d roundpos=%d f_rounded=%f f=%f %s" f_str stddev magnitude cutpos dotpos newdotpos dig rounddigit roundpos f_rounded f*) - f_result, Float.of_string f_result - ) - + let round f = + let result = Float.round_significant ~significant_digits:4 f in + sprintf "%f" result, f in let of_round avg stddev ~f0 ~f1 ~f2 = if no_rounding then @@ -854,8 +814,8 @@ in if Float.(abs avg < min_value) then f0 () else if Float.(stddev /. avg < 0.05) (* see if the relative std error is <5% *) - then f1 (round avg stddev) (* 95% confidence *) - else f2 (round lower stddev) (round avg stddev) (round upper stddev) (* 95% confidence *) + then f1 (round avg) (* 95% confidence *) + else f2 (round lower) (round avg) (round upper) (* 95% confidence *) in (* pretty print a value f and its stddev *) let str_of_round ?f1_fmt ?f2_fmt avg stddev = From 0474636b870f58565e02c453fd4de5676504c760 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 16 Dec 2019 18:24:43 +0000 Subject: [PATCH 28/36] Simplify code: drop wiki writer MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We use the HTML writer + post-processing scripts. This avoids a lot of code duplication. Signed-off-by: Edwin Török --- src/brief_handler.ml | 155 ++----------------------------------------- 1 file changed, 6 insertions(+), 149 deletions(-) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index 45b0551..0948b9f 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -31,7 +31,6 @@ type base_t = (string * string list) list [@@deriving sexp] type baseline_t = int [@@deriving sexp] type ctx_t = (string * string list) list [@@deriving sexp] type str_lst_t = string list [@@deriving sexp] -type out_t = [`Html | `Wiki] [@@deriving sexp] type sort_by_col_t = int [@@deriving sexp] type result_t = Avg of float | Range of float * float * float @@ -210,7 +209,7 @@ let t ~args = object (self) let get_input_rows_from_id id fn = let%bind brief_params_from = fetch_brief_params_from id in let args = parse_url brief_params_from in - let%map _,_input_rows,_,_,_,_ = fn args in + let%map _,_input_rows,_,_,_ = fn args in _input_rows in @@ -220,7 +219,6 @@ let t ~args = object (self) let params_rows=(try url_decode (List.Assoc.find_exn ~equal:String.equal args "rows") with |_-> "") in let params_base=(try url_decode (List.Assoc.find_exn ~equal:String.equal args "base") with |_-> "") in let params_baseline=(try url_decode (List.Assoc.find_exn ~equal:String.equal args "baseline") with |_-> "") in - let params_out=(try url_decode (List.Assoc.find_exn ~equal:String.equal args "out") with |_-> "") in let params_sort_by_col=(try url_decode (List.Assoc.find_exn ~equal:String.equal args "sort_by_col") with |_-> "") in let params_add_rows_from=(try url_decode (List.Assoc.find_exn ~equal:String.equal args k_add_rows_from) with |_-> "") in @@ -283,21 +281,13 @@ let t ~args = object (self) in printf "\n" (Sexp.to_string (sexp_of_baseline_t baseline_col_idx)); - let out = - if String.(params_out <> "") then - attempt ~f:(fun ()->out_t_of_sexp (Sexp.of_string (String.capitalize params_out))) "out" - else (*default value *) - `Html - in - printf "\n" (params_out) (Sexp.to_string (sexp_of_out_t out)); - let sort_by_col = if String.(params_sort_by_col <> "") then Some (attempt ~f:(fun ()->sort_by_col_t_of_sexp (Sexp.of_string (String.capitalize params_sort_by_col))) "sort_by_col") else (*default value *) None in - (input_cols, input_rows, input_base_context, baseline_col_idx, out, sort_by_col) + (input_cols, input_rows, input_base_context, baseline_col_idx, sort_by_col) in let%bind args = @@ -318,7 +308,7 @@ let t ~args = object (self) in (* === process === *) - let%bind input_cols, input_rows, input_base_context, baseline_col_idx, out, sort_by_col = + let%bind input_cols, input_rows, input_base_context, baseline_col_idx, sort_by_col = get_input_values args in @@ -860,10 +850,10 @@ in |Range (bl, ba, bu)-> Float.abs ba) in (* pretty print a list of values as average and stddev *) - let str_stddev_of ?f1_fmt ?f2_fmt xs = + let str_stddev_of xs = try if List.length xs < 1 then "-" - else str_of_round ?f1_fmt ?f2_fmt (avg xs) (stddev xs) + else str_of_round (avg xs) (stddev xs) with |e-> sprintf "error %s: %s %f %f " (Exn.to_string e) (Sexp.to_string (sexp_of_str_lst_t xs)) (avg xs) (stddev xs) in let val_stddev_of xs = @@ -1083,139 +1073,6 @@ in printf ""; in - let wiki_writer table = - - let str_of_values vs=List.fold_left vs ~init:"" ~f:(fun acc v->if String.(acc="") then "\""^v^"\"" else acc^", \""^v^"\"") in - let str_of_ctxs ?(txtonly=false) kvs = - List.fold_left kvs ~init:"" ~f:(fun acc (k,v)-> - (sprintf "%s %s=(%s)%s " acc k (str_of_values v) (if txtonly then "" else "\\\\") ) - ) - in - let str_desc_of_ctxs kvs = - Deferred.List.fold kvs ~init:"" ~f:(fun acc (k,vs)-> - if String.(k<>"soms") then return acc else - let%map r = - Deferred.List.fold vs ~init:"" ~f:(fun acc2 som-> - let%map tc = tc_of_som som - and name = name_of_som som - and u = unit_of_som som - and mbstr = - let%map mb=more_is_better_of_som som in if String.(mb="") then "none" else if String.(mb="f") then "less" else "more" - in - let s=sprintf "%s: *%s* (%s%s)" tc name (if String.(u="") then u else u^", ") (sprintf "%s is better" mbstr) in - if String.(acc="") then s else acc^","^s - ) - in - sprintf "%s %s \\\\" acc r - ) - in - let link ctx = - (* link *) - ( - (* rage is not generic enough to receive an arbirary number of soms in a link, pick just the first one *) - let som_id=match List.find_exn ctx ~f:(fun (k,_)->String.(k="soms")) with |(k,v)->List.hd_exn v in - (sprintf "[graph|http://%s/?som=%s&show_dist=on%s%s]" (Utils.server_name ()) som_id - (* xaxis *) - (List.fold_left link_xaxis ~init:"" ~f:(fun acc x->sprintf "%s%s" acc (sprintf "&xaxis=%s" x))) - (* preset values *) - (List.fold_left ctx ~init:"" ~f:(fun acc (k,vs)->sprintf "%s%s" acc - (List.fold_left vs ~init:"" ~f:(fun acc2 v->sprintf "%s&v_%s=%s" acc2 k (rage_encode v)) - ) - )) - )) - in - let is_more_is_better ctx = - match List.find ctx ~f:(fun (k,_)->String.(k="soms")) with - |None->return None - |Some (k,_vs)->( - let rec is_mb acc vs = (match vs with - |[]-> return @@ if Option.is_none acc then None else acc - |v::vs->(let%bind mb = more_is_better_of_som v in - if String.(mb="") then is_mb acc vs (* ignore more_is_better if not defined in db *) - else - let mbtf = match mb with m when String.(m="f")->false|_->true in - match acc with - |None->is_mb (Some mbtf) vs - |Some _mbtf->if Bool.(_mbtf=mbtf) - then is_mb (Some mbtf) vs (* more_is_better values agree between soms *) - else return None (* more_is_better values disagree between soms *) - ) - ) in - is_mb None _vs - ) - in - let%map cells = - (List.map2_exn table link_ctxs ~f:(fun (r,cs) lnkctx -> - let%bind str_desc = str_desc_of_ctxs r in - let%map cells = - Deferred.List.mapi ~how:`Parallel cs ~f:(fun i (r,c,ctx,ms)-> - let _,_,_,baseline_ms = List.nth_exn cs baseline_col_idx in - let%map is_mb = is_more_is_better ctx in - (* - sprintf "
    %s
    " - (Sexp.to_string (sexp_of_ctx_t r)) - (Sexp.to_string (sexp_of_ctx_t c)) - (str_of_ctxs ctx ~txtonly:true) - (Sexp.to_string (sexp_of_str_lst_t (vals_of_ms ms))) - *) - (sprintf "{color:%s} %s %s %s {color}" - (if baseline_col_idx = i then "" else - match is_mb with - |None->"" - |Some mb->if is_green (val_stddev_of (vals_of_ms baseline_ms)) (val_stddev_of (vals_of_ms ms)) mb then "green" else "red" - ) - (str_stddev_of (vals_of_ms ms) ~f2_fmt:"\\\\[%s, %s, %s\\\\]") - (sprintf "~(%d)~" (List.length ms)) - (if baseline_col_idx = i then "" else - match is_mb with - |None->"" - |Some mb->sprintf "~(%+.0f%%)~" (100.0 *. (proportion (val_stddev_of (vals_of_ms baseline_ms)) (val_stddev_of (vals_of_ms ms)) mb)) - ))) - in - sprintf "| %s | %s | %s | %s \n" - (* row id/title *) - (str_of_ctxs r) - (* row description *) - str_desc - (* graph link *) - (link lnkctx) - (* cells to the right *) - (List.fold_left ~init:"" ~f:(fun acc c_ms->(sprintf "%s %s | " acc c_ms)) cells) - )) - |> Deferred.List.all - in - let wiki_table = - sprintf "| %s|\n%s%s\n%s" - (* print the base context *) - (str_of_ctxs b) - (* print the header *) - (sprintf "||id|| Description || View || %s \n" - (List.foldi cs ~init:"" ~f:(fun i acc _ -> - sprintf "%s %s ||" acc (if i=baseline_col_idx then "Baseline" else (sprintf "Comparison %d" i)) - )) - ) - (* print the columns *) - (sprintf "|| || || || %s" - (List.fold_left ~init:"" - ~f:(fun acc cs->sprintf "%s %s || " acc (str_of_ctxs cs)) cs - ) - ) - (* print the cells *) - (String.concat ~sep:"" cells) - in - printf "%s" "
    ";
    -      printf "%s" "h1. Brief Rage Report\n\n";
    -      printf "- [live html version, with parameters %s |http://%s/?%s]\n" (List.fold_left params ~init:"" ~f:(fun acc (k,v)->if String.(k="out") then acc else if String.(acc="") then (sprintf "%s=%s" k v) else (sprintf "%s, %s=%s" acc k (url_decode v)))) (Utils.server_name ()) (List.fold_left params ~init:"" ~f:(fun acc (k,v)->if String.(k="out") then acc else sprintf "%s&%s=%s" acc k (url_decode v)));
    -      printf "%s" "- Numbers reported at 95% confidence level from the data of existing runs\n";
    -      printf "%s" "- \\(x) indicates number of samples\n";
    -      printf "%s" "- \\(x%) indicates difference with baseline column\n";
    -      printf "%s" "- \\[lower, avg, upper] indicates \\[avg-2*stddev, avg, avg+2*stddev]. If relative standard error < 5%, only avg is shown.\n\n";
    -      printf "%s" wiki_table;
    -      printf "%s" "
    "; - in - - match out with - |`Html -> html_writer (sort_table measurements_of_table) - |`Wiki -> wiki_writer (sort_table measurements_of_table) + html_writer (sort_table measurements_of_table) end From 06ebff9855e75fb89ec983bfc8d8143e808fa873 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 16 Dec 2019 18:30:30 +0000 Subject: [PATCH 29/36] Report relative uncertainty and more accurate ranges MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Continuation of 858c472f6b57c221ccd1005d66755564e7fd36cb. Signed-off-by: Edwin Török --- src/brief_handler.ml | 40 ++++++++++++++++++---------------------- 1 file changed, 18 insertions(+), 22 deletions(-) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index 0948b9f..38e822e 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -790,37 +790,33 @@ in in ignore (relative_std_error []); - (* round value f to the optimal decimal place according to magnitude of its stddev *) - let round f = - let result = Float.round_significant ~significant_digits:4 f in - sprintf "%f" result, f - in - let of_round avg stddev ~f0 ~f1 ~f2 = + (* round value f to 4 significant digits *) + let round ?(significant_digits=4) f = if no_rounding then - f1 (Float.to_string avg, avg) + Float.to_string f, f else - let lower = avg -. 2.0 *. stddev in (* 2-sigma = 95% confidence assuming normal distribution *) - let upper = avg +. 2.0 *. stddev in - if Float.(abs avg < min_value) - then f0 () - else if Float.(stddev /. avg < 0.05) (* see if the relative std error is <5% *) - then f1 (round avg) (* 95% confidence *) - else f2 (round lower) (round avg) (round upper) (* 95% confidence *) + f |> Float.round_significant ~significant_digits |> Float.to_padded_compact_string, f + in + let of_round avg stddev ~f0 ~f2 = + let delta = 1.96 *. stddev in + let lower = avg -. delta in (* 1.96-sigma = 95% confidence assuming normal distribution *) + let upper = avg +. delta in + let rel = 100.0 *. delta in + if Float.(abs avg < min_value) + then f0 () + else f2 (round lower) (round avg) (round upper) (round ~significant_digits:2 rel) (* 95% confidence *) in (* pretty print a value f and its stddev *) - let str_of_round ?f1_fmt ?f2_fmt avg stddev = - let _f1_fmt = match f1_fmt with None->"%s"|Some x->x in - let _f2_fmt = match f2_fmt with None->"[%s, %s, %s]"|Some x->x in + let str_of_round avg stddev = of_round avg stddev ~f0:(fun ()->"0") - ~f1:(fun a->sprintf (Scanf.format_from_string _f1_fmt "%s") (fst a) ) - ~f2:(fun l a u->sprintf (Scanf.format_from_string _f2_fmt "%s %s %s") (fst l) (fst a) (fst u)) + ~f2:(fun (l,_) (a,_) (u,_) (rel,_) -> + sprintf "%s±%s%% = [%s, %s]" a rel l u) in let val_of_round avg stddev = of_round avg stddev ~f0:(fun ()->Avg 0.0) - ~f1:(fun a->Avg (snd a)) - ~f2:(fun l a u->Range ((snd l),(snd a),(snd u)) ) + ~f2:(fun l a u _ ->Range ((snd l),(snd a),(snd u)) ) in let is_green baseline value more_is_better = if more_is_better then @@ -1046,7 +1042,7 @@ in printf "%s" "
    • Numbers reported at 95% confidence level from the data of existing runs\n"; printf "%s" "
    • (x) indicates number of samples\n"; printf "%s" "
    • (x%) indicates difference with baseline column\n"; - printf "%s" "
    • [lower, avg, upper] indicates [avg-2*stddev, avg, avg+2*stddev]. If relative standard error < 5%, only avg is shown.

    "; + printf "%s" "
  • avg±rel%% = [lower, upper] indicates the relative uncertainty (rel=196*stddev/avg) and 95% confidence interval [avg-1.96*stddev, avg+1.96*stddev].
    "; printf "

    Report Quality

    "; printf "Rows with data in last column:
    "; printf "Rows with data in 2nd-to-last, but not last:

    "; From dc1ad2526874143be6caa4937fb15a5bb561031a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 17 Dec 2019 10:54:21 +0000 Subject: [PATCH 30/36] Use more accurate confidence intervals MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We usually have a small number of samples, so a 95% confidence interval would be larger than 2.0*stddev. Signed-off-by: Edwin Török --- src/brief_handler.ml | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index 38e822e..081044e 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -797,9 +797,21 @@ in else f |> Float.round_significant ~significant_digits |> Float.to_padded_compact_string, f in - let of_round avg stddev ~f0 ~f2 = - let delta = 1.96 *. stddev in - let lower = avg -. delta in (* 1.96-sigma = 95% confidence assuming normal distribution *) + let t_95 n = + (* For infinitely many values a 95% confidence interval is 1.96 * stddev. + * However we typically have fewer values, so use the table *) + if n <= 0 then 0. + else if n < 30 then + [|12.71 ;4.303 ;3.182 ;2.776 ;2.571 ;2.447 ;2.365 ;2.306 ;2.262 ;2.228 ;2.201 ;2.179 ;2.160 + ;2.145 ;2.131 ;2.120 ;2.110 ;2.101 ;2.093 ;2.086 ;2.080 ;2.074 ;2.069 ;2.064 ;2.060 ;2.056 + ;2.052 ;2.048 ;2.045|].(n-1) + else if n <= 120 then + [|2.042; 2.021; 2.009; 2.000; 1.995; 1.990; 1.987; 1.984; 1.982; 1.980|].((n-30)/10) + else 1.96 + in + let of_round avg stddev n ~f0 ~f2 = + let delta = t_95 (n-1) *. stddev in + let lower = avg -. delta in (* 95% confidence assuming normal distribution *) let upper = avg +. delta in let rel = 100.0 *. delta in if Float.(abs avg < min_value) @@ -807,14 +819,14 @@ in else f2 (round lower) (round avg) (round upper) (round ~significant_digits:2 rel) (* 95% confidence *) in (* pretty print a value f and its stddev *) - let str_of_round avg stddev = - of_round avg stddev + let str_of_round avg stddev n = + of_round avg stddev n ~f0:(fun ()->"0") ~f2:(fun (l,_) (a,_) (u,_) (rel,_) -> sprintf "%s±%s%% = [%s, %s]" a rel l u) in - let val_of_round avg stddev = - of_round avg stddev + let val_of_round avg stddev n = + of_round avg stddev n ~f0:(fun ()->Avg 0.0) ~f2:(fun l a u _ ->Range ((snd l),(snd a),(snd u)) ) in @@ -849,13 +861,13 @@ in let str_stddev_of xs = try if List.length xs < 1 then "-" - else str_of_round (avg xs) (stddev xs) + else str_of_round (avg xs) (stddev xs) (List.length xs) with |e-> sprintf "error %s: %s %f %f " (Exn.to_string e) (Sexp.to_string (sexp_of_str_lst_t xs)) (avg xs) (stddev xs) in let val_stddev_of xs = try if List.length xs < 1 then Avg 0.0 - else val_of_round (avg xs) (stddev xs) + else val_of_round (avg xs) (stddev xs) (List.length xs) with |_-> Avg (-1000.0) in @@ -1042,7 +1054,7 @@ in printf "%s" "
    • Numbers reported at 95% confidence level from the data of existing runs\n"; printf "%s" "
    • (x) indicates number of samples\n"; printf "%s" "
    • (x%) indicates difference with baseline column\n"; - printf "%s" "
    • avg±rel%% = [lower, upper] indicates the relative uncertainty (rel=196*stddev/avg) and 95% confidence interval [avg-1.96*stddev, avg+1.96*stddev].

    "; + printf "%s" "
  • avg±rel%% = [lower, upper] indicates the relative uncertainty (rel=100*t(95%,n-1)*stddev/avg) and 95% confidence interval [avg-t(95%,n-1)*stddev, avg+t(95%,n-1)*stddev].
    "; printf "

    Report Quality

    "; printf "Rows with data in last column:
    "; printf "Rows with data in 2nd-to-last, but not last:

    "; From b14de6381e03008d4dd5dda180bcd6c7929b0a90 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 18 Dec 2019 17:53:22 +0000 Subject: [PATCH 31/36] More accurate speedup comparison MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Based on the papers cited in analysis.ml Signed-off-by: Edwin Török --- dune-project | 1 + src/analysis.ml | 81 +++++++++++++++++++++++++++++++ src/brief_handler.ml | 112 ++++++++++++++++--------------------------- src/dune | 2 +- 4 files changed, 123 insertions(+), 73 deletions(-) create mode 100644 src/analysis.ml diff --git a/dune-project b/dune-project index f1fddc2..2d7cc72 100644 --- a/dune-project +++ b/dune-project @@ -11,6 +11,7 @@ (async (>= v0.13)) (postgresql (>= 4.5.2)) (ocurl (>= 0.9.0)) + owl (ssl (= 0.5.7)) ppx_sexp_conv re diff --git a/src/analysis.ml b/src/analysis.ml new file mode 100644 index 0000000..5c53e97 --- /dev/null +++ b/src/analysis.ml @@ -0,0 +1,81 @@ +open Owl_base + +let () = + (* use a static seed to keep RAGE's results deterministic *) + Owl_base_stats_prng.init 42 + +(* T. Chen et al. Statistical Performance Comparison of Computers. 2012 *) +let hpt_uni ?alpha ~baseline ~comparison = + let open Owl in + (* Wilcoxon Rank-Sum Test, a.k.a. Mann-Whitney U-test. *) + (Stats.mannwhitneyu ?alpha ~side:Stats.RightSide comparison baseline).reject + +let hpt_cross ?alpha ~baseline ~comparison = + let open Owl in + let is_significant = Array.map2 (fun baseline comparison -> + hpt_uni ?alpha ~baseline ~comparison) baseline comparison in + let baseline = + Array.map2 + (fun x is -> if is then Stats.median x else 0.) + baseline is_significant + in + let comparison = + Array.map2 + (fun y is -> if is then Stats.median y else 0.) + comparison is_significant + in + fun gamma -> + let comparison = Array.map (fun x -> x /. gamma) comparison in + (Stats.wilcoxon ?alpha ~side:RightSide comparison baseline).reject + +(** [speedup ?r ?gamma ~baseline ~comparison] computes the speedup of [comparison] over [baseline] + * at confidence level [r], starting from value [gamma]. *) +let rec speedup ?r ?(limit = 10.0) ?(gamma = 1.0) baseline comparison = + if gamma >= limit then gamma + else if hpt_uni ?alpha:r ~comparison:(Array.map (fun x -> x /. gamma) comparison) ~baseline then + (* [a] significantly outperforms [b] [gamma] times *) + speedup ?r ~limit ~gamma:(gamma +. 0.01) baseline comparison + else + (* We cannot prove that [a] outperforms [b] [gamma] times at [r] confidence level. + * (Although this might just mean that the performance is identical). *) + gamma + +(** [speedup_cross ?r ?gamma a b] computes the speedup of a over b + * at confidence level [r], starting from value [gamma]. + * Like [speedup], but for multiple benchmarks, e.g. when comparing 2 builds or 2 machines. + * *) +let speedup_cross ?r ?(limit = 10.0) ?(gamma = 1.0) ~baseline ~comparison = + if gamma >= limit then gamma + else + let hpt = hpt_cross ?alpha:r ~baseline ~comparison in + let rec loop gamma = if hpt gamma then loop (gamma +. 0.01) else gamma in + loop gamma + +(* Le Boudec, Jean-Yves. Performance Evaluation of Computer and Communication Systems, 2010 *) + +let bootstrap_gen ?(r0 = 25) ?(gamma = 0.95) f t xs = + let r = (Float.ceil (float (2 * r0) /. (1. -. gamma)) |> int_of_float) - 1 in + let boot_samples = Array.init r (fun _ -> xs |> f |> t) in + Array.sort Float.compare boot_samples ; + (* percentile bootstrap estimate *) + (boot_samples.(r0), t xs, boot_samples.(r + 1 - r0)) + +let sample xs = Stats.sample xs (Array.length xs) + +let sample2 (xs, ys) = (sample xs, sample ys) + +(** [bootstrap ?r0 ?gamma t xs] computes the confidence interval at level [gamma] for the + * statistic [t]. [xs] are samples from an iid sequence, and [r0] is the algorithm's accuracy + * parameter. Does not require the distribution to be normal. + *) +let bootstrap ?gamma t xs = bootstrap_gen ?gamma sample t xs + +let bootstrap_mean ?gamma = bootstrap ?gamma Stats.mean + +(* T. Kalibera, R. Jones. Quantifying Performance Changes with Effect Size Confidence Intervals. 2012 *) + +(** [bootstrap_ratio ?gamma old_ys new_ys] computes the bootstrap confidence interval at level [gamma] + * for the ratio of means of two systems *) +let bootstrap_ratio ?gamma baseline comparison = + let ratio (ns, os) = Stats.mean ns /. Stats.mean os in + bootstrap_gen ?gamma sample2 ratio (comparison, baseline) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index 081044e..02d727e 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -31,13 +31,14 @@ type base_t = (string * string list) list [@@deriving sexp] type baseline_t = int [@@deriving sexp] type ctx_t = (string * string list) list [@@deriving sexp] type str_lst_t = string list [@@deriving sexp] +type float_lst_t = float list [@@deriving sexp] type sort_by_col_t = int [@@deriving sexp] type result_t = Avg of float | Range of float * float * float type job_and_value = {job: int; value: string} let jobs_of_ms = List.map ~f:(fun m -> m.job) -let vals_of_ms = List.map ~f:(fun m -> m.value) +let vals_of_ms = List.map ~f:(fun m -> Float.of_string m.value) let k_add_rows_from = "add_rows_from" let k_for = "for" @@ -769,27 +770,6 @@ in (* === output === *) - let n_sum xs = List.fold_left ~init:(0,0.) ~f:(fun (n,sum1) x->succ n, sum1 +. (Float.of_string x)) xs in - let avg xs = let n,sum=n_sum xs in sum /. (float n) in - let variance xs = (* 2-pass algorithm *) - let n,sum1 = n_sum xs in - if n<2 - then 0.0 (* default variance if not enough measurements present to compute it *) - else - let mean = sum1 /. (float n) in - let sum2 = List.fold_left ~init:0. ~f:(fun sum2 x->sum2 +. ((Float.of_string x) -. mean)*.((Float.of_string x) -. mean)) xs in - sum2 /. (float (n-1)) - in - let stddev xs = sqrt (variance xs) in - let is_valid f = (if Float.is_inf f || Float.is_nan f then false else true) in - let relative_std_error xs = - let avg = avg xs in let stddev = stddev xs in - if (is_valid avg) && (is_valid stddev) then - Float.to_int (stddev /. avg *. 100.) - else 0 - in - ignore (relative_std_error []); - (* round value f to 4 significant digits *) let round ?(significant_digits=4) f = if no_rounding then @@ -797,37 +777,26 @@ in else f |> Float.round_significant ~significant_digits |> Float.to_padded_compact_string, f in - let t_95 n = - (* For infinitely many values a 95% confidence interval is 1.96 * stddev. - * However we typically have fewer values, so use the table *) - if n <= 0 then 0. - else if n < 30 then - [|12.71 ;4.303 ;3.182 ;2.776 ;2.571 ;2.447 ;2.365 ;2.306 ;2.262 ;2.228 ;2.201 ;2.179 ;2.160 - ;2.145 ;2.131 ;2.120 ;2.110 ;2.101 ;2.093 ;2.086 ;2.080 ;2.074 ;2.069 ;2.064 ;2.060 ;2.056 - ;2.052 ;2.048 ;2.045|].(n-1) - else if n <= 120 then - [|2.042; 2.021; 2.009; 2.000; 1.995; 1.990; 1.987; 1.984; 1.982; 1.980|].((n-30)/10) - else 1.96 - in - let of_round avg stddev n ~f0 ~f2 = - let delta = t_95 (n-1) *. stddev in - let lower = avg -. delta in (* 95% confidence assuming normal distribution *) - let upper = avg +. delta in - let rel = 100.0 *. delta in - if Float.(abs avg < min_value) - then f0 () - else f2 (round lower) (round avg) (round upper) (round ~significant_digits:2 rel) (* 95% confidence *) + let of_round xs ~f1 ~f2 = + let open Owl_base in + let xs = Array.of_list xs in + if Array.length xs = 1 then + f1 (round xs.(0)) + else + let l, avg, u = Analysis.bootstrap_mean xs in + let rel = 100.0 *. Float.abs (Owl_base.Stats.std ~mean:avg xs /. avg) in + f2 (round l) (round avg) (round u) (round ~significant_digits:2 rel) (* 95% confidence *) in (* pretty print a value f and its stddev *) - let str_of_round avg stddev n = - of_round avg stddev n - ~f0:(fun ()->"0") + let str_of_round xs = + of_round xs + ~f1:(fun x -> fst x) ~f2:(fun (l,_) (a,_) (u,_) (rel,_) -> - sprintf "%s±%s%% = [%s, %s]" a rel l u) + sprintf "Values=%s±%s%%. Mean=[%s, %s]" a rel l u) in - let val_of_round avg stddev n = - of_round avg stddev n - ~f0:(fun ()->Avg 0.0) + let val_of_round xs = + of_round xs + ~f1:(fun x -> Avg (snd x)) ~f2:(fun l a u _ ->Range ((snd l),(snd a),(snd u)) ) in let is_green baseline value more_is_better = @@ -844,32 +813,28 @@ in |Range (bl, ba, bu), Avg v-> Float.(v<=ba) |Range (bl, ba, bu), Range (vl,va,vu)-> Float.(va<=ba) in - let delta baseline value more_is_better = - match baseline, value with - |Avg b, Avg v-> v -. b - |Avg b, Range (vl, va, vu)-> va -. b - |Range (bl, ba, bu), Avg v-> v -. ba - |Range (bl, ba, bu), Range (vl,va,vu)-> va -. ba - in - let proportion baseline value more_is_better = - (delta baseline value more_is_better) /. - (match baseline with - |Avg b-> Float.abs b - |Range (bl, ba, bu)-> Float.abs ba) - in (* pretty print a list of values as average and stddev *) let str_stddev_of xs = - try - if List.length xs < 1 then "-" - else str_of_round (avg xs) (stddev xs) (List.length xs) - with |e-> sprintf "error %s: %s %f %f " (Exn.to_string e) (Sexp.to_string (sexp_of_str_lst_t xs)) (avg xs) (stddev xs) + if List.length xs < 1 then "-" + else str_of_round xs in let val_stddev_of xs = try if List.length xs < 1 then Avg 0.0 - else val_of_round (avg xs) (stddev xs) (List.length xs) + else val_of_round xs with |_-> Avg (-1000.0) in + let proportion baseline comparison more_is_better = + let convert x = x |> vals_of_ms |> Array.of_list in + let baseline = convert baseline in + let comparison = convert comparison in + let to_percent x = (x -. 1.) *. 100. in + let (l,a,u),speedup = + Analysis.bootstrap_ratio baseline comparison, + Analysis.speedup baseline comparison + in + (to_percent l, to_percent a, to_percent u), to_percent speedup + in let sort_table mt = (* use url option sort_by_col if present *) match sort_by_col with @@ -887,10 +852,11 @@ in let ms cs = let _,_,_,cmp_ms = List.nth_exn cs compare_col_idx in let _,_,_,base_ms = List.nth_exn cs baseline_col_idx in - proportion (val_stddev_of (vals_of_ms base_ms)) (val_stddev_of (vals_of_ms cmp_ms)) None + let (_,a,_),s = proportion base_ms cmp_ms None in + Float.abs s, Float.abs a in - let ms1, ms2 = (Float.abs (ms cs1)),(Float.abs (ms cs2)) in - if Float.(ms1 > ms2) then -1 else if Float.(ms2 > ms1) then 1 else 0 (* decreasing order *) + let ms1, ms2 = ms cs1, ms cs2 in + -(Stdlib.compare ms1 ms2) (* decreasing order *) ) @ mt_0s (* rows with no measurements stay at the end *) in @@ -991,7 +957,7 @@ in let debug_r = Sexp.to_string (sexp_of_ctx_t r) and debug_c = Sexp.to_string (sexp_of_ctx_t c) and context = str_of_ctxs ctx ~txtonly:true - and debug_ms = Sexp.to_string (sexp_of_str_lst_t (vals_of_ms ms)) in + and debug_ms = Sexp.to_string (sexp_of_float_lst_t (vals_of_ms ms)) in let number = List.length ms in let number_str = if show_jobids then @@ -1012,7 +978,9 @@ in (if number = 0 || baseline_col_idx = i || (List.length baseline_ms < 1) then return "" else match%map is_more_is_better ctx with |None->"" - |Some mb->sprintf "(%+.0f%%)" (100.0 *. (proportion (val_stddev_of (vals_of_ms baseline_ms)) (val_stddev_of (vals_of_ms ms)) mb)) + |Some mb-> + let (l,ratio,u),speedup = proportion baseline_ms ms mb in + sprintf "Speedup=%+.1f%%(%+.1f%%,%+.1f%%)(%+.0f%%)" speedup l u ratio ) in let text = sprintf "%s
    %s %s
    " colour avg number_str diff in sprintf "
    %s
    " debug_r debug_c context debug_ms text diff --git a/src/dune b/src/dune index 67df187..f5afc10 100644 --- a/src/dune +++ b/src/dune @@ -5,4 +5,4 @@ (:standard -principal -short-paths)) (preprocess (pps ppx_sexp_conv ppx_let)) - (libraries threads.posix core postgresql curl async sql uri str re ssl)) + (libraries threads.posix core postgresql curl async sql uri str re ssl owl-base owl)) From 9842593d9e7398538e4544c430ccba8dd1ec905c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 18 Dec 2019 18:15:00 +0000 Subject: [PATCH 32/36] round MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- src/brief_handler.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index 02d727e..3490fba 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -784,8 +784,10 @@ in f1 (round xs.(0)) else let l, avg, u = Analysis.bootstrap_mean xs in - let rel = 100.0 *. Float.abs (Owl_base.Stats.std ~mean:avg xs /. avg) in - f2 (round l) (round avg) (round u) (round ~significant_digits:2 rel) (* 95% confidence *) + let ravg = round avg in + let avg' = snd ravg in + let rel = 100.0 *. Float.abs (Owl_base.Stats.std ~mean:avg' xs /. avg') in + f2 (round l) ravg (round u) (round ~significant_digits:3 rel) (* 95% confidence *) in (* pretty print a value f and its stddev *) let str_of_round xs = From ca24246b4814d3dbc5b29f526d3189418a09f908 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 18 Dec 2019 18:16:14 +0000 Subject: [PATCH 33/36] round MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- src/brief_handler.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index 3490fba..dc4199e 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -771,7 +771,7 @@ in (* === output === *) (* round value f to 4 significant digits *) - let round ?(significant_digits=4) f = + let round ?(significant_digits=5) f = if no_rounding then Float.to_string f, f else @@ -787,7 +787,7 @@ in let ravg = round avg in let avg' = snd ravg in let rel = 100.0 *. Float.abs (Owl_base.Stats.std ~mean:avg' xs /. avg') in - f2 (round l) ravg (round u) (round ~significant_digits:3 rel) (* 95% confidence *) + f2 (round l) ravg (round u) (round rel) (* 95% confidence *) in (* pretty print a value f and its stddev *) let str_of_round xs = From 07f9712bc346d7e40ae665a1c3d6bee7657a4b2e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 18 Dec 2019 18:24:18 +0000 Subject: [PATCH 34/36] round MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- src/brief_handler.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index dc4199e..2f5cbb8 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -982,7 +982,7 @@ in |None->"" |Some mb-> let (l,ratio,u),speedup = proportion baseline_ms ms mb in - sprintf "Speedup=%+.1f%%(%+.1f%%,%+.1f%%)(%+.0f%%)" speedup l u ratio + sprintf "Speedup=%+.0f%%(%+.0f%%,%+.0f%%)(%+.0f%%)" speedup l u ratio ) in let text = sprintf "%s
    %s %s
    " colour avg number_str diff in sprintf "
    %s
    " debug_r debug_c context debug_ms text From d2036f79a86bd28b9cd23bb73f09a58caac92ebe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 18 Dec 2019 18:25:44 +0000 Subject: [PATCH 35/36] round MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- src/brief_handler.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/brief_handler.ml b/src/brief_handler.ml index 2f5cbb8..dc78584 100644 --- a/src/brief_handler.ml +++ b/src/brief_handler.ml @@ -771,7 +771,7 @@ in (* === output === *) (* round value f to 4 significant digits *) - let round ?(significant_digits=5) f = + let round ?(significant_digits=4) f = if no_rounding then Float.to_string f, f else @@ -787,7 +787,7 @@ in let ravg = round avg in let avg' = snd ravg in let rel = 100.0 *. Float.abs (Owl_base.Stats.std ~mean:avg' xs /. avg') in - f2 (round l) ravg (round u) (round rel) (* 95% confidence *) + f2 (round l) ravg (round u) (round ~significant_digits:2 rel) (* 95% confidence *) in (* pretty print a value f and its stddev *) let str_of_round xs = From 5e5e7f24fc0b6b664a65075e32d35bcfd52cf596 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 19 Dec 2019 17:32:16 +0000 Subject: [PATCH 36/36] Add Travis CI build script MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- .travis.yml | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..99f3b26 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,12 @@ +language: c +sudo: required +service: docker +install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh +script: + - bash -ex .travis-docker.sh +env: + global: + - OCAML_VERSION="4.08" + - DISTRO="debian-unstable" + - PACKAGE="rage" + - PINS="rage:."