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..7ef0dead309 --- /dev/null +++ b/ocaml/xapi-guard/lib/dune @@ -0,0 +1,13 @@ +(library + (name xapi_guard) + (libraries + cohttp-lwt-unix + conduit-lwt-unix + inotify.lwt + 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 54% rename from ocaml/xapi-guard/src/varstored_interface.ml rename to ocaml/xapi-guard/lib/varstored_interface.ml index d0fb3b1da5b..dbe24ada74c 100644 --- a/ocaml/xapi-guard/src/varstored_interface.ml +++ b/ocaml/xapi-guard/lib/varstored_interface.ml @@ -13,7 +13,7 @@ *) open Rpc -open Lwt.Infix +open Lwt.Syntax module D = Debug.Make (struct let name = "varstored_interface" end) @@ -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 -> + let* session = login ~rpc in Hashtbl.add valid_sessions session () ; debug "SessionCache.acquired" ; Lwt.return session in let dispose session = debug "SessionCache.dispose" ; - logout session >|= fun () -> + let+ () = logout ~rpc session in 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, @@ -91,9 +95,9 @@ 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 ~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,21 +126,13 @@ 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 ; Lwt.async (fun () -> - Lwt_switch.turn_off shutdown >>= fun () -> + let* () = Lwt_switch.turn_off shutdown in info "Cleanup complete, exiting" ; exit 0 ) @@ -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 @@ -155,22 +151,62 @@ let with_xapi 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 - ) - (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 + (* 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) ; + (* 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 () ) + 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 @@ -182,14 +218,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 () | _, _ -> @@ -216,41 +253,84 @@ 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_file_to_appear 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 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 -> + 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 @@ 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 - @@ 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: + 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 + (let* vtpms = with_xapi ~cache @@ VM.get_VTPMs ~self:vm in + match vtpms with + | [] -> + 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 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 160e934bb94..b5d0afeeb45 100644 --- a/ocaml/xapi-guard/src/main.ml +++ b/ocaml/xapi-guard/src/main.ml @@ -13,12 +13,13 @@ * GNU Lesser General Public License for more details. *) +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 @@ -37,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" @@ -66,17 +67,32 @@ 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 -> + 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 = @@ -91,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 ) @@ -106,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 @@ -120,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) 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/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..135738cdde1 --- /dev/null +++ b/ocaml/xapi-guard/test/xapi_guard_test.ml @@ -0,0 +1,254 @@ +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 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 + 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) ; + 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 -> + 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 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 + 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 change contents" `Quick @@ with_rpc test_change_nvram] + +(* 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 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 () ; + Lwt_main.run + @@ Alcotest_lwt.run "xapi_guard_test" + [ + ("VTPM", vtpm_tests) + ; ("UEFI", uefi_tests) + ; ("bad_params", bad_params_tests) + ; ("shutdown", [test_case "shutdown" `Quick shutdown_test]) + ] 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/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 diff --git a/quality-gate.sh b/quality-gate.sh index f05ea40b8d6..e97a42c0576 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=517 + N=516 # 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 '.'" \;)