diff --git a/ocaml/idl/datamodel_vm.ml b/ocaml/idl/datamodel_vm.ml index 7edc823639..018433498d 100644 --- a/ocaml/idl/datamodel_vm.ml +++ b/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) ] diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index 5c769fe685..6a8a27a49b 100644 --- a/ocaml/idl/schematest.ml +++ b/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 = "87b39cf2131c990f186bb6baa6e5ece8" +let last_known_schema_hash = "74ab53bec7861bcc9743cd8af10c0929" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 0aef471252..13de9094be 100644 --- a/ocaml/xapi/helpers.ml +++ b/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 @@ -2477,3 +2477,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 + ) diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index f02c37366a..e6a8e3eeb4 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -3180,6 +3180,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 diff --git a/ocaml/xapi/xapi_task.ml b/ocaml/xapi/xapi_task.ml index 8c6ebf00a4..93c91c9af7 100644 --- a/ocaml/xapi/xapi_task.ml +++ b/ocaml/xapi/xapi_task.ml @@ -89,92 +89,8 @@ let set_resident_on ~__context ~self ~value = TaskHelper.assert_op_valid ~__context self ; Db.Task.set_resident_on ~__context ~self ~value -(* 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 = - (* 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:"task" ~fieldname:"other_config" - 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 - +(* restricts all *_other_config calls to only the task objects that + sessions created. *) let assert_can_modify_other_config ~__context ~task = TaskHelper.assert_op_valid ~__context task @@ -186,100 +102,9 @@ let remove_from_other_config ~__context ~self ~key = assert_can_modify_other_config ~__context ~task:self ; Db.Task.remove_from_other_config ~__context ~self ~key -(* 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_other_config" because the required writer role for the entire - field is usually higher than the role(s) required for - individually-protected keys. - - Task's "set_other_config" is a special case where read-only - sessions must be able to manipulate a subset of entries (those not - protected by a more privileged role), along with this capability - being restricted to only the task objects that they created. -*) let set_other_config ~__context ~self ~value = - let module S = Set.Make (String) in assert_can_modify_other_config ~__context ~task:self ; - let create_lookup kvs = - let table = List.to_seq kvs |> Hashtbl.of_seq in - Hashtbl.find_opt table - in - let old_value = Db.Task.get_other_config ~__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 ~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 "task.%s_other_config/key:%s" operation 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. *) - Db.Task.set_other_config ~__context ~self ~value - | Some disallowed -> - (* Report it as an RBAC error. *) - let action = "task.set_other_config" in - let extra_msg = "" in - let extra_dmsg = "" in - raise - (Rbac.disallowed_permission_exn ~extra_dmsg ~extra_msg ~__context - ~permission:disallowed ~action - ) + let match_protected = Helpers.match_protected_key "task" in + Helpers.set_map_with_rbac ~__context ~self ~value + ~get_fn:Db.Task.get_other_config ~set_fn:Db.Task.set_other_config + ~match_protected ~object_name:"task" ~field_name:"other_config" diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index dcb1e48208..bd80666c5b 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1782,3 +1782,27 @@ let sysprep ~__context ~self ~unattend ~timeout = raise Api_errors.(Server_error (sysprep, [uuid; msg])) | exception e -> raise e + +let add_to_other_config ~__context ~self ~key ~value = + Db.VM.add_to_other_config ~__context ~self ~key ~value + +let remove_from_other_config ~__context ~self ~key = + Db.VM.remove_from_other_config ~__context ~self ~key + +let set_other_config ~__context ~self ~value = + let match_protected = Helpers.match_protected_key "VM" in + Helpers.set_map_with_rbac ~__context ~self ~value + ~get_fn:Db.VM.get_other_config ~set_fn:Db.VM.set_other_config + ~match_protected ~object_name:"vm" ~field_name:"other_config" + +let add_to_platform ~__context ~self ~key ~value = + Db.VM.add_to_platform ~__context ~self ~key ~value + +let remove_from_platform ~__context ~self ~key = + Db.VM.remove_from_platform ~__context ~self ~key + +let set_platform ~__context ~self ~value = + let match_protected = Helpers.match_protected_key "VM" in + Helpers.set_map_with_rbac ~__context ~self ~value ~get_fn:Db.VM.get_platform + ~set_fn:Db.VM.set_platform ~match_protected ~object_name:"vm" + ~field_name:"platform" diff --git a/ocaml/xapi/xapi_vm.mli b/ocaml/xapi/xapi_vm.mli index b3f07d38a9..5c3392e4e1 100644 --- a/ocaml/xapi/xapi_vm.mli +++ b/ocaml/xapi/xapi_vm.mli @@ -457,3 +457,21 @@ val sysprep : -> unattend:SecretString.t -> timeout:float -> unit + +val add_to_other_config : + __context:Context.t -> self:API.ref_VM -> key:string -> value:string -> unit + +val remove_from_other_config : + __context:Context.t -> self:API.ref_VM -> key:string -> unit + +val set_other_config : + __context:Context.t -> self:API.ref_VM -> value:(string * string) list -> unit + +val add_to_platform : + __context:Context.t -> self:API.ref_VM -> key:string -> value:string -> unit + +val remove_from_platform : + __context:Context.t -> self:API.ref_VM -> key:string -> unit + +val set_platform : + __context:Context.t -> self:API.ref_VM -> value:(string * string) list -> unit