From d754b913728dc5df7afec9d605b783ed5ae25b7b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 5 Apr 2022 11:39:06 +0100 Subject: [PATCH 01/11] CP-39134: xapi-guard: add filtering for VTPM API calls MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-guard/src/varstored_interface.ml | 37 ++++++++++++++++++ .../varstore_deprivileged_interface.ml | 38 +++++++++++++++++++ 2 files changed, 75 insertions(+) diff --git a/ocaml/xapi-guard/src/varstored_interface.ml b/ocaml/xapi-guard/src/varstored_interface.ml index d0fb3b1da5b..26811f85cff 100644 --- a/ocaml/xapi-guard/src/varstored_interface.ml +++ b/ocaml/xapi-guard/src/varstored_interface.ml @@ -244,13 +244,50 @@ let make_server_rpcfn path vm_uuid = >>= 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 @@ 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 @@ VTPM.get_profile ~self + in + let get_contents _ _ = + with_vtpm @@ fun ~self -> with_xapi @@ VTPM.get_contents ~self + in + let set_contents _ _ contents = + with_vtpm @@ fun ~self -> with_xapi @@ 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 diff --git a/ocaml/xapi-idl/varstore/deprivileged/varstore_deprivileged_interface.ml b/ocaml/xapi-idl/varstore/deprivileged/varstore_deprivileged_interface.ml index e418dc4d094..d3c15e09df1 100644 --- a/ocaml/xapi-idl/varstore/deprivileged/varstore_deprivileged_interface.ml +++ b/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 From ba27bb06edb4e95093b3e665774a7a8ec7422d32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 5 Apr 2022 16:03:23 +0100 Subject: [PATCH 02/11] CP-39134: xapi-guard: do not hardcode rpc function - allow for unit testing MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-guard/src/main.ml | 15 ++++- ocaml/xapi-guard/src/varstored_interface.ml | 63 ++++++++++----------- 2 files changed, 44 insertions(+), 34 deletions(-) diff --git a/ocaml/xapi-guard/src/main.ml b/ocaml/xapi-guard/src/main.ml index 160e934bb94..1e726c08f99 100644 --- a/ocaml/xapi-guard/src/main.ml +++ b/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 diff --git a/ocaml/xapi-guard/src/varstored_interface.ml b/ocaml/xapi-guard/src/varstored_interface.ml index 26811f85cff..b30acb8904b 100644 --- a/ocaml/xapi-guard/src/varstored_interface.ml +++ b/ocaml/xapi-guard/src/varstored_interface.ml @@ -25,26 +25,26 @@ 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 *) @@ -52,11 +52,15 @@ module SessionCache : sig 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,21 +220,21 @@ 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 @@ -253,7 +249,7 @@ let make_server_rpcfn path vm_uuid = let get_vm _ _ = ret @@ Lwt.return "DUMMYVM" in let with_vtpm f = ret - (with_xapi @@ VM.get_VTPMs ~self:vm >>= function + (with_xapi ~cache @@ VM.get_VTPMs ~self:vm >>= function | [] -> Lwt.fail_with "No VTPMs" | [vtpm] -> @@ -270,13 +266,14 @@ let make_server_rpcfn path vm_uuid = is for. *) let get_profile _ _ = - with_vtpm @@ fun ~self -> with_xapi @@ VTPM.get_profile ~self + with_vtpm @@ fun ~self -> with_xapi ~cache @@ VTPM.get_profile ~self in let get_contents _ _ = - with_vtpm @@ fun ~self -> with_xapi @@ VTPM.get_contents ~self + with_vtpm @@ fun ~self -> with_xapi ~cache @@ VTPM.get_contents ~self in let set_contents _ _ contents = - with_vtpm @@ fun ~self -> with_xapi @@ VTPM.set_contents ~self ~contents + with_vtpm @@ fun ~self -> + with_xapi ~cache @@ VTPM.set_contents ~self ~contents in Server.get_NVRAM get_nvram ; From 229036af9c945afae2e859be2674c712e619ae8a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 5 Apr 2022 17:22:42 +0100 Subject: [PATCH 03/11] CP-39134: xapi-guard: separate code into own library for testability MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-guard/{src => lib}/dorpc.ml | 0 ocaml/xapi-guard/lib/dune | 12 ++++++++++ .../{src => lib}/varstored_interface.ml | 0 ocaml/xapi-guard/src/dune | 23 ++++++++----------- ocaml/xapi-guard/src/main.ml | 1 + 5 files changed, 22 insertions(+), 14 deletions(-) rename ocaml/xapi-guard/{src => lib}/dorpc.ml (100%) create mode 100644 ocaml/xapi-guard/lib/dune rename ocaml/xapi-guard/{src => lib}/varstored_interface.ml (100%) diff --git a/ocaml/xapi-guard/src/dorpc.ml b/ocaml/xapi-guard/lib/dorpc.ml similarity index 100% rename from ocaml/xapi-guard/src/dorpc.ml rename to ocaml/xapi-guard/lib/dorpc.ml diff --git a/ocaml/xapi-guard/lib/dune b/ocaml/xapi-guard/lib/dune new file mode 100644 index 00000000000..764d3d3d4b4 --- /dev/null +++ b/ocaml/xapi-guard/lib/dune @@ -0,0 +1,12 @@ +(library + (name xapi_guard) + (libraries + cohttp-lwt-unix + conduit-lwt-unix + rpclib-lwt + xapi-idl + xapi-idl.varstore.deprivileged + xapi-idl.varstore.privileged + xen-api-client-lwt + ) + (preprocess (pps ppx_deriving_rpc))) diff --git a/ocaml/xapi-guard/src/varstored_interface.ml b/ocaml/xapi-guard/lib/varstored_interface.ml similarity index 100% rename from ocaml/xapi-guard/src/varstored_interface.ml rename to ocaml/xapi-guard/lib/varstored_interface.ml diff --git a/ocaml/xapi-guard/src/dune b/ocaml/xapi-guard/src/dune index 50985ad93ca..4ea01d83f14 100644 --- a/ocaml/xapi-guard/src/dune +++ b/ocaml/xapi-guard/src/dune @@ -1,17 +1,12 @@ (executable - (name main) - (libraries - cmdliner - cohttp-lwt - message-switch-lwt - rpclib-lwt - xapi-idl - xapi-idl.varstore.deprivileged - xapi-idl.varstore.privileged - xen-api-client-lwt) - (preprocess (pps ppx_deriving_rpc))) + (name main) + (libraries + cmdliner + message-switch-lwt + xapi_guard) + (preprocess (pps ppx_deriving_rpc))) (install - (package varstored-guard) - (section sbin) - (files (main.exe as varstored-guard))) + (package varstored-guard) + (section sbin) + (files (main.exe as varstored-guard))) diff --git a/ocaml/xapi-guard/src/main.ml b/ocaml/xapi-guard/src/main.ml index 1e726c08f99..d45ef881da1 100644 --- a/ocaml/xapi-guard/src/main.ml +++ b/ocaml/xapi-guard/src/main.ml @@ -13,6 +13,7 @@ * GNU Lesser General Public License for more details. *) +open Xapi_guard open Varstored_interface open Lwt.Infix From 01b69e5c6fc2092be3807b99f103a8f08dffd6f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 5 Apr 2022 18:55:16 +0100 Subject: [PATCH 04/11] CP-39134: basic unit test for xapi-guard MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Check that basic API calls get forwarded Signed-off-by: Edwin Török --- ocaml/xapi-guard/test/dune | 7 + ocaml/xapi-guard/test/xapi_guard_test.ml | 155 +++++++++++++++++++++++ 2 files changed, 162 insertions(+) create mode 100644 ocaml/xapi-guard/test/dune create mode 100644 ocaml/xapi-guard/test/xapi_guard_test.ml diff --git a/ocaml/xapi-guard/test/dune b/ocaml/xapi-guard/test/dune new file mode 100644 index 00000000000..2033e6d6fa5 --- /dev/null +++ b/ocaml/xapi-guard/test/dune @@ -0,0 +1,7 @@ +(test + (name xapi_guard_test) + (libraries + alcotest-lwt + xapi_guard) + (package varstored-guard) + ) diff --git a/ocaml/xapi-guard/test/xapi_guard_test.ml b/ocaml/xapi-guard/test/xapi_guard_test.ml new file mode 100644 index 00000000000..2118bb37943 --- /dev/null +++ b/ocaml/xapi-guard/test/xapi_guard_test.ml @@ -0,0 +1,155 @@ +open Xapi_guard +open Varstored_interface +open Alcotest_lwt +open Lwt.Syntax +open Xen_api_lwt_unix + +module D = Debug.Make (struct let name = "xapi-guard-test" end) + +let expected_session_id = Ref.make () +let vm = Ref.make () +let vtpm = Ref.make () +let vtpm_contents = ref "" +let nvram_contents = ref [] + +(* simulates what xapi would do *) +let xapi_rpc call = + D.debug "Got rpc %s" call.Rpc.name; + let ret_ok contents = Lwt.return Rpc.{success = true; contents = Rpc.String contents; is_notification=false} in + let cmp_ref a b = String.equal (Ref.string_of a) (Ref.string_of b) in + let ref = Alcotest.testable (Fmt.of_to_string Ref.string_of) cmp_ref in + let expect_session_id session_id_rpc = + let actual = API.ref_session_of_rpc session_id_rpc in + Alcotest.(check' ref) ~expected:expected_session_id ~actual ~msg:"session id" + in + let expect_vm vm_rpc = + let actual = API.ref_VM_of_rpc vm_rpc in + Alcotest.(check' ref) ~expected:vm ~actual ~msg:"vm ref" + in + let expect_vtpm vtpm_rpc = + let actual = API.ref_VTPM_of_rpc vtpm_rpc in + Alcotest.(check' ref) ~expected:vtpm ~actual ~msg:"vtpm ref" + in + match call.Rpc.name, call.Rpc.params with + | "session.login_with_password", _ -> + ret_ok (Ref.string_of expected_session_id) + | "session.logout", [session_id_rpc] -> + expect_session_id session_id_rpc; + ret_ok "" + | "VM.get_by_uuid", [session_id_rpc; uuid] -> + expect_session_id session_id_rpc; + ret_ok (Ref.string_of vm) + | "VM.get_VTPMs", [session_id_rpc; vm_rpc] -> + expect_session_id session_id_rpc; + expect_vm vm_rpc; + Lwt.return Rpc.{success=true; contents=Rpc.Enum [Rpc.String (Ref.string_of vtpm)]; + is_notification=false} + | "VTPM.get_profile", [session_id_rpc; vtpm_rpc] -> + expect_session_id session_id_rpc; + expect_vtpm vtpm_rpc; + Lwt.return Rpc.{success=true; contents=Rpc.Dict []; + is_notification=false} + | "VTPM.get_contents", [session_id_rpc; vtpm_rpc] -> + expect_session_id session_id_rpc; + expect_vtpm vtpm_rpc; + ret_ok !vtpm_contents + | "VTPM.set_contents", [session_id_rpc; vtpm_rpc; contents] -> + expect_session_id session_id_rpc; + expect_vtpm vtpm_rpc; + vtpm_contents := API.string_of_rpc contents; + ret_ok "" + | "VM.get_NVRAM", [session_id_rpc; vm_rpc] -> + expect_session_id session_id_rpc; + expect_vm vm_rpc; + Lwt.return Rpc.{success=true; contents=API.rpc_of_string_to_string_map !nvram_contents;is_notification=false} + | "VM.set_NVRAM_EFI_variables", [session_id_rpc; vm_rpc; contents] -> + expect_session_id session_id_rpc; + expect_vm vm_rpc; + nvram_contents := ["EFI-variables", API.string_of_rpc contents]; + ret_ok "" + | _ -> + Fmt.failwith "XAPI RPC call %s not expected in test" call.Rpc.name + +let uuid = Uuidm.create `V4 |> Uuidm.to_string + +let () = + let old_hook = !Lwt.async_exception_hook in + (Lwt.async_exception_hook := + fun exn -> + D.log_backtrace () ; + D.error "Lwt caught async exception: %s" (Printexc.to_string exn) ; + old_hook exn + ) + +let with_rpc f switch () = + Lwt_io.with_temp_dir ~prefix:"xapi_guard" @@ fun tmp -> + let cache = SessionCache.create ~rpc:xapi_rpc ~login ~logout in + (Lwt_switch.add_hook (Some switch) @@ fun () -> + SessionCache.destroy cache); + let path = Filename.concat tmp "socket" in + (* Create an internal server on 'path', the socket that varstored/swtpm would connect to *) + let* stop_server = make_server_rpcfn ~cache path uuid in + (* rpc simulates what varstored/swtpm would do *) + let uri = Uri.make ~scheme:"file" ~path () |> Uri.to_string in + D.debug "Connecting to %s" uri; + let rpc = Xen_api_lwt_unix.make uri in + Lwt.finalize (fun () -> + (* not strictly necessary to login/logout here - since we only get dummy sessions *) + let* session_id = Session.login_with_password ~rpc ~uname:"root" ~pwd:"" ~version:"0.0" ~originator:"test" + in + let logout () = Session.logout ~rpc ~session_id in + Lwt.finalize logout @@ f ~rpc ~session_id + ) stop_server + +let with_vtpm ~rpc ~session_id f = + let* vm_ref = VM.get_by_uuid ~rpc ~session_id ~uuid in + let* vtpms = VM.get_VTPMs ~rpc ~session_id ~self:vm_ref in + Alcotest.(check' int) ~msg:"no. vtpms" ~expected:1 ~actual:(List.length vtpms); + let vtpm = List.hd vtpms in + f ~self:vtpm + +let test_get_vtpm ~rpc ~session_id () = + with_vtpm ~rpc ~session_id @@ fun ~self -> + let* vm_ref = VTPM.get_VM ~rpc ~session_id ~self in + let* profile = VTPM.get_profile ~rpc ~session_id ~self in + let* contents = VTPM.get_contents ~rpc ~session_id ~self in + Lwt.return_unit + +let test_change_contents ~rpc ~session_id () = + with_vtpm ~rpc ~session_id @@ fun ~self -> + let* contents0 = VTPM.get_contents ~rpc ~session_id ~self in + Alcotest.(check' string) ~msg:"contents" ~expected:"" ~actual:contents0; + let contents = "somedata" in + let* () = VTPM.set_contents ~rpc ~session_id ~self ~contents in + let* contents1 = VTPM.get_contents ~rpc ~session_id ~self in + Alcotest.(check' string) ~msg:"contents" ~expected:contents ~actual:contents1; + Lwt.return_unit + +let vtpm_tests = [ + test_case "VTPM query" `Quick @@ with_rpc test_get_vtpm + ; test_case "VTPM change contents" `Quick @@ with_rpc test_change_contents +] + +let test_change_nvram ~rpc ~session_id () = + let* self = VM.get_by_uuid ~rpc ~session_id ~uuid in + let* nvram0 = VM.get_NVRAM ~rpc ~session_id ~self in + let dict = Alcotest.(list @@ pair string string) in + Alcotest.(check' dict) ~msg:"nvram initial" ~expected:[] ~actual:nvram0; + let contents = "nvramnew" in + let* () = VM.set_NVRAM_EFI_variables ~rpc ~session_id ~self ~value:contents in + let* nvram1 = VM.get_NVRAM ~rpc ~session_id ~self in + Alcotest.(check' dict) ~msg:"nvram changed" ~expected:["EFI-variables", contents] ~actual:nvram1; + Lwt.return_unit + +let uefi_tests = [ + test_case "NVRAM" `Quick @@ with_rpc test_change_nvram +] + +let () = + Debug.log_to_stdout (); + Lwt_main.run @@ Alcotest_lwt.run "xapi_guard_test" + [ "VTPM", vtpm_tests + ; "UEFI", uefi_tests + ] + + From fd49aa543106f92e05e211cda8d69daba368e628 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 5 Apr 2022 19:18:41 +0100 Subject: [PATCH 05/11] CP-39134: xapi-guard: add unit tests for bad values MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-guard/test/xapi_guard_test.ml | 209 ++++++++++++++++------- 1 file changed, 147 insertions(+), 62 deletions(-) diff --git a/ocaml/xapi-guard/test/xapi_guard_test.ml b/ocaml/xapi-guard/test/xapi_guard_test.ml index 2118bb37943..09e20a183d7 100644 --- a/ocaml/xapi-guard/test/xapi_guard_test.ml +++ b/ocaml/xapi-guard/test/xapi_guard_test.ml @@ -7,20 +7,32 @@ open Xen_api_lwt_unix module D = Debug.Make (struct let name = "xapi-guard-test" end) let expected_session_id = Ref.make () + let vm = Ref.make () + let vtpm = Ref.make () + +let badref = Ref.make () + +let badref' = Ref.make () + let vtpm_contents = ref "" + let nvram_contents = ref [] (* simulates what xapi would do *) let xapi_rpc call = - D.debug "Got rpc %s" call.Rpc.name; - let ret_ok contents = Lwt.return Rpc.{success = true; contents = Rpc.String contents; is_notification=false} in + D.debug "Got rpc %s" call.Rpc.name ; + let ret_ok contents = + Lwt.return + Rpc.{success= true; contents= Rpc.String contents; is_notification= false} + in let cmp_ref a b = String.equal (Ref.string_of a) (Ref.string_of b) in let ref = Alcotest.testable (Fmt.of_to_string Ref.string_of) cmp_ref in let expect_session_id session_id_rpc = let actual = API.ref_session_of_rpc session_id_rpc in - Alcotest.(check' ref) ~expected:expected_session_id ~actual ~msg:"session id" + Alcotest.(check' ref) + ~expected:expected_session_id ~actual ~msg:"session id" in let expect_vm vm_rpc = let actual = API.ref_VM_of_rpc vm_rpc in @@ -30,81 +42,96 @@ let xapi_rpc call = let actual = API.ref_VTPM_of_rpc vtpm_rpc in Alcotest.(check' ref) ~expected:vtpm ~actual ~msg:"vtpm ref" in - match call.Rpc.name, call.Rpc.params with + match (call.Rpc.name, call.Rpc.params) with | "session.login_with_password", _ -> - ret_ok (Ref.string_of expected_session_id) + ret_ok (Ref.string_of expected_session_id) | "session.logout", [session_id_rpc] -> - expect_session_id session_id_rpc; - ret_ok "" + expect_session_id session_id_rpc ; + ret_ok "" | "VM.get_by_uuid", [session_id_rpc; uuid] -> - expect_session_id session_id_rpc; - ret_ok (Ref.string_of vm) + expect_session_id session_id_rpc ; + ret_ok (Ref.string_of vm) | "VM.get_VTPMs", [session_id_rpc; vm_rpc] -> - expect_session_id session_id_rpc; - expect_vm vm_rpc; - Lwt.return Rpc.{success=true; contents=Rpc.Enum [Rpc.String (Ref.string_of vtpm)]; - is_notification=false} + expect_session_id session_id_rpc ; + expect_vm vm_rpc ; + Lwt.return + Rpc. + { + success= true + ; contents= Rpc.Enum [Rpc.String (Ref.string_of vtpm)] + ; is_notification= false + } + | "VTPM.get_profile", [session_id_rpc; vtpm_rpc] -> - expect_session_id session_id_rpc; - expect_vtpm vtpm_rpc; - Lwt.return Rpc.{success=true; contents=Rpc.Dict []; - is_notification=false} + expect_session_id session_id_rpc ; + expect_vtpm vtpm_rpc ; + Lwt.return + Rpc.{success= true; contents= Rpc.Dict []; is_notification= false} | "VTPM.get_contents", [session_id_rpc; vtpm_rpc] -> - expect_session_id session_id_rpc; - expect_vtpm vtpm_rpc; - ret_ok !vtpm_contents + expect_session_id session_id_rpc ; + expect_vtpm vtpm_rpc ; + ret_ok !vtpm_contents | "VTPM.set_contents", [session_id_rpc; vtpm_rpc; contents] -> - expect_session_id session_id_rpc; - expect_vtpm vtpm_rpc; - vtpm_contents := API.string_of_rpc contents; - ret_ok "" + expect_session_id session_id_rpc ; + expect_vtpm vtpm_rpc ; + vtpm_contents := API.string_of_rpc contents ; + ret_ok "" | "VM.get_NVRAM", [session_id_rpc; vm_rpc] -> - expect_session_id session_id_rpc; - expect_vm vm_rpc; - Lwt.return Rpc.{success=true; contents=API.rpc_of_string_to_string_map !nvram_contents;is_notification=false} + expect_session_id session_id_rpc ; + expect_vm vm_rpc ; + Lwt.return + Rpc. + { + success= true + ; contents= API.rpc_of_string_to_string_map !nvram_contents + ; is_notification= false + } + | "VM.set_NVRAM_EFI_variables", [session_id_rpc; vm_rpc; contents] -> - expect_session_id session_id_rpc; - expect_vm vm_rpc; - nvram_contents := ["EFI-variables", API.string_of_rpc contents]; - ret_ok "" + expect_session_id session_id_rpc ; + expect_vm vm_rpc ; + nvram_contents := [("EFI-variables", API.string_of_rpc contents)] ; + ret_ok "" | _ -> - Fmt.failwith "XAPI RPC call %s not expected in test" call.Rpc.name + Fmt.failwith "XAPI RPC call %s not expected in test" call.Rpc.name let uuid = Uuidm.create `V4 |> Uuidm.to_string let () = let old_hook = !Lwt.async_exception_hook in - (Lwt.async_exception_hook := - fun exn -> - D.log_backtrace () ; - D.error "Lwt caught async exception: %s" (Printexc.to_string exn) ; - old_hook exn - ) + Lwt.async_exception_hook := + fun exn -> + D.log_backtrace () ; + D.error "Lwt caught async exception: %s" (Printexc.to_string exn) ; + old_hook exn let with_rpc f switch () = Lwt_io.with_temp_dir ~prefix:"xapi_guard" @@ fun tmp -> let cache = SessionCache.create ~rpc:xapi_rpc ~login ~logout in - (Lwt_switch.add_hook (Some switch) @@ fun () -> - SessionCache.destroy cache); + (Lwt_switch.add_hook (Some switch) @@ fun () -> SessionCache.destroy cache) ; let path = Filename.concat tmp "socket" in (* Create an internal server on 'path', the socket that varstored/swtpm would connect to *) let* stop_server = make_server_rpcfn ~cache path uuid in (* rpc simulates what varstored/swtpm would do *) let uri = Uri.make ~scheme:"file" ~path () |> Uri.to_string in - D.debug "Connecting to %s" uri; + D.debug "Connecting to %s" uri ; let rpc = Xen_api_lwt_unix.make uri in - Lwt.finalize (fun () -> + Lwt.finalize + (fun () -> (* not strictly necessary to login/logout here - since we only get dummy sessions *) - let* session_id = Session.login_with_password ~rpc ~uname:"root" ~pwd:"" ~version:"0.0" ~originator:"test" + let* session_id = + Session.login_with_password ~rpc ~uname:"root" ~pwd:"" ~version:"0.0" + ~originator:"test" in let logout () = Session.logout ~rpc ~session_id in Lwt.finalize logout @@ f ~rpc ~session_id - ) stop_server + ) + stop_server let with_vtpm ~rpc ~session_id f = let* vm_ref = VM.get_by_uuid ~rpc ~session_id ~uuid in let* vtpms = VM.get_VTPMs ~rpc ~session_id ~self:vm_ref in - Alcotest.(check' int) ~msg:"no. vtpms" ~expected:1 ~actual:(List.length vtpms); + Alcotest.(check' int) ~msg:"no. vtpms" ~expected:1 ~actual:(List.length vtpms) ; let vtpm = List.hd vtpms in f ~self:vtpm @@ -118,38 +145,96 @@ let test_get_vtpm ~rpc ~session_id () = let test_change_contents ~rpc ~session_id () = with_vtpm ~rpc ~session_id @@ fun ~self -> let* contents0 = VTPM.get_contents ~rpc ~session_id ~self in - Alcotest.(check' string) ~msg:"contents" ~expected:"" ~actual:contents0; + Alcotest.(check' string) ~msg:"contents" ~expected:"" ~actual:contents0 ; let contents = "somedata" in let* () = VTPM.set_contents ~rpc ~session_id ~self ~contents in let* contents1 = VTPM.get_contents ~rpc ~session_id ~self in - Alcotest.(check' string) ~msg:"contents" ~expected:contents ~actual:contents1; + Alcotest.(check' string) ~msg:"contents" ~expected:contents ~actual:contents1 ; Lwt.return_unit -let vtpm_tests = [ - test_case "VTPM query" `Quick @@ with_rpc test_get_vtpm +let vtpm_tests = + [ + test_case "VTPM query" `Quick @@ with_rpc test_get_vtpm ; test_case "VTPM change contents" `Quick @@ with_rpc test_change_contents -] + ] + +let dict = Alcotest.(list @@ pair string string) let test_change_nvram ~rpc ~session_id () = let* self = VM.get_by_uuid ~rpc ~session_id ~uuid in let* nvram0 = VM.get_NVRAM ~rpc ~session_id ~self in - let dict = Alcotest.(list @@ pair string string) in - Alcotest.(check' dict) ~msg:"nvram initial" ~expected:[] ~actual:nvram0; + Alcotest.(check' dict) ~msg:"nvram initial" ~expected:[] ~actual:nvram0 ; let contents = "nvramnew" in let* () = VM.set_NVRAM_EFI_variables ~rpc ~session_id ~self ~value:contents in let* nvram1 = VM.get_NVRAM ~rpc ~session_id ~self in - Alcotest.(check' dict) ~msg:"nvram changed" ~expected:["EFI-variables", contents] ~actual:nvram1; + Alcotest.(check' dict) + ~msg:"nvram changed" + ~expected:[("EFI-variables", contents)] + ~actual:nvram1 ; Lwt.return_unit -let uefi_tests = [ - test_case "NVRAM" `Quick @@ with_rpc test_change_nvram -] +let uefi_tests = + [test_case "NVRAM change contents" `Quick @@ with_rpc test_change_nvram] -let () = - Debug.log_to_stdout (); - Lwt_main.run @@ Alcotest_lwt.run "xapi_guard_test" - [ "VTPM", vtpm_tests - ; "UEFI", uefi_tests - ] +(* xapi-guard filters API calls, and ignores VM/VTPM/session refs, and replaces it with the VM/VTPM + ref the daemon is supposed to use. + It doesn't reject bad refs, although it could in the future, and then the tests below should be + updated *) +let test_bad_get_nvram ~rpc ~session_id () = + let* nvram = VM.get_NVRAM ~rpc ~session_id ~self:badref in + Lwt.return_unit + +let test_bad_get_vtpm ~rpc ~session_id () = + let* vtpm = VTPM.get_contents ~rpc ~session_id ~self:badref' in + Lwt.return_unit +let test_bad_set_nvram ~rpc ~session_id () = + let* () = + VM.set_NVRAM_EFI_variables ~rpc ~session_id ~self:badref ~value:"bad" + in + let* vm_ref = VM.get_by_uuid ~rpc ~session_id ~uuid in + let* nvram = VM.get_NVRAM ~rpc ~session_id ~self:vm_ref in + Alcotest.(check' dict) + ~msg:"only managed to change own nvram" ~actual:nvram + ~expected:[("EFI-variables", "bad")] ; + Lwt.return_unit + +let test_bad_set_vtpm ~rpc ~session_id () = + let* () = VTPM.set_contents ~rpc ~session_id ~self:badref' ~contents:"bad" in + with_vtpm ~rpc ~session_id @@ fun ~self -> + let* contents = VTPM.get_contents ~rpc ~session_id ~self in + Alcotest.(check' string) + ~msg:"only managed to change own vtpm" ~actual:contents ~expected:"bad" ; + Lwt.return_unit + +let test_vtpm_all ~rpc ~session_id () = + let+ res = Lwt_result.catch (VTPM.get_all_records ~rpc ~session_id) in + let res = res |> Result.map ignore |> Result.map_error Printexc.to_string in + (* the exception is not exported, so can only check it as a string *) + Alcotest.(check' @@ result unit string) + ~msg:"bad method" + ~expected: + (Error + {|Server_error(Internal_error, [ Idl.UnknownMethod("VTPM.get_all_records") ])|} + ) + ~actual:res + +let bad_params_tests = + [ + test_case "VM.get_NVRAM" `Quick @@ with_rpc test_bad_get_nvram + ; test_case "VTPM.get_contents" `Quick @@ with_rpc test_bad_get_vtpm + ; test_case "VM.set_NVRAM_EFI_variables" `Quick @@ with_rpc test_bad_set_nvram + ; test_case "VTPM.set_contents" `Quick @@ with_rpc test_bad_set_vtpm + ; test_case "VTPM.get_all_records" `Quick @@ with_rpc test_vtpm_all + ] + +let () = + Debug.log_to_stdout () ; + Lwt_main.run + @@ Alcotest_lwt.run "xapi_guard_test" + [ + ("VTPM", vtpm_tests) + ; ("UEFI", uefi_tests) + ; ("bad_params", bad_params_tests) + ] From 9d12dcd9ebbe8515606532d5c10b20c6591414a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 5 Apr 2022 19:34:51 +0100 Subject: [PATCH 06/11] CP-39134: varstore-guard: use inotify to wait for the apperance of the socket MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is the socket created by xapi-guard itself through Conduit, but Conduit doesn't currently have an API to notify us when the socket got created and listen()-ed on. And we don't want to return too early to our caller (the unit test or xenopsd) since they may get an ECONNREFUSED if they try to connect too early. Signed-off-by: Edwin Török --- ocaml/xapi-guard/lib/dune | 1 + ocaml/xapi-guard/lib/varstored_interface.ml | 66 +++++++++++++++++---- 2 files changed, 54 insertions(+), 13 deletions(-) diff --git a/ocaml/xapi-guard/lib/dune b/ocaml/xapi-guard/lib/dune index 764d3d3d4b4..7ef0dead309 100644 --- a/ocaml/xapi-guard/lib/dune +++ b/ocaml/xapi-guard/lib/dune @@ -3,6 +3,7 @@ (libraries cohttp-lwt-unix conduit-lwt-unix + inotify.lwt rpclib-lwt xapi-idl xapi-idl.varstore.deprivileged diff --git a/ocaml/xapi-guard/lib/varstored_interface.ml b/ocaml/xapi-guard/lib/varstored_interface.ml index b30acb8904b..c14e02ea7f1 100644 --- a/ocaml/xapi-guard/lib/varstored_interface.ml +++ b/ocaml/xapi-guard/lib/varstored_interface.ml @@ -14,6 +14,7 @@ open Rpc open Lwt.Infix +open Lwt.Syntax module D = Debug.Make (struct let name = "varstored_interface" end) @@ -151,22 +152,61 @@ let with_xapi ~cache f = * It only ever returns from server creation when the server is stopped. * Try actually connecting: the file could be present but nobody listening on the other side. * *) -let rec wait_for_file_to_appear path = - Lwt.pause () >>= fun () -> - Lwt.try_bind - (fun () -> - Conduit_lwt_unix.connect ~ctx:Conduit_lwt_unix.default_ctx - (`Unix_domain_socket (`File path)) - ) - (fun (_, ic, _oc) -> +let rec wait_connectable path = + let* res = + Lwt_result.catch + (Conduit_lwt_unix.connect ~ctx:Conduit_lwt_unix.default_ctx + (`Unix_domain_socket (`File path)) + ) + in + match res with + | Ok (_, ic, _oc) -> D.debug "Socket at %s works" path ; (* do not close both channels, or we get an EBADF *) Lwt_io.close ic + | Error e -> + D.debug "Waiting for socket to be connectable at %s: %s" path + (Printexc.to_string e) ; + (* just in case Lwt_unix.listen doesn't get called soon enough, + avoid using up 100% CPU waiting for it, + better than Lwt.pause () + *) + let* () = Lwt_unix.sleep 0.001 in + wait_connectable path + +let with_inotify f = + let* inotify = Lwt_inotify.create () in + Lwt.finalize (fun () -> f inotify) (fun () -> Lwt_inotify.close inotify) + +let wait_for_file_to_appear path = + with_inotify @@ fun inotify -> + (* we need to check for existence after setting up the watch to avoid race conditions: + S_Create event on parent dir is only sent on creating a new file, + and you cannot set up an inotify on a non-existent file. + *) + let* (_watch : Inotify.watch) = + Lwt_inotify.add_watch inotify (Filename.dirname path) [Inotify.S_Create] + in + let rec loop () = + let* exists = Lwt_unix.file_exists path in + if exists then + Lwt.return_unit + else ( + D.debug "Waiting for file %s to appear" path ; + let* (_event : Inotify.event) = Lwt_inotify.read inotify in + (* we've got a create event knowing that *a* file got created, + but not necessarily the one we were looking for *) + loop () ) - (fun e -> - D.debug "Waiting for file %s to appear (%s)" path (Printexc.to_string e) ; - Lwt_unix.sleep 0.1 >>= fun () -> wait_for_file_to_appear path - ) + in + loop () + +let wait_for_connectable_socket path = + (* pause gives a chance for the conduit lwt promise to run and listen *) + let* () = Lwt.pause () in + let* () = wait_for_file_to_appear path in + let* () = Lwt.pause () in + wait_connectable path let serve_forever_lwt rpc_fn path = let conn_closed _ = () in @@ -214,7 +254,7 @@ let serve_forever_lwt rpc_fn path = * otherwise do not cancel the server if the file appeared (Lwt.protected) *) Lwt.pick [ - Lwt_unix.with_timeout 120. (fun () -> wait_for_file_to_appear path) + Lwt_unix.with_timeout 120. (fun () -> wait_for_connectable_socket path) ; Lwt.protected server_wait_exit ] >>= fun () -> Lwt.return cleanup From 561caf4b9f5e2d19758b635fbba22b73f984041a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 6 Apr 2022 10:01:43 +0100 Subject: [PATCH 07/11] Maintenance: xapi-guard: use Lwt.Syntax instead of Lwt.Infix MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Instead of `foo () >>= fun result -> ...` use `let* result = foo () in ...`. Instead of `foo () >|= fun result -> ...` use `let+ result = foo () in ...`. Signed-off-by: Edwin Török --- ocaml/xapi-guard/lib/varstored_interface.ml | 57 +++++++------- ocaml/xapi-guard/src/main.ml | 83 ++++++++++++--------- 2 files changed, 77 insertions(+), 63 deletions(-) diff --git a/ocaml/xapi-guard/lib/varstored_interface.ml b/ocaml/xapi-guard/lib/varstored_interface.ml index c14e02ea7f1..f0a11928d0e 100644 --- a/ocaml/xapi-guard/lib/varstored_interface.ml +++ b/ocaml/xapi-guard/lib/varstored_interface.ml @@ -13,7 +13,6 @@ *) open Rpc -open Lwt.Infix open Lwt.Syntax module D = Debug.Make (struct let name = "varstored_interface" end) @@ -71,14 +70,14 @@ end = struct Lwt.return is_valid in let acquire () = - login ~rpc >>= fun session -> + let* session = login ~rpc in Hashtbl.add valid_sessions session () ; debug "SessionCache.acquired" ; Lwt.return session in let dispose session = debug "SessionCache.dispose" ; - logout ~rpc session >|= fun () -> + let+ () = logout ~rpc session in debug "SessionCache.disposed" ; Hashtbl.remove valid_sessions session in @@ -96,7 +95,7 @@ end = struct let rec with_session t f = (* we can use the same session from multiple concurrent requests, * we just do not want to log in more than once *) - Lwt_pool.use t.pool Lwt.return >>= fun session_id -> + let* session_id = Lwt_pool.use t.pool Lwt.return in Lwt.catch (fun () -> f ~rpc:t.rpc ~session_id) (function @@ -133,7 +132,7 @@ let () = let cleanup n = debug "Triggering cleanup on signal %d, and waiting for servers to stop" n ; Lwt.async (fun () -> - Lwt_switch.turn_off shutdown >>= fun () -> + let* () = Lwt_switch.turn_off shutdown in info "Cleanup complete, exiting" ; exit 0 ) @@ -218,14 +217,15 @@ let serve_forever_lwt rpc_fn path = let uri = Cohttp.Request.uri req in match (Cohttp.Request.meth req, Uri.path uri) with | `POST, _ -> - Cohttp_lwt.Body.to_string body >>= fun body -> - Dorpc.wrap_rpc err (fun () -> - let call = Xmlrpc.call_of_string body in - (* Do not log the request, it will contain NVRAM *) - D.debug "Received request on %s, method %s" path call.Rpc.name ; - rpc_fn call - ) - >>= fun response -> + let* body = Cohttp_lwt.Body.to_string body in + let* response = + Dorpc.wrap_rpc err (fun () -> + let call = Xmlrpc.call_of_string body in + (* Do not log the request, it will contain NVRAM *) + D.debug "Received request on %s, method %s" path call.Rpc.name ; + rpc_fn call + ) + in let body = response |> Xmlrpc.string_of_response in Cohttp_lwt_unix.Server.respond_string ~status:`OK ~body () | _, _ -> @@ -252,21 +252,23 @@ let serve_forever_lwt rpc_fn path = Lwt_switch.add_hook (Some shutdown) cleanup ; (* if server_wait_exit fails then cancel waiting for file to appear * otherwise do not cancel the server if the file appeared (Lwt.protected) *) - Lwt.pick - [ - Lwt_unix.with_timeout 120. (fun () -> wait_for_connectable_socket path) - ; Lwt.protected server_wait_exit - ] - >>= fun () -> Lwt.return cleanup + let* () = + Lwt.pick + [ + Lwt_unix.with_timeout 120. (fun () -> wait_for_connectable_socket path) + ; Lwt.protected server_wait_exit + ] + in + Lwt.return cleanup (* Create a restricted RPC function and socket for a specific VM *) let make_server_rpcfn ~cache path vm_uuid = let module Server = Varstore_deprivileged_interface.RPC_API (Rpc_lwt.GenServer ()) in - with_xapi ~cache @@ VM.get_by_uuid ~uuid:vm_uuid >>= fun vm -> + let* vm = with_xapi ~cache @@ VM.get_by_uuid ~uuid:vm_uuid in let ret v = (* TODO: maybe map XAPI exceptions *) - v >>= Lwt.return_ok |> Rpc_lwt.T.put + Lwt.bind v Lwt.return_ok |> Rpc_lwt.T.put in let get_nvram _ _ = ret @@ with_xapi ~cache @@ VM.get_NVRAM ~self:vm in let set_nvram _ _ nvram = @@ -274,10 +276,12 @@ let make_server_rpcfn ~cache path vm_uuid = in let message_create _ _name priority _cls _uuid body = ret - ( with_xapi ~cache - @@ Message.create ~name:"VM_SECURE_BOOT_FAILED" ~priority ~cls:`VM - ~obj_uuid:vm_uuid ~body - >>= fun _ -> Lwt.return_unit + (let* (_ : _ Ref.t) = + with_xapi ~cache + @@ Message.create ~name:"VM_SECURE_BOOT_FAILED" ~priority ~cls:`VM + ~obj_uuid:vm_uuid ~body + in + Lwt.return_unit ) in (* we return a static string for these API calls: @@ -289,7 +293,8 @@ let make_server_rpcfn ~cache path vm_uuid = let get_vm _ _ = ret @@ Lwt.return "DUMMYVM" in let with_vtpm f = ret - (with_xapi ~cache @@ VM.get_VTPMs ~self:vm >>= function + (let* vtpms = with_xapi ~cache @@ VM.get_VTPMs ~self:vm in + match vtpms with | [] -> Lwt.fail_with "No VTPMs" | [vtpm] -> diff --git a/ocaml/xapi-guard/src/main.ml b/ocaml/xapi-guard/src/main.ml index d45ef881da1..b5d0afeeb45 100644 --- a/ocaml/xapi-guard/src/main.ml +++ b/ocaml/xapi-guard/src/main.ml @@ -15,11 +15,11 @@ open Xapi_guard open Varstored_interface -open Lwt.Infix +open Lwt.Syntax module D = Debug.Make (struct let name = "varstored-guard" end) -let ret v = v >>= Lwt.return_ok |> Rpc_lwt.T.put +let ret v = Lwt.bind v Lwt.return_ok |> Rpc_lwt.T.put let sockets = Hashtbl.create 127 @@ -38,18 +38,18 @@ module Persistent = struct Lwt_io.with_file ~mode:Lwt_io.Output path (fun ch -> Lwt_io.write ch json) let loadfrom path = - Lwt_unix.file_exists path >>= function - | false -> - Lwt.return_nil - | true -> ( + let* exists = Lwt_unix.file_exists path in + if exists then + let* json = Lwt_io.with_file ~mode:Lwt_io.Input path (fun ch -> Lwt_io.read ch) - >>= fun json -> - json |> Jsonrpc.of_string |> Rpcmarshal.unmarshal typ_of |> function - | Ok result -> - Lwt.return result - | Error (`Msg m) -> - Lwt.fail_with m - ) + in + json |> Jsonrpc.of_string |> Rpcmarshal.unmarshal typ_of |> function + | Ok result -> + Lwt.return result + | Error (`Msg m) -> + Lwt.fail_with m + else + Lwt.return_nil end let recover_path = "/run/nonpersistent/varstored-guard-active.json" @@ -83,14 +83,16 @@ let () = 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 ~cache path vm_uuid_str >>= fun stop_server -> + let* () = safe_unlink path in + let* stop_server = make_server_rpcfn ~cache path vm_uuid_str in Hashtbl.add sockets path (stop_server, (vm_uuid, gid)) ; - Lwt_unix.chmod path 0o660 >>= fun () -> Lwt_unix.chown path 0 gid + let* () = Lwt_unix.chmod path 0o660 in + Lwt_unix.chown path 0 gid let resume () = - Persistent.loadfrom recover_path >>= Lwt_list.iter_p listen_for_vm - >>= fun () -> D.debug "resume completed" ; Lwt.return_unit + let* vms = Persistent.loadfrom recover_path in + let+ () = Lwt_list.iter_p listen_for_vm vms in + D.debug "resume completed" (* caller here is trusted (xenopsd through message-switch *) let depriv_create dbg vm_uuid gid path = @@ -105,7 +107,7 @@ let depriv_create dbg vm_uuid gid path = @@ ( D.debug "[%s] creating deprivileged socket at %s, owned by group %d" dbg path gid ; - listen_for_vm {Persistent.path; vm_uuid; gid} >>= fun () -> + let* () = listen_for_vm {Persistent.path; vm_uuid; gid} in store_args sockets ) @@ -120,9 +122,10 @@ let depriv_destroy dbg gid path = Lwt.return_unit | Some (stop_server, _) -> let finally () = - safe_unlink path >|= fun () -> Hashtbl.remove sockets path + let+ () = safe_unlink path in + Hashtbl.remove sockets path in - Lwt.finalize stop_server finally >>= fun () -> + let* () = Lwt.finalize stop_server finally in D.debug "[%s] stopped server for gid %d and removed socket" dbg gid ; Lwt.return_unit @@ -134,32 +137,38 @@ let rpc_fn = Rpc_lwt.server Server.implementation let process body = - Dorpc.wrap_rpc Varstore_privileged_interface.E.error (fun () -> - let call = Jsonrpc.call_of_string body in - D.debug "Received request from message-switch, method %s" call.Rpc.name ; - rpc_fn call - ) - >|= Jsonrpc.string_of_response + let+ response = + Dorpc.wrap_rpc Varstore_privileged_interface.E.error (fun () -> + let call = Jsonrpc.call_of_string body in + D.debug "Received request from message-switch, method %s" call.Rpc.name ; + rpc_fn call + ) + in + Jsonrpc.string_of_response response let make_message_switch_server () = let open Message_switch_lwt.Protocol_lwt in let wait_server, server_stopped = Lwt.task () in - Server.listen ~process ~switch:!Xcp_client.switch_path - ~queue:Varstore_privileged_interface.queue_name () - >>= fun result -> + let* result = + Server.listen ~process ~switch:!Xcp_client.switch_path + ~queue:Varstore_privileged_interface.queue_name () + in match Server.error_to_msg result with | Ok t -> Lwt_switch.add_hook (Some shutdown) (fun () -> D.debug "Stopping message-switch queue server" ; - Server.shutdown ~t () >|= Lwt.wakeup server_stopped + let+ () = Server.shutdown ~t () in + Lwt.wakeup server_stopped () ) ; (* best effort resume *) - Lwt.catch resume (fun e -> - D.log_backtrace () ; - D.warn "Resume failed: %s" (Printexc.to_string e) ; - Lwt.return_unit - ) - >>= fun () -> wait_server + let* () = + Lwt.catch resume (fun e -> + D.log_backtrace () ; + D.warn "Resume failed: %s" (Printexc.to_string e) ; + Lwt.return_unit + ) + in + wait_server | Error (`Msg m) -> Lwt.fail_with (Printf.sprintf "Failed to listen on message-switch queue: %s" m) From f1c07f855863792fda58772bd04ebe7d78714ed2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 6 Apr 2022 10:06:44 +0100 Subject: [PATCH 08/11] CP-39134: add shutdown unit test MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-guard/test/xapi_guard_test.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ocaml/xapi-guard/test/xapi_guard_test.ml b/ocaml/xapi-guard/test/xapi_guard_test.ml index 09e20a183d7..7eaace5f7b2 100644 --- a/ocaml/xapi-guard/test/xapi_guard_test.ml +++ b/ocaml/xapi-guard/test/xapi_guard_test.ml @@ -229,6 +229,8 @@ let bad_params_tests = ; test_case "VTPM.get_all_records" `Quick @@ with_rpc test_vtpm_all ] +let shutdown_test _ () = Lwt_switch.turn_off Varstored_interface.shutdown + let () = Debug.log_to_stdout () ; Lwt_main.run @@ -237,4 +239,5 @@ let () = ("VTPM", vtpm_tests) ; ("UEFI", uefi_tests) ; ("bad_params", bad_params_tests) + ; ("shutdown", [test_case "shutdown" `Quick shutdown_test]) ] From 18ff14b3542f94ae2eb63452fcf943f054b0e9d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 6 Apr 2022 10:09:54 +0100 Subject: [PATCH 09/11] CP-39134: quality gate fixups MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-guard/src/main.mli | 0 ocaml/xapi-guard/test/xapi_guard_test.ml | 6 ++++-- ocaml/xapi-guard/test/xapi_guard_test.mli | 0 quality-gate.sh | 2 +- 4 files changed, 5 insertions(+), 3 deletions(-) create mode 100644 ocaml/xapi-guard/src/main.mli create mode 100644 ocaml/xapi-guard/test/xapi_guard_test.mli diff --git a/ocaml/xapi-guard/src/main.mli b/ocaml/xapi-guard/src/main.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/xapi-guard/test/xapi_guard_test.ml b/ocaml/xapi-guard/test/xapi_guard_test.ml index 7eaace5f7b2..c9e67e3ba00 100644 --- a/ocaml/xapi-guard/test/xapi_guard_test.ml +++ b/ocaml/xapi-guard/test/xapi_guard_test.ml @@ -132,8 +132,10 @@ let with_vtpm ~rpc ~session_id f = let* vm_ref = VM.get_by_uuid ~rpc ~session_id ~uuid in let* vtpms = VM.get_VTPMs ~rpc ~session_id ~self:vm_ref in Alcotest.(check' int) ~msg:"no. vtpms" ~expected:1 ~actual:(List.length vtpms) ; - let vtpm = List.hd vtpms in - f ~self:vtpm + match vtpms with + | [] -> Alcotest.fail "No VTPMs" + | [vtpm] -> f ~self:vtpm + | multiple -> Alcotest.failf "Too many vTPMs: %d" (List.length multiple) let test_get_vtpm ~rpc ~session_id () = with_vtpm ~rpc ~session_id @@ fun ~self -> diff --git a/ocaml/xapi-guard/test/xapi_guard_test.mli b/ocaml/xapi-guard/test/xapi_guard_test.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/quality-gate.sh b/quality-gate.sh index 1064409547e..b66e7864001 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=519 + N=518 # do not count ml files from the tests in ocaml/{tests/perftest/quicktest} MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) From fd67a69a577fce2b470cb37bc7f7b08b1a75a237 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 8 Apr 2022 13:39:55 +0100 Subject: [PATCH 10/11] Add fd leak test MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-guard/test/xapi_guard_test.ml | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/ocaml/xapi-guard/test/xapi_guard_test.ml b/ocaml/xapi-guard/test/xapi_guard_test.ml index c9e67e3ba00..135738cdde1 100644 --- a/ocaml/xapi-guard/test/xapi_guard_test.ml +++ b/ocaml/xapi-guard/test/xapi_guard_test.ml @@ -231,7 +231,16 @@ let bad_params_tests = ; test_case "VTPM.get_all_records" `Quick @@ with_rpc test_vtpm_all ] -let shutdown_test _ () = Lwt_switch.turn_off Varstored_interface.shutdown +let linux_count_fds () = Sys.readdir "/proc/self/fd" |> Array.length + +let shutdown_test _ () = + let fd0 = linux_count_fds () in + let noop ~rpc ~session_id () = Lwt.return_unit in + let* () = with_rpc noop Varstored_interface.shutdown () in + let* () = Lwt_switch.turn_off Varstored_interface.shutdown in + let fd1 = linux_count_fds () in + Alcotest.(check' int) ~msg:"No FD leak" ~expected:fd0 ~actual:fd1; + Lwt.return_unit let () = Debug.log_to_stdout () ; From 6d4a6684640bab62f70168b5ff5d990a17b01e8b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Fri, 8 Apr 2022 13:36:49 +0100 Subject: [PATCH 11/11] Avoid leak in wait_connectable MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- ocaml/xapi-guard/lib/varstored_interface.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/ocaml/xapi-guard/lib/varstored_interface.ml b/ocaml/xapi-guard/lib/varstored_interface.ml index f0a11928d0e..dbe24ada74c 100644 --- a/ocaml/xapi-guard/lib/varstored_interface.ml +++ b/ocaml/xapi-guard/lib/varstored_interface.ml @@ -159,10 +159,11 @@ let rec wait_connectable path = ) in match res with - | Ok (_, ic, _oc) -> + | Ok (_, ic, oc) -> D.debug "Socket at %s works" path ; - (* do not close both channels, or we get an EBADF *) - Lwt_io.close ic + (* close both channels, in non-SSL mode this would leak otherwise *) + let* () = Lwt_io.close ic in + Lwt_io.close oc | Error e -> D.debug "Waiting for socket to be connectable at %s: %s" path (Printexc.to_string e) ;