CP-52708: make file descriptor argument optional in Server.dispatch_call

This will enable short-circuiting internal API calls.

When the FD is missing mark the call as Internal.

Signed-off-by: Edwin Török <[email protected]>

Author: edwintorok

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/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]