Add http status metrics middleware

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
 

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)

http_status_middleware/dune

@@ -0,0 +1,3 @@
+(library
+ (name http_status_metrics)
+ (libraries dream metrics lwt))

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