CP-39134: add filtering for vTPM API calls

ocaml/xapi-guard/src/main.ml

@@ -66,11 +66,24 @@ let safe_unlink path =
  | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_unit | e -> Lwt.fail e
  )
 
+(* make_json doesn't work here *)
+let rpc = Xen_api_lwt_unix.make "file:///var/lib/xcp/xapi"
+
+let cache =
+ SessionCache.create ~rpc ~login:Varstored_interface.login
+ ~logout:Varstored_interface.logout
+
+let () =
+ Lwt_switch.add_hook (Some Varstored_interface.shutdown) (fun () ->
+ D.debug "Cleaning up cache at exit" ;
+ SessionCache.destroy cache
+ )
+
 let listen_for_vm {Persistent.vm_uuid; path; gid} =
  let vm_uuid_str = Uuidm.to_string vm_uuid in
  D.debug "resume: listening on socket %s for VM %s" path vm_uuid_str ;
  safe_unlink path >>= fun () ->
- make_server_rpcfn path vm_uuid_str >>= fun stop_server ->
+ make_server_rpcfn ~cache path vm_uuid_str >>= fun stop_server ->
  Hashtbl.add sockets path (stop_server, (vm_uuid, gid)) ;
  Lwt_unix.chmod path 0o660 >>= fun () -> Lwt_unix.chown path 0 gid
 

ocaml/xapi-guard/src/varstored_interface.ml

@@ -25,38 +25,42 @@ let err = Xenops_interface.err
 
 type nvram = (string * string) list [@@deriving rpcty]
 
-(* make_json doesn't work here *)
-let rpc = Xen_api_lwt_unix.make "file:///var/lib/xcp/xapi"
-
 let originator = "varstored-guard"
 
 let version = "0.1"
 
 type session = [`session] Ref.t
 
+type rpc = call -> response Lwt.t
+
 module SessionCache : sig
  type t
 
  val create :
- login:(unit -> session Lwt.t) -> logout:(session -> unit Lwt.t) -> t
+ rpc:rpc
+ -> login:(rpc:rpc -> session Lwt.t)
+ -> logout:(rpc:rpc -> session -> unit Lwt.t)
+ -> t
  (** [create ~login ~logout] will create a global session cache holding 1 session. *)
 
  val with_session :
- t
- -> (rpc:(call -> response Lwt.t) -> session_id:session -> 'a Lwt.t)
- -> 'a Lwt.t
+ t -> (rpc:rpc -> session_id:session -> 'a Lwt.t) -> 'a Lwt.t
  (** [with_session cache f] acquires a session (logging in if necessary) and calls [f].
  ** If [f] fails due to an invalid session then the session is removed from the cache,
  ** and [f] is retried with a new session *)
 
  val destroy : t -> unit Lwt.t
  (** [destroy cache] logs out all sessions from the cache *)
 end = struct
- type t = {valid_sessions: (session, unit) Hashtbl.t; pool: session Lwt_pool.t}
+ type t = {
+ rpc: rpc
+ ; valid_sessions: (session, unit) Hashtbl.t
+ ; pool: session Lwt_pool.t
+ }
 
  (* Do NOT log session IDs, they are secret *)
 
- let create ~login ~logout =
+ let create ~rpc ~login ~logout =
  let valid_sessions = Hashtbl.create 3 in
  let validate session =
  let is_valid = Hashtbl.mem valid_sessions session in
@@ -66,19 +70,19 @@ end = struct
  Lwt.return is_valid
  in
  let acquire () =
- login () >>= fun session ->
+ login ~rpc >>= fun session ->
  Hashtbl.add valid_sessions session () ;
  debug "SessionCache.acquired" ;
  Lwt.return session
  in
  let dispose session =
  debug "SessionCache.dispose" ;
- logout session >|= fun () ->
+ logout ~rpc session >|= fun () ->
  debug "SessionCache.disposed" ;
  Hashtbl.remove valid_sessions session
  in
  let pool = Lwt_pool.create 1 ~validate ~dispose acquire in
- {valid_sessions; pool}
+ {valid_sessions; pool; rpc}
 
  let invalidate t session_id =
  (* Remove just the specified expired session,
@@ -93,7 +97,7 @@ end = struct
  * we just do not want to log in more than once *)
  Lwt_pool.use t.pool Lwt.return >>= fun session_id ->
  Lwt.catch
- (fun () -> f ~rpc ~session_id)
+ (fun () -> f ~rpc:t.rpc ~session_id)
  (function
  | Api_errors.Server_error (code, _)
  when code = Api_errors.session_invalid ->
@@ -107,10 +111,10 @@ end
 
 open Xen_api_lwt_unix
 
-let login () =
+let login ~rpc =
  Session.login_with_password ~rpc ~uname:"root" ~pwd:"" ~version ~originator
 
-let logout session_id =
+let logout ~rpc session_id =
  Lwt.catch
  (fun () -> Session.logout ~rpc ~session_id)
  (function
@@ -122,16 +126,8 @@ let logout session_id =
  Lwt.fail e
  )
 
-let cache = SessionCache.create ~login ~logout
-
 let shutdown = Lwt_switch.create ()
 
-let () =
- Lwt_switch.add_hook (Some shutdown) (fun () ->
- debug "Cleaning up cache at exit" ;
- SessionCache.destroy cache
- )
-
 let () =
  let cleanup n =
  debug "Triggering cleanup on signal %d, and waiting for servers to stop" n ;
@@ -147,7 +143,7 @@ let () =
  * this is only needed for syscalls that would otherwise block *)
  Lwt_unix.set_pool_size 16
 
-let with_xapi f =
+let with_xapi ~cache f =
  Lwt_unix.with_timeout 120. (fun () -> SessionCache.with_session cache f)
 
 (* Unfortunately Cohttp doesn't provide us a way to know when it finished
@@ -224,33 +220,71 @@ let serve_forever_lwt rpc_fn path =
  >>= fun () -> Lwt.return cleanup
 
 (* Create a restricted RPC function and socket for a specific VM *)
-let make_server_rpcfn path vm_uuid =
+let make_server_rpcfn ~cache path vm_uuid =
  let module Server =
  Varstore_deprivileged_interface.RPC_API (Rpc_lwt.GenServer ()) in
- with_xapi @@ VM.get_by_uuid ~uuid:vm_uuid >>= fun vm ->
+ with_xapi ~cache @@ VM.get_by_uuid ~uuid:vm_uuid >>= fun vm ->
  let ret v =
  (* TODO: maybe map XAPI exceptions *)
  v >>= Lwt.return_ok |> Rpc_lwt.T.put
  in
- let get_nvram _ _ = ret @@ with_xapi @@ VM.get_NVRAM ~self:vm in
+ let get_nvram _ _ = ret @@ with_xapi ~cache @@ VM.get_NVRAM ~self:vm in
  let set_nvram _ _ nvram =
- ret @@ with_xapi @@ VM.set_NVRAM_EFI_variables ~self:vm ~value:nvram
+ ret @@ with_xapi ~cache @@ VM.set_NVRAM_EFI_variables ~self:vm ~value:nvram
  in
  let message_create _ _name priority _cls _uuid body =
  ret
- ( with_xapi
+ ( with_xapi ~cache
  @@ Message.create ~name:"VM_SECURE_BOOT_FAILED" ~priority ~cls:`VM
  ~obj_uuid:vm_uuid ~body
  >>= fun _ -> Lwt.return_unit
  )
  in
+ (* we return a static string for these API calls:
+ the sandboxed varstored/swtpm is not allowed to choose which VM/VTPM to talk to,
+ it can only query its own, so we'll replace these parameters in calls anyway *)
  let get_by_uuid _ _ = ret @@ Lwt.return "DUMMYVM" in
  let dummy_login _ _ _ _ = ret @@ Lwt.return "DUMMYSESSION" in
  let dummy_logout _ = ret @@ Lwt.return_unit in
+ let get_vm _ _ = ret @@ Lwt.return "DUMMYVM" in
+ let with_vtpm f =
+ ret
+ (with_xapi ~cache @@ VM.get_VTPMs ~self:vm >>= function
+ | [] ->
+ Lwt.fail_with "No VTPMs"
+ | [vtpm] ->
+ f ~self:vtpm
+ | _ ->
+ Lwt.fail_with "Multiple VTPMs are not supported"
+ )
+ in
+ let get_vtpm _ _ = with_vtpm @@ fun ~self:_ -> Lwt.return ["DUMMYVTPM"] in
+
+ (* Note: sandboxing is done only to isolate VMs, but varstored will be able to access/change swtpm
+ storage, and swtpm will be able to change UEFI NVRAM storage.
+ If needed this can be isolated in the future too if xapi-guard is told which daemon the socket
+ is for.
+ *)
+ let get_profile _ _ =
+ with_vtpm @@ fun ~self -> with_xapi ~cache @@ VTPM.get_profile ~self
+ in
+ let get_contents _ _ =
+ with_vtpm @@ fun ~self -> with_xapi ~cache @@ VTPM.get_contents ~self
+ in
+ let set_contents _ _ contents =
+ with_vtpm @@ fun ~self ->
+ with_xapi ~cache @@ VTPM.set_contents ~self ~contents
+ in
+
  Server.get_NVRAM get_nvram ;
  Server.set_NVRAM set_nvram ;
  Server.message_create message_create ;
  Server.session_login dummy_login ;
  Server.session_logout dummy_logout ;
  Server.get_by_uuid get_by_uuid ;
+ Server.get_vtpm get_vtpm ;
+ Server.get_profile get_profile ;
+ Server.get_vm get_vm ;
+ Server.get_contents get_contents ;
+ Server.set_contents set_contents ;
  serve_forever_lwt (Rpc_lwt.server Server.implementation) path

ocaml/xapi-idl/varstore/deprivileged/varstore_deprivileged_interface.ml

@@ -19,6 +19,12 @@ let err = Xenops_interface.err
 
 type nvram = (string * string) list [@@deriving rpcty]
 
+type vtpm = string [@@deriving rpcty]
+
+type vtpm_profile = (string * string) list [@@deriving rpcty]
+
+type vtpms = string list [@@deriving rpcty]
+
 module RPC_API (R : RPC) = struct
  open R
 
@@ -40,6 +46,12 @@ module RPC_API (R : RPC) = struct
 
  let nvram_p = Param.mk ~name:"NVRAM" nvram
 
+ let vtpm_p = Param.mk vtpm
+
+ let vtpm_profile_p = Param.mk vtpm_profile
+
+ let vtpms_p = Param.mk vtpms
+
  let string_p = Param.mk Types.string
 
  let int64_p = Param.mk Types.int64
@@ -91,4 +103,30 @@ module RPC_API (R : RPC) = struct
  @-> string_p
  @-> returning unit_p err
  )
+
+ (* these should match the API in Datamodel_vtpm.ml *)
+ let get_vtpm =
+ declare "VM.get_VTPMs"
+ ["Dummy, for wire compatibility with XAPI"]
+ (string_p @-> string_p @-> returning vtpms_p err)
+
+ let get_profile =
+ declare "VTPM.get_profile"
+ ["Obtain the profile of the TPM"]
+ (string_p @-> string_p @-> returning vtpm_profile_p err)
+
+ let get_vm =
+ declare "VTPM.get_VM"
+ ["Dummy, for wire compatibility with XAPI"]
+ (string_p @-> string_p @-> returning string_p err)
+
+ let get_contents =
+ declare "VTPM.get_contents"
+ ["Obtain the contents of the TPM"]
+ (string_p @-> string_p @-> returning vtpm_p err)
+
+ let set_contents =
+ declare "VTPM.set_contents"
+ ["Obtain the contents of the TPM"]
+ (string_p @-> string_p @-> vtpm_p @-> returning unit_p err)
 end