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 =