Merge pull request #4892 from psafont/private/paus/gc-vtpm

ocaml/xapi-types/ref.ml

@@ -46,6 +46,22 @@ let is_real = function Real _ -> true | _ -> false
 
 let is_dummy = function Dummy _ -> true | _ -> false
 
+let compare (a : 'a t) (b : 'a t) =
+  match (a, b) with
+  | Real a, Real b ->
+      String.compare a b
+  | Dummy (a1, a2), Dummy (b1, b2) ->
+      let c = String.compare a1 b1 in
+      if c = 0 then String.compare a2 b2 else c
+  | Other a, Other b ->
+      String.compare a b
+  | Null, Null ->
+      0
+  | Null, _ | Other _, _ | Dummy _, _ ->
+      -1
+  | Real _, _ ->
+      1
+
 let string_of = function
   | Real uuid ->
       ref_prefix ^ uuid

ocaml/xapi-types/ref.mli

@@ -20,6 +20,10 @@ val make : unit -> 'a t
 
 val null : 'a t
 
+val compare : 'a t -> 'a t -> int
+(** [compare a b] returns [0] if [a] and [b] are equal, a negative integer if
+    [a] is less than [b], and a positive integer if [a] is greater than [b]. *)
+
 val string_of : 'a t -> string
 
 val to_option : 'a t -> 'a t option

ocaml/xapi/db_gc_util.ml

@@ -246,6 +246,21 @@ let gc_certificates ~__context =
      )
   |> List.iter (fun (cert, _) -> Db.Certificate.destroy ~__context ~self:cert)
 
+let gc_vtpms ~__context =
+  Db.VTPM.get_all ~__context
+  |> List.iter (fun vtpm ->
+         let is_valid =
+           valid_ref __context (Db.VTPM.get_VM ~__context ~self:vtpm)
+         in
+
+         if not is_valid then (
+           let contents = Db.VTPM.get_contents ~__context ~self:vtpm in
+           if contents <> Ref.null then
+             Db.Secret.destroy ~__context ~self:contents ;
+           Db.VTPM.destroy ~__context ~self:vtpm
+         )
+     )
+
 let probation_pending_tasks = Hashtbl.create 53
 
 let timeout_tasks ~__context =
@@ -605,6 +620,7 @@ let gc_subtask_list =
   ; ("PVS servers", gc_PVS_servers)
   ; ("PVS cache storage", gc_PVS_cache_storage)
   ; ("Certificates", gc_certificates)
+  ; ("VTPMs", gc_vtpms)
   ; (* timeout_alerts; *)
     (* CA-29253: wake up all blocked clients *)
     ("Heartbeat", Xapi_event.heartbeat)

ocaml/xapi/xapi_vm.ml

@@ -691,7 +691,7 @@ let destroy ~__context ~self =
   let uuid = Db.VM.get_uuid ~__context ~self in
   log_and_ignore_exn (fun () -> Rrdd.remove_rrd uuid) ;
   List.iter
-    (fun self -> Db.VTPM.destroy ~__context ~self)
+    (fun self -> Xapi_vtpm.destroy ~__context ~self)
     (Db.VM.get_VTPMs ~__context ~self) ;
   destroy ~__context ~self