Merge pull request #4730 from edwintorok/private/edvint/vtpm-state-me…

…rged

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 =

ocaml/xapi-idl/lib/uuidm_rpc_type.ml

@@ -0,0 +1,42 @@
+module Uuidm = struct
+  include Uuidm
+
+  (** Validate UUIDs by converting them to Uuidm.t in the API *)
+  let typ_of =
+    Rpc.Types.Abstract
+      {
+        aname= "uuid"
+      ; test_data= [Uuidm.v4_gen (Random.get_state ()) ()]
+      ; rpc_of= (fun t -> Rpc.String (Uuidm.to_string t))
+      ; of_rpc=
+          (function
+          | Rpc.String s -> (
+            match Uuidm.of_string s with
+            | Some uuid ->
+                Ok uuid
+            | None ->
+                Error
+                  (`Msg
+                    (Printf.sprintf "typ_of_vm_uuid: not a valid UUID: %s" s)
+                    )
+          )
+          | r ->
+              Error
+                (`Msg
+                  (Printf.sprintf
+                     "typ_of_vm_uuid: expected rpc string but got %s"
+                     (Rpc.to_string r)
+                  )
+                  )
+          )
+      }
+
+  let t_of_sexp sexp =
+    match sexp |> Sexplib.Std.string_of_sexp |> Uuidm.of_string with
+    | None ->
+        Sexplib.Conv.of_sexp_error "not a UUID" sexp
+    | Some u ->
+        u
+
+  let sexp_of_t t = t |> Uuidm.to_string |> Sexplib.Std.sexp_of_string
+end

ocaml/xapi-idl/lib/uuidm_rpc_type.mli

@@ -0,0 +1,11 @@
+module Uuidm : sig
+  type t = Uuidm.t
+
+  include module type of Uuidm with type t := t
+
+  val typ_of : t Rpc.Types.typ
+
+  val t_of_sexp : Sexplib.Sexp.t -> t
+
+  val sexp_of_t : t -> Sexplib.Sexp.t
+end

ocaml/xapi-idl/varstore/privileged/varstore_privileged_interface.ml

@@ -21,6 +21,7 @@
 
 open Rpc
 open Idl
+module Uuidm = Uuidm_rpc_type.Uuidm
 
 let service_name = "xapi_depriv"
 
@@ -34,42 +35,10 @@ module E = Error.Make (struct
   let internal_error_of e = Some (InternalError (Printexc.to_string e))
 end)
 
-module Uuidm = struct
-  include Uuidm
-
-  (** Validate UUIDs by converting them to Uuidm.t in the API *)
-  let typ_of =
-    Rpc.Types.Abstract
-      {
-        aname= "uuid"
-      ; test_data= [Uuidm.v4_gen (Random.get_state ()) ()]
-      ; rpc_of= (fun t -> Rpc.String (Uuidm.to_string t))
-      ; of_rpc=
-          (function
-          | Rpc.String s -> (
-            match Uuidm.of_string s with
-            | Some uuid ->
-                Ok uuid
-            | None ->
-                Error
-                  (`Msg
-                    (Printf.sprintf "typ_of_vm_uuid: not a valid UUID: %s" s)
-                    )
-          )
-          | r ->
-              Error
-                (`Msg
-                  (Printf.sprintf
-                     "typ_of_vm_uuid: expected rpc string but got %s"
-                     (Rpc.to_string r)
-                  )
-                  )
-          )
-      }
-end
-
 type vm_uuid = Uuidm.t [@@deriving rpcty]
 
+type vtpm_uuid = Uuidm.t [@@deriving rpcty]
+
 module RPC_API (R : RPC) = struct
   open R
 
@@ -120,4 +89,17 @@ module RPC_API (R : RPC) = struct
     declare "destroy"
       ["Stop listening on sockets for the specified group"]
       (debug_info_p @-> gid_p @-> path_p @-> returning unit_p err)
+
+  let vtpm_uuid_p =
+    Param.mk ~name:"vtpm_uuid" ~description:["VTPM UUID"] vtpm_uuid
+
+  let string_p = Param.mk Types.string
+
+  let vtpm_set_contents =
+    declare "vtpm_set_contents" ["Set vTPM contents blob"]
+      (debug_info_p @-> vtpm_uuid_p @-> string_p @-> returning unit_p err)
+
+  let vtpm_get_contents =
+    declare "vtpm_get_contents" ["Get vTPM contents blob"]
+      (debug_info_p @-> vtpm_uuid_p @-> returning string_p err)
 end

ocaml/xapi-idl/xen/xenops_types.ml

@@ -1,5 +1,6 @@
 open Sexplib.Std
 open Xcp_pci
+open Uuidm_rpc_type
 
 module TopLevel = struct
   type power_state = Running | Halted | Suspended | Paused
@@ -77,7 +78,7 @@ module Vm = struct
 
   let default_firmware = Bios [@@deriving rpcty]
 
-  type tpm = Vtpm [@@deriving rpcty, sexp]
+  type tpm = Vtpm of Uuidm.t [@@deriving rpcty, sexp]
 
   type hvm_info = {
       hap: bool [@default true]

ocaml/xapi/xapi_xenops.ml

@@ -346,7 +346,7 @@ let is_boot_file_whitelisted filename =
   (* avoid ..-style attacks and other weird things *)
   && safe_str filename
 
-let builder_of_vm ~__context (_, vm) timeoffset pci_passthrough vgpu =
+let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu =
   let open Vm in
   let video_mode =
     if vgpu then
@@ -386,20 +386,28 @@ let builder_of_vm ~__context (_, vm) timeoffset pci_passthrough vgpu =
       warn "QEMU stub domains are no longer implemented" ;
 
     let tpm_of_vm () =
-      if bool vm.API.vM_platform false "vtpm" then (
-        if vm.API.vM_VTPMs = [] then (
-          let ref () = Ref.make () in
-          let uuid () = Uuid.(to_string (make_uuid ())) in
-          let profile = [] in
-          let other_config = [] in
-          let contents = ref () in
-          Db.Secret.create ~__context ~ref:contents ~uuid:(uuid ()) ~value:""
-            ~other_config ;
-          Db.VTPM.create ~__context ~ref:(ref ()) ~uuid:(uuid ()) ~vM:vmref
-            ~profile ~contents
-        ) ;
-        Some Xenops_interface.Vm.Vtpm
-      ) else
+      if bool vm.API.vM_platform false "vtpm" then
+        let uuid =
+          match vm.API.vM_VTPMs with
+          | [] ->
+              let ref () = Ref.make () in
+              let uuid () = Uuid.(to_string (make ())) in
+              let profile = [] in
+              let other_config = [] in
+              let contents = ref () in
+              Db.Secret.create ~__context ~ref:contents ~uuid:(uuid ())
+                ~value:"" ~other_config ;
+              let vtpm_uuid = uuid () in
+              Db.VTPM.create ~__context ~ref:(ref ()) ~uuid:vtpm_uuid ~vM:vmref
+                ~profile ~contents ;
+              vtpm_uuid
+          | [self] ->
+              Db.VTPM.get_uuid ~__context ~self
+          | _ :: _ :: _ ->
+              failwith "Multiple vTPMs are not supported"
+        in
+        Some (Xenops_interface.Vm.Vtpm (Uuidm.of_string uuid |> Option.get))
+      else
         None
     in
 

ocaml/xenopsd/cli/xn.ml

@@ -605,8 +605,9 @@ let add' _copts x () =
                   ; firmware= Xenops_types.Vm.default_firmware
                   ; tpm=
                       ( match find_opt _vtpm with
-                      | Some id when bool id ->
-                          Some Vtpm
+                      | Some id ->
+                          Some
+                            (Vtpm (string id |> Uuidm.of_string |> Option.get))
                       | _ ->
                           None
                       )

ocaml/xenopsd/lib/resources.ml

@@ -20,6 +20,8 @@ let qemu_system_i386 = ref "qemu-system-i386"
 
 let upstream_compat_qemu_dm_wrapper = ref "qemu-wrapper"
 
+let swtpm_wrapper = ref "swtpm-wrapper"
+
 let chgrp = ref "chgrp"
 
 let modprobe = ref "/usr/sbin/modprobe"
@@ -77,6 +79,9 @@ let pvinpvh_guests =
     )
   ]
 
+let vtpm_guests =
+  [(X_OK, "swtpm-wrapper", swtpm_wrapper, "path to swtpm-wrapper")]
+
 (* libvirt xc *)
 let network_configuration =
   [(R_OK, "network-conf", network_conf, "path to the network backend switch")]

ocaml/xenopsd/lib/suspend_image.ml

@@ -62,6 +62,7 @@ type header_type =
   | Qemu_xen
   | Demu
   | Varstored
+  | Swtpm
   | End_of_image
 
 exception Invalid_header_type
@@ -83,6 +84,8 @@ let header_type_of_int64 = function
       Ok Demu
   | 0x0f11L ->
       Ok Varstored
+  | 0x0f12L ->
+      Ok Swtpm
   | 0xffffL ->
       Ok End_of_image
   | _ ->
@@ -105,6 +108,8 @@ let int64_of_header_type = function
       0x0f10L
   | Varstored ->
       0x0f11L
+  | Swtpm ->
+      0x0f12L
   | End_of_image ->
       0xffffL
 
@@ -129,6 +134,8 @@ let string_of_header h =
       s "vGPU save record (record length=%Ld)" len
   | Varstored, len ->
       s "varstored save record (record length=%Ld)" len
+  | Swtpm, len ->
+      s "swtpm save record (record length=%Ld)" len
   | End_of_image, _ ->
       s "Suspend image footer"
 

ocaml/xenopsd/lib/suspend_image.mli

@@ -40,6 +40,7 @@ type header_type =
   | Qemu_xen
   | Demu
   | Varstored
+  | Swtpm
   | End_of_image
 
 type format = Structured | Legacy

ocaml/xenopsd/lib/xenops_sandbox.ml

@@ -120,6 +120,8 @@ end
 module type SANDBOX = sig
   val create : domid:int -> vm_uuid:string -> Chroot.Path.t -> string
 
+  val chroot : domid:int -> vm_uuid:string -> Chroot.t
+
   val start :
        string
     -> vm_uuid:string

ocaml/xenopsd/lib/xenops_sandbox.mli

@@ -48,6 +48,11 @@ module type SANDBOX = sig
       [domid] inside the chroot for [domid] and returns the absolute path to it
       outside the chroot *)
 
+  val chroot : domid:int -> vm_uuid:string -> Chroot.t
+  (** [chroot ~domid ~vm_uuid] returns the chroot for [domid] and [vm_uuid].
+      The chroot may not necessarily exist yet.
+  *)
+
   val start :
        string
     -> vm_uuid:string

ocaml/xenopsd/scripts/make-custom-xenopsd.conf

@@ -46,6 +46,7 @@ qemu-dm-wrapper=${LIBEXECDIR}/qemu-dm-wrapper
 setup-vif-rules=${LIBEXECDIR}/setup-vif-rules
 sockets-group=$group
 qemu-wrapper=${QEMU_WRAPPER_DIR}/qemu-wrapper
+swtpm-wrapper=${QEMU_WRAPPER_DIR}/qemu-wrapper
 
 disable-logging-for=http
 # Workaround xenopsd bug #45

ocaml/xenopsd/suspend_image_viewer/suspend_image_viewer.ml

@@ -68,6 +68,9 @@ let parse_layout fd =
         | Varstored, len ->
             Io.read fd (Io.int_of_int64_exn len) |> ignore ;
             aux (h :: acc)
+        | Swtpm, len ->
+            Io.read fd (Io.int_of_int64_exn len) |> ignore ;
+            aux (h :: acc)
         | End_of_image, _ ->
             return (h :: acc)
         | Libxl, _ ->

ocaml/xenopsd/test/test.ml

@@ -231,7 +231,7 @@ let create_vm vmid =
       ; qemu_disk_cmdline= false
       ; qemu_stubdom= false
       ; firmware= Bios
-      ; tpm= Some Vtpm
+      ; tpm= None
       }
   in
   {