diff --git a/benchpress-server.opam b/benchpress-server.opam index 03c237d..563f166 100644 --- a/benchpress-server.opam +++ b/benchpress-server.opam @@ -20,7 +20,7 @@ depends: [ "gnuplot" { >= "0.6" & < "0.8" } "sqlite3" "sqlite3_utils" { >= "0.4" & < "0.5" } - "tiny_httpd" { >= "0.12" & < "1.0" } + "tiny_httpd" { >= "0.16" & < "1.0" } "printbox" { >= "0.6" } "printbox-text" { >= "0.6" } "ocaml" {>= "4.12" } diff --git a/benchpress.opam b/benchpress.opam index 5df3525..f3b3f6b 100644 --- a/benchpress.opam +++ b/benchpress.opam @@ -24,7 +24,7 @@ depends: [ "processor" "pp_loc" { >= "2.0" & < "3.0" } "gnuplot" { >= "0.6" & < "0.8" } - "sqlite3" + "sqlite3" { >= "5.0.3" } # https://github.com/sneeuwballen/benchpress/pull/73#issuecomment-1764108025 "sqlite3_utils" { >= "0.4" & < "0.6" } "printbox" { >= "0.6" } "printbox-text" { >= "0.6" } diff --git a/src/bin/benchpress_bin.ml b/src/bin/benchpress_bin.ml index 1f55696..f4f3102 100644 --- a/src/bin/benchpress_bin.ml +++ b/src/bin/benchpress_bin.ml @@ -19,9 +19,10 @@ module Run = struct (* sub-command for running tests *) let cmd = let open Cmdliner in - let aux j cpus pp_results dyn paths dir_files proof_dir defs task timeout - memory meta provers csv summary no_color output save wal_mode + let aux j cpus pp_results dyn paths dir_files proof_dir (log_lvl, defs) task + timeout memory meta provers csv summary no_color output save wal_mode desktop_notification no_failure update = + Misc.setup_logs log_lvl; catch_err @@ fun () -> if no_color then CCFormat.set_color_default false; let dyn = @@ -173,10 +174,11 @@ module Slurm = struct (* sub-command for running tests with slurm *) let cmd = let open Cmdliner in - let aux j pp_results dyn paths dir_files proof_dir defs task timeout memory - meta provers csv summary no_color output save wal_mode + let aux j pp_results dyn paths dir_files proof_dir (log_lvl, defs) task + timeout memory meta provers csv summary no_color output save wal_mode desktop_notification no_failure update partition nodes addr port ntasks = + Misc.setup_logs log_lvl; catch_err @@ fun () -> if no_color then CCFormat.set_color_default false; let dyn = @@ -543,7 +545,8 @@ end (** {2 See prover(s)} *) module Prover_show = struct - let run defs names = + let run (log_lvl, defs) names = + Misc.setup_logs log_lvl; catch_err @@ fun () -> let l = CCList.map (Definitions.find_prover' defs) names in Format.printf "@[%a@]@." (Misc.pp_list Prover.pp) l; @@ -561,7 +564,8 @@ end (** {2 List provers} *) module Prover_list = struct - let run defs = + let run (log_lvl, defs) = + Misc.setup_logs log_lvl; catch_err @@ fun () -> let l = Definitions.all_provers defs in Format.printf "@[%a@]@." @@ -580,7 +584,8 @@ end (** {2 Show Task} *) module Task_show = struct - let run defs names = + let run (log_lvl, defs) names = + Misc.setup_logs log_lvl; catch_err @@ fun () -> let l = CCList.map (Definitions.find_task' defs) names in Format.printf "@[%a@]@." (Misc.pp_list Task.pp) l; @@ -598,7 +603,8 @@ end (** {2 List Tasks} *) module Task_list = struct - let run defs = + let run (log_lvl, defs) = + Misc.setup_logs log_lvl; catch_err @@ fun () -> let l = Definitions.all_tasks defs in Format.printf "@[%a@]@." diff --git a/src/core/Bin_utils.ml b/src/core/Bin_utils.ml index 70205e9..2a209e0 100644 --- a/src/core/Bin_utils.ml +++ b/src/core/Bin_utils.ml @@ -2,10 +2,9 @@ module T = Test module Db = Misc.Db module MStr = Misc.Str_map -let definitions_term : Definitions.t Cmdliner.Term.t = +let definitions_term : (Logs.level option * Definitions.t) Cmdliner.Term.t = let open Cmdliner in let aux conf_files with_default logs_cmd = - Misc.setup_logs logs_cmd; let conf_files = CCList.flatten conf_files in let conf_files = let default_conf = Misc.default_config () in @@ -22,7 +21,7 @@ let definitions_term : Definitions.t Cmdliner.Term.t = try let stanzas = Stanza.parse_files conf_files in let defs = Definitions.add_stanza_l stanzas Definitions.empty in - `Ok defs + `Ok (logs_cmd, defs) with Error.E err -> `Error (false, Error.show err) in let args = diff --git a/src/core/Prover.ml b/src/core/Prover.ml index bdc841a..1bff507 100644 --- a/src/core/Prover.ml +++ b/src/core/Prover.ml @@ -347,7 +347,7 @@ let of_db db name : t = ~ty:Db.Ty.(p1 text, p2 any_str any_str, mkp2) ~f:Db.Cursor.to_list name with e -> - Log.err (fun k -> + Log.debug (fun k -> k "prover.of_db: could not find tags: %s" (Printexc.to_string e)); [] in diff --git a/src/core/Test_detailed_res.ml b/src/core/Test_detailed_res.ml index 43942a0..5f9c8a2 100644 --- a/src/core/Test_detailed_res.ml +++ b/src/core/Test_detailed_res.ml @@ -141,9 +141,8 @@ let get_res db prover file : _ * proof_check_res option = float; float; ], - fun x1 x2 x3 x4 x5 x6 x7 x8 x9 -> - Logs.info (fun k -> k "got results"); - x1, x2, x3, x4, x5, x6, x7, x8, x9 )) + fun x1 x2 x3 x4 x5 x6 x7 x8 x9 -> x1, x2, x3, x4, x5, x6, x7, x8, x9 + )) |> Misc.unwrap_db (fun () -> spf "listing results") |> Error.unwrap_opt' (fun () -> spf "expected a non-empty result for prover='%s', file='%s'" prover @@ -157,7 +156,6 @@ let get_res db prover file : _ * proof_check_res option = rtime, utime, stime ) -> - Logs.info (fun k -> k "got results 2"); let stdout = CCOpt.get_or ~default:"" stdout in let stderr = CCOpt.get_or ~default:"" stderr in Logs.debug (fun k -> k "res.of_string tags=[%s]" (String.concat "," tags)); @@ -171,9 +169,7 @@ let get_res db prover file : _ * proof_check_res option = { Run_proc_result.errcode; stdout; stderr; rtime; utime; stime } in let proof_check_res = get_proof_check db prover file in - Logs.info (fun k -> k "try to get prover"); let prover = Prover.of_db db prover in - Logs.info (fun k -> k "got prover"); Run_result.map ~f:(fun _ -> prover) res, proof_check_res module PB = PrintBox diff --git a/src/core/Test_stat.ml b/src/core/Test_stat.ml index 913577b..e56d83b 100644 --- a/src/core/Test_stat.ml +++ b/src/core/Test_stat.ml @@ -11,12 +11,7 @@ module Stats = struct let curr = snd let init = { n = 0; total = 0.; mean = 0., 0.; s = 0., 0. } - let step ({ n; total; mean; s } as acc) x = - let x = - match x with - | Sqlite3.Data.FLOAT f -> f - | _ -> assert false - in + let step ({ n; total; mean; s } as acc) (x : float) = let n = n + 1 in let total = total +. x in if n = 1 then @@ -40,13 +35,6 @@ module Stats = struct 0. else Float.(sqrt (s /. of_int (n - 1))) - - let final acc = - let res = Fmt.asprintf "%f|%f|%f" (total acc) (mean acc) (sd acc) in - Sqlite3.Data.TEXT res - - let attach_aggregate db = - Sqlite3.Aggregate.create_fun1 db ~init ~step ~final "stats" end type detail_stats = { n: int; total: float; mean: float; sd: float } @@ -159,29 +147,35 @@ let to_printbox_l ?(details = false) ?to_link l : PB.t = let of_db_for ~(prover : Prover.name) (db : Db.t) : t = Error.guard (Error.wrapf "reading stat(%s) from DB" prover) @@ fun () -> let custom = Prover.tags_of_db db in - Stats.attach_aggregate db; - let convert n stats = - let extract_stats stats = - String.split_on_char '|' stats |> List.map Float.of_string |> function - | [ total; mean; sd ] -> - { n = CCOpt.get_or ~default:0 n; total; mean; sd } - | _ -> assert false - in - extract_stats stats - in let get_res r = Error.guard (Error.wrapf "get-res %S" r) @@ fun () -> - Logs.debug (fun k -> k "get-res %S" r); - Db.exec db - {| select count(*), stats(rtime) from prover_res where prover=? and res=?; |} - prover r - ~ty:Db.Ty.(p2 text text, p2 (nullable int) text, convert) - ~f:Db.Cursor.get_one_exn - |> Misc.unwrap_db (fun () -> spf "problems with result %s" r) + let count : int option = + Db.exec db {| select count(*) from prover_res where prover=? and res=?; |} + prover r + ~ty:Db.Ty.(p2 text text, p1 (nullable int), Fun.id) + ~f:Db.Cursor.get_one_exn + |> Misc.unwrap_db (fun () -> spf "problems with result %s" r) + in + + let stats = + let stat = ref Stats.init in + Db.exec db {| select rtime from prover_res where prover=? and res=?; |} + prover r + ~ty:Db.Ty.(p2 text text, p1 float, Fun.id) + ~f:(fun cursor -> + Db.Cursor.iter cursor ~f:(fun rtime -> stat := Stats.step !stat rtime)) + |> Misc.unwrap_db (fun () -> spf "problems with result %s" r); + !stat + in + + let total = Stats.total stats in + let mean = Stats.mean stats in + let sd = Stats.sd stats in + { n = CCOpt.get_or ~default:0 count; total; mean; sd } in + let get_proof_res r = Error.guard (Error.wrapf "get-proof-res %S %S" prover r) @@ fun () -> - Logs.debug (fun k -> k "get-proof-res %S %S" prover r); try Db.exec db {| select count( * ) from proof_check_res where prover=? and res=?; |} diff --git a/src/server/benchpress_server.ml b/src/server/benchpress_server.ml index f39905e..6e7a815 100644 --- a/src/server/benchpress_server.ml +++ b/src/server/benchpress_server.ml @@ -9,6 +9,36 @@ module Log = (val Logs.src_log (Logs.Src.create "benchpress-serve")) let spf = Printf.sprintf let[@inline] ( let@ ) f x = f x +module Logger = struct + let show_lvl = function + | Logs.Debug -> "<7>DEBUG" + | Logs.Info -> "<6>INFO" + | Logs.Error -> "<3>ERROR" + | Logs.Warning -> "<4>WARNING" + | Logs.App -> "<5>APP" + + let make_stdout () : Logs.reporter = + let app = Format.std_formatter in + let dst = Format.std_formatter in + let pp_header out (lvl, src) : unit = + let src = + match src with + | None -> "" + | Some s -> spf "[%s]" s + in + Fmt.fprintf out "%s%s: " (show_lvl lvl) src + in + Logs.format_reporter ~pp_header ~app ~dst () + + let setup (lvl : Logs.level option) = + let m = Mutex.create () in + Logs.set_reporter_mutex + ~lock:(fun () -> Mutex.lock m) + ~unlock:(fun () -> Mutex.unlock m); + Logs.set_level ~all:true lvl; + Logs.set_reporter @@ make_stdout () +end + type expect_filter = | TD_expect_improved | TD_expect_ok @@ -48,7 +78,7 @@ end = struct let attrs_of_style (s : B.Style.t) : _ list * _ = let open B.Style in - let { bold; bg_color; fg_color } = s in + let { bold; bg_color; fg_color; _ } = s in let encode_color = function | Red -> "red" | Blue -> "blue" @@ -348,9 +378,9 @@ let handle_show (self : t) : unit = H.Route.(exact "show" @/ string_urlencoded @/ return) @@ fun file _req -> let@ chrono = query_wrap (Error.wrapf "serving %s" @@ uri_show file) in - Log.info (fun k -> k "----- start show %s -----" file); + Log.debug (fun k -> k "----- start show %s -----" file); let _file_full, cr = Bin_utils.load_file_summary ~full:false file in - Log.info (fun k -> + Log.debug (fun k -> k "show: loaded summary in %.3fs" (Misc.Chrono.since_last chrono)); let box_meta = (* link to the prover locally *) @@ -377,7 +407,7 @@ let handle_show (self : t) : unit = let uri_plot = uri_gnuplot file in let uri_err = uri_error_bad file in let uri_invalid = uri_invalid file in - Log.info (fun k -> + Log.debug (fun k -> k "rendered to PB in %.3fs" (Misc.Chrono.since_last chrono)); let h = let open Html in @@ -435,7 +465,7 @@ let handle_show (self : t) : unit = [ h3 [] [ txt "comparisons" ]; div [] [ pb_html box_compare_l ] ]); ] in - Log.info (fun k -> + Log.debug (fun k -> k "show: turned into html in %.3fs" (Misc.Chrono.since_last chrono)); Log.debug (fun k -> k "show: successful reply for %S" file); H.Response.make_string ~headers:default_html_headers (Ok (Html.to_string h)) @@ -447,7 +477,7 @@ let handle_prover_in (self : t) : unit = exact "prover-in" @/ string_urlencoded @/ string_urlencoded @/ return) @@ fun file p_name _req -> let@ _chrono = query_wrap (Error.wrapf "prover-in-file/%s/%s" file p_name) in - Log.info (fun k -> k "----- start prover-in %s %s -----" file p_name); + Log.debug (fun k -> k "----- start prover-in %s %s -----" file p_name); let@ db = Bin_utils.with_file_as_db ~map_err:(Error.wrapf "reading file '%s'" file) @@ -482,7 +512,7 @@ let handle_show_gp (self : t) : unit = H.Route.(exact "show-gp" @/ string_urlencoded @/ return) @@ fun q_arg _req -> let@ chrono = query_wrap (Error.wrapf "serving /show-gp/%s" q_arg) in - Log.info (fun k -> k "----- start show-gp %s -----" q_arg); + Log.debug (fun k -> k "----- start show-gp %s -----" q_arg); let files = CCString.split_on_char ',' q_arg |> List.map String.trim in let files_full = CCList.map @@ -520,16 +550,16 @@ let handle_show_errors (self : t) : unit = H.Route.(exact "show-err" @/ string_urlencoded @/ return) @@ fun file _req -> let@ chrono = query_wrap (Error.wrapf "serving show-err/%s" file) in - Log.info (fun k -> k "----- start show-err %s -----" file); + Log.debug (fun k -> k "----- start show-err %s -----" file); let _file_full, cr = Bin_utils.load_file_summary ~full:true file in - Log.info (fun k -> + Log.debug (fun k -> k "show-err: loaded full summary in %.3fs" (Misc.Chrono.since_last chrono)); let link_file = link_show_single file in let bad = Test_analyze.to_printbox_bad_l ~link:link_file cr.cr_analyze in let errors = Test_analyze.to_printbox_errors_l ~link:link_file cr.cr_analyze in - Log.info (fun k -> + Log.debug (fun k -> k "rendered to PB in %.3fs" (Misc.Chrono.since_last chrono)); let mk_dl_file l = let open Html in @@ -577,8 +607,8 @@ let handle_show_errors (self : t) : unit = errors); ] in - Log.info (fun k -> - k "show:turned into html in %.3fs" (Misc.Chrono.since_last chrono)); + Log.debug (fun k -> + k "show: turned into html in %.3fs" (Misc.Chrono.since_last chrono)); Log.debug (fun k -> k "successful reply for %S" file); H.Response.make_string (Ok (Html.to_string_elt h)) @@ -587,15 +617,16 @@ let handle_show_invalid (self : t) : unit = H.Route.(exact "show-invalid" @/ string_urlencoded @/ return) @@ fun file _req -> let@ chrono = query_wrap (Error.wrapf "serving show-invalid/%s" file) in - Log.info (fun k -> k "----- start show-invalid %s -----" file); + Log.debug (fun k -> k "----- start show-invalid %s -----" file); let _file_full, cr = Bin_utils.load_file_summary ~full:true file in - Log.info (fun k -> - k "show-err: loaded full summary in %.3fs" (Misc.Chrono.since_last chrono)); + Log.debug (fun k -> + k "show-invalid: loaded full summary in %.3fs" + (Misc.Chrono.since_last chrono)); let link_file = link_show_single file in let invalid = Test_analyze.to_printbox_invalid_proof_l ~link:link_file cr.cr_analyze in - Log.info (fun k -> + Log.debug (fun k -> k "rendered to PB in %.3fs" (Misc.Chrono.since_last chrono)); let mk_dl_file l = let open Html in @@ -626,8 +657,8 @@ let handle_show_invalid (self : t) : unit = ]) invalid) in - Log.info (fun k -> - k "show:turned into html in %.3fs" (Misc.Chrono.since_last chrono)); + Log.debug (fun k -> + k "show-info: turned into html in %.3fs" (Misc.Chrono.since_last chrono)); Log.debug (fun k -> k "successful reply for %S" file); H.Response.make_string (Ok (Html.to_string_elt h)) @@ -669,7 +700,7 @@ let handle_show_as_table (self : t) : unit = Test_top_result.db_to_printbox_table ?filter_res ~filter_pb ~offset ~link_pb:link_get_file ~page_size ~link_res db in - Log.info (fun k -> + Log.debug (fun k -> k "loaded table[offset=%d] in %.3fs" offset (Misc.Chrono.since_last chrono)); let h = @@ -1601,7 +1632,7 @@ let handle_root (self : t) : unit = ]; ] in - Log.info (fun k -> + Log.debug (fun k -> k "listed results in %.3fs" (Misc.Chrono.since_last chrono)); Jemalloc.epoch (); H.Response.make_string ~headers:default_html_headers (Ok (Html.to_string h)) @@ -1627,7 +1658,7 @@ let handle_file_summary (self : t) : unit = H.Response.make_string ~headers:default_html_headers (Ok (Html.to_string_elt h)) in - Log.info (fun k -> + Log.debug (fun k -> k "summary for %s in %.3fs" file (Misc.Chrono.since_last chrono)); r @@ -1675,8 +1706,10 @@ let handle_file self : unit = (** {2 Embedded web server} *) module Cmd = struct - let main ?(local_only = false) ?port ~allow_delete (defs : Definitions.t) () = + let main ?(local_only = false) ?port ~allow_delete ~log_lvl + (defs : Definitions.t) () = try + Logger.setup log_lvl; let addr = if local_only then "127.0.0.1" @@ -1684,6 +1717,11 @@ module Cmd = struct "0.0.0.0" in let server = H.create ~max_connections:32 ~addr ?port () in + + let prometheus = Tiny_httpd_prometheus.(global) in + Tiny_httpd_prometheus.instrument_server server prometheus; + Tiny_httpd_prometheus.GC_metrics.create_and_update_before_emit prometheus; + let data_dir = Misc.data_dir () in let self = { @@ -1697,10 +1735,6 @@ module Cmd = struct in (* thread to execute tasks *) let _th_r = Thread.create Task_queue.loop self.task_q in - (* trick: see if debug level is active *) - Log.debug (fun k -> - H._enable_debug true; - k "enable http debug"); (* maybe serve the API *) Printf.printf "listen on http://localhost:%d/\n%!" (H.port server); handle_root self; @@ -1743,8 +1777,8 @@ module Cmd = struct & info [ "allow-delete" ] ~doc:"allow deletion of files") and defs = Bin_utils.definitions_term in let doc = "serve embedded web UI on given port" in - let aux defs port local_only allow_delete () = - main ?port ~local_only ~allow_delete defs () + let aux (log_lvl, defs) port local_only allow_delete () = + main ?port ~local_only ~allow_delete defs ~log_lvl () in ( Term.(const aux $ defs $ port $ local_only $ allow_delete $ const ()), Cmd.info ~doc "serve" ) diff --git a/src/server/dune b/src/server/dune index 1e0d4dd..e559d45 100644 --- a/src/server/dune +++ b/src/server/dune @@ -7,7 +7,7 @@ (into ../../) (until-clean)) (libraries benchpress containers cmdliner result uuidm logs logs.cli - tiny_httpd sqlite3_utils base64 printbox jemalloc) + tiny_httpd tiny_httpd.prometheus sqlite3_utils base64 printbox jemalloc) (flags :standard -warn-error -a+8 -safe-string -open Benchpress -linkall)) (rule diff --git a/src/worker/benchpress_worker.ml b/src/worker/benchpress_worker.ml index de63b03..9704df9 100644 --- a/src/worker/benchpress_worker.ml +++ b/src/worker/benchpress_worker.ml @@ -1,6 +1,7 @@ let parse_cmdline = let open Cmdliner in - let aux defs id socket_addr_opt socket_port j timeout memory = + let aux (log_lvl, defs) id socket_addr_opt socket_port j timeout memory = + Misc.setup_logs log_lvl; try let socket_addr = match socket_addr_opt with