Merge master into feature/trusted-certs (#7043)

Author: minglumlu

ocaml/idl/datamodel_vm.ml

@@ -2384,6 +2384,105 @@ let sysprep =
        as part of a reboot."
     ~allowed_roles:_R_VM_ADMIN ()
 
+module Other_config = struct
+  let protected_keys =
+    [
+      ("hvm_serial", _R_POOL_ADMIN)
+    ; ("pci", _R_POOL_ADMIN)
+    ; ("folder", _R_VM_OP)
+    ; ("XenCenter.CustomFields.*", _R_VM_OP)
+    ]
+
+  let call =
+    call
+      ~lifecycle:[(Published, rel_rio, "additional configuration")]
+      ~allowed_roles:_R_VM_ADMIN
+
+  let add_to_other_config =
+    call ~name:"add_to_other_config"
+      ~doc:
+        "Add the given key-value pair to the other_config field of the given \
+         VM."
+      ~params:
+        [
+          (Ref _vm, "self", "reference to object")
+        ; (String, "key", "Key to add")
+        ; (String, "value", "Value to add")
+        ]
+      ~map_keys_roles:protected_keys ~flags:[`Session] ()
+
+  let remove_from_other_config =
+    call ~name:"remove_from_other_config"
+      ~doc:
+        "Remove the given key and its corresponding value from the \
+         other_config field of the given VM. If the key is not in that Map, \
+         then do nothing."
+      ~params:
+        [
+          (Ref _vm, "self", "reference to object")
+        ; (String, "key", "Key of entry to remove")
+        ]
+      ~map_keys_roles:protected_keys ~flags:[`Session] ()
+
+  (* map_keys_roles can't be cited here, since they're only implemented for
+   {add_to,remove_from}_other_config, RBAC handling is done in a manual
+   implementation. *)
+  let set_other_config =
+    call ~name:"set_other_config"
+      ~doc:"Set the other_config field of the given VM."
+      ~params:
+        [
+          (Ref _vm, "self", "reference to object")
+        ; (Map (String, String), "value", "New value to set")
+        ]
+      ~flags:[`Session] ()
+end
+
+module Platform = struct
+  let protected_keys = [("hvm_serial", _R_POOL_ADMIN)]
+
+  let call =
+    call
+      ~lifecycle:[(Published, rel_rio, "platform-specific configuration")]
+      ~allowed_roles:_R_VM_ADMIN
+
+  let add_to_platform =
+    call ~name:"add_to_platform"
+      ~doc:"Add the given key-value pair to the platform field of the given VM."
+      ~params:
+        [
+          (Ref _vm, "self", "reference to object")
+        ; (String, "key", "Key to add")
+        ; (String, "value", "Value to add")
+        ]
+      ~map_keys_roles:protected_keys ~flags:[`Session] ()
+
+  let remove_from_platform =
+    call ~name:"remove_from_platform"
+      ~doc:
+        "Remove the given key and its corresponding value from the platform \
+         field of the given VM. If the key is not in that Map, then do \
+         nothing."
+      ~params:
+        [
+          (Ref _vm, "self", "reference to object")
+        ; (String, "key", "Key of entry to remove")
+        ]
+      ~map_keys_roles:protected_keys ~flags:[`Session] ()
+
+  (* map_keys_roles can't be cited here, since they're only implemented for
+   {add_to,remove_from}_platform, RBAC handling is done in a manual
+   implementation. *)
+  let set_platform =
+    call ~name:"set_platform" ~doc:"Set the platform field of the given VM."
+      ~params:
+        [
+          (Ref _vm, "self", "reference to object")
+        ; (Map (String, String), "value", "New value to set")
+        ]
+      ~flags:[`Session] ()
+end
+
 let vm_uefi_mode =
   Enum
     ( "vm_uefi_mode"
@@ -2587,6 +2686,12 @@ let t =
       ; add_to_blocked_operations
       ; remove_from_blocked_operations
       ; sysprep
+      ; Other_config.add_to_other_config
+      ; Other_config.remove_from_other_config
+      ; Other_config.set_other_config
+      ; Platform.add_to_platform
+      ; Platform.remove_from_platform
+      ; Platform.set_platform
       ]
     ~contents:
       ([
@@ -2715,9 +2820,10 @@ let t =
             ~qualifier:DynamicRO ~ty:(Set (Ref _vtpm)) "VTPMs" "virtual TPMs"
         ; namespace ~name:"PV" ~contents:pv ()
         ; namespace ~name:"HVM" ~contents:hvm ()
-        ; field
+        ; field ~qualifier:StaticRO
             ~ty:(Map (String, String))
             ~lifecycle:[(Published, rel_rio, "platform-specific configuration")]
+            ~map_keys_roles:[("hvm_serial", _R_POOL_ADMIN)]
             "platform" "platform-specific configuration"
         ; field
             ~lifecycle:
@@ -2726,13 +2832,14 @@ let t =
               ; (Deprecated, rel_boston, "Field was never used")
               ]
             "PCI_bus" "PCI bus path for pass-through devices"
-        ; field
+        ; field ~qualifier:StaticRO
             ~lifecycle:[(Published, rel_rio, "additional configuration")]
             ~ty:(Map (String, String))
             "other_config" "additional configuration"
             ~map_keys_roles:
               [
                 ("pci", _R_POOL_ADMIN)
+              ; ("hvm_serial", _R_POOL_ADMIN)
               ; ("folder", _R_VM_OP)
               ; ("XenCenter.CustomFields.*", _R_VM_OP)
               ]

ocaml/idl/schematest.ml

@@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex
 (* BEWARE: if this changes, check that schema has been bumped accordingly in
    ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *)
 
-let last_known_schema_hash = "4f2ba6e138f25124b8f211af96516805"
+let last_known_schema_hash = "2d8501063ef6b243facc24a3dbdc2a5d"
 
 let current_schema_hash : string =
   let open Datamodel_types in

ocaml/quicktest/quicktest_http.ml

@@ -102,7 +102,7 @@ module Cookies = struct
       match body with
       | first_line :: _ ->
           D.warn "expected = [%s]; received = [%s]" expected first_line ;
-          Astring.String.is_infix ~affix:first_line expected
+          Astring.String.is_infix ~affix:expected first_line
       | _ ->
           false
     in

ocaml/xapi/helpers.ml

@@ -428,7 +428,7 @@ module TraceHelper = struct
 end
 
 (** Once the server functor has been instantiated, xapi sets this reference to the appropriate
-    "fake_rpc" (loopback non-HTTP) rpc function. 
+    "fake_rpc" (loopback non-HTTP) rpc function.
     This way, internally the coordinator can short-circuit API calls without having to go over the network. *)
 let rpc_fun : (Http.Request.t -> Rpc.call -> Rpc.response) option ref = ref None
 
@@ -2462,3 +2462,185 @@ module AuthenticationCache = struct
           None
   end
 end
+
+(* Simple trie data structure that performs a favoured lookup to
+   implement a simple form of wildcard key matching. The trie is not
+   pruned during (or after) construction. *)
+module MatchTrie = struct
+  type 'a node = {arrows: (string, 'a node) Hashtbl.t; mutable value: 'a option}
+
+  let create_node () =
+    let arrows = Hashtbl.create 16 in
+    let value = None in
+    {arrows; value}
+
+  let create = create_node
+
+  let insert root ~key ~value =
+    let parts = String.split_on_char '.' key in
+    let rec extend focused = function
+      | part :: parts ->
+          let next =
+            match Hashtbl.find_opt focused.arrows part with
+            | Some node ->
+                node
+            | _ ->
+                let next = create_node () in
+                Hashtbl.replace focused.arrows part next ;
+                next
+          in
+          extend next parts
+      | [] ->
+          focused
+    in
+    let final = extend root parts in
+    final.value <- Some value
+
+  let find root ~key =
+    let parts = String.split_on_char '.' key in
+    let rec find focused = function
+      | part :: parts -> (
+        (* Wildcard edges override other edges. *)
+        match Hashtbl.find_opt focused.arrows "*" with
+        | Some _ as sink ->
+            sink
+        | _ -> (
+          match Hashtbl.find_opt focused.arrows part with
+          | Some next ->
+              (find [@tailcall]) next parts
+          | _ ->
+              None
+        )
+      )
+      | _ ->
+          Some focused
+    in
+    match find root parts with Some node -> node.value | _ -> None
+end
+
+(* Given an input key, compare against the protected keys of the
+   task.other_config field. If a protected key matches, return it.
+
+   For example, if the datamodel specifies "foo.bar.*" as a protected
+   key, then: match_protected_key ~key:"foo.bar.baz" = Some "foo.bar.*".
+
+   It must return the protected key as that is what key-related RBAC
+   entries are defined in terms of.
+*)
+let match_protected_key objname fieldname =
+  (* Attain the listing of protected keys from the datamodel at module
+     initialisation. Usually, this list is passed to Rbac.check by
+     handlers inside the auto-generated server.ml file. *)
+  let protected_keys =
+    let api = Datamodel.all_api in
+    let field = Dm_api.get_field_by_name api ~objname ~fieldname in
+    List.map fst field.field_map_keys_roles
+  in
+  (* Define the lookup function in terms of a simple trie data
+     structure - which is flexible to account for overlapping paths and
+     presence of wildcards. *)
+  let trie =
+    let root = MatchTrie.create () in
+    let add key = MatchTrie.insert root ~key ~value:key in
+    List.iter add protected_keys ;
+    root
+  in
+  MatchTrie.find trie
+
+(* The behaviour of this function, with respect to RBAC checking, must
+   match serial "remove_from" and "add_to" operations (for only the keys
+   that are changing).
+
+   There is normally no key-related RBAC checking for
+   "set_X" (e.g. set_other_config) because the required writer role for the
+   entire field is usually higher than the role(s) required for
+   individually-protected keys.
+
+   {Task,VM}.set_other_config and VM.set_platform are special cases where
+   lower-privileged sessions must be able to manipulate a subset of entries
+   (those not protected by a more privileged role).
+*)
+let set_map_with_rbac ~__context ~self ~value ~get_fn ~set_fn ~match_protected
+    ~object_name ~field_name =
+  let match_protected = match_protected field_name in
+  let module S = Set.Make (String) in
+  let create_lookup kvs =
+    let table = List.to_seq kvs |> Hashtbl.of_seq in
+    Hashtbl.find_opt table
+  in
+  let old_value = get_fn ~__context ~self in
+  let lookup_old, lookup_new = (create_lookup old_value, create_lookup value) in
+  let keys_before, keys_after =
+    let keys = List.map fst in
+    let before = keys old_value in
+    let after = keys value in
+    S.(of_list before, of_list after)
+  in
+  let keys_removed =
+    (* Keys no longer appearing in the map. The user must have the
+       "remove_from" role for each of the protected keys in the set. *)
+    S.diff keys_before keys_after
+  in
+  let keys_unchanged =
+    (* Keys that persist across the update. If any key in this set is
+       protected AND the value mapped to by the key would be changed by
+       the update, the session must have the "add_to" role. *)
+    let updated = S.inter keys_before keys_after in
+    let is_entry_unchanged key =
+      let is_same =
+        let ( let* ) = Option.bind in
+        let* old_value = lookup_old key in
+        let* new_value = lookup_new key in
+        Some (old_value = new_value)
+      in
+      Option.value ~default:false is_same
+    in
+    (* Filter out the unchanged entries, as you don't need any
+       extra privileges to maintain an entry that's already there. *)
+    S.filter is_entry_unchanged updated
+  in
+  let keys_added =
+    (* Treat all keys as new, unless they're referring to entries that
+       are unchanged across the update. *)
+    S.diff keys_after keys_unchanged
+  in
+  let permissions =
+    (* Map each of the added and removed keys to protected keys, if
+       such a key exists. *)
+    let filter keys =
+      S.filter_map (fun key -> match_protected ~key) keys |> S.elements
+    in
+    let added = filter keys_added in
+    let removed = filter keys_removed in
+    let format operation key =
+      (* All the permissions are stored in lowercase. *)
+      let key = String.lowercase_ascii key in
+      Printf.sprintf "%s.%s_%s/key:%s" object_name operation field_name key
+    in
+    (* The required permissions are defined in terms of those
+       generated for "add_to" and "remove_from" (both implemented
+       above). They can be defined as custom AND use RBAC checking within
+       server.ml because their operation is purely destructive, so it's
+       sufficient to guard the entire action with Rbac.check. *)
+    let added_perms = List.map (format "add_to") added in
+    let removed_perms = List.map (format "remove_from") removed in
+    added_perms @ removed_perms
+  in
+  (* Find the first disallowed permission, indicating that we cannot
+     perform the action. *)
+  let session_id = Context.get_session_id __context in
+  match
+    Rbac.find_first_disallowed_permission ~__context ~session_id ~permissions
+  with
+  | None ->
+      (* No disallowed permission, perform the update. *)
+      set_fn ~__context ~self ~value
+  | Some disallowed ->
+      (* Report it as an RBAC error. *)
+      let action = Printf.sprintf "%s.set_%s" object_name field_name in
+      let extra_msg = "" in
+      let extra_dmsg = "" in
+      raise
+        (Rbac.disallowed_permission_exn ~extra_dmsg ~extra_msg ~__context
+           ~permission:disallowed ~action
+        )

ocaml/xapi/message_forwarding.ml

@@ -3245,6 +3245,34 @@ functor
           ~policy (fun () ->
             forward_vm_op ~local_fn ~__context ~vm:self ~remote_fn
         )
+
+      let add_to_other_config ~__context ~self ~key ~value =
+        info "VM.add_to_other_config: self = '%s', key = '%s'"
+          (vm_uuid ~__context self) key ;
+        Local.VM.add_to_other_config ~__context ~self ~key ~value
+
+      let remove_from_other_config ~__context ~self ~key =
+        info "VM.remove_from_other_config: self = '%s', key = '%s'"
+          (vm_uuid ~__context self) key ;
+        Local.VM.remove_from_other_config ~__context ~self ~key
+
+      let set_other_config ~__context ~self ~value =
+        info "VM.set_other_config: self = '%s'" (vm_uuid ~__context self) ;
+        Local.VM.set_other_config ~__context ~self ~value
+
+      let add_to_platform ~__context ~self ~key ~value =
+        info "VM.add_to_platform: self = '%s', key = '%s'"
+          (vm_uuid ~__context self) key ;
+        Local.VM.add_to_platform ~__context ~self ~key ~value
+
+      let remove_from_platform ~__context ~self ~key =
+        info "VM.remove_from_platform: self = '%s', key = '%s'"
+          (vm_uuid ~__context self) key ;
+        Local.VM.remove_from_platform ~__context ~self ~key
+
+      let set_platform ~__context ~self ~value =
+        info "VM.set_platform: self = '%s'" (vm_uuid ~__context self) ;
+        Local.VM.set_platform ~__context ~self ~value
     end
 
     module VM_metrics = struct end