CA-283754: ppxified interfaces, do not discard internal errors (#204)

* CA-283754: memory_interface, do not discard internal errors

Signed-off-by: Marcello Seri <[email protected]>

* memory_interface: run ocp-indent

Signed-off-by: Marcello Seri <[email protected]>

* CA-283754: gpumon_interface, do not discard internal errors

Signed-off-by: Marcello Seri <[email protected]>

* gpumon_interface: run ocp-indent

Signed-off-by: Marcello Seri <[email protected]>

* CA-283754: v6_interface, do not discard internal errors

Signed-off-by: Marcello Seri <[email protected]>

Author: mseri

gpumon/gpumon_interface.ml

@@ -64,6 +64,8 @@ type gpu_errors =
   (** Exception raised when gpumon is unable to load the nvml nvidia library *)
   | NvmlFailure of string
   (** Exception raised by the c bindings to the nvml nvidia library*)
+  | Internal_error of string
+  (** Exception raised if an unexpected error is triggered by the library *)
   | Gpumon_failure
   (** Default exception raised upon daemon failure *)
 [@@default Gpumon_failure]
@@ -72,11 +74,13 @@ type gpu_errors =
 exception Gpumon_error of gpu_errors
 
 (** Error handler *)
-module GpuErrors = Error.Make(struct
-    type t = gpu_errors
-    let t = gpu_errors
-  end)
-let gpu_err = GpuErrors.error
+let gpu_err = Error.{
+    def = gpu_errors;
+    raiser = (fun e -> raise (Gpumon_error e));
+    matcher = (function
+        | Gpumon_error e -> Some e
+        | e -> Some (Internal_error (Printexc.to_string e)))
+  }
 
 (** Functor to autogenerate API calls *)
 module RPC_API(R : RPC) = struct
@@ -151,9 +155,9 @@ module RPC_API(R : RPC) = struct
       declare "get_vgpu_metadata"
         [ "Obtains metadata for all vGPUs running in a domain." ]
         ( debug_info_p
-         @-> domid_p
-         @-> pgpu_address_p
-         @-> returning nvidia_vgpu_metadata_list_p gpu_err
+          @-> domid_p
+          @-> pgpu_address_p
+          @-> returning nvidia_vgpu_metadata_list_p gpu_err
         )
 
     let get_pgpu_vgpu_compatibility =

memory/memory_interface.ml

@@ -13,7 +13,7 @@
  *)
 (**
  * @group Memory
- *)
+*)
 open Rpc
 open Idl
 
@@ -24,57 +24,64 @@ let xml_path = "/var/xapi/memory"
 
 type reservation_id =
   string [@@doc [
-    "The reservation_id is an opaque identifier associated with a block of ";
-    "memory. It is used to reserve memory for a domain before the domain has ";
-    "been created.";
-  ]]
-  [@@deriving rpcty]
+  "The reservation_id is an opaque identifier associated with a block of ";
+  "memory. It is used to reserve memory for a domain before the domain has ";
+  "been created.";
+]]
+[@@deriving rpcty]
 
 type domain_zero_policy =
-   | Fixed_size of int64 [@doc ["Never balloon, use the specified fixed size"]]
-   | Auto_balloon of int64 * int64 [@doc ["Balloon between the two sizes specified"]]
-  [@@doc ["Domain zero can have a different policy to that used by guest domains."]]
-  [@@deriving rpcty]
+  | Fixed_size of int64 [@doc ["Never balloon, use the specified fixed size"]]
+  | Auto_balloon of int64 * int64 [@doc ["Balloon between the two sizes specified"]]
+[@@doc ["Domain zero can have a different policy to that used by guest domains."]]
+[@@deriving rpcty]
 
 type errors =
-| Cannot_free_this_much_memory of (int64 * int64)
-[@doc [
-  "[Cannot_free_this_much_memory (required, free)] is reported if it is not ";
-  "possible to free [required] kib. [free] is the amount of memory currently free"]]
-| Domains_refused_to_cooperate of (int list)
-[@doc [
-  "[Domains_refused_to_cooperate (domid list)] is reported if a set of domains do ";
-  "not respond in a timely manner to the request to balloon. The uncooperative ";
-  "domain ids are returned."]]
-| Unknown_reservation of (reservation_id)
-[@doc [
-  "[Unknown_reservation (id)] is reported if a the specified reservation_id is ";
-  "unknown."
-]]
-| No_reservation
-[@doc [
-  "[No_reservation] is reported by [query_reservation_of_domain] if the domain ";
-  "does not have a reservation."
-]]
-| Invalid_memory_value of (int64)
-[@doc [
-  "[Invalid_memory_value (value)] is reported if a memory value passed is not ";
-  "valid, e.g. negative."
-]]
-| Unknown_error
-[@doc [
-  "The default variant for forward compatibility."
-]]
+  | Cannot_free_this_much_memory of (int64 * int64)
+        [@doc [
+          "[Cannot_free_this_much_memory (required, free)] is reported if it is not ";
+          "possible to free [required] kib. [free] is the amount of memory currently free"]]
+  | Domains_refused_to_cooperate of (int list)
+        [@doc [
+          "[Domains_refused_to_cooperate (domid list)] is reported if a set of domains do ";
+          "not respond in a timely manner to the request to balloon. The uncooperative ";
+          "domain ids are returned."]]
+  | Unknown_reservation of (reservation_id)
+        [@doc [
+          "[Unknown_reservation (id)] is reported if a the specified reservation_id is ";
+          "unknown."
+        ]]
+  | No_reservation
+      [@doc [
+        "[No_reservation] is reported by [query_reservation_of_domain] if the domain ";
+        "does not have a reservation."
+      ]]
+  | Invalid_memory_value of (int64)
+        [@doc [
+          "[Invalid_memory_value (value)] is reported if a memory value passed is not ";
+          "valid, e.g. negative."
+        ]]
+  | Internal_error of (string)
+        [@doc [
+          "[Internal_error (value)] is reported if an unexpected error is triggered ";
+          "by the library."
+        ]]
+  | Unknown_error
+      [@doc [
+        "The default variant for forward compatibility."
+      ]]
 [@@default Unknown_error]
 [@@deriving rpcty]
 
 exception MemoryError of errors
 
 let err = Error.{
-  def = errors;
-  raiser = (function | e -> raise (MemoryError e));
-  matcher = function | MemoryError e -> Some e | _ -> None
-}
+    def = errors;
+    raiser = (fun e -> raise (MemoryError e));
+    matcher = (function
+        | MemoryError e -> Some e
+        | e -> Some (Internal_error (Printexc.to_string e)))
+  }
 
 type debug_info = string
 [@@doc ["An uninterpreted string associated with the operation."]]
@@ -108,118 +115,118 @@ module API(R : RPC) = struct
   (* General parameters, used by more than one API call *)
 
   let debug_info_p = Param.mk ~description:[
-    "An uninterpreted string to associate with the operation."
+      "An uninterpreted string to associate with the operation."
     ] Types.string
 
   let diagnostics_result_p = Param.mk ~description:[
-    "A string containing diagnostic information from the server."
+      "A string containing diagnostic information from the server."
     ] Types.string
 
   let service_name_p = Param.mk ~description:[
-    "The name of the service attempting to interact with the squeeze daemon."
+      "The name of the service attempting to interact with the squeeze daemon."
     ] Types.string
 
   let session_id_p = Param.mk ~description:[
-    "An identifier to associate requests with a client. This is ";
-    "obtained by a call to [login]."]
-    Types.string
+      "An identifier to associate requests with a client. This is ";
+      "obtained by a call to [login]."]
+      Types.string
 
   let domid_p = Param.mk ~description:[
-    "Domain id of a VM."
+      "Domain id of a VM."
     ] Types.int
 
   let reservation_id_p = Param.mk ~description:[
-    "The reservation_id is the token used to identify a memory allocation."
+      "The reservation_id is the token used to identify a memory allocation."
     ] reservation_id
 
   let size_p = Param.mk ~description:[
-    "The size in bytes to reserve"]
-    Types.int64
+      "The size in bytes to reserve"]
+      Types.int64
 
   let unit_p = Param.mk Types.unit
 
   (* Individual API calls *)
 
   let get_diagnostics = declare
-    "get_diagnostics"
-    ["Gets diagnostic information from the server"]
-    (debug_info_p @-> returning diagnostics_result_p err)
+      "get_diagnostics"
+      ["Gets diagnostic information from the server"]
+      (debug_info_p @-> returning diagnostics_result_p err)
 
   let login = declare
-    "login"
-    ["Logs into the squeeze daemon. Any reservations previously made with the ";
-    "specified service name not yet associated with a domain will be removed."]
-    (debug_info_p @-> service_name_p @-> returning session_id_p err)
+      "login"
+      ["Logs into the squeeze daemon. Any reservations previously made with the ";
+       "specified service name not yet associated with a domain will be removed."]
+      (debug_info_p @-> service_name_p @-> returning session_id_p err)
 
 
   let reserve_memory = declare
-    "reserve_memory"
-    ["[reserve_memory dbg session size] reserves memory for a domain. If necessary, ";
-     "other domains will be ballooned down to ensure [size] is available. The call ";
-     "returns a reservation_id that can later be transferred to a domain."]
-    (debug_info_p @-> session_id_p @-> size_p @-> returning reservation_id_p err)
+      "reserve_memory"
+      ["[reserve_memory dbg session size] reserves memory for a domain. If necessary, ";
+       "other domains will be ballooned down to ensure [size] is available. The call ";
+       "returns a reservation_id that can later be transferred to a domain."]
+      (debug_info_p @-> session_id_p @-> size_p @-> returning reservation_id_p err)
 
   let reserve_memory_range =
     let result = Param.mk
-      ~description:[
-        "A tuple containing the reservation_id and the amount of memory actually reserved."
-      ]
-      reserve_memory_range_result
+        ~description:[
+          "A tuple containing the reservation_id and the amount of memory actually reserved."
+        ]
+        reserve_memory_range_result
     in
     declare
       "reserve_memory_range"
-     ["[reserve_memory_range dbg session min max] reserves memory for a domain. If necessary, ";
-      "other domains will be ballooned down to ensure enough memory is available. The amount ";
-      "of memory will be between [min] and [max] according to the policy in operation. The call ";
-      "returns a reservation_id and the actual memory amount that can later be transferred to a domain."]
-    (debug_info_p @-> session_id_p @-> size_p @-> size_p @-> returning result err)
+      ["[reserve_memory_range dbg session min max] reserves memory for a domain. If necessary, ";
+       "other domains will be ballooned down to ensure enough memory is available. The amount ";
+       "of memory will be between [min] and [max] according to the policy in operation. The call ";
+       "returns a reservation_id and the actual memory amount that can later be transferred to a domain."]
+      (debug_info_p @-> session_id_p @-> size_p @-> size_p @-> returning result err)
 
 
   let delete_reservation =
     declare
-    "delete_reservation"
-    ["Deletes a reservation. Note that memory rebalancing is not done synchronously after the ";
-     "operation has completed."]
-    (debug_info_p @-> session_id_p @-> reservation_id_p @-> returning unit_p err)
+      "delete_reservation"
+      ["Deletes a reservation. Note that memory rebalancing is not done synchronously after the ";
+       "operation has completed."]
+      (debug_info_p @-> session_id_p @-> reservation_id_p @-> returning unit_p err)
 
   let transfer_reservation_to_domain =
     declare
-    "transfer_reservation_to_domain"
-    ["Transfers a reservation to a domain. This is called when the domain has been created for ";
-     "the VM for which the reservation was initially made."]
-    (debug_info_p @-> session_id_p @-> reservation_id_p @-> domid_p @-> returning unit_p err)
+      "transfer_reservation_to_domain"
+      ["Transfers a reservation to a domain. This is called when the domain has been created for ";
+       "the VM for which the reservation was initially made."]
+      (debug_info_p @-> session_id_p @-> reservation_id_p @-> domid_p @-> returning unit_p err)
 
   let query_reservation_of_domain =
     declare
-    "query_reservation_of_domain"
-    ["Queries the reservation_id associated with a domain"]
-    (debug_info_p @-> session_id_p @-> domid_p @-> returning reservation_id_p err)
+      "query_reservation_of_domain"
+      ["Queries the reservation_id associated with a domain"]
+      (debug_info_p @-> session_id_p @-> domid_p @-> returning reservation_id_p err)
 
   let balance_memory =
     declare
-    "balance_memory"
-    ["Forces a rebalance of the hosts memory. Blocks until the system is in a stable ";
-    "state."]
-    (debug_info_p @-> returning unit_p err)
+      "balance_memory"
+      ["Forces a rebalance of the hosts memory. Blocks until the system is in a stable ";
+       "state."]
+      (debug_info_p @-> returning unit_p err)
 
   let get_host_reserved_memory =
     declare
-    "get_host_reserved_memory"
-    ["Gets the amount of reserved memory in a host. This is the lower limit of memory that ";
-     "squeezed will ensure remains unused by any domain or reservation."]
-    (debug_info_p @-> returning size_p err)
+      "get_host_reserved_memory"
+      ["Gets the amount of reserved memory in a host. This is the lower limit of memory that ";
+       "squeezed will ensure remains unused by any domain or reservation."]
+      (debug_info_p @-> returning size_p err)
 
   let get_host_initial_free_memory =
     declare
-    "get_host_initial_free_memory"
-    ["Gets the amount of initial free memory in a host"]
-    (debug_info_p @-> returning size_p err)
+      "get_host_initial_free_memory"
+      ["Gets the amount of initial free memory in a host"]
+      (debug_info_p @-> returning size_p err)
 
   let get_domain_zero_policy =
     let result_p = Param.mk ~description:["The policy associated with domain 0"] domain_zero_policy in
     declare
-    "get_domain_zero_policy"
-    ["Gets the ballooning policy for domain zero."]
-    (debug_info_p @-> returning result_p err)
+      "get_domain_zero_policy"
+      ["Gets the ballooning policy for domain zero."]
+      (debug_info_p @-> returning result_p err)
 
 end

v6/v6_interface.ml

@@ -82,6 +82,8 @@ type errors =
   (** Thrown if connection port or address parameter not supplied to check_license *)
   | V6d_failure
   (** Daemon failed to enable features *)
+  | Internal_error of string
+  (** Exception raised if an unexpected error is triggered by the library *)
 [@@default V6d_failure]
 [@@deriving rpcty]
 
@@ -92,11 +94,10 @@ exception V6_error of errors
 (** handle exception generation and raising *)
 let err = Error.{
     def = errors;
-    raiser = (function
-        | e -> raise (V6_error e));
+    raiser = (fun e -> raise (V6_error e));
     matcher = (function
-      | V6_error e -> Some e
-      | _ -> None)
+        | V6_error e -> Some e
+        | e -> Some (Internal_error (Printexc.to_string e)))
   }