From f5d60943a8f6937745e326a1071de95351504608 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Fri, 15 Nov 2024 11:49:44 +0000
Subject: [PATCH] CP-52708: Avoid making Unix read/write calls for internal API
 calls: forward the API call directly like we do with the CLI for calls to the
 coordinator when we are the coordinator
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 ocaml/xapi/helpers.ml | 33 +++++++++++++++++++++------------
 ocaml/xapi/xapi.ml    |  7 +++++++
 2 files changed, 28 insertions(+), 12 deletions(-)

diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml
index 1175b6aa03..31ffc71172 100644
--- a/ocaml/xapi/helpers.ml
+++ b/ocaml/xapi/helpers.ml
@@ -402,6 +402,11 @@ module TraceHelper = struct
     Tracing_propagator.Propagator.Http.inject_into trace_context
 end
 
+(** Once the server functor has been instantiated, xapi sets this reference to the appropriate
+    "fake_rpc" (loopback non-HTTP) rpc function. 
+    This way, internally the coordinator can short-circuit API calls without having to go over the network. *)
+let rpc_fun : (Http.Request.t -> Rpc.call -> Rpc.response) option ref = ref None
+
 (* Note that both this and `make_timeboxed_rpc` are almost always
  * partially applied, returning a function of type 'Rpc.request -> Rpc.response'.
  * The body is therefore not evaluated until the RPC call is actually being
@@ -418,18 +423,22 @@ let make_rpc ~__context rpc : Rpc.response =
   in
   let http = xmlrpc ~subtask_of ~version:"1.1" path in
   let http = TraceHelper.inject_span_into_req tracing http in
-  let transport =
-    if Pool_role.is_master () then
-      Unix Xapi_globs.unix_domain_socket
-    else
-      SSL
-        ( SSL.make ~use_stunnel_cache:true ~verify_cert:(Stunnel_client.pool ())
-            ()
-        , Pool_role.get_master_address ()
-        , !Constants.https_port
-        )
-  in
-  dorpc ~srcstr:"xapi" ~dststr:"xapi" ~transport ~http rpc
+  match !rpc_fun with
+  | Some rpcfun when Pool_role.is_master () ->
+      rpcfun http rpc
+  | _ ->
+      let transport =
+        if Pool_role.is_master () then
+          Unix Xapi_globs.unix_domain_socket
+        else
+          SSL
+            ( SSL.make ~use_stunnel_cache:true
+                ~verify_cert:(Stunnel_client.pool ()) ()
+            , Pool_role.get_master_address ()
+            , !Constants.https_port
+            )
+      in
+      dorpc ~srcstr:"xapi" ~dststr:"xapi" ~transport ~http rpc
 
 let make_timeboxed_rpc ~__context timeout rpc : Rpc.response =
   let subtask_of = Ref.string_of (Context.get_task_id __context) in
diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml
index dc1a1e7e04..726944eacf 100644
--- a/ocaml/xapi/xapi.ml
+++ b/ocaml/xapi/xapi.ml
@@ -159,11 +159,18 @@ let random_setup () =
   finally (fun () -> really_input chan s 0 n) (fun () -> close_in chan) ;
   Random.full_init (Array.init n (fun i -> Char.code (Bytes.get s i)))
 
+let dummy_fd, dummy_fd2 = Unix.pipe ()
+
+let () = Unix.close dummy_fd
+
+let fake_rpc2 req rpc = Api_server.Server.dispatch_call req dummy_fd2 rpc
+
 let register_callback_fns () =
   let fake_rpc req sock xml : Rpc.response =
     Api_server.callback1 false req sock xml
   in
   Xapi_cli.rpc_fun := Some fake_rpc ;
+  Helpers.rpc_fun := Some fake_rpc2 ;
   Message_forwarding.register_callback_fns ()
 
 let noevents = ref false