Introduce VTPM for guests

Makefile

@@ -173,6 +173,7 @@ install: build doc sdk doc-json
 	install -D ./ocaml/xenopsd/scripts/common.py $(DESTDIR)/$(XENOPSD_LIBEXECDIR)/common.py
 	install -D ./ocaml/xenopsd/scripts/igmp_query_injector.py $(DESTDIR)/$(XENOPSD_LIBEXECDIR)/igmp_query_injector.py
 	install -D ./ocaml/xenopsd/scripts/qemu-wrapper $(DESTDIR)/$(QEMU_WRAPPER_DIR)/qemu-wrapper
+	install -D ./ocaml/xenopsd/scripts/swtpm-wrapper $(DESTDIR)/$(QEMU_WRAPPER_DIR)/swtpm-wrapper
 	DESTDIR=$(DESTDIR) SBINDIR=$(SBINDIR) QEMU_WRAPPER_DIR=$(QEMU_WRAPPER_DIR) XENOPSD_LIBEXECDIR=$(XENOPSD_LIBEXECDIR) ETCDIR=$(ETCDIR) ./ocaml/xenopsd/scripts/make-custom-xenopsd.conf
 # squeezed
 	install -D _build/install/default/bin/squeezed $(DESTDIR)/$(SBINDIR)/squeezed

ocaml/database/database_test.ml

@@ -84,6 +84,15 @@ functor
       ->
         ()
 
+    let expect_missing_default name f =
+      try f ()
+      with
+      | Db_exn.DBCache_NotFound
+          ("missing default value in datamodel for new field", name', _)
+      when name' = name
+      ->
+        ()
+
     let expect_missing_field name f =
       try f ()
       with
@@ -515,7 +524,7 @@ functor
       ) ;
       Printf.printf
         "create_row <unique ref> <unique uuid> <missing required field>\n" ;
-      expect_missing_field name_label (fun () ->
+      expect_missing_default name_label (fun () ->
           let broken_vm =
             List.filter
               (fun (k, _) -> k <> name_label)

ocaml/database/db_cache_types.ml

@@ -171,7 +171,12 @@ module Row = struct
               add g c.Schema.Column.name default t
           | None ->
               raise
-                (DBCache_NotFound ("missing field", c.Schema.Column.name, ""))
+                (DBCache_NotFound
+                   ( "missing default value in datamodel for new field"
+                   , c.Schema.Column.name
+                   , ""
+                   )
+                )
         else
           t
       )

ocaml/database/db_upgrade.ml

@@ -12,9 +12,7 @@
  * GNU Lesser General Public License for more details.
  *)
 
-module D = Debug.Make (struct
-  let name = "xapi" (* this is set to 'xapi' deliberately! :) *)
-end)
+module D = Debug.Make (struct let name = __MODULE__ end)
 
 open D
 open Db_cache_types

ocaml/idl/datamodel.ml

@@ -5012,23 +5012,6 @@ module Role = struct
       ()
 end
 
-module VTPM = struct
-  let t =
-    create_obj ~in_db:true ~in_product_since:rel_rio ~in_oss_since:oss_since_303
-      ~internal_deprecated_since:None ~persist:PersistEverything
-      ~gen_constructor_destructor:true ~name:_vtpm ~descr:"A virtual TPM device"
-      ~gen_events:false ~doccomments:[]
-      ~messages_default_allowed_roles:_R_VM_ADMIN ~messages:[]
-      ~contents:
-        [
-          uid _vtpm
-        ; field ~qualifier:StaticRO ~ty:(Ref _vm) "VM" "the virtual machine"
-        ; field ~qualifier:StaticRO ~ty:(Ref _vm) "backend"
-            "the domain where the backend is located"
-        ]
-      ()
-end
-
 module Console = struct
   (** Console protocols *)
   let protocol =
@@ -7789,7 +7772,7 @@ let all_system =
   ; PBD.t
   ; Crashdump.t
   ; (* misc *)
-    VTPM.t
+    Datamodel_vtpm.t
   ; Console.t
   ; (* filesystem; *)
     User.t
@@ -8048,6 +8031,7 @@ let expose_get_all_messages_for =
   ; _cluster_host
   ; _certificate
   ; _repository
+  ; _vtpm
   ]
 
 let no_task_id_for = [_task; (* _alert; *) _event]

ocaml/idl/datamodel_common.ml

@@ -9,7 +9,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 = 752
+let schema_minor_vsn = 755
 
 (* Historical schema versions just in case this is useful later *)
 let rio_schema_major_vsn = 5

ocaml/idl/datamodel_errors.ml

@@ -1944,9 +1944,11 @@ let _ =
   error Api_errors.apply_livepatch_failed ["livepatch"]
     ~doc:"Failed to apply a livepatch." () ;
   error Api_errors.update_guidance_changed ["guidance"]
-    ~doc:"Guidance for the update has changed" ()
+    ~doc:"Guidance for the update has changed" () ;
+
+  error Api_errors.vtpm_max_amount_reached ["amount"]
+    ~doc:"The VM cannot be associated with more VTPMs." () ;
 
-let _ =
   message
     (fst Api_messages.ha_pool_overcommitted)
     ~doc:

ocaml/idl/datamodel_vtpm.ml

@@ -0,0 +1,83 @@
+(*
+   Copyright (C) Citrix Systems Inc.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU Lesser General Public License as published
+   by the Free Software Foundation; version 2.1 only. with the special
+   exception on linking described in file LICENSE.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU Lesser General Public License for more details.
+ *)
+
+open Datamodel_types
+open Datamodel_common
+open Datamodel_roles
+
+let persistence_backend =
+  Enum ("persistence_backend", [("xapi", "This VTPM is persisted in XAPI's DB")])
+
+let create =
+  call ~name:"create" ~lifecycle:[]
+    ~doc:"Create a new VTPM instance, and return its handle."
+    ~params:
+      [
+        (Ref _vm, "vM", "The VM reference the VTPM will be attached to")
+      ; (Bool, "is_unique", "Whether the VTPM must be unique")
+      ]
+    ~result:(Ref _vtpm, "The reference of the newly created VTPM")
+    ~allowed_roles:_R_VM_ADMIN ()
+
+let destroy =
+  call ~name:"destroy" ~lifecycle:[]
+    ~doc:"Destroy the specified VTPM instance, along with its state."
+    ~params:[(Ref _vtpm, "self", "The reference to the VTPM object")]
+    ~allowed_roles:_R_VM_ADMIN ()
+
+let get_contents =
+  call ~name:"get_contents" ~lifecycle:[] ~doc:"Obtain the contents of the TPM"
+    ~secret:true
+    ~params:[(Ref _vtpm, "self", "The VTPM reference")]
+    ~result:(String, "The contents") ~hide_from_docs:true
+    ~allowed_roles:_R_LOCAL_ROOT_ONLY ()
+
+let set_contents =
+  call ~name:"set_contents" ~lifecycle:[]
+    ~doc:"Introduce new contents for the TPM" ~secret:true
+    ~params:
+      [
+        (Ref _vtpm, "self", "The VTPM reference")
+      ; (String, "contents", "The new contents")
+      ]
+    ~hide_from_docs:true ~allowed_roles:_R_LOCAL_ROOT_ONLY ()
+
+let t =
+  create_obj ~in_db:true ~in_oss_since:oss_since_303 ~persist:PersistEverything
+    ~lifecycle:[] ~gen_constructor_destructor:false ~name:_vtpm
+    ~descr:"A virtual TPM device" ~gen_events:true ~doccomments:[]
+    ~messages_default_allowed_roles:_R_POOL_ADMIN
+    ~contents:
+      [
+        uid _vtpm
+      ; field ~qualifier:StaticRO ~ty:(Ref _vm) "VM"
+          "The virtual machine the TPM is attached to"
+      ; field ~qualifier:DynamicRO ~ty:(Ref _vm) "backend"
+          ~default_value:(Some (VRef null_ref))
+          "The domain where the backend is located (unused)"
+      ; field ~qualifier:DynamicRO ~ty:persistence_backend
+          ~default_value:(Some (VEnum "xapi")) ~lifecycle:[]
+          "persistence_backend" "The backend where the vTPM is persisted"
+      ; field ~qualifier:StaticRO ~ty:Bool ~default_value:(Some (VBool false))
+          ~lifecycle:[] "is_unique"
+          "Whether the contents are never copied, satisfying the TPM spec"
+      ; field ~qualifier:DynamicRO ~ty:Bool ~default_value:(Some (VBool false))
+          ~lifecycle:[] "is_protected"
+          "Whether the contents of the VTPM are secured according to the TPM \
+           spec"
+      ; field ~qualifier:DynamicRO ~ty:(Ref _secret) ~internal_only:true
+          ~lifecycle:[] "contents" "The contents of the TPM"
+      ]
+    ~messages:[create; destroy; get_contents; set_contents]
+    ()

ocaml/idl/dune

@@ -5,7 +5,8 @@
     datamodel_errors datamodel_roles datamodel_vm datamodel_host
     datamodel_pool datamodel_cluster datamodel_cluster_host dm_api escaping
     datamodel_values datamodel_schema datamodel_certificate
-    datamodel_diagnostics datamodel_repository datamodel_lifecycle)
+    datamodel_diagnostics datamodel_repository datamodel_lifecycle
+    datamodel_vtpm)
   (libraries
     ppx_sexp_conv.runtime-lib
     rpclib.core

ocaml/idl/schematest.ml

@@ -1,7 +1,7 @@
 let hash x = Digest.string x |> Digest.to_hex
 
 (* BEWARE: if this changes, check that schema has been bumped accordingly *)
-let last_known_schema_hash = "cc62c6cd69cb75cb16abc39922d24cf9"
+let last_known_schema_hash = "7959564ea47f1bad8ab6935ccbaa1f6c"
 
 let current_schema_hash : string =
   let open Datamodel_types in

ocaml/xapi-cli-server/cli_frontend.ml

@@ -3570,6 +3570,24 @@ let rec cmdtable_data : (string * cmd_spec) list =
       ; flags= []
       }
     )
+  ; ( "vtpm-create"
+    , {
+        reqd= ["vm-uuid"]
+      ; optn= []
+      ; help= "Create a VTPM associated with a VM."
+      ; implementation= No_fd Cli_operations.VTPM.create
+      ; flags= []
+      }
+    )
+  ; ( "vtpm-destroy"
+    , {
+        reqd= ["uuid"]
+      ; optn= []
+      ; help= "Destroy a VTPM"
+      ; implementation= No_fd Cli_operations.VTPM.destroy
+      ; flags= []
+      }
+    )
   ]
 
 let cmdtable : (string, cmd_spec) Hashtbl.t = Hashtbl.create 50

ocaml/xapi-cli-server/cli_operations.ml

@@ -1287,6 +1287,10 @@ let gen_cmds rpc session_id =
           ]
           rpc session_id
       )
+    ; Client.VTPM.(
+        mk get_all_records_where get_by_uuid vtpm_record "vtpm" []
+          ["uuid"; "vm"; "profile"] rpc session_id
+      )
     ]
 
 let message_create (_ : printer) rpc session_id params =
@@ -7836,3 +7840,24 @@ module Repository = struct
     Client.Repository.set_gpgkey_path ~rpc ~session_id ~self:ref
       ~value:gpgkey_path
 end
+
+module VTPM = struct
+  let create printer rpc session_id params =
+    let vm_uuid = List.assoc "vm-uuid" params in
+    let vM = Client.VM.get_by_uuid ~rpc ~session_id ~uuid:vm_uuid in
+    let is_unique =
+      match List.assoc_opt "is_unique" params with
+      | Some value ->
+          bool_of_string "is_unique" value
+      | None ->
+          false
+    in
+    let ref = Client.VTPM.create ~rpc ~session_id ~vM ~is_unique in
+    let uuid = Client.VTPM.get_uuid ~rpc ~session_id ~self:ref in
+    printer (Cli_printer.PList [uuid])
+
+  let destroy _ rpc session_id params =
+    let uuid = List.assoc "uuid" params in
+    let ref = Client.VTPM.get_by_uuid ~rpc ~session_id ~uuid in
+    Client.VTPM.destroy ~rpc ~session_id ~self:ref
+end

ocaml/xapi-cli-server/records.ml

@@ -2519,6 +2519,9 @@ let vm_record rpc session_id vm =
               (x ()).API.vM_pending_guidances
           )
           ()
+      ; make_field ~name:"vtpm"
+          ~get:(fun () -> get_uuids_from_refs (x ()).API.vM_VTPMs)
+          ()
       ]
   }
 
@@ -5146,3 +5149,38 @@ let repository_record rpc session_id repository =
           ()
       ]
   }
+
+let vtpm_record rpc session_id vtpm =
+  let _ref = ref vtpm in
+  let empty_record =
+    ToGet (fun () -> Client.VTPM.get_record ~rpc ~session_id ~self:!_ref)
+  in
+  let record = ref empty_record in
+  let x () = lzy_get record in
+  {
+    setref=
+      (fun r ->
+        _ref := r ;
+        record := empty_record
+      )
+  ; setrefrec=
+      (fun (a, b) ->
+        _ref := a ;
+        record := Got b
+      )
+  ; record= x
+  ; getref= (fun () -> !_ref)
+  ; fields=
+      [
+        make_field ~name:"uuid" ~get:(fun () -> (x ()).API.vTPM_uuid) ()
+      ; make_field ~name:"vm"
+          ~get:(fun () -> get_uuid_from_ref (x ()).API.vTPM_VM)
+          ()
+      ; make_field ~name:"is_unique"
+          ~get:(fun () -> string_of_bool (x ()).API.vTPM_is_unique)
+          ()
+      ; make_field ~name:"is_protected"
+          ~get:(fun () -> string_of_bool (x ()).API.vTPM_is_protected)
+          ()
+      ]
+  }

ocaml/xapi-consts/api_errors.ml

@@ -1281,3 +1281,7 @@ let dynamic_memory_control_unavailable = "DYNAMIC_MEMORY_CONTROL_UNAVAILABLE"
 let apply_livepatch_failed = "APPLY_LIVEPATCH_FAILED"
 
 let update_guidance_changed = "UPDATE_GUIDANCE_CHANGED"
+
+(* VTPMs *)
+
+let vtpm_max_amount_reached = "VTPM_MAX_AMOUNT_REACHED"

ocaml/xapi-guard/src/main.ml

@@ -119,11 +119,30 @@ let depriv_destroy dbg gid path =
       D.debug "[%s] stopped server for gid %d and removed socket" dbg gid ;
       Lwt.return_unit
 
+let vtpm_set_contents dbg vtpm_uuid contents =
+  let open Xen_api_lwt_unix in
+  let open Lwt.Syntax in
+  let uuid = Uuidm.to_string vtpm_uuid in
+  D.debug "[%s] saving vTPM contents for %s" dbg uuid ;
+  ret
+  @@ let* self = Varstored_interface.with_xapi @@ VTPM.get_by_uuid ~uuid in
+     Varstored_interface.with_xapi @@ VTPM.set_contents ~self ~contents
+
+let vtpm_get_contents _dbg vtpm_uuid =
+  let open Xen_api_lwt_unix in
+  let open Lwt.Syntax in
+  let uuid = Uuidm.to_string vtpm_uuid in
+  ret
+  @@ let* self = Varstored_interface.with_xapi @@ VTPM.get_by_uuid ~uuid in
+     Varstored_interface.with_xapi @@ VTPM.get_contents ~self
+
 let rpc_fn =
   let module Server = Varstore_privileged_interface.RPC_API (Rpc_lwt.GenServer ()) in
   (* bind APIs *)
   Server.create depriv_create ;
   Server.destroy depriv_destroy ;
+  Server.vtpm_set_contents vtpm_set_contents ;
+  Server.vtpm_get_contents vtpm_get_contents ;
   Rpc_lwt.server Server.implementation
 
 let process body =