http-lib: add backtrace to logs on connection without response

ocaml/libs/http-lib/dune

@@ -113,6 +113,8 @@
     safe-resources
     stunnel
     threads.posix
+    xapi-backtrace
+    xapi-log
     xapi-stdext-pervasives
     xapi-stdext-unix
   )
@@ -133,14 +135,10 @@
   )
 )
 
-(rule
-  (alias runtest)
+(cram
   (package xapi)
   (deps
     test_client.exe
     test_server.exe
-    client_server_test.sh
   )
-  (action (run bash client_server_test.sh))
 )
-

ocaml/libs/http-lib/http_client.ml

@@ -177,6 +177,11 @@ let response_of_fd_exn fd =
        (Astring.String.cuts ~sep:"\n" buf)
     )
 
+(* Use a different logging brand, the one used by {D} is ignore in the default
+   configuration. This allows to have visibility of an issue that interrupts
+   storage migrations. *)
+module L = Debug.Make (struct let name = __MODULE__ end)
+
 (** [response_of_fd fd] returns an optional Http.Response.t record *)
 let response_of_fd ?(use_fastpath = false) fd =
   try
@@ -188,7 +193,10 @@ let response_of_fd ?(use_fastpath = false) fd =
   | Unix.Unix_error (_, _, _) as e ->
       raise e
   | e ->
-      D.debug "%s: returning no response because of the exception: %s"
+      Backtrace.is_important e ;
+      let bt = Backtrace.get e in
+      Debug.log_backtrace e bt ;
+      L.debug "%s: returning no response because of the exception: %s"
         __FUNCTION__ (Printexc.to_string e) ;
       None
 

ocaml/libs/http-lib/test_client.ml

@@ -4,12 +4,15 @@ open Safe_resources
 
 let user_agent = "test_client"
 
-(* To do:
-   1. test with and without SSL
-   2. test with n parallel threads
-   3. make sure xapi still works
-   4. make xapi able to read stats
-*)
+let ip = ref "127.0.0.1"
+
+let port = ref 8080
+
+let use_ssl = ref false
+
+let use_fastpath = ref false
+
+let use_framing = ref false
 
 let with_connection ip port f =
   let inet_addr = Unix.inet_addr_of_string ip in
@@ -108,78 +111,100 @@ let sample n f =
   done ;
   !p
 
-let _ =
-  let ip = ref "127.0.0.1" in
-  let port = ref 8080 in
-  let use_ssl = ref false in
-  let use_fastpath = ref false in
-  let use_framing = ref false in
-  Arg.parse
-    [
-      ("-ip", Arg.Set_string ip, "IP to connect to")
-    ; ("-p", Arg.Set_int port, "port to connect")
-    ; ("-fast", Arg.Set use_fastpath, "use HTTP fastpath")
-    ; ("-frame", Arg.Set use_framing, "use HTTP framing")
-    ; ("--ssl", Arg.Set use_ssl, "use SSL rather than plaintext")
-    ]
-    (fun x -> Printf.fprintf stderr "Ignoring unexpected argument: %s\n" x)
-    "A simple test HTTP client" ;
+let ( let@ ) f x = f x
+
+let perf () =
   let use_fastpath = !use_fastpath in
   let use_framing = !use_framing in
   let transport = if !use_ssl then with_stunnel else with_connection in
-  (*
-	Printf.printf "Overhead of timing:                ";
-	let overhead = sample 10 (fun () -> per_nsec 1. (fun () -> ())) in
-	Printf.printf "%s ops/sec\n" (Normal_population.to_string overhead);
-*)
-  Printf.printf "1 thread non-persistent connections:        " ;
+  Printf.printf "1 thread non-persistent connections:         " ;
   let nonpersistent =
-    sample 1 (fun () ->
-        per_nsec 1. (fun () ->
-            transport !ip !port (one ~use_fastpath ~use_framing false)
-        )
-    )
+    let@ () = sample 10 in
+    let@ () = per_nsec 0.1 in
+    transport !ip !port (one ~use_fastpath ~use_framing false)
   in
   Printf.printf "%s RPCs/sec\n%!" (Normal_population.to_string nonpersistent) ;
-  Printf.printf "1 thread non-persistent connections (query):        " ;
+  Printf.printf "1 thread non-persistent connections (query): " ;
   let nonpersistent_query =
-    sample 1 (fun () ->
-        per_nsec 1. (fun () ->
-            transport !ip !port (query ~use_fastpath ~use_framing false)
-        )
-    )
+    let@ () = sample 10 in
+    let@ () = per_nsec 0.1 in
+    transport !ip !port (query ~use_fastpath ~use_framing false)
   in
   Printf.printf "%s RPCs/sec\n%!"
     (Normal_population.to_string nonpersistent_query) ;
-  Printf.printf "10 threads non-persistent connections: " ;
+  Printf.printf "10 threads non-persistent connections:       " ;
   let thread_nonpersistent =
-    sample 1 (fun () ->
-        threads 10 (fun () ->
-            per_nsec 5. (fun () ->
-                transport !ip !port (one ~use_fastpath ~use_framing false)
-            )
-        )
-    )
+    let@ () = sample 10 in
+    let@ () = threads 10 in
+    let@ () = per_nsec 0.1 in
+    transport !ip !port (one ~use_fastpath ~use_framing false)
   in
   Printf.printf "%s RPCs/sec\n%!"
     (Normal_population.to_string thread_nonpersistent) ;
-  Printf.printf "1 thread persistent connection:             " ;
+  Printf.printf "1 thread persistent connection:              " ;
   let persistent =
-    sample 1 (fun () ->
-        transport !ip !port (fun s ->
-            per_nsec 1. (fun () -> one ~use_fastpath ~use_framing true s)
-        )
-    )
+    let@ () = sample 10 in
+    let@ s = transport !ip !port in
+    let@ () = per_nsec 0.1 in
+    one ~use_fastpath ~use_framing true s
   in
   Printf.printf "%s RPCs/sec\n%!" (Normal_population.to_string persistent) ;
-  Printf.printf "10 threads persistent connections: " ;
+  Printf.printf "10 threads persistent connections:           " ;
   let thread_persistent =
-    sample 1 (fun () ->
-        threads 10 (fun () ->
-            transport !ip !port (fun s ->
-                per_nsec 5. (fun () -> one ~use_fastpath ~use_framing true s)
-            )
-        )
-    )
+    let@ () = sample 10 in
+    let@ () = threads 10 in
+    let@ s = transport !ip !port in
+    let@ () = per_nsec 0.1 in
+    one ~use_fastpath ~use_framing true s
   in
   Printf.printf "%s RPCs/sec\n%!" (Normal_population.to_string thread_persistent)
+
+let send_close_conn ~use_fastpath ~use_framing keep_alive s =
+  try
+    Http_client.rpc ~use_fastpath s
+      (Http.Request.make ~frame:use_framing ~version:"1.1" ~keep_alive
+         ~user_agent ~body:"hello" Http.Get "/close_conn"
+      ) (fun response s ->
+        match response.Http.Response.content_length with
+        | Some l ->
+            let _ = Unixext.really_read_string s (Int64.to_int l) in
+            Printf.printf "Received a response with %Ld bytes.\n" l ;
+            exit 1
+        | None ->
+            Printf.printf "Need a content length\n" ;
+            exit 1
+    )
+  with Unix.Unix_error (Unix.ECONNRESET, "read", "") as e ->
+    Backtrace.is_important e ;
+    let bt = Backtrace.get e in
+    Debug.log_backtrace e bt
+
+let logerr () =
+  (* Send a request to the server to close connection instead of replying with
+     an http request, force the error to be logged *)
+  Printexc.record_backtrace true ;
+  Debug.log_to_stdout () ;
+  Debug.set_level Syslog.Debug ;
+  let use_fastpath = !use_fastpath in
+  let use_framing = !use_framing in
+  let transport = if !use_ssl then with_stunnel else with_connection in
+  let call () =
+    let@ () = Backtrace.with_backtraces in
+    let@ s = transport !ip !port in
+    send_close_conn ~use_fastpath ~use_framing false s
+  in
+  match call () with `Ok () -> () | `Error (_, _) -> ()
+
+let () =
+  Arg.parse
+    [
+      ("-ip", Arg.Set_string ip, "IP to connect to")
+    ; ("-p", Arg.Set_int port, "port to connect")
+    ; ("-fast", Arg.Set use_fastpath, "use HTTP fastpath")
+    ; ("-frame", Arg.Set use_framing, "use HTTP framing")
+    ; ("--ssl", Arg.Set use_ssl, "use SSL rather than plaintext")
+    ; ("--perf", Arg.Unit perf, "Collect performance stats")
+    ; ("--logerr", Arg.Unit logerr, "Test log on error")
+    ]
+    (fun x -> Printf.fprintf stderr "Ignoring unexpected argument: %s\n" x)
+    "A simple test HTTP client"

ocaml/libs/http-lib/test_client_server.t

@@ -0,0 +1,16 @@
+== Bring server up
+  $ trap 'kill $(jobs -p)' EXIT
+  $ ./test_server.exe &
+  $ sleep 0.1
+
+== Normal
+  $ ./test_client.exe --perf > /dev/null
+
+== Expect to log after a closed connection
+  $ ./test_client.exe --logerr > result
+  $ grep "ECONNRESET" result -c
+  1
+  $ grep "backtrace" result -c
+  11
+  $ grep "Called from" result -c
+  8

ocaml/libs/http-lib/test_server.ml

@@ -80,6 +80,10 @@ let _ =
                )
        )
     ) ;
+  (* Forces a protocol error by closing the connection without sending a
+      proper http reponse code *)
+  Server.add_handler server Http.Get "/close_conn"
+    (FdIO (fun _ _ _ -> raise End_of_file)) ;
   let ip = "0.0.0.0" in
   let inet_addr = Unix.inet_addr_of_string ip in
   let addr = Unix.ADDR_INET (inet_addr, !port) in