Merge feature/guest-vm-service-aware into master

ocaml/idl/datamodel.ml

@@ -7621,6 +7621,10 @@ module VM_guest_metrics = struct
             ~ty:Bool ~default_value:(Some (VBool false)) "PV_drivers_detected"
             "At least one of the guest's devices has successfully connected to \
              the backend."
+        ; field ~qualifier:DynamicRO ~lifecycle:[]
+            ~ty:(Map (String, String))
+            ~default_value:(Some (VMap [])) "services"
+            "The guest's services data."
         ]
       ()
 end

ocaml/idl/datamodel_common.ml

@@ -10,7 +10,7 @@ open Datamodel_roles
               to leave a gap for potential hotfixes needing to increment the schema version.*)
 let schema_major_vsn = 5
 
-let schema_minor_vsn = 786
+let schema_minor_vsn = 787
 
 (* Historical schema versions just in case this is useful later *)
 let rio_schema_major_vsn = 5

ocaml/idl/datamodel_lifecycle.ml

@@ -109,6 +109,8 @@ let prototyped_of_field = function
       Some "22.27.0"
   | "host", "last_software_update" ->
       Some "22.20.0"
+  | "VM_guest_metrics", "services" ->
+      Some "25.14.0-next"
   | "VM_guest_metrics", "netbios_name" ->
       Some "24.28.0"
   | "VM", "groups" ->

ocaml/idl/schematest.ml

@@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex
 (* BEWARE: if this changes, check that schema has been bumped accordingly in
    ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *)
 
-let last_known_schema_hash = "ad67a64cd47cdea32085518c1fb38d27"
+let last_known_schema_hash = "7756b4bea0be3985c1c8f6708f04d442"
 
 let current_schema_hash : string =
   let open Datamodel_types in

ocaml/tests/test_guest_agent.ml

@@ -468,9 +468,93 @@ module Initial_guest_metrics = Generic.MakeStateless (struct
       ]
 end)
 
+module Services = Generic.MakeStateless (struct
+  module Io = struct
+    type input_t = (string * string) list
+
+    type output_t = (string * string) list
+
+    let string_of_input_t = Test_printers.(assoc_list string string)
+
+    let string_of_output_t = Test_printers.(assoc_list string string)
+  end
+
+  (* prototype funtions lookup and list are in Xapi_xenops.ml::update_vm *)
+  let lookup state key = List.assoc_opt key state
+
+  let list_subkeys state dir =
+    if dir = "" then
+      []
+    else
+      let dir =
+        if dir.[0] = '/' then
+          String.sub dir 1 (String.length dir - 1)
+        else
+          dir
+      in
+      let results =
+        List.filter_map
+          (fun (path, _) ->
+            if String.starts_with ~prefix:dir path then
+              let rest =
+                String.sub path (String.length dir)
+                  (String.length path - String.length dir)
+              in
+              let is_sep = function '/' -> true | _ -> false in
+              match Astring.String.fields ~empty:false ~is_sep rest with
+              | x :: _ ->
+                  Some x
+              | _ ->
+                  None
+            else
+              None
+          )
+          state
+        |> Xapi_stdext_std.Listext.List.setify
+      in
+      results
+
+  let transform input =
+    Xapi_guest_agent.get_guest_services (lookup input) (list_subkeys input)
+
+  let tests =
+    `QuickAndAutoDocumented
+      [
+        (* no data/service *)
+        ([("data/key1", "v1"); ("data/key2", "v2")], [])
+      ; (* less than two depth in data/service *)
+        ([("data/service/key1", "v1"); ("data/service/key2", "v2")], [])
+      ; (* beyond two depth in data/service *)
+        ( [
+            ("data/service/service-a/sub/key1", "sab-v1")
+          ; ("data/service/service-a/sub/key2", "sab-v2")
+          ]
+        , [("service-a/sub", "")]
+        )
+      ; (* normal case *)
+        ( [
+            ("data/service", "")
+          ; ("data/service/service-a", "")
+          ; ("data/service/service-b", "")
+          ; ("data/service/service-a/key1", "sa-v1")
+          ; ("data/service/service-a/key2", "sa-v2")
+          ; ("data/service/service-b/key1", "sb-v1")
+          ; ("data/service/service-b/key2", "sb-v2")
+          ]
+        , [
+            ("service-a/key1", "sa-v1")
+          ; ("service-a/key2", "sa-v2")
+          ; ("service-b/key1", "sb-v1")
+          ; ("service-b/key2", "sb-v2")
+          ]
+        )
+      ]
+end)
+
 let tests =
   make_suite "guest_agent_"
     [
       ("networks", Networks.tests)
     ; ("get_initial_guest_metrics", Initial_guest_metrics.tests)
+    ; ("get_guest_services", Services.tests)
     ]

ocaml/xapi-cli-server/records.ml

@@ -2416,6 +2416,18 @@ let vm_record rpc session_id vm =
               (xgm ())
           )
           ()
+      ; make_field ~name:"services"
+          ~get:(fun () ->
+            Option.fold ~none:nid
+              ~some:(fun m -> get_from_map m.API.vM_guest_metrics_services)
+              (xgm ())
+          )
+          ~get_map:(fun () ->
+            Option.fold ~none:[]
+              ~some:(fun m -> m.API.vM_guest_metrics_services)
+              (xgm ())
+          )
+          ()
       ; make_field ~name:"PV-drivers-detected"
           ~get:(fun () ->
             Option.fold ~none:nid

ocaml/xapi/import.ml

@@ -836,6 +836,7 @@ module GuestMetrics : HandlerTools = struct
       ~memory:gm_record.API.vM_guest_metrics_memory
       ~disks:gm_record.API.vM_guest_metrics_disks
       ~networks:gm_record.API.vM_guest_metrics_networks
+      ~services:gm_record.API.vM_guest_metrics_services
       ~pV_drivers_detected:gm_record.API.vM_guest_metrics_PV_drivers_detected
       ~other:gm_record.API.vM_guest_metrics_other
       ~last_updated:gm_record.API.vM_guest_metrics_last_updated

ocaml/xapi/xapi_guest_agent.ml

@@ -224,6 +224,7 @@ type guest_metrics_t = {
   ; other: m
   ; memory: m
   ; device_id: m
+  ; services: m
   ; last_updated: float
   ; can_use_hotplug_vbd: API.tristate_type
   ; can_use_hotplug_vif: API.tristate_type
@@ -235,6 +236,29 @@ let dead_domains : IntSet.t ref = ref IntSet.empty
 
 let mutex = Mutex.create ()
 
+(* Parse data/service which has the following structure:
+   data/service/<service_name>/<key> = <value>
+   data/service/<service_name>/<key> = <value>
+   ...
+   data/service/<service_name>/<key> = <value>
+   Read and convert to [(<service_name>/<key>, <value>)] pair list.
+   The list is intended to store in VM_guest_metrics.services at last *)
+let get_guest_services (lookup : string -> string option)
+    (list : string -> string list) =
+  let base_path = "data/service" in
+  let services = list base_path in
+  services
+  |> List.concat_map (fun service ->
+         let sub_path = base_path // service in
+         list sub_path
+         |> List.map (fun key ->
+                let full_path_key = sub_path // key in
+                let db_key = service // key in
+                let value = lookup full_path_key in
+                (db_key, Option.value ~default:"" value)
+            )
+     )
+
 (* In the following functions, 'lookup' reads a key from xenstore and 'list' reads
    a directory from xenstore. Both are relative to the guest's domainpath. *)
 let get_initial_guest_metrics (lookup : string -> string option)
@@ -289,6 +313,7 @@ let get_initial_guest_metrics (lookup : string -> string option)
          ; networks "xenserver/attr" "net-sriov-vf" list
          ]
       )
+  and services = get_guest_services lookup list
   and other = List.append (to_map (other all_control)) ts
   and memory = to_map memory
   and last_updated = Unix.gettimeofday () in
@@ -310,6 +335,7 @@ let get_initial_guest_metrics (lookup : string -> string option)
   ; other
   ; memory
   ; device_id
+  ; services
   ; last_updated
   ; can_use_hotplug_vbd
   ; can_use_hotplug_vif
@@ -326,7 +352,8 @@ let create_and_set_guest_metrics (lookup : string -> string option)
     ~os_version:initial_gm.os_version ~netbios_name:initial_gm.netbios_name
     ~pV_drivers_version:initial_gm.pv_drivers_version
     ~pV_drivers_up_to_date:pV_drivers_detected ~memory:[] ~disks:[]
-    ~networks:initial_gm.networks ~pV_drivers_detected ~other:initial_gm.other
+    ~networks:initial_gm.networks ~services:initial_gm.services
+    ~pV_drivers_detected ~other:initial_gm.other
     ~last_updated:(Date.of_unix_time initial_gm.last_updated)
     ~other_config:[] ~live:true
     ~can_use_hotplug_vbd:initial_gm.can_use_hotplug_vbd
@@ -356,6 +383,7 @@ let all (lookup : string -> string option) (list : string -> string list)
   ; other
   ; memory
   ; device_id
+  ; services
   ; last_updated
   ; can_use_hotplug_vbd
   ; can_use_hotplug_vif
@@ -390,6 +418,7 @@ let all (lookup : string -> string option) (list : string -> string list)
             ; other= []
             ; memory= []
             ; device_id= []
+            ; services= []
             ; last_updated= 0.0
             ; can_use_hotplug_vbd= `unspecified
             ; can_use_hotplug_vif= `unspecified
@@ -407,6 +436,7 @@ let all (lookup : string -> string option) (list : string -> string list)
         ; other
         ; memory
         ; device_id
+        ; services
         ; last_updated
         ; can_use_hotplug_vbd
         ; can_use_hotplug_vif
@@ -420,6 +450,7 @@ let all (lookup : string -> string option) (list : string -> string list)
     || guest_metrics_cached.networks <> networks
     || guest_metrics_cached.other <> other
     || guest_metrics_cached.device_id <> device_id
+    || guest_metrics_cached.services <> services
     )
     || guest_metrics_cached.can_use_hotplug_vbd <> can_use_hotplug_vbd
     || guest_metrics_cached.can_use_hotplug_vif <> can_use_hotplug_vif
@@ -452,6 +483,8 @@ let all (lookup : string -> string option) (list : string -> string list)
         ~value:netbios_name ;
     if guest_metrics_cached.networks <> networks then
       Db.VM_guest_metrics.set_networks ~__context ~self:gm ~value:networks ;
+    if guest_metrics_cached.services <> services then
+      Db.VM_guest_metrics.set_services ~__context ~self:gm ~value:services ;
     if guest_metrics_cached.other <> other then (
       Db.VM_guest_metrics.set_other ~__context ~self:gm ~value:other ;
       Helpers.call_api_functions ~__context (fun rpc session_id ->

ocaml/xapi/xapi_vm_helpers.ml

@@ -1465,6 +1465,7 @@ let copy_guest_metrics ~__context ~vm =
       ~memory:all.API.vM_guest_metrics_memory
       ~disks:all.API.vM_guest_metrics_disks
       ~networks:all.API.vM_guest_metrics_networks
+      ~services:all.API.vM_guest_metrics_services
       ~pV_drivers_detected:all.API.vM_guest_metrics_PV_drivers_detected
       ~other:all.API.vM_guest_metrics_other
       ~last_updated:all.API.vM_guest_metrics_last_updated

ocaml/xenopsd/xc/xenops_server_xen.ml

@@ -2748,9 +2748,10 @@ module VM = struct
                 (fun port -> {Vm.protocol= Vm.Vt100; port; path= ""})
                 (Device.get_tc_port ~xs di.Xenctrl.domid)
             in
-            let local x =
-              Printf.sprintf "/local/domain/%d/%s" di.Xenctrl.domid x
+            let root_path =
+              Printf.sprintf "/local/domain/%d" di.Xenctrl.domid
             in
+            let local x = Printf.sprintf "%s/%s" root_path x in
             let uncooperative =
               try
                 ignore_string (xs.Xs.read (local "memory/uncooperative")) ;
@@ -2853,22 +2854,19 @@ module VM = struct
               ; ("drivers", None, 0)
               ; ("data", None, 0)
                 (* in particular avoid data/volumes which contains many entries for each disk *)
+              ; ("data/service", None, 1) (* data/service/<service-name>/<key>*)
               ]
               |> List.fold_left
                    (fun acc (dir, excludes, depth) ->
-                     ls_lR ?excludes ~depth
-                       (Printf.sprintf "/local/domain/%d" di.Xenctrl.domid)
-                       acc dir
+                     ls_lR ?excludes ~depth root_path acc dir
                    )
                    (quota, [])
               |> fun (quota, acc) ->
               (quota, map_tr (fun (k, v) -> (k, Xenops_utils.utf8_recode v)) acc)
             in
             let quota, xsdata_state =
               Domain.allowed_xsdata_prefixes
-              |> List.fold_left
-                   (ls_lR (Printf.sprintf "/local/domain/%d" di.Xenctrl.domid))
-                   (quota, [])
+              |> List.fold_left (ls_lR root_path) (quota, [])
             in
             let path =
               Device_common.xenops_path_of_domain di.Xenctrl.domid
@@ -4829,6 +4827,7 @@ module Actions = struct
       sprintf "/local/domain/%d/attr" domid
     ; sprintf "/local/domain/%d/data/updated" domid
     ; sprintf "/local/domain/%d/data/ts" domid
+    ; sprintf "/local/domain/%d/data/service" domid
     ; sprintf "/local/domain/%d/memory/target" domid
     ; sprintf "/local/domain/%d/memory/uncooperative" domid
     ; sprintf "/local/domain/%d/console/vnc-port" domid