Web: record curl times

Author: rr0gi

web.ml

@@ -41,6 +41,16 @@ let url_get_args url = try String.split url "?" |> snd |> parse_url_args with _
 
 let () = Curl.global_init Curl.CURLINIT_GLOBALALL
 
+let curl_times h =
+  Curl.[
+    "Curl.dns", get_namelookuptime h;
+    "Curl.conn", get_connecttime h;
+(*       "Curl.app", get_appconnecttime; *)
+    "Curl.pre", get_pretransfertime h;
+    "Curl.start", get_starttransfertime h;
+    "Curl.total", get_totaltime h;
+  ]
+
 module CurlCache = Cache.Reuse(struct type t = Curl.t let create = Curl.init let reset = Curl.reset end)
 
 let curl_default_setup h =
@@ -114,6 +124,7 @@ module type HTTP = sig
   val with_curl_cache : (Curl.t -> 'a IO.t) -> 'a IO.t
   val http_gets :
     ?setup:(Curl.t -> unit) ->
+    ?timer:Action.timer ->
     ?max_size:int ->
     ?check:(Curl.t -> bool) ->
     ?result:(Curl.t -> Curl.curlCode -> unit IO.t) ->
@@ -124,6 +135,7 @@ module type HTTP = sig
     ?timeout:int ->
     ?verbose:bool ->
     ?setup:(Curl.t -> unit) ->
+    ?timer:Action.timer ->
     ?max_size:int ->
     ?http_1_0:bool ->
     ?headers:string list ->
@@ -141,6 +153,7 @@ module type HTTP = sig
     ?timeout:int ->
     ?verbose:bool ->
     ?setup:(Curl.t -> unit) ->
+    ?timer:Action.timer ->
     ?http_1_0:bool ->
     ?headers:string list ->
     ?action:http_action ->
@@ -167,6 +180,7 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
     ?timeout:int ->
     ?verbose:bool ->
     ?setup:(Curl.t -> unit) ->
+    ?timer:Action.timer ->
     ?max_size:int ->
     ?http_1_0:bool ->
     ?headers:string list ->
@@ -182,8 +196,18 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
   let with_curl f = bracket (return @@ Curl.init ()) (fun h -> Curl.cleanup h; return_unit) f
   let with_curl_cache f = bracket (return @@ CurlCache.get ()) (fun h -> CurlCache.release h; return_unit) f
 
+  let update_timer h timer =
+    match timer with
+    | None -> ()
+    | Some t ->
+      let total = Curl.get_totaltime h in
+      let now = Time.now () in
+      t#record "Curl.start" (now -. total);
+      curl_times h |> List.iter (fun (name,time) -> t#record name (now -. total +. time));
+      ()
+
   (* deprecated *)
-  let http_gets ?(setup=ignore) ?max_size ?(check=(fun _ -> true)) ?(result=(fun _ _ -> return_unit)) url =
+  let http_gets ?(setup=ignore) ?timer ?max_size ?(check=(fun _ -> true)) ?(result=(fun _ _ -> return_unit)) url =
     with_curl_cache begin fun h ->
       Curl.set_url h url;
       curl_default_setup h;
@@ -201,8 +225,9 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
           | Some max_size when !read_size > max_size -> Exn.fail "received too much data (%db) when max is %db" !read_size max_size
           | _ -> l
       end;
-      Curl_IO.perform h >>= fun code ->
-      result h code >>= fun () ->
+      timer |> Option.may (fun t -> t#mark "Web.http");
+      catch (fun () -> Curl_IO.perform h) (fun exn -> update_timer h timer; IO.raise exn) >>= fun code ->
+      (update_timer h timer; result h code) >>= fun () ->
       return @@ match code with
       | Curl.CURLE_OK -> `Ok (Curl.get_httpcode h, Buffer.contents b)
       | code -> `Error code
@@ -236,7 +261,7 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
 
   (* NOTE don't forget to set http_1_0=true when sending requests to a Httpev-based server *)
   (* Don't use curl_setheaders when using ?headers option *)
-  let http_request' ?ua ?timeout ?(verbose=false) ?(setup=ignore) ?max_size ?(http_1_0=false) ?headers ?body (action:http_action) url =
+  let http_request' ?ua ?timeout ?(verbose=false) ?(setup=ignore) ?timer ?max_size ?(http_1_0=false) ?headers ?body (action:http_action) url =
     let open Curl in
     let set_body_and_headers h ct body =
       set_httpheader h (("Content-Type: "^ct) :: Option.default [] headers);
@@ -282,22 +307,22 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
     end;
     let t = new Action.timer in
     let result = if verbose then Some (verbose_curl_result nr_http action t) else None in
-    http_gets ~setup ?result ?max_size url
+    http_gets ~setup ?timer ?result ?max_size url
 
-  let http_request ?ua ?timeout ?verbose ?setup ?max_size ?http_1_0 ?headers ?body (action:http_action) url =
-    http_request' ?ua ?timeout ?verbose ?setup ?max_size ?http_1_0 ?headers ?body action url >>= fun res ->
+  let http_request ?ua ?timeout ?verbose ?setup ?timer ?max_size ?http_1_0 ?headers ?body (action:http_action) url =
+    http_request' ?ua ?timeout ?verbose ?setup ?timer ?max_size ?http_1_0 ?headers ?body action url >>= fun res ->
     return @@ simple_result ?verbose res
 
-  let http_request_exn ?ua ?timeout ?verbose ?setup ?max_size ?http_1_0 ?headers ?body (action:http_action) url =
-    http_request ?ua ?timeout ?verbose ?setup ?max_size ?http_1_0 ?headers ?body action url
+  let http_request_exn ?ua ?timeout ?verbose ?setup ?timer ?max_size ?http_1_0 ?headers ?body (action:http_action) url =
+    http_request ?ua ?timeout ?verbose ?setup ?timer ?max_size ?http_1_0 ?headers ?body action url
     >>= function `Ok s -> return s | `Error error -> fail "%s" error
 
-  let http_query ?ua ?timeout ?verbose ?setup ?max_size ?http_1_0 ?headers ?body (action:http_action) url =
+  let http_query ?ua ?timeout ?verbose ?setup ?timer ?max_size ?http_1_0 ?headers ?body (action:http_action) url =
     let body = match body with Some (ct,s) -> Some (`Raw (ct,s)) | None -> None in
-    http_request ?ua ?timeout ?verbose ?setup ?max_size ?http_1_0 ?headers ?body action url
+    http_request ?ua ?timeout ?verbose ?setup ?timer ?max_size ?http_1_0 ?headers ?body action url
 
-  let http_submit ?ua ?timeout ?verbose ?setup ?http_1_0 ?headers ?(action=`POST) url args =
-    http_request ?ua ?timeout ?verbose ?setup ?http_1_0 ?headers ~body:(`Form args) action url
+  let http_submit ?ua ?timeout ?verbose ?setup ?timer ?http_1_0 ?headers ?(action=`POST) url args =
+    http_request ?ua ?timeout ?verbose ?setup ?timer ?http_1_0 ?headers ~body:(`Form args) action url
 
 end