CP-52708: Avoid making Unix read/write calls for internal API calls: …

ocaml/idl/ocaml_backend/gen_server.ml

@@ -470,7 +470,7 @@ let gen_module api : O.Module.t =
              ~params:
                [
                  O.Anon (Some "http_req", "Http.Request.t")
-               ; O.Anon (Some "fd", "Unix.file_descr")
+               ; O.Anon (Some "fd", "Unix.file_descr option")
                ; O.Anon (Some "call", "Rpc.call")
                ]
              ~ty:"response"

ocaml/tests/test_client.ml

@@ -10,7 +10,7 @@
     work in unit tests. *)
 let make_client_params ~__context =
   let req = Xmlrpc_client.xmlrpc ~version:"1.1" "/" in
-  let rpc = Api_server.Server.dispatch_call req Unix.stdout in
+  let rpc = Api_server.Server.dispatch_call req None in
   let session_id =
     let session_id = Ref.make_secret () in
     let now = Xapi_stdext_date.Date.now () in

ocaml/xapi/api_server.ml

@@ -33,7 +33,7 @@ let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call =
   else
     let response =
       let@ req = Helper.with_tracing ~name:"Server.dispatch_call" req in
-      Server.dispatch_call req fd call
+      Server.dispatch_call req (Some fd) call
     in
     let translated =
       if

ocaml/xapi/context.ml

@@ -460,29 +460,28 @@ let get_http_other_config http_req =
 let of_http_req ?session_id ?(internal_async_subtask = false) ~generate_task_for
     ~supports_async ~label ~http_req ~fd () =
   let http_other_config = get_http_other_config http_req in
+  let origin =
+    match fd with None -> Internal | Some fd -> Http (http_req, fd)
+  in
   let new_task_context () =
     let subtask_of =
       Option.map Ref.of_string http_req.Http.Request.subtask_of
     in
     make ?session_id ?subtask_of ~http_other_config ~task_in_database:true
-      ~origin:(Http (http_req, fd))
-      label
+      ~origin label
   in
   if internal_async_subtask then
     new_task_context ()
   else
     match http_req.Http.Request.task with
     | Some task_id ->
-        from_forwarded_task ?session_id ~http_other_config
-          ~origin:(Http (http_req, fd))
+        from_forwarded_task ?session_id ~http_other_config ~origin
           (Ref.of_string task_id)
     | None ->
         if generate_task_for && supports_async then
           new_task_context ()
         else
-          make ?session_id ~http_other_config
-            ~origin:(Http (http_req, fd))
-            label
+          make ?session_id ~http_other_config ~origin label
 
 let set_test_rpc context rpc = context.test_rpc <- Some rpc
 

ocaml/xapi/context.mli

@@ -49,7 +49,7 @@ val of_http_req :
   -> supports_async:bool
   -> label:string
   -> http_req:Http.Request.t
-  -> fd:Unix.file_descr
+  -> fd:Unix.file_descr option
   -> unit
   -> t
 

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

ocaml/xapi/server.mli

@@ -3,5 +3,5 @@ module Make : functor
   (_ : Custom_actions.CUSTOM_ACTIONS)
   -> sig
   val dispatch_call :
-    Http.Request.t -> Unix.file_descr -> Rpc.call -> Rpc.response
+    Http.Request.t -> Unix.file_descr option -> Rpc.call -> Rpc.response
 end

ocaml/xapi/server_helpers.mli

@@ -61,7 +61,7 @@ val do_dispatch :
   -> string
   -> (__context:Context.t -> 'a)
   -> ('a -> Rpc.t)
-  -> Unix.file_descr
+  -> Unix.file_descr option
   -> Http.Request.t
   -> string
   -> [< `Async | `InternalAsync | `Sync > `Sync `InternalAsync]

ocaml/xapi/xapi.ml

@@ -159,11 +159,14 @@ 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 fake_rpc2 req rpc = Api_server.Server.dispatch_call req None 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