diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index 45995c9..0c5cd0a 100644 --- a/bin/builder_web_app.ml +++ b/bin/builder_web_app.ml @@ -95,6 +95,7 @@ let setup_app level influx port host datadir = Dream.run ~port ~interface:host ~https:false @@ Dream.logger @@ Dream.sql_pool ("sqlite3:" ^ dbpath) + @@ Http_status_metrics.handle @@ Builder_web.add_routes datadir @@ Dream.not_found diff --git a/bin/dune b/bin/dune index 2768d15..2eee321 100644 --- a/bin/dune +++ b/bin/dune @@ -2,7 +2,7 @@ (public_name builder-web) (name builder_web_app) (modules builder_web_app) - (libraries builder_web mirage-crypto-rng.unix cmdliner logs.cli metrics metrics-lwt metrics-influx metrics-rusage ipaddr ipaddr.unix)) + (libraries builder_web mirage-crypto-rng.unix cmdliner logs.cli metrics metrics-lwt metrics-influx metrics-rusage ipaddr ipaddr.unix http_status_metrics)) (executable (public_name builder-db) diff --git a/http_status_middleware/dune b/http_status_middleware/dune new file mode 100644 index 0000000..35f82ae --- /dev/null +++ b/http_status_middleware/dune @@ -0,0 +1,3 @@ +(library + (name http_status_metrics) + (libraries dream metrics lwt)) diff --git a/http_status_middleware/http_status_metrics.ml b/http_status_middleware/http_status_metrics.ml new file mode 100644 index 0000000..f708131 --- /dev/null +++ b/http_status_middleware/http_status_metrics.ml @@ -0,0 +1,42 @@ +open Lwt.Infix + +let create ~f = + let data : (string, int) Hashtbl.t = Hashtbl.create 7 in + (fun x -> + let key = f x in + let cur = match Hashtbl.find_opt data key with + | None -> 0 + | Some x -> x + in + Hashtbl.replace data key (succ cur)), + (fun () -> + let data, total = + Hashtbl.fold (fun key value (acc, total) -> + (Metrics.uint key value :: acc), value + total) + data ([], 0) + in + Metrics.uint "total" total :: data) + +let counter_metrics ~f name = + let open Metrics in + let doc = "Counter metrics" in + let incr, get = create ~f in + let data thing = incr thing; Data.v (get ()) in + Src.v ~doc ~tags:Metrics.Tags.[] ~data name + +let add_http_status = + let f = function + | #Dream.informational -> "1xx" + | #Dream.successful -> "2xx" + | #Dream.redirection -> "3xx" + | #Dream.client_error -> "4xx" + | #Dream.server_error -> "5xx" + | `Status c -> Printf.sprintf "%dxx" (c / 100) + in + let src = counter_metrics ~f "http_response" in + (fun r -> Metrics.add src (fun x -> x) (fun d -> d r)) + +let handle next_handler req = + next_handler req >|= fun response -> + add_http_status (Dream.status response); + response