diff --git a/ocaml/forkexecd/test/fe_test.ml b/ocaml/forkexecd/test/fe_test.ml index 870ac591601..1c5e46bc1f9 100644 --- a/ocaml/forkexecd/test/fe_test.ml +++ b/ocaml/forkexecd/test/fe_test.ml @@ -292,7 +292,7 @@ let slave = function (* Printf.fprintf stderr "%s %d\n" total_fds (List.length present - 1) *) - if total_fds <> List.length filtered then + if total_fds + 1 (* Uuid.dev_urandom *) <> List.length filtered then fail "Expected %d fds; /proc/self/fd has %d: %s" total_fds (List.length filtered) ls diff --git a/ocaml/idl/ocaml_backend/gen_api.ml b/ocaml/idl/ocaml_backend/gen_api.ml index 5b18d603f4e..1caf9eee138 100644 --- a/ocaml/idl/ocaml_backend/gen_api.ml +++ b/ocaml/idl/ocaml_backend/gen_api.ml @@ -400,15 +400,7 @@ let gen_client_types highapi = ; " Rpc.failure (rpc_of_failure ([\"Fault\"; code]))" ] ; ["include Rpc"; "type string_list = string list [@@deriving rpc]"] - ; [ - "module Ref = struct" - ; " include Ref" - ; " let rpc_of_t (_:'a -> Rpc.t) (x: 'a Ref.t) = rpc_of_string \ - (Ref.string_of x)" - ; " let t_of_rpc (_:Rpc.t -> 'a) x : 'a t = of_string (string_of_rpc \ - x);" - ; "end" - ] + ; ["module Ref = Ref"] ; [ "module Date = struct" ; " open Xapi_stdext_date" diff --git a/ocaml/idl/ocaml_backend/gen_db_actions.ml b/ocaml/idl/ocaml_backend/gen_db_actions.ml index 44542173fe9..e0cc5cc8454 100644 --- a/ocaml/idl/ocaml_backend/gen_db_actions.ml +++ b/ocaml/idl/ocaml_backend/gen_db_actions.ml @@ -134,8 +134,12 @@ let string_to_dm tys : O.Module.t = | DT.Map (key, value) -> let kf = OU.alias_of_ty key and vf = OU.alias_of_ty value in "fun m -> map " ^ kf ^ " " ^ vf ^ " m" - | DT.Ref _ -> - "fun x -> (Ref.of_string x : " ^ OU.ocaml_of_ty ty ^ ")" + | DT.Ref t -> + "fun x -> (Ref.of_" + ^ (if t = "session" then "secret_" else "") + ^ "string x : " + ^ OU.ocaml_of_ty ty + ^ ")" | DT.Set ty -> "fun s -> set " ^ OU.alias_of_ty ty ^ " s" | DT.String -> @@ -360,7 +364,8 @@ let db_action api : O.Module.t = expr ; Printf.sprintf "List.map (fun (ref,(__regular_fields,__set_refs)) -> \ - Ref.of_string ref, %s __regular_fields __set_refs) records" + Ref.of_%sstring ref, %s __regular_fields __set_refs) records" + (if obj.DT.name = "session" then "secret_" else "") conversion_fn ] ) @@ -374,9 +379,10 @@ let db_action api : O.Module.t = obj.DT.name ; Printf.sprintf "(fun ~__context ~self -> (fun () -> API.rpc_of_%s_t \ - (%s.get_record ~__context ~self:(Ref.of_string self))))" + (%s.get_record ~__context ~self:(Ref.of_%sstring self))))" (OU.ocaml_of_record_name obj.DT.name) (OU.ocaml_of_obj_name obj.DT.name) + (if obj.DT.name = "session" then "secret_" else "") ] () in diff --git a/ocaml/libs/uuid/dune b/ocaml/libs/uuid/dune index 5f7c5c25b95..81c7edec804 100644 --- a/ocaml/libs/uuid/dune +++ b/ocaml/libs/uuid/dune @@ -4,6 +4,7 @@ (modules uuidx) (libraries unix (re_export uuidm) + threads.posix ) (wrapped false) ) diff --git a/ocaml/libs/uuid/uuid_test.ml b/ocaml/libs/uuid/uuid_test.ml index dbaf294545f..127f10b5824 100644 --- a/ocaml/libs/uuid/uuid_test.ml +++ b/ocaml/libs/uuid/uuid_test.ml @@ -25,7 +25,7 @@ let uuid_arrays = let non_uuid_arrays = [[|0|]; [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14|]] -type resource +type resource = [`Generic] let uuid_testable : (module Alcotest.TESTABLE with type t = resource Uuidx.t) = Alcotest.testable Uuidx.pp Uuidx.equal diff --git a/ocaml/libs/uuid/uuidx.ml b/ocaml/libs/uuid/uuidx.ml index 01dbda46899..98eefe1ab73 100644 --- a/ocaml/libs/uuid/uuidx.ml +++ b/ocaml/libs/uuid/uuidx.ml @@ -12,7 +12,85 @@ * GNU Lesser General Public License for more details. *) -type 'a t = Uuidm.t +type without_secret = + [ `auth + | `blob + | `Bond + | `Certificate + | `Cluster + | `Cluster_host + | `console + | `crashdump + | `data_source + | `Diagnostics + | `DR_task + | `event + | `Feature + | `generation + | `Generic + | `GPU_group + | `host + | `host_cpu + | `host_crashdump + | `host_metrics + | `host_patch + | `LVHD + | `message + | `network + | `network_sriov + | `Observer + | `PBD + | `PCI + | `PGPU + | `PIF + | `PIF_metrics + | `pool + | `pool_patch + | `pool_update + | `probe_result + | `PUSB + | `PVS_cache_storage + | `PVS_proxy + | `PVS_server + | `PVS_site + | `Repository + | `role + | `SDN_controller + | `secret + | `SM + | `SR + | `sr_stat + | `subject + | `task + | `tunnel + | `USB_group + | `user + | `VBD + | `VBD_metrics + | `VDI + | `vdi_nbd_server_info + | `VGPU + | `VGPU_type + | `VIF + | `VIF_metrics + | `VLAN + | `VM + | `VM_appliance + | `VM_group + | `VM_guest_metrics + | `VM_metrics + | `VMPP + | `VMSS + | `VTPM + | `VUSB ] + +type secret = [`session] + +type not_secret = [without_secret | `session of [`use_make_uuid_rnd_instead]] + +type all = [without_secret | secret] + +type 'a t = Uuidm.t constraint 'a = [< all] let null = Uuidm.nil @@ -38,34 +116,40 @@ let is_uuid str = match of_string str with None -> false | Some _ -> true let dev_urandom = "/dev/urandom" +let dev_urandom_fd = Unix.openfile dev_urandom [Unix.O_RDONLY] 0o640 +(* we can't close this in at_exit, because Crowbar runs at_exit, and + it'll fail because this FD will then be closed +*) + let read_bytes dev n = - let fd = Unix.openfile dev [Unix.O_RDONLY] 0o640 in - let finally body_f clean_f = - try - let ret = body_f () in - clean_f () ; ret - with e -> clean_f () ; raise e - in - finally - (fun () -> - let buf = Bytes.create n in - let read = Unix.read fd buf 0 n in - if read <> n then - raise End_of_file - else - Bytes.to_string buf - ) - (fun () -> Unix.close fd) - -let make_uuid_urnd () = of_bytes (read_bytes dev_urandom 16) |> Option.get - -(* Use the CSPRNG-backed urandom *) -let make = make_uuid_urnd + let buf = Bytes.create n in + let read = Unix.read dev buf 0 n in + if read <> n then + raise End_of_file + else + Bytes.to_string buf + +let make_uuid_urnd () = of_bytes (read_bytes dev_urandom_fd 16) |> Option.get + +(** Use non-CSPRNG by default, for CSPRNG see {!val:make_uuid_urnd} *) +let make_uuid_fast = + let uuid_state = Random.State.make_self_init () in + (* On OCaml 5 we could use Random.State.split instead, + and on OCaml 4 the mutex may not be strictly needed + *) + let m = Mutex.create () in + let finally () = Mutex.unlock m in + let gen = Uuidm.v4_gen uuid_state in + fun () -> Mutex.lock m ; Fun.protect ~finally gen + +let make_default = ref make_uuid_urnd + +let make () = !make_default () type cookie = string let make_cookie () = - read_bytes dev_urandom 64 + read_bytes dev_urandom_fd 64 |> String.to_seq |> Seq.map (fun c -> Printf.sprintf "%1x" (int_of_char c)) |> List.of_seq diff --git a/ocaml/libs/uuid/uuidx.mli b/ocaml/libs/uuid/uuidx.mli index 618235b4ae6..ebc9f2e1611 100644 --- a/ocaml/libs/uuid/uuidx.mli +++ b/ocaml/libs/uuid/uuidx.mli @@ -22,32 +22,127 @@ Also, cookies aren't UUIDs and should be put somewhere else. *) +(** regular UUIDs *) +type without_secret = + [ `auth + | `blob + | `Bond + | `Certificate + | `Cluster + | `Cluster_host + | `console + | `crashdump + | `data_source + | `Diagnostics + | `DR_task + | `event + | `Feature + | `generation + | `Generic + | `GPU_group + | `host + | `host_cpu + | `host_crashdump + | `host_metrics + | `host_patch + | `LVHD + | `message + | `network + | `network_sriov + | `Observer + | `PBD + | `PCI + | `PGPU + | `PIF + | `PIF_metrics + | `pool + | `pool_patch + | `pool_update + | `probe_result + | `PUSB + | `PVS_cache_storage + | `PVS_proxy + | `PVS_server + | `PVS_site + | `Repository + | `role + | `SDN_controller + | `secret + | `SM + | `SR + | `sr_stat + | `subject + | `task + | `tunnel + | `USB_group + | `user + | `VBD + | `VBD_metrics + | `VDI + | `vdi_nbd_server_info + | `VGPU + | `VGPU_type + | `VIF + | `VIF_metrics + | `VLAN + | `VM + | `VM_appliance + | `VM_group + | `VM_guest_metrics + | `VM_metrics + | `VMPP + | `VMSS + | `VTPM + | `VUSB ] + +(** ensures that attempting to unify the type with `session yields + an error message about a type conflict, + and also avoids accidentally getting session added to the above + {!type:without_secret} type. + *) +type not_secret = [without_secret | `session of [`use_make_uuid_rnd_instead]] + +(** session UUIDs and Refs are secret: they are effectively authentication tokens *) +type secret = [`session] + +(** all object classes supported by XAPI *) +type all = [without_secret | secret] + (** A 128-bit UUID to identify an object of class 'a. For example the UUID of - a host has the type ([\[`host\] Uuidx.t]). *) -type 'a t + a host has the type ([\[`host\] Uuidx.t]). + The type parameter is one of {!type:all} + *) +type 'a t = Uuidm.t constraint 'a = [< all] -val null : 'a t +val null : [< not_secret] t (** A null UUID, as if such a thing actually existed. It turns out to be useful though. *) -val make : unit -> 'a t +val make : unit -> [< not_secret] t (** Create a fresh UUID *) -val make_uuid_urnd : unit -> 'a t +val make_uuid_urnd : unit -> [< secret] t +(** [make_uuid_urnd ()] generate a UUID using a CSPRNG. + Currently this reads from /dev/urandom directly. *) -val pp : Format.formatter -> 'a t -> unit +val make_uuid_fast : unit -> [< not_secret] t +(** [make_uuid_fast ()] generate a UUID using a PRNG. + Don't use this to generate secrets, see {!val:make_uuid_urnd} for that instead. + *) + +val pp : Format.formatter -> [< not_secret] t -> unit val equal : 'a t -> 'a t -> bool val is_uuid : string -> bool -val of_string : string -> 'a t option +val of_string : string -> [< not_secret] t option (** Create a UUID from a string. *) val to_string : 'a t -> string (** Marshal a UUID to a string. *) -val uuid_of_string : string -> 'a t option +val uuid_of_string : string -> [< not_secret] t option [@@deprecated "Use of_string"] (** Deprecated alias for {! Uuidx.of_string} *) @@ -55,13 +150,13 @@ val string_of_uuid : 'a t -> string [@@deprecated "Use to_string"] (** Deprecated alias for {! Uuidx.to_string} *) -val of_int_array : int array -> 'a t option +val of_int_array : int array -> [< not_secret] t option (** Convert an array to a UUID. *) val to_int_array : 'a t -> int array (** Convert a UUID to an array. *) -val uuid_of_int_array : int array -> 'a t option +val uuid_of_int_array : int array -> [< not_secret] t option [@@deprecated "Use Uuidx.of_int_array"] (** Deprecated alias for {! Uuidx.of_int_array} *) @@ -69,7 +164,7 @@ val int_array_of_uuid : 'a t -> int array [@@deprecated "Use Uuidx.to_int_array"] (** Deprecated alias for {! Uuidx.to_int_array} *) -val of_bytes : string -> 'a t option +val of_bytes : string -> [< not_secret] t option val to_bytes : 'a t -> string @@ -87,5 +182,10 @@ module Hash : sig namespace UUID e93e0639-2bdb-4a59-8b46-352b3f408c19. *) (* UUID Version 5 derived from argument string and namespace UUID *) - val string : string -> 'a t + val string : string -> [< not_secret] t end + +(**/**) + +(* just for feature flag, to be removed *) +val make_default : (unit -> [< not_secret] t) ref diff --git a/ocaml/mpathalert/mpathalert.ml b/ocaml/mpathalert/mpathalert.ml index c236f602702..bea5ae2ee0a 100644 --- a/ocaml/mpathalert/mpathalert.ml +++ b/ocaml/mpathalert/mpathalert.ml @@ -53,7 +53,7 @@ let debug (fmt : ('a, unit, string, unit) format4) = type t = { host: [`host] Uuidx.t ; host_name: string - ; pbd: [`pbd] Uuidx.t + ; pbd: [`PBD] Uuidx.t ; timestamp: float ; scsi_id: string ; current: int diff --git a/ocaml/nbd/src/main.ml b/ocaml/nbd/src/main.ml index 25919464839..5b5be77f03a 100644 --- a/ocaml/nbd/src/main.ml +++ b/ocaml/nbd/src/main.ml @@ -50,7 +50,7 @@ let handle_connection fd tls_role = ( match Uri.get_query_param uri "session_id" with | Some session_str -> (* Validate the session *) - let session_id = API.Ref.of_string session_str in + let session_id = API.Ref.of_secret_string session_str in Xen_api.Session.get_uuid ~rpc ~session_id ~self:session_id >>= fun _ -> Lwt.return session_id | None -> diff --git a/ocaml/tests/bench/bench_uuid.ml b/ocaml/tests/bench/bench_uuid.ml new file mode 100644 index 00000000000..a04ff192d76 --- /dev/null +++ b/ocaml/tests/bench/bench_uuid.ml @@ -0,0 +1,12 @@ +open Bechamel + +let () = Uuidx.make_default := Uuidx.make_uuid_fast + +let benchmarks = + Test.make_grouped ~name:"uuidx creation" + [ + Test.make ~name:"Uuidx.make_uuid_urnd" (Staged.stage Uuidx.make_uuid_urnd) + ; Test.make ~name:"Uuidx.make" (Staged.stage Uuidx.make) + ] + +let () = Bechamel_simple_cli.cli benchmarks diff --git a/ocaml/tests/bench/dune b/ocaml/tests/bench/dune index 0d11700e285..dcd61813e1e 100644 --- a/ocaml/tests/bench/dune +++ b/ocaml/tests/bench/dune @@ -1,4 +1,4 @@ -(executable - (name bench_tracing) - (libraries tracing bechamel bechamel-notty notty.unix tracing_export threads.posix fmt notty) +(executables + (names bench_tracing bench_uuid) + (libraries tracing bechamel bechamel-notty notty.unix tracing_export threads.posix fmt notty uuid) ) diff --git a/ocaml/tests/common/test_common.ml b/ocaml/tests/common/test_common.ml index c327914b0f9..7908eb4e3ff 100644 --- a/ocaml/tests/common/test_common.ml +++ b/ocaml/tests/common/test_common.ml @@ -516,7 +516,7 @@ let make_pool_update ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ()) Xapi_pool_update.create_update_record ~__context ~update:ref ~update_info ~vdi ; ref -let make_session ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ()) +let make_session ~__context ?(ref = Ref.make_secret ()) ?(uuid = make_uuid ()) ?(this_host = Ref.null) ?(this_user = Ref.null) ?(last_active = API.Date.epoch) ?(pool = false) ?(other_config = []) ?(is_local_superuser = false) ?(subject = Ref.null) diff --git a/ocaml/tests/test_client.ml b/ocaml/tests/test_client.ml index 1c3137721b8..55096a5c48a 100644 --- a/ocaml/tests/test_client.ml +++ b/ocaml/tests/test_client.ml @@ -12,7 +12,7 @@ let make_client_params ~__context = let req = Xmlrpc_client.xmlrpc ~version:"1.1" "/" in let rpc = Api_server.Server.dispatch_call req Unix.stdout in let session_id = - let session_id = Ref.make () in + let session_id = Ref.make_secret () in let now = Xapi_stdext_date.Date.now () in let (_ : _ API.Ref.t) = Test_common.make_session ~__context ~ref:session_id diff --git a/ocaml/tests/test_ref.ml b/ocaml/tests/test_ref.ml index 401746c0690..7213e615e3f 100644 --- a/ocaml/tests/test_ref.ml +++ b/ocaml/tests/test_ref.ml @@ -9,7 +9,7 @@ let uuidm = let ref_of_uuidm uuidm = Ref.ref_prefix ^ (uuidm |> Uuidm.to_string) |> Ref.of_string -type arg +type arg = [`Generic] type t = arg Ref.t diff --git a/ocaml/xapi-cli-server/xapi_cli.ml b/ocaml/xapi-cli-server/xapi_cli.ml index 89a9a0177b4..59c033efb74 100644 --- a/ocaml/xapi-cli-server/xapi_cli.ml +++ b/ocaml/xapi-cli-server/xapi_cli.ml @@ -295,7 +295,8 @@ let parse_session_and_args str = try let line = List.hd args in if Astring.String.is_prefix ~affix:"session_id=" line then - ( Some (Ref.of_string (String.sub line 11 (String.length line - 11))) + ( Some + (Ref.of_secret_string (String.sub line 11 (String.length line - 11))) , List.tl args ) else diff --git a/ocaml/xapi-client/event_helper.ml b/ocaml/xapi-client/event_helper.ml index 10ef0db12ab..3ec6e7f9236 100644 --- a/ocaml/xapi-client/event_helper.ml +++ b/ocaml/xapi-client/event_helper.ml @@ -13,9 +13,9 @@ *) type event_record = - | Session of [`Session] Ref.t * API.session_t option + | Session of [`session] Ref.t * API.session_t option | Task of [`task] Ref.t * API.task_t option - | Event of [`Event] Ref.t * API.event_t option + | Event of [`event] Ref.t * API.event_t option | VM of [`VM] Ref.t * API.vM_t option | VM_metrics of [`VM_metrics] Ref.t * API.vM_metrics_t option | VM_guest_metrics of @@ -33,10 +33,10 @@ type event_record = | VBD of [`VBD] Ref.t * API.vBD_t option | VBD_metrics of [`VBD_metrics] Ref.t * API.vBD_metrics_t option | PBD of [`PBD] Ref.t * API.pBD_t option - | Crashdump of [`Crashdump] Ref.t * API.crashdump_t option + | Crashdump of [`crashdump] Ref.t * API.crashdump_t option | VTPM of [`VTPM] Ref.t * API.vTPM_t option - | Console of [`Console] Ref.t * API.console_t option - | User of [`User] Ref.t * API.user_t option + | Console of [`console] Ref.t * API.console_t option + | User of [`user] Ref.t * API.user_t option | Pool of [`pool] Ref.t * API.pool_t option | Message of [`message] Ref.t * API.message_t option | Secret of [`secret] Ref.t * API.secret_t option @@ -50,7 +50,9 @@ let record_of_event ev = match ev.Event_types.ty with | "session" -> Session - (Ref.of_string ev.Event_types.reference, maybe API.session_t_of_rpc rpc) + ( Ref.of_secret_string ev.Event_types.reference + , maybe API.session_t_of_rpc rpc + ) | "task" -> Task (Ref.of_string ev.Event_types.reference, maybe API.task_t_of_rpc rpc) | "event" -> diff --git a/ocaml/xapi-guard/test/xapi_guard_test.ml b/ocaml/xapi-guard/test/xapi_guard_test.ml index b9e6fea2c9b..5486f6b61d2 100644 --- a/ocaml/xapi-guard/test/xapi_guard_test.ml +++ b/ocaml/xapi-guard/test/xapi_guard_test.ml @@ -6,7 +6,7 @@ open Xen_api_client_lwt.Xen_api_lwt_unix module D = Debug.Make (struct let name = "xapi-guard-test" end) -let expected_session_id : [`session] Ref.t = Ref.make () +let expected_session_id : [`session] Ref.t = Ref.make_secret () let vm : [`VM] Ref.t = Ref.make () diff --git a/ocaml/xapi-types/ref.ml b/ocaml/xapi-types/ref.ml index 32e60c1a2fc..c3ce6da534f 100644 --- a/ocaml/xapi-types/ref.ml +++ b/ocaml/xapi-types/ref.ml @@ -12,6 +12,16 @@ * GNU Lesser General Public License for more details. *) +type without_secret = Uuidx.without_secret + +type not_secret = + [ without_secret + | `session of [`use_make_secret_or_ref_of_secret_string_instead] ] + +type secret = Uuidx.secret + +type all = Uuidx.all + type 'a t = | Real of string (* ref to an object in the database *) @@ -20,6 +30,7 @@ type 'a t = | Other of string (* ref used for other purposes (it doesn't have one of the official prefixes) *) | Null + constraint 'a = [< all] (* ref to nothing at all *) @@ -37,6 +48,10 @@ let make () = let uuid = Uuidx.(to_string (make ())) in Real uuid +let make_secret () = + let uuid = Uuidx.(to_string (make_uuid_urnd ())) in + Real uuid + let null = Null (* a dummy reference is a reference of an object which is not in database *) @@ -102,6 +117,8 @@ let of_string x = else Other x +let of_secret_string = of_string + let to_option = function Null -> None | ref -> Some ref let name_of_dummy = function @@ -138,3 +155,7 @@ let really_pretty_and_small x = "NULL" let pp ppf x = Format.fprintf ppf "%s" (string_of x) + +let rpc_of_t _ x = Rpc.rpc_of_string (string_of x) + +let t_of_rpc _ x = of_string (Rpc.string_of_rpc x) diff --git a/ocaml/xapi-types/ref.mli b/ocaml/xapi-types/ref.mli index b61243266d1..2e201b6b3d6 100644 --- a/ocaml/xapi-types/ref.mli +++ b/ocaml/xapi-types/ref.mli @@ -12,13 +12,29 @@ * GNU Lesser General Public License for more details. *) -type 'a t +type without_secret = Uuidx.without_secret + +type secret = Uuidx.secret + +type not_secret = + [ without_secret + | `session of [`use_make_secret_or_ref_of_secret_string_instead] ] + +type all = Uuidx.all + +type 'a t constraint 'a = [< all] + +val rpc_of_t : ('a -> Rpc.t) -> 'a t -> Rpc.t + +val t_of_rpc : (Rpc.t -> 'a) -> Rpc.t -> 'a t val ref_prefix : string -val make : unit -> 'a t +val make : unit -> [< not_secret] t -val null : 'a t +val make_secret : unit -> [< secret] t + +val null : _ t val compare : 'a t -> 'a t -> int (** [compare a b] returns [0] if [a] and [b] are equal, a negative integer if @@ -30,11 +46,13 @@ val to_option : 'a t -> 'a t option (** [to_option ref] returns [None] when [ref] is [Ref.Null] or [Some ref] otherwise *) -val short_string_of : 'a t -> string +val short_string_of : [< not_secret] t -> string + +val of_string : string -> [< not_secret] t -val of_string : string -> 'a t +val of_secret_string : string -> [< secret] t -val make_dummy : string -> 'a t +val make_dummy : string -> [< not_secret] t val is_real : 'a t -> bool @@ -42,6 +60,6 @@ val is_dummy : 'a t -> bool val name_of_dummy : 'a t -> string -val really_pretty_and_small : 'a t -> string +val really_pretty_and_small : [< not_secret] t -> string val pp : Format.formatter -> 'a t -> unit diff --git a/ocaml/xapi/context.mli b/ocaml/xapi/context.mli index a501db213ff..98e04215272 100644 --- a/ocaml/xapi/context.mli +++ b/ocaml/xapi/context.mli @@ -124,7 +124,7 @@ val __make_task : -> ?session_id:API.ref_session -> ?subtask_of:API.ref_task -> string - -> API.ref_task * API.ref_task Uuidx.t + -> API.ref_task * [`task] Uuidx.t ) ref diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 0a32a8af1d3..30965068f3f 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -547,7 +547,7 @@ let call_api_functions ~__context f = Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> match Context.get_test_rpc __context with | Some rpc -> - f rpc (Ref.of_string "fake_session") + f rpc (Ref.of_secret_string "fake_session") | None -> call_api_functions_internal ~__context f @@ -1955,7 +1955,9 @@ end = struct (* by default we generate the pool secret using /dev/urandom, but if a script to generate the pool secret exists, use that instead *) let make_urandom () = - Stdlib.List.init 3 (fun _ -> Uuidx.(make_uuid_urnd () |> to_string)) + Stdlib.List.init 3 (fun _ -> + Uuidx.((make_uuid_urnd () : [`session] t) |> to_string) + ) |> String.concat "/" in let make_script () = diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml index 7e1a1cb8f12..a1aaa306f53 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -2515,7 +2515,7 @@ let handler (req : Request.t) s _ = if List.mem_assoc "session_id" all then let external_session_id = List.assoc "session_id" all in Xapi_session.consider_touching_session rpc - (Ref.of_string external_session_id) + (Ref.of_secret_string external_session_id) else fun () -> () in diff --git a/ocaml/xapi/taskHelper.ml b/ocaml/xapi/taskHelper.ml index 27e30ce3d39..30d36c0ed37 100644 --- a/ocaml/xapi/taskHelper.ml +++ b/ocaml/xapi/taskHelper.ml @@ -29,7 +29,7 @@ type t = API.ref_task (* creates a new task *) let make ~__context ~http_other_config ?(description = "") ?session_id - ?subtask_of label : t * t Uuidx.t = + ?subtask_of label : t * [`task] Uuidx.t = let@ __context = Context.with_tracing ~__context __FUNCTION__ in let uuid = Uuidx.make () in let uuid_str = Uuidx.to_string uuid in diff --git a/ocaml/xapi/xapi_clustering.mli b/ocaml/xapi/xapi_clustering.mli index 7fceae58118..746c538fa79 100644 --- a/ocaml/xapi/xapi_clustering.mli +++ b/ocaml/xapi/xapi_clustering.mli @@ -15,11 +15,14 @@ val set_ha_cluster_stack : __context:Context.t -> unit val with_clustering_lock : string -> (unit -> 'a) -> 'a val pif_of_host : - __context:Context.t -> API.ref_network -> API.ref_host -> 'a Ref.t * API.pIF_t + __context:Context.t + -> API.ref_network + -> API.ref_host + -> API.ref_PIF * API.pIF_t -val ip_of_pif : 'a Ref.t * API.pIF_t -> Cluster_interface.address +val ip_of_pif : API.ref_PIF * API.pIF_t -> Cluster_interface.address -val assert_pif_prerequisites : 'a Ref.t * API.pIF_t -> unit +val assert_pif_prerequisites : API.ref_PIF * API.pIF_t -> unit val assert_pif_attached_to : __context:Context.t -> host:[`host] Ref.t -> pIF:[`PIF] Ref.t -> unit @@ -27,7 +30,7 @@ val assert_pif_attached_to : val handle_error : Cluster_interface.error -> 'a val assert_cluster_host_can_be_created : - __context:Context.t -> host:'a Ref.t -> unit + __context:Context.t -> host:API.ref_host -> unit val get_required_cluster_stacks : __context:Context.t -> sr_sm_type:string -> string list @@ -41,7 +44,7 @@ val with_clustering_lock_if_cluster_exists : __context:Context.t -> string -> (unit -> 'a) -> 'a val find_cluster_host : - __context:Context.t -> host:[`host] Ref.t -> 'a Ref.t option + __context:Context.t -> host:[`host] Ref.t -> API.ref_Cluster_host option val get_network_internal : __context:Context.t -> self:[`Cluster] Ref.t -> [`network] Ref.t @@ -69,7 +72,7 @@ val rpc : __context:Context.t -> Rpc.call -> Rpc.response Idl.IdM.t val maybe_switch_cluster_stack_version : __context:Context.t - -> self:'a Ref.t + -> self:API.ref_Cluster_host -> cluster_stack:Cluster_interface.Cluster_stack.t -> unit diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index d23d7ec4ce6..3000669bd6f 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -1612,6 +1612,12 @@ let other_options = , (fun () -> string_of_bool !disable_webserver) , "Disable the host webserver" ) + ; ( "use-prng-uuid-gen" + (* eventually this'll be the default, except for Sessions *) + , Arg.Unit (fun () -> Uuidx.make_default := Uuidx.make_uuid_fast) + , (fun () -> !Uuidx.make_default = Uuidx.make_uuid_fast |> string_of_bool) + , "Use PRNG based UUID generator instead of CSPRNG" + ) ] (* The options can be set with the variable xapiflags in /etc/sysconfig/xapi. diff --git a/ocaml/xapi/xapi_http.ml b/ocaml/xapi/xapi_http.ml index 694520a5609..65de926376c 100644 --- a/ocaml/xapi/xapi_http.ml +++ b/ocaml/xapi/xapi_http.ml @@ -65,8 +65,11 @@ let ref_param_of_req (req : Http.Request.t) param_name = let _session_id = "session_id" +let session_ref_param_of_req (req : Http.Request.t) = + lookup_param_of_req req _session_id |> Option.map Ref.of_secret_string + let get_session_id (req : Request.t) = - ref_param_of_req req _session_id |> Option.value ~default:Ref.null + session_ref_param_of_req req |> Option.value ~default:Ref.null let append_to_master_audit_log __context action line = (* http actions are not automatically written to the master's audit log *) @@ -138,7 +141,7 @@ let assert_credentials_ok realm ?(http_action = realm) ?(fn = Rbac.nofn) (* Connections from unix-domain socket implies you're root on the box, ergo everything is OK *) else match - ( ref_param_of_req req _session_id + ( session_ref_param_of_req req , Helpers.secret_string_of_request req , req.Http.Request.auth ) @@ -203,7 +206,7 @@ let with_context ?(dummy = false) label (req : Request.t) (s : Unix.file_descr) ) else match - ( ref_param_of_req req _session_id + ( session_ref_param_of_req req , Helpers.secret_string_of_request req , req.Http.Request.auth ) diff --git a/ocaml/xapi/xapi_local_session.ml b/ocaml/xapi/xapi_local_session.ml index 7a5cf5f5070..2985ca3d9a4 100644 --- a/ocaml/xapi/xapi_local_session.ml +++ b/ocaml/xapi/xapi_local_session.ml @@ -26,7 +26,7 @@ let get_all ~__context = with_lock m (fun () -> Hashtbl.fold (fun k _ acc -> k :: acc) table []) let create ~__context ~pool = - let r = Ref.make () in + let r = Ref.make_secret () in let session = {r; pool; last_active= Xapi_stdext_date.Date.now ()} in with_lock m (fun () -> Hashtbl.replace table r session) ; r diff --git a/ocaml/xapi/xapi_pif.mli b/ocaml/xapi/xapi_pif.mli index 07c3a85877c..6c83936c1aa 100644 --- a/ocaml/xapi/xapi_pif.mli +++ b/ocaml/xapi/xapi_pif.mli @@ -247,7 +247,7 @@ val update_management_flags : __context:Context.t -> host:[`host] Ref.t -> unit * which holds the bridge of the management interface in the MANAGEMENT_INTERFACE field. *) val calculate_pifs_required_at_start_of_day : - __context:Context.t -> ('b Ref.t * API.pIF_t) list + __context:Context.t -> (API.ref_PIF * API.pIF_t) list (** Returns the set of PIF references + records which we want to be plugged in by the end of the start of day code. These are the PIFs on the localhost that are not bond slaves. For PIFs that have [disallow_unplug] set to true, and the management interface, will diff --git a/ocaml/xapi/xapi_session.ml b/ocaml/xapi/xapi_session.ml index 4def022bfcc..7e77def1f43 100644 --- a/ocaml/xapi/xapi_session.ml +++ b/ocaml/xapi/xapi_session.ml @@ -615,8 +615,8 @@ let login_no_password_common ~__context ~uname ~originator ~host ~pool ~rbac_permissions ~db_ref ~client_certificate = Context.with_tracing ~originator ~__context __FUNCTION__ @@ fun __context -> let create_session () = - let session_id = Ref.make () in - let uuid = Uuidx.to_string (Uuidx.make ()) in + let session_id = Ref.make_secret () in + let uuid = Uuidx.to_string (Uuidx.make_uuid_urnd ()) in let user = Ref.null in (* always return a null reference to the deprecated user object *) let parent = try Context.get_session_id __context with _ -> Ref.null in @@ -645,7 +645,7 @@ let login_no_password_common ~__context ~uname ~originator ~host ~pool Ref.string_of session_id in let session_id = - Ref.of_string + Ref.of_secret_string ( match db_ref with | Some db_ref -> Xapi_database.Db_backend.create_registered_session create_session diff --git a/ocaml/xapi/xapi_vdi.mli b/ocaml/xapi/xapi_vdi.mli index ff3e5a9e0ec..0731a5f6082 100644 --- a/ocaml/xapi/xapi_vdi.mli +++ b/ocaml/xapi/xapi_vdi.mli @@ -22,8 +22,8 @@ val check_operation_error : __context:Context.t -> ?sr_records:'a list - -> ?pbd_records:('b API.Ref.t * API.pBD_t) list - -> ?vbd_records:('c API.Ref.t * Db_actions.vBD_t) list + -> ?pbd_records:(API.ref_PBD * API.pBD_t) list + -> ?vbd_records:(API.ref_VBD * Db_actions.vBD_t) list -> bool -> Db_actions.vDI_t -> API.ref_VDI @@ -39,8 +39,8 @@ val update_allowed_operations_internal : __context:Context.t -> self:[`VDI] API.Ref.t -> sr_records:'a list - -> pbd_records:('b API.Ref.t * API.pBD_t) list - -> ?vbd_records:('c API.Ref.t * Db_actions.vBD_t) list + -> pbd_records:(API.ref_PBD * API.pBD_t) list + -> ?vbd_records:(API.ref_VBD * Db_actions.vBD_t) list -> unit -> unit @@ -50,7 +50,7 @@ val update_allowed_operations : val cancel_tasks : __context:Context.t -> self:[`VDI] API.Ref.t - -> all_tasks_in_db:'a Ref.t list + -> all_tasks_in_db:API.ref_task list -> task_ids:string list -> unit diff --git a/ocaml/xapi/xapi_vif_helpers.mli b/ocaml/xapi/xapi_vif_helpers.mli index 0f3ef24955b..6451ba02ddc 100644 --- a/ocaml/xapi/xapi_vif_helpers.mli +++ b/ocaml/xapi/xapi_vif_helpers.mli @@ -25,7 +25,7 @@ val update_allowed_operations : __context:Context.t -> self:[`VIF] Ref.t -> unit val cancel_tasks : __context:Context.t -> self:[`VIF] Ref.t - -> all_tasks_in_db:'a Ref.t list + -> all_tasks_in_db:API.ref_task list -> task_ids:string list -> unit (** Cancel all current operations. *) diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index 677da6fe8f1..1f4994fee6c 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -103,7 +103,7 @@ let remote_of_dest ~__context dest = in let master_url = List.assoc _master dest |> maybe_set_https in let xenops_url = List.assoc _xenops dest |> maybe_set_https in - let session_id = Ref.of_string (List.assoc _session_id dest) in + let session_id = Ref.of_secret_string (List.assoc _session_id dest) in let remote_ip = get_ip_from_url xenops_url in let remote_master_ip = get_ip_from_url master_url in let dest_host_string = List.assoc _host dest in diff --git a/ocaml/xenopsd/xc/domain.mli b/ocaml/xenopsd/xc/domain.mli index 598a9efc3d9..c8f83b0994a 100644 --- a/ocaml/xenopsd/xc/domain.mli +++ b/ocaml/xenopsd/xc/domain.mli @@ -146,7 +146,7 @@ val make : -> create_info -> int -> arch_domainconfig - -> [`Vm] Uuidx.t + -> [`VM] Uuidx.t -> string option -> bool (* no_sharept *) -> domid @@ -294,7 +294,7 @@ val soft_reset : val vcpu_affinity_get : xc:Xenctrl.handle -> domid -> int -> bool array (** Get Cpu affinity of some vcpus of a domain *) -val get_uuid : xc:Xenctrl.handle -> Xenctrl.domid -> [`Vm] Uuidx.t +val get_uuid : xc:Xenctrl.handle -> Xenctrl.domid -> [`VM] Uuidx.t (** Get the uuid from a specific domain *) val set_memory_dynamic_range :