From 62db5cb48965f80ed98d545de759d192080013af Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 23 May 2024 10:48:53 +0100 Subject: [PATCH 1/3] xapi-idl: Delete String.{explode,implode} functions These are highly inefficient. Also changes some functions to be able to have less types and make normal usage clearer. This comes at the cost of having to destructure the main type when pattern-matching it. Moves the device_number tests to its own executable to easily iterate on the tests. Signed-off-by: Pau Ruiz Safont --- ocaml/idl/markdown_backend.ml | 5 +- ocaml/libs/http-lib/http.ml | 59 +--- ocaml/libs/http-lib/http.mli | 1 + .../lib/xapi-stdext-std/xstringext.ml | 44 ++- .../lib/xapi-stdext-std/xstringext.mli | 12 +- ocaml/perftest/createpool.ml | 64 ++-- ocaml/xapi-idl/lib_test/device_number_test.ml | 93 +++--- .../xapi-idl/lib_test/device_number_test.mli | 0 ocaml/xapi-idl/lib_test/dune | 14 +- ocaml/xapi-idl/lib_test/test.ml | 1 - ocaml/xapi-idl/xen/device_number.ml | 277 +++++++++--------- ocaml/xapi-idl/xen/device_number.mli | 36 +-- ocaml/xapi-idl/xen/dune | 1 + ocaml/xapi/dbsync_slave.ml | 2 +- ocaml/xapi/storage_access.ml | 13 +- ocaml/xapi/vbdops.ml | 24 +- ocaml/xapi/xapi_dr_task.ml | 2 +- ocaml/xapi/xapi_templates_install.ml | 5 +- ocaml/xapi/xapi_vbd.ml | 29 +- ocaml/xapi/xapi_vbd_helpers.ml | 37 +-- ocaml/xapi/xapi_vm.ml | 2 +- ocaml/xapi/xapi_vm_helpers.ml | 10 +- ocaml/xapi/xapi_xenops.ml | 64 ++-- ocaml/xapi/xha_interface.ml | 4 +- ocaml/xapi/xmlrpc_sexpr.ml | 4 +- ocaml/xenopsd/cli/xn.ml | 20 +- ocaml/xenopsd/lib/xenops_server_simulator.ml | 16 +- ocaml/xenopsd/xc/device.ml | 19 +- ocaml/xenopsd/xc/xenops_server_xen.ml | 4 +- quality-gate.sh | 4 +- xapi-idl.opam | 1 + xapi-idl.opam.template | 1 + 32 files changed, 408 insertions(+), 460 deletions(-) create mode 100644 ocaml/xapi-idl/lib_test/device_number_test.mli diff --git a/ocaml/idl/markdown_backend.ml b/ocaml/idl/markdown_backend.ml index e039a7cfc42..66110b7d694 100644 --- a/ocaml/idl/markdown_backend.ml +++ b/ocaml/idl/markdown_backend.ml @@ -43,8 +43,6 @@ let compare_case_ins x y = compare (String.lowercase_ascii x) (String.lowercase_ascii y) let escape s = - let open Xapi_stdext_std.Xstringext in - let sl = String.explode s in let esc_char = function | '\\' -> "\" @@ -79,8 +77,7 @@ let escape s = | c -> String.make 1 c in - let escaped_list = List.map esc_char sl in - String.concat "" escaped_list + String.to_seq s |> Seq.map esc_char |> List.of_seq |> String.concat "" let rec of_ty_verbatim = function | SecretString | String -> diff --git a/ocaml/libs/http-lib/http.ml b/ocaml/libs/http-lib/http.ml index b6b4791e06f..c2f7e2aeda8 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -24,8 +24,6 @@ exception Forbidden exception Method_not_implemented -exception Malformed_url of string - exception Timeout exception Too_large @@ -145,61 +143,8 @@ let output_http fd headers = |> String.concat "" |> Unixext.really_write_string fd -let explode str = Astring.String.fold_right (fun c acc -> c :: acc) str [] - -let implode chr_list = - String.concat "" (List.map Astring.String.of_char chr_list) - -let urldecode url = - let chars = explode url in - let rec fn ac = function - | '+' :: tl -> - fn (' ' :: ac) tl - | '%' :: a :: b :: tl -> - let cs = - try int_of_string (implode ['0'; 'x'; a; b]) - with _ -> raise (Malformed_url url) - in - fn (Char.chr cs :: ac) tl - | x :: tl -> - fn (x :: ac) tl - | [] -> - implode (List.rev ac) - in - fn [] chars - (* Encode @param suitably for appearing in a query parameter in a URL. *) -let urlencode param = - let chars = explode param in - let rec fn = function - | x :: tl -> - let s = - if x = ' ' then - "+" - else - match x with - | 'A' .. 'Z' - | 'a' .. 'z' - | '0' .. '9' - | '$' - | '-' - | '_' - | '.' - | '!' - | '*' - | '\'' - | '(' - | ')' - | ',' -> - Astring.String.of_char x - | _ -> - Printf.sprintf "%%%2x" (Char.code x) - in - s ^ fn tl - | [] -> - "" - in - fn chars +let urlencode param = Uri.pct_encode ~component:`Query param (** Parses strings of the form a=b;c=d (new, RFC-compliant cookie format) and a=b&c=d (old, incorrect style) into [("a", "b"); ("c", "d")] *) @@ -219,7 +164,7 @@ let parse_cookies xs = List.map (function | k :: vs -> - (urldecode k, urldecode (String.concat "=" vs)) + (Uri.pct_decode k, Uri.pct_decode (String.concat "=" vs)) | [] -> raise Http_parse_failure ) diff --git a/ocaml/libs/http-lib/http.mli b/ocaml/libs/http-lib/http.mli index 384367e2463..91590bcdcdd 100644 --- a/ocaml/libs/http-lib/http.mli +++ b/ocaml/libs/http-lib/http.mli @@ -235,6 +235,7 @@ val output_http : Unix.file_descr -> string list -> unit val parse_cookies : string -> (string * string) list val urlencode : string -> string +(** Encode parameter suitably for appearing in a query parameter in a URL. *) type 'a ll = End | Item of 'a * (unit -> 'a ll) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml index 7fb16aba6f8..0b3da00c476 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml @@ -39,10 +39,6 @@ module String = struct done ; !accu - let explode string = fold_right (fun h t -> h :: t) string [] - - let implode list = concat "" (List.map of_char list) - (** True if string 'x' ends with suffix 'suffix' *) let endswith suffix x = let x_l = String.length x and suffix_l = String.length suffix in @@ -56,16 +52,6 @@ module String = struct (** Returns true for whitespace characters, false otherwise *) let isspace = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false - (** Removes all the characters from the ends of a string for which the predicate is true *) - let strip predicate string = - let rec remove = function - | [] -> - [] - | c :: cs -> - if predicate c then remove cs else c :: cs - in - implode (List.rev (remove (List.rev (remove (explode string))))) - let escaped ?rules string = match rules with | None -> @@ -81,24 +67,28 @@ module String = struct in concat "" (fold_right aux string []) - (** Take a predicate and a string, return a list of strings separated by - runs of characters where the predicate was true (excluding those characters from the result) *) let split_f p str = - let not_p x = not (p x) in - let rec split_one p acc = function - | [] -> - (List.rev acc, []) - | c :: cs -> - if p c then split_one p (c :: acc) cs else (List.rev acc, c :: cs) + let split_one seq = + let not_p c = not (p c) in + let a = Seq.take_while not_p seq in + let b = Seq.drop_while not_p seq in + (a, b) in - let rec alternate acc drop chars = - if chars = [] then + let drop seq = Seq.drop_while p seq in + let rec split acc chars = + if Seq.is_empty chars then acc else - let a, b = split_one (if drop then p else not_p) [] chars in - alternate (if drop then acc else a :: acc) (not drop) b + let a, b = split_one chars in + let b = drop b in + let acc = if Seq.is_empty a then acc else Seq.cons a acc in + split acc b in - List.rev (List.map implode (alternate [] true (explode str))) + String.to_seq str + |> split Seq.empty + |> Seq.map String.of_seq + |> List.of_seq + |> List.rev let index_opt s c = let rec loop i = diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli index e2587929916..e2b486285a6 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli @@ -29,12 +29,6 @@ module String : sig val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a (** Iterate over the characters in a string in reverse order. *) - val explode : string -> char list - (** Split a string into a list of characters. *) - - val implode : char list -> string - (** Concatenate a list of characters into a string. *) - val endswith : string -> string -> bool (** True if string 'x' ends with suffix 'suffix' *) @@ -44,9 +38,6 @@ module String : sig val isspace : char -> bool (** True if the character is whitespace *) - val strip : (char -> bool) -> string -> string - (** Removes all the characters from the ends of a string for which the predicate is true *) - val escaped : ?rules:(char * string) list -> string -> string (** Backward-compatible string escaping, defaulting to the built-in OCaml string escaping but allowing an arbitrary mapping from characters @@ -54,7 +45,8 @@ module String : sig val split_f : (char -> bool) -> string -> string list (** Take a predicate and a string, return a list of strings separated by - runs of characters where the predicate was true *) + runs of characters where the predicate was true. Avoid if possible, it's + very costly to execute. *) val split : ?limit:int -> char -> string -> string list (** split a string on a single char *) diff --git a/ocaml/perftest/createpool.ml b/ocaml/perftest/createpool.ml index ad4207427f6..bf96cfb7c36 100644 --- a/ocaml/perftest/createpool.ml +++ b/ocaml/perftest/createpool.ml @@ -350,24 +350,20 @@ let create_sdk_pool session_id sdkname pool_name key ipbase = let pingable = Array.make (Array.length hosts) false in let firstboot = Array.make (Array.length hosts) false in let string_of_status () = - Xstringext.String.implode - (Array.to_list - (Array.mapi - (fun i ping -> - let boot = firstboot.(i) in - match (ping, boot) with - | false, false -> - '.' - | true, false -> - 'P' - | true, true -> - 'B' - | _, _ -> - '?' - ) - pingable - ) - ) + Array.to_seq pingable + |> Seq.mapi (fun i ping -> + let boot = firstboot.(i) in + match (ping, boot) with + | false, false -> + '.' + | true, false -> + 'P' + | true, true -> + 'B' + | _, _ -> + '?' + ) + |> String.of_seq in let has_guest_booted i _vm = let ip = Printf.sprintf "192.168.%d.%d" pool.ipbase (i + 1) in @@ -469,24 +465,20 @@ let create_sdk_pool session_id sdkname pool_name key ipbase = let live = Array.make (Array.length hosts) false in let enabled = Array.make (Array.length hosts) false in let string_of_status () = - Xstringext.String.implode - (Array.to_list - (Array.mapi - (fun i live -> - let enabled = enabled.(i) in - match (live, enabled) with - | false, false -> - '.' - | true, false -> - 'L' - | true, true -> - 'E' - | _, _ -> - '?' - ) - live - ) - ) + Array.to_seq live + |> Seq.mapi (fun i live -> + let enabled = enabled.(i) in + match (live, enabled) with + | false, false -> + '.' + | true, false -> + 'L' + | true, true -> + 'E' + | _, _ -> + '?' + ) + |> String.of_seq in let has_host_booted rpc session_id i host = try diff --git a/ocaml/xapi-idl/lib_test/device_number_test.ml b/ocaml/xapi-idl/lib_test/device_number_test.ml index 9105299a16e..fc8d5b210f1 100644 --- a/ocaml/xapi-idl/lib_test/device_number_test.ml +++ b/ocaml/xapi-idl/lib_test/device_number_test.ml @@ -30,7 +30,7 @@ let deprecated = let examples_to_test = let using_deprecated_ide = try - ignore (make (Ide, 4, 0)) ; + ignore (make Ide ~disk:4 ~partition:0) ; true with _ -> false in @@ -46,16 +46,18 @@ let equivalent = ; ("d536p37", "xvdtq37") ] +let invalid = ["d0p0q"] + let test_examples = let tests = List.map - (fun (spec, linux, xenstore) -> - ( "test_examples " ^ linux + (fun ((bus, disk, partition), linux, xenstore) -> + let of_spec = make bus ~disk ~partition |> Option.get in + let of_linux = of_linux_device linux |> Option.get in + let of_xenstore = of_xenstore_key xenstore in + ( Printf.sprintf "%s = %s = %d" (to_debug_string of_spec) linux xenstore , `Quick , fun () -> - let of_spec = make spec in - let of_linux = of_linux_device linux in - let of_xenstore = of_xenstore_key xenstore in Alcotest.check device_number "examples must be equal" of_spec of_linux ; Alcotest.check device_number "examples must be equal" of_spec @@ -64,7 +66,7 @@ let test_examples = ) examples_to_test in - tests + ("Compare with linux and xenstore values", tests) (* NB we always understand the deprecated linux/xenstore devices even if we don't generate them ourselves *) @@ -72,40 +74,50 @@ let test_deprecated = let tests = List.map (fun (_, linux, xenstore) -> - ( "test_deprecated " ^ linux + ( linux , `Quick , fun () -> - let of_linux = of_linux_device linux in + let of_linux = of_linux_device linux |> Option.get in let of_xenstore = of_xenstore_key xenstore in Alcotest.check device_number "must be equal" of_linux of_xenstore ) ) deprecated in - tests + ("Deprecated linux device", tests) let test_equivalent = let tests = List.map (fun (x, y) -> - let test_name = Printf.sprintf "test_equivalent %s=%s" x y in + let test_name = Printf.sprintf "%s = %s" x y in ( test_name , `Quick , fun () -> - let x' = of_string false x in - let y' = of_string false y in + let x' = of_string ~hvm:false x |> Option.get in + let y' = of_string ~hvm:false y |> Option.get in Alcotest.check device_number "must be equal" x' y' ) ) equivalent in - tests + ("Equivalent devices", tests) + +let test_invalid = + let test x () = + if Option.is_some (of_string ~hvm:false x) then + Alcotest.failf "%s was not rejected" x + in + let tests = List.map (fun x -> (x, `Quick, test x)) invalid in + ("Reject invalid devices", tests) let test_2_way_convert = (* We now always convert Ide specs into xvd* linux devices, so they become Xen specs when converted back. *) - let equal_linux old_t new_t = - match (spec old_t, spec new_t) with + let equal_linux (old_t : t) (new_t : t) = + match + ((old_t, new_t) :> (bus_type * int * int) * (bus_type * int * int)) + with | (Ide, disk1, partition1), (Xen, disk2, partition2) when disk1 = disk2 && partition1 = partition2 -> true @@ -117,25 +129,36 @@ let test_2_way_convert = (Fmt.of_to_string Device_number.to_debug_string) equal_linux in + let test disk_number hvm = + let original = of_disk_number hvm disk_number |> Option.get in + let of_linux = of_linux_device (to_linux_device original) |> Option.get in + let of_xenstore = of_xenstore_key (to_xenstore_key original) in + Alcotest.check device_number_equal_linux + "of_linux must be equal to original" original of_linux ; + Alcotest.check device_number "of_xenstore must be equal to original" + original of_xenstore + in + + let max_d = (1 lsl 20) - 1 in + ( "2-way conversion" + , [ + ( Printf.sprintf "All disk numbers until %d" max_d + , `Slow + , fun () -> + for disk_number = 0 to max_d do + List.iter (test disk_number) [true; false] + done + ) + ] + ) + +let tests = [ - ( "test_2_way_convert" - , `Slow - , fun () -> - for disk_number = 0 to (1 lsl 20) - 1 do - List.iter - (fun hvm -> - let original = of_disk_number hvm disk_number in - let of_linux = of_linux_device (to_linux_device original) in - let of_xenstore = of_xenstore_key (to_xenstore_key original) in - Alcotest.check device_number_equal_linux - "of_linux must be equal to original" original of_linux ; - Alcotest.check device_number - "of_xenstore must be equal to original" original of_xenstore - ) - [true; false] - done - ) + test_examples + ; test_deprecated + ; test_equivalent + ; test_invalid + ; test_2_way_convert ] -let tests = - test_examples @ test_deprecated @ test_equivalent @ test_2_way_convert +let () = Alcotest.run "Device_number" tests diff --git a/ocaml/xapi-idl/lib_test/device_number_test.mli b/ocaml/xapi-idl/lib_test/device_number_test.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/xapi-idl/lib_test/dune b/ocaml/xapi-idl/lib_test/dune index 0806453c035..1b1e8193ca7 100644 --- a/ocaml/xapi-idl/lib_test/dune +++ b/ocaml/xapi-idl/lib_test/dune @@ -18,11 +18,22 @@ ) ) +(test + (name device_number_test) + (package xapi-idl) + (modules device_number_test) + (libraries + alcotest + fmt + xapi-idl.xen.interface.types + ) +) + (test (name test) (modes exe) (package xapi-idl) - (modules (:standard \ idl_test_common guard_interfaces_test)) + (modules (:standard \ idl_test_common guard_interfaces_test device_number_test)) (deps (source_tree test_data)) (libraries alcotest @@ -47,7 +58,6 @@ xapi-idl.v6 xapi-idl.xen xapi-idl.xen.interface - xapi-idl.xen.interface.types xapi-log ) (preprocess (per_module ((pps ppx_deriving_rpc) Task_server_test Updates_test)))) diff --git a/ocaml/xapi-idl/lib_test/test.ml b/ocaml/xapi-idl/lib_test/test.ml index 712ac7a4640..bba5c5f6055 100644 --- a/ocaml/xapi-idl/lib_test/test.ml +++ b/ocaml/xapi-idl/lib_test/test.ml @@ -17,7 +17,6 @@ let () = ; ("Syslog tests", Syslog_test.tests) ; ("Cohttp_posix_io tests", Http_test.tests) ; ("Xenops_interface tests", Xen_test.tests) - ; ("Device_number tests", Device_number_test.tests) ; ("xcp-config-file tests", Config_file_test.tests) (* "xcp-channel-test", Channel_test.tests; TODO: Turn these on when the code works. *) diff --git a/ocaml/xapi-idl/xen/device_number.ml b/ocaml/xapi-idl/xen/device_number.ml index 2577c8a54ad..66bee601edb 100644 --- a/ocaml/xapi-idl/xen/device_number.ml +++ b/ocaml/xapi-idl/xen/device_number.ml @@ -1,63 +1,51 @@ type bus_type = Xen | Scsi | Floppy | Ide [@@deriving rpcty] -type spec = bus_type * int * int [@@deriving rpcty] +type t = bus_type * int * int [@@deriving rpcty] -type t = spec [@@deriving rpcty] +let bus_type_to_string = function + | Xen -> + "Xen" + | Scsi -> + "Scsi" + | Floppy -> + "Floppy" + | Ide -> + "Ide" -let to_debug_string = function - | Xen, disk, partition -> - Printf.sprintf "Xen(%d, %d)" disk partition - | Scsi, disk, partition -> - Printf.sprintf "Scsi(%d, %d)" disk partition - | Floppy, disk, partition -> - Printf.sprintf "Floppy(%d, %d)" disk partition - | Ide, disk, partition -> - Printf.sprintf "Ide(%d, %d)" disk partition +let to_debug_string (bus, disk, partition) = + Printf.sprintf "%s(%d, %d)" (bus_type_to_string bus) disk partition + +let ( let* ) = Option.bind (* ocamlp4-friendly operators *) let ( <| ) = ( lsl ) let ( >| ) = ( lsr ) -let int_of_string x = - try int_of_string x - with _ -> failwith (Printf.sprintf "int_of_string [%s]" x) - (* If this is true then we will use the deprecated (linux-specific) IDE encodings for disks > 3 *) let use_deprecated_ide_encoding = true -let make (x : spec) : t = - let max_xen = ((1 <| 20) - 1, 15) in - let max_scsi = (15, 15) in - let max_ide = if use_deprecated_ide_encoding then (19, 63) else (3, 63) in - let max_floppy = (2, 0) in - let assert_in_range description (disk_limit, partition_limit) (disk, partition) - = - if disk < 0 || disk > disk_limit then - failwith - (Printf.sprintf "%s disk number out of range 0 <= %d <= %d" description - disk disk_limit - ) ; - if partition < 0 || partition > partition_limit then - failwith - (Printf.sprintf "%s partition number out of range 0 <= %d <= %d" - description partition partition_limit - ) +let max_of = function + | Xen -> + ((1 <| 20) - 1, 15) + | Scsi -> + (15, 15) + | Floppy -> + (2, 0) + | Ide -> + if use_deprecated_ide_encoding then (19, 63) else (3, 63) + +let make bus ~disk ~partition = + let in_range ~min ~max n = min <= n && n <= max in + let all_in_range (disk_max, partition_max) ~disk ~partition = + in_range ~min:0 ~max:disk_max disk + && in_range ~min:0 ~max:partition_max partition in - ( match x with - | Xen, disk, partition -> - assert_in_range "xen" max_xen (disk, partition) - | Scsi, disk, partition -> - assert_in_range "scsi" max_scsi (disk, partition) - | Floppy, disk, partition -> - assert_in_range "floppy" max_floppy (disk, partition) - | Ide, disk, partition -> - assert_in_range "ide" max_ide (disk, partition) - ) ; - x - -let spec (x : t) : spec = x + if all_in_range (max_of bus) ~disk ~partition then + Some (bus, disk, partition) + else + None let ( || ) = ( lor ) @@ -103,8 +91,6 @@ let of_xenstore_int x = if idx < 0 then failwith (Printf.sprintf "Unknown device number: %d" x) ; (Ide, (x >| 6 && ((1 <| 2) - 1)) + (idx * 2), x && ((1 <| 6) - 1)) -type xenstore_key = int - let to_xenstore_key x = to_xenstore_int x let of_xenstore_key x = of_xenstore_int x @@ -119,112 +105,119 @@ let rec string_of_int26 x = let low' = String.make 1 (char_of_int (low + int_of_char 'a' - 1)) in high' ^ low' -module String = struct - include String - - let fold_right f string accu = - let accu = ref accu in - for i = length string - 1 downto 0 do - accu := f string.[i] !accu - done ; - !accu - - let explode string = fold_right (fun h t -> h :: t) string [] - - let implode list = concat "" (List.map (String.make 1) list) -end - -(** Convert a linux device string back into an integer *) -let int26_of_string x = - let ints = - List.map (fun c -> int_of_char c - int_of_char 'a' + 1) (String.explode x) - in - List.fold_left (fun acc x -> (acc * 26) + x) 0 ints - 1 - -let to_linux_device = +let to_linux_prefix = function + | Xen -> + "xvd" + | Scsi -> + "sd" + | Floppy -> + "fd" + | Ide -> + "xvd" + +let to_linux_device (bus, disk, part) = let p x = if x = 0 then "" else string_of_int x in - function - | Xen, disk, part -> - Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) - | Scsi, disk, part -> - Printf.sprintf "sd%s%s" (string_of_int26 disk) (p part) - | Floppy, disk, part -> - Printf.sprintf "fd%s%s" (string_of_int26 disk) (p part) - | Ide, disk, part -> - Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) + let bus = to_linux_prefix bus in + Printf.sprintf "%s%s%s" bus (string_of_int26 disk) (p part) let of_linux_device x = - let letter c = 'a' <= c && c <= 'z' in - let digit c = '0' <= c && c <= '9' in - let take f x = - let rec inner f acc = function - | x :: xs -> - if f x then inner f (x :: acc) xs else (List.rev acc, x :: xs) - | [] -> - (List.rev acc, []) + let open Astring in + let b26_to_int x = + (* Convert a linux device string back into an integer *) + (* Assumes all characters are in range *) + let b26 = + String.Sub.to_string x + |> Stdlib.String.to_seq + |> Seq.map (fun c -> int_of_char c - int_of_char 'a' + 1) + |> Seq.fold_left (fun acc x -> (acc * 26) + x) 0 in - inner f [] x + b26 - 1 + in + + let parse_int x = + match String.Sub.span ~min:1 ~sat:Char.Ascii.is_digit x with + | i, s -> + Option.map (fun i -> (i, s)) (String.Sub.to_int i) + in + let parse_b26 x = + match String.Sub.span ~min:1 ~sat:Char.Ascii.is_lower x with + | b, s -> + (b26_to_int b, s) in (* Parse a string "abc123" into x, y where x is "abc" interpreted as base-26 and y is 123 *) let parse_b26_int x = - let d, p = take letter x in - let d' = int26_of_string (String.implode d) in - let p' = if p = [] then 0 else int_of_string (String.implode p) in - (d', p') + let pre, x = parse_b26 x in + if String.Sub.is_empty x then + Some (pre, 0) + else + let* post, x = parse_int x in + if not (String.Sub.is_empty x) then + None + else + Some (pre, post) in (* Parse a string "123p456" into x, y where x = 123 and y = 456 *) let parse_int_p_int x = - let d, rest = take digit x in - match rest with - | 'p' :: rest -> - let p, _ = take digit rest in - (int_of_string (String.implode d), int_of_string (String.implode p)) - | [] -> - (int_of_string (String.implode d), 0) - | _ -> - failwith - (Printf.sprintf "expected digit+ p digit+ got: %s" (String.implode x)) + let parse_p x = + match String.Sub.head x with + | Some 'p' -> + Some (String.Sub.tail x) + | Some _ | None -> + None + in + let* pre, x = parse_int x in + if String.Sub.is_empty x then + Some (pre, 0) + else + let* x = parse_p x in + let* post, x = parse_int x in + if not (String.Sub.is_empty x) then + None + else + Some (pre, post) in - match String.explode x with - | 'x' :: 'v' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - (Xen, disk, partition) - | 's' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - (Scsi, disk, partition) - | 'f' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - (Floppy, disk, partition) - | 'h' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - (Ide, disk, partition) - | 'd' :: rest -> - let disk, partition = parse_int_p_int rest in - (Xen, disk, partition) - | _ -> - failwith (Printf.sprintf "Failed to parse device name: %s" x) + if String.is_prefix ~affix:"xvd" x then + let rest = String.sub_with_range ~first:3 x in + let* disk, partition = parse_b26_int rest in + Some (Xen, disk, partition) + else if String.is_prefix ~affix:"sd" x then + let rest = String.sub_with_range ~first:2 x in + let* disk, partition = parse_b26_int rest in + Some (Scsi, disk, partition) + else if String.is_prefix ~affix:"fd" x then + let rest = String.sub_with_range ~first:2 x in + let* disk, partition = parse_b26_int rest in + Some (Floppy, disk, partition) + else if String.is_prefix ~affix:"hd" x then + let rest = String.sub_with_range ~first:2 x in + let* disk, partition = parse_b26_int rest in + Some (Ide, disk, partition) + else if String.is_prefix ~affix:"d" x then + let rest = String.sub_with_range ~first:1 x in + let* disk, partition = parse_int_p_int rest in + Some (Xen, disk, partition) + else + None let upgrade_linux_device x = - match String.explode x with - | 'h' :: 'd' :: rest -> - "xvd" ^ String.implode rest - | _ -> - x - -type disk_number = int - -let to_disk_number = function - | Xen, disk, _ -> - disk - | Scsi, disk, _ -> - disk - | Floppy, disk, _ -> - disk - | Ide, disk, _ -> - disk - -let of_disk_number hvm n = if hvm && n < 4 then (Ide, n, 0) else (Xen, n, 0) - -let of_string hvm name = - try of_disk_number hvm (int_of_string name) with _ -> of_linux_device name + if Astring.String.is_prefix ~affix:"hd" x then + let rest = Astring.String.with_range ~first:2 x in + "xvd" ^ rest + else + x + +let disk (_, disk, _) = disk + +let bus (bus, _, _) = bus + +let of_disk_number hvm n = + let bus = if hvm && n < 4 then Ide else Xen in + make bus ~disk:n ~partition:0 + +let of_string ~hvm name = + let maybe_disk = + let* n = int_of_string_opt name in + of_disk_number hvm n + in + match maybe_disk with None -> of_linux_device name | dev -> dev diff --git a/ocaml/xapi-idl/xen/device_number.mli b/ocaml/xapi-idl/xen/device_number.mli index 4b5c431cd62..ffcfcbd05e9 100644 --- a/ocaml/xapi-idl/xen/device_number.mli +++ b/ocaml/xapi-idl/xen/device_number.mli @@ -5,23 +5,22 @@ type bus_type = | Floppy (** A floppy bus *) | Ide (** An IDE bus *) -(** A specification for a device number. There are more valid specifications - than valid device numbers because of hardware and/or protocol limits. *) -type spec = bus_type * int * int - (** A valid device number *) -type t +type t = private bus_type * int * int val typ_of : t Rpc.Types.typ -val make : spec -> t -(** [make spec] validates a given device number specification [spec] and returns - a device number *) +val make : bus_type -> disk:int -> partition:int -> t option +(** [make bus ~disk ~partition] returns [Some device] when the parameters + define a valid device number, or [None] otherwise. *) + +val disk : t -> int +(** [disk t] returns the corresponding non-negative disk number *) -val spec : t -> spec -(** [spec t] takes a [t] and returns the corresponding [spec] *) +val bus : t -> bus_type +(** [bus t] returns the bus type of the device *) -val of_string : bool -> string -> t +val of_string : hvm:bool -> string -> t option (** [of_string hvm name] returns the interface which best matches the [name] by applying the policy: first check if it is a disk_number, else fall back to a linux_device for backwards compatability *) @@ -33,26 +32,19 @@ val to_linux_device : t -> string (** [to_linux_device i] returns a possible linux string representation of interface [i] *) -val of_linux_device : string -> t +val of_linux_device : string -> t option (** [of_linux_device x] returns the interface corresponding to string [x] *) val upgrade_linux_device : string -> string (** [upgrade_linux_device x] upgrades hd* style device names to xvd* and leaves all other device names unchanged. *) -type xenstore_key = int - -val to_xenstore_key : t -> xenstore_key +val to_xenstore_key : t -> int (** [to_xenstore_key i] returns the xenstore key from interface [i] *) -val of_xenstore_key : xenstore_key -> t +val of_xenstore_key : int -> t (** [of_xenstore_key key] returns an interface from a xenstore key *) -type disk_number = int - -val to_disk_number : t -> disk_number -(** [to_disk_number i] returns the corresponding non-negative disk number *) - -val of_disk_number : bool -> disk_number -> t +val of_disk_number : bool -> int -> t option (** [of_disk_number hvm n] returns the interface corresponding to disk number [n] which depends on whether the guest is [hvm] or not. *) diff --git a/ocaml/xapi-idl/xen/dune b/ocaml/xapi-idl/xen/dune index c2352eff385..7f19e4a2714 100644 --- a/ocaml/xapi-idl/xen/dune +++ b/ocaml/xapi-idl/xen/dune @@ -3,6 +3,7 @@ (public_name xapi-idl.xen.interface.types) (modules xenops_types device_number) (libraries + astring result rpclib.core rresult diff --git a/ocaml/xapi/dbsync_slave.ml b/ocaml/xapi/dbsync_slave.ml index 84af29bbf7f..32ee7d44d21 100644 --- a/ocaml/xapi/dbsync_slave.ml +++ b/ocaml/xapi/dbsync_slave.ml @@ -69,7 +69,7 @@ let get_start_time () = debug "Calculating boot time..." ; let now = Unix.time () in let uptime = Unixext.string_of_file "/proc/uptime" in - let uptime = String.strip String.isspace uptime in + let uptime = String.trim uptime in let uptime = String.split ' ' uptime in let uptime = List.hd uptime in let uptime = float_of_string uptime in diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index 02e5545d16e..a307eb48bdd 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -558,8 +558,17 @@ let of_vbd ~__context ~vbd ~domid = Helpers.has_qemu ~__context ~self:(Db.VBD.get_VM ~__context ~self:vbd) in let dbg = Context.get_task_id __context in - let device_number = Device_number.of_string has_qemu userdevice in - let device = Device_number.to_linux_device device_number in + let device = + Option.map Device_number.to_linux_device + (Device_number.of_string ~hvm:has_qemu userdevice) + in + let device = + match device with + | Some dev -> + dev + | None -> + raise Api_errors.(Server_error (invalid_device, [userdevice])) + in let dp = datapath_of_vbd ~domid ~device in ( rpc , Ref.string_of dbg diff --git a/ocaml/xapi/vbdops.ml b/ocaml/xapi/vbdops.ml index 18e1f8413b9..0b9494e6f9e 100644 --- a/ocaml/xapi/vbdops.ml +++ b/ocaml/xapi/vbdops.ml @@ -24,15 +24,15 @@ module L = Debug.Make (struct let name = "license" end) (** Thrown if an empty VBD which isn't a CDROM is attached to an HVM guest *) exception Only_CD_VBDs_may_be_empty -let translate_vbd_device vbd_ref name is_hvm = - try - let i = Device_number.of_string is_hvm name in - debug "VBD device name %s interpreted as %s (hvm = %b)" name - (Device_number.to_debug_string i) - is_hvm ; - i - with _ -> - raise - (Api_errors.Server_error - (Api_errors.illegal_vbd_device, [Ref.string_of vbd_ref; name]) - ) +let translate_vbd_device vbd_ref name hvm = + match Device_number.of_string ~hvm name with + | Some i -> + debug "VBD device name %s interpreted as %s (hvm = %b)" name + (Device_number.to_debug_string i) + hvm ; + i + | None -> + raise + (Api_errors.Server_error + (Api_errors.illegal_vbd_device, [Ref.string_of vbd_ref; name]) + ) diff --git a/ocaml/xapi/xapi_dr_task.ml b/ocaml/xapi/xapi_dr_task.ml index 6766775a5f1..415a4e45c8f 100644 --- a/ocaml/xapi/xapi_dr_task.ml +++ b/ocaml/xapi/xapi_dr_task.ml @@ -31,7 +31,7 @@ type sr_probe_sr = {uuid: string; name_label: string; name_description: string} (* Attempt to parse a key/value pair from XML. *) let parse_kv = function | Xml.Element (key, _, [Xml.PCData v]) -> - (key, String.strip String.isspace v) (* remove whitespace at both ends *) + (key, String.trim v) | Xml.Element (key, _, []) -> (key, "") | _ -> diff --git a/ocaml/xapi/xapi_templates_install.ml b/ocaml/xapi/xapi_templates_install.ml index c22e51bf0ae..fc126b588bb 100644 --- a/ocaml/xapi/xapi_templates_install.ml +++ b/ocaml/xapi/xapi_templates_install.ml @@ -34,10 +34,7 @@ let is_whitelisted script = | _ -> false in - let safe_str str = - List.fold_left ( && ) true - (List.map safe_char (Xapi_stdext_std.Xstringext.String.explode str)) - in + let safe_str str = String.for_all safe_char str in (* make sure the script prefix is the allowed dom0 directory *) Filename.dirname script = !Xapi_globs.post_install_scripts_dir (* avoid ..-style attacks and other weird things *) diff --git a/ocaml/xapi/xapi_vbd.ml b/ocaml/xapi/xapi_vbd.ml index 1da2516d809..5e1b31c5bee 100644 --- a/ocaml/xapi/xapi_vbd.ml +++ b/ocaml/xapi/xapi_vbd.ml @@ -215,24 +215,23 @@ let create ~__context ~vM ~vDI ~device ~userdevice ~bootable ~mode ~_type ) ) in - if - (not (valid_device userdevice ~_type)) - || (userdevice = "autodetect" && possibilities = []) - then - raise - (Api_errors.Server_error (Api_errors.invalid_device, [userdevice])) ; + let raise_invalid_device () = + raise Api_errors.(Server_error (invalid_device, [userdevice])) + in + if not (valid_device userdevice ~_type) then + raise_invalid_device () ; (* Resolve the "autodetect" into a fixed device name now *) let userdevice = - if userdevice = "autodetect" then - match _type with - (* already checked for [] above *) - | `Floppy -> - Device_number.to_linux_device (List.hd possibilities) - | `CD | `Disk -> - string_of_int - (Device_number.to_disk_number (List.hd possibilities)) - else + if userdevice <> "autodetect" then userdevice + else + match (_type, possibilities) with + | _, [] -> + raise_invalid_device () + | `Floppy, dev :: _ -> + Device_number.to_linux_device dev + | (`CD | `Disk), dev :: _ -> + string_of_int (Device_number.disk dev) in let uuid = Uuidx.make () in let ref = Ref.make () in diff --git a/ocaml/xapi/xapi_vbd_helpers.ml b/ocaml/xapi/xapi_vbd_helpers.ml index 6226b26c34e..1285c740c27 100644 --- a/ocaml/xapi/xapi_vbd_helpers.ml +++ b/ocaml/xapi/xapi_vbd_helpers.ml @@ -376,38 +376,17 @@ let clear_current_operations ~__context ~self = (** Check if the device string has the right form *) let valid_device dev ~_type = - let check_rest rest = - (* checks the rest of the device name = [] is ok, or a number is ok *) - if rest = [] then - true - else - try - ignore (int_of_string (String.implode rest)) ; - true - with _ -> false - in dev = "autodetect" + || Option.is_none (Device_number.of_string dev ~hvm:false) || - match String.explode dev with - | 's' :: 'd' :: 'a' .. 'p' :: rest -> - check_rest rest - | 'x' :: 'v' :: 'd' :: 'a' .. 'p' :: rest -> - check_rest rest - | 'h' :: 'd' :: 'a' .. 'p' :: rest -> - check_rest rest - | 'f' :: 'd' :: 'a' .. 'b' :: rest -> - check_rest rest - (* QEMU only supports up to 2 floppy drives, hence fda or fdb *) + match _type with + | `Floppy -> + false | _ -> ( - match _type with - | `Floppy -> - false - | _ -> ( - try - let n = int_of_string dev in - n >= 0 || n < 16 - with _ -> false - ) + try + let n = int_of_string dev in + n >= 0 || n < 16 + with _ -> false ) (** VBD.destroy doesn't require any interaction with xen *) diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 8819d393170..eff46f84b93 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1206,7 +1206,7 @@ let get_possible_hosts ~__context ~vm = let get_allowed_VBD_devices ~__context ~vm = List.map - (fun d -> string_of_int (Device_number.to_disk_number d)) + (fun d -> string_of_int (Device_number.disk d)) (snd @@ allowed_VBD_devices ~__context ~vm ~_type:`Disk) let get_allowed_VIF_devices = allowed_VIF_devices diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index c715303b836..88590dc195b 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -1284,7 +1284,7 @@ let set_HVM_shadow_multiplier ~__context ~self ~value = let inclusive_range a b = List.init (b - a + 1) (fun k -> a + k) let vbd_inclusive_range hvm a b = - List.map (Device_number.of_disk_number hvm) (inclusive_range a b) + List.filter_map (Device_number.of_disk_number hvm) (inclusive_range a b) let vif_inclusive_range a b = List.map string_of_int (inclusive_range a b) @@ -1302,8 +1302,8 @@ let allowed_VBD_devices_PV = vbd_inclusive_range false 0 254 let allowed_VBD_devices_control_domain = vbd_inclusive_range false 0 255 let allowed_VBD_devices_HVM_floppy = - List.map - (fun x -> Device_number.make (Device_number.Floppy, x, 0)) + List.filter_map + (fun x -> Device_number.(make Floppy ~disk:x ~partition:0)) (inclusive_range 0 1) let allowed_VIF_devices_HVM = vif_inclusive_range 0 6 @@ -1314,8 +1314,8 @@ let allowed_VIF_devices_PV = vif_inclusive_range 0 6 represent possible interpretations of [s]. *) let possible_VBD_devices_of_string s = (* NB userdevice fields are arbitrary strings and device fields may be "" *) - let parse hvm x = try Some (Device_number.of_string hvm x) with _ -> None in - Listext.List.unbox_list [parse true s; parse false s] + let parse hvm x = Device_number.of_string ~hvm x in + List.filter_map Fun.id [parse true s; parse false s] (** [all_used_VBD_devices __context self] returns a list of Device_number.t which are considered to be already in-use in the VM *) diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index cb1932aab0a..dfb2b666205 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -555,31 +555,37 @@ module MD = struct | `pv_in_pvh | `pv | `pvh | `unspecified -> false in - let device_number = Device_number.of_string hvm vbd.API.vBD_userdevice in + let device_number = + match Device_number.of_string ~hvm vbd.API.vBD_userdevice with + | Some dev -> + dev + | None -> + raise + Api_errors.(Server_error (invalid_device, [vbd.API.vBD_userdevice])) + in let open Vbd in let ty = vbd.API.vBD_qos_algorithm_type in let params = vbd.API.vBD_qos_algorithm_params in let qos_class params = - if List.mem_assoc "class" params then - match List.assoc "class" params with - | "highest" -> - Highest - | "high" -> - High - | "normal" -> - Normal - | "low" -> - Low - | "lowest" -> - Lowest - | s -> ( - try Other (int_of_string s) - with _ -> - warn "Unknown VBD QoS scheduler class (try 'high' 'low' 'normal')" ; - Normal - ) - else - Normal + match List.assoc_opt "class" params with + | Some "highest" -> + Highest + | Some "high" -> + High + | Some "normal" -> + Normal + | Some "low" -> + Low + | Some "lowest" -> + Lowest + | Some s -> ( + try Other (int_of_string s) + with _ -> + warn "Unknown VBD QoS scheduler class (try 'high' 'low' 'normal')" ; + Normal + ) + | None -> + Normal in let qos_scheduler params = try @@ -2459,18 +2465,16 @@ let update_vbd ~__context (id : string * string) = in let linux_device = snd id in let device_number = Device_number.of_linux_device linux_device in - (* only try matching against disk number if the device is not a floppy (as "0" shouldn't match "fda") *) - let disk_number = - match Device_number.spec device_number with - | Device_number.Ide, _, _ | Device_number.Xen, _, _ -> - Some - (device_number - |> Device_number.to_disk_number - |> string_of_int - ) + let disk_of dev = + (* only try matching against disk number if the device is not a + floppy (as "0" shouldn't match "fda") *) + match Device_number.bus dev with + | Ide | Xen -> + Some (string_of_int Device_number.(disk dev)) | _ -> None in + let disk_number = Option.bind device_number disk_of in debug "VM %s VBD userdevices = [ %s ]" (fst id) (String.concat "; " (List.map (fun (_, r) -> r.API.vBD_userdevice) vbdrs) diff --git a/ocaml/xapi/xha_interface.ml b/ocaml/xapi/xha_interface.ml index 608ae9a64a2..53be303e04c 100644 --- a/ocaml/xapi/xha_interface.ml +++ b/ocaml/xapi/xha_interface.ml @@ -40,9 +40,9 @@ let first_xml_element_with_name elements name = are stripped of leading and trailing whitespace. *) let hash_table_entry_of_leaf_xml_element = function | Xml.Element (name, _, Xml.PCData value :: _) -> - Some (String.strip String.isspace name, String.strip String.isspace value) + Some (String.trim name, String.trim value) | Xml.Element (name, _, []) -> - Some (String.strip String.isspace name, "") + Some (String.trim name, "") | _ -> None diff --git a/ocaml/xapi/xmlrpc_sexpr.ml b/ocaml/xapi/xmlrpc_sexpr.ml index 4e394fdb697..d241491cdc3 100644 --- a/ocaml/xapi/xmlrpc_sexpr.ml +++ b/ocaml/xapi/xmlrpc_sexpr.ml @@ -41,7 +41,7 @@ let xmlrpc_to_sexpr (root : xml) = | _, [] -> [] | _, PCData text :: _ -> - let text = String.strip String.isspace text in + let text = String.trim text in [SExpr.String text] (* empty s have default value '' *) | h, Element ("value", _, []) :: siblings -> @@ -69,7 +69,7 @@ let xmlrpc_to_sexpr (root : xml) = (*ignore incorrect member*) (* any other element *) | h, Element (tag, _, children) :: siblings -> - let tag = String.strip String.isspace tag in + let tag = String.trim tag in let mytag = SExpr.String tag in let (mychildren : SExpr.t list) = visit (h + 1) children in let anode = SExpr.Node (mytag :: mychildren) in diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index 5ac6100669c..9658650699f 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -223,20 +223,30 @@ type disk_info = { let parse_disk_info x = match Re.Str.split_delim (Re.Str.regexp "[,]") x with | [source; device_number; rw] -> - let ty, device_number, device_number' = + let maybe_device = match Re.Str.split_delim (Re.Str.regexp "[:]") device_number with | [x] -> - (Vbd.Disk, x, Device_number.of_string false x) + Some (Vbd.Disk, x) | [x; "floppy"] -> - (Vbd.Floppy, x, Device_number.of_string false x) + Some (Vbd.Floppy, x) | [x; "cdrom"] -> - (Vbd.CDROM, x, Device_number.of_string false x) + Some (Vbd.CDROM, x) | _ -> + None + in + let get_position (ty, id) = + Option.map (fun x -> (ty, id, x)) (Device_number.of_string ~hvm:false id) + in + let ty, device_number, position = + match Option.bind maybe_device get_position with + | None -> Printf.fprintf stderr "Failed to understand disk name '%s'. It should be 'xvda' or \ 'hda:cdrom'\n" device_number ; exit 2 + | Some disk -> + disk in let mode = match String.lowercase_ascii rw with @@ -250,7 +260,7 @@ let parse_disk_info x = exit 2 in let backend = parse_source source in - {id= device_number; ty; position= device_number'; mode; disk= backend} + {id= device_number; ty; position; mode; disk= backend} | _ -> Printf.fprintf stderr "I don't understand '%s'. Please use 'phy:path,xvda,w'\n" x ; diff --git a/ocaml/xenopsd/lib/xenops_server_simulator.ml b/ocaml/xenopsd/lib/xenops_server_simulator.ml index c12a929392f..c5123641978 100644 --- a/ocaml/xenopsd/lib/xenops_server_simulator.ml +++ b/ocaml/xenopsd/lib/xenops_server_simulator.ml @@ -240,12 +240,20 @@ let add_vbd (vm : Vm.id) (vbd : Vbd.t) () = debug "add_vbd" ; let d = DB.read_exn vm in (* there shouldn't be any None values in here anyway *) - let ps = List.map (fun vbd -> vbd.Vbd.position) d.Domain.vbds in - assert (not (List.mem None ps)) ; - let dns = List.map Option.get ps in - let indices = List.map Device_number.to_disk_number dns in + let dns = List.filter_map (fun vbd -> vbd.Vbd.position) d.Domain.vbds in + let indices = List.map Device_number.disk dns in let next_index = List.fold_left max (-1) indices + 1 in let next_dn = Device_number.of_disk_number d.Domain.hvm next_index in + let next_dn = + match next_dn with + | None -> + raise + (Xenopsd_error + (Internal_error "Ran out of available device numbers for the vbd") + ) + | Some dn -> + dn + in let this_dn = Option.value ~default:next_dn vbd.Vbd.position in if List.mem this_dn dns then ( debug "VBD.plug %s.%s: Already exists" (fst vbd.Vbd.id) (snd vbd.Vbd.id) ; diff --git a/ocaml/xenopsd/xc/device.ml b/ocaml/xenopsd/xc/device.ml index 20f2405a7e7..3f6da8152a6 100644 --- a/ocaml/xenopsd/xc/device.ml +++ b/ocaml/xenopsd/xc/device.ml @@ -585,17 +585,18 @@ module Vbd_Common = struct (fun x -> x.frontend.devid |> Device_number.of_xenstore_key - |> Device_number.spec - |> function - | _, disk, _ -> - disk + |> Device_number.disk ) (Device_common.list_frontends ~xs domid) in let next = List.fold_left max 0 disks + 1 in let open Device_number in let bus_type = if hvm && next < 4 then Ide else Xen in - (bus_type, next, 0) + match make bus_type ~disk:next ~partition:0 with + | Some x -> + x + | None -> + raise (Xenopsd_error (Internal_error "Unable to decide slot for vbd")) type t = { mode: mode @@ -620,7 +621,7 @@ module Vbd_Common = struct | Some x -> x | None -> - make (free_device ~xs hvm domid) + free_device ~xs hvm domid in let devid = to_xenstore_key device_number in let device = @@ -2986,7 +2987,11 @@ module Backend = struct qemu-upstream-compat backend *) module Vbd = struct let cd_of devid = - devid |> Device_number.of_xenstore_key |> Device_number.spec |> function + match + ( Device_number.of_xenstore_key devid + :> Device_number.bus_type * int * int + ) + with | Ide, 0, _ -> "ide0-cd0" | Ide, 1, _ -> diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index 44d4e4e942c..ee4524cf781 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -3774,14 +3774,14 @@ module VBD = struct let qemu_domid = this_domid ~xs in let qemu_frontend = let maybe_create_vbd_frontend () = - let index = Device_number.to_disk_number device_number in + let index = Device_number.disk device_number in match vbd.Vbd.backend with | None -> Some (index, Empty) | Some _ -> Some (index, create_vbd_frontend ~xc ~xs task qemu_domid vdi) in - match Device_number.spec device_number with + match (device_number :> Device_number.bus_type * int * int) with | Ide, n, _ when 0 <= n && n < 4 -> maybe_create_vbd_frontend () | Floppy, n, _ when 0 <= n && n < 2 -> diff --git a/quality-gate.sh b/quality-gate.sh index 8f761718627..e4a8379f214 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=302 + N=300 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages" @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=513 + N=512 # 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|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) diff --git a/xapi-idl.opam b/xapi-idl.opam index d6e7a390671..1af2c2bd516 100644 --- a/xapi-idl.opam +++ b/xapi-idl.opam @@ -36,6 +36,7 @@ depends: [ "xapi-open-uri" "xapi-stdext-date" "xapi-stdext-pervasives" + "xapi-stdext-std" "xapi-stdext-threads" "xapi-tracing" "xapi-inventory" diff --git a/xapi-idl.opam.template b/xapi-idl.opam.template index 6c879e68b97..b07bec320ec 100644 --- a/xapi-idl.opam.template +++ b/xapi-idl.opam.template @@ -34,6 +34,7 @@ depends: [ "xapi-open-uri" "xapi-stdext-date" "xapi-stdext-pervasives" + "xapi-stdext-std" "xapi-stdext-threads" "xapi-tracing" "xapi-inventory" From bc511a3f31cc260f7be000651dcae3dc9a067c61 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 24 May 2024 11:42:54 +0100 Subject: [PATCH 2/3] xapi-idl: do not use custom operators for bit manipulations Use the standard ones instead Signed-off-by: Pau Ruiz Safont --- ocaml/xapi-idl/xen/device_number.ml | 35 +++++++++++++---------------- 1 file changed, 15 insertions(+), 20 deletions(-) diff --git a/ocaml/xapi-idl/xen/device_number.ml b/ocaml/xapi-idl/xen/device_number.ml index 66bee601edb..31943b7e123 100644 --- a/ocaml/xapi-idl/xen/device_number.ml +++ b/ocaml/xapi-idl/xen/device_number.ml @@ -17,18 +17,13 @@ let to_debug_string (bus, disk, partition) = let ( let* ) = Option.bind -(* ocamlp4-friendly operators *) -let ( <| ) = ( lsl ) - -let ( >| ) = ( lsr ) - (* If this is true then we will use the deprecated (linux-specific) IDE encodings for disks > 3 *) let use_deprecated_ide_encoding = true let max_of = function | Xen -> - ((1 <| 20) - 1, 15) + ((1 lsl 20) - 1, 15) | Scsi -> (15, 15) | Floppy -> @@ -55,31 +50,30 @@ let deprecated_ide_table = standard_ide_table @ [33; 34; 56; 57; 88; 89; 90; 91] let to_xenstore_int = function | Xen, disk, partition when disk < 16 -> - 202 <| 8 || disk <| 4 || partition + (202 lsl 8) || (disk lsl 4) || partition | Xen, disk, partition -> - 1 <| 28 || disk <| 8 || partition + (1 lsl 28) || (disk lsl 8) || partition | Scsi, disk, partition -> - 8 <| 8 || disk <| 4 || partition + (8 lsl 8) || (disk lsl 4) || partition | Floppy, disk, partition -> - 203 <| 8 || disk <| 4 || partition + (203 lsl 8) || (disk lsl 4) || partition | Ide, disk, partition -> let m = List.nth deprecated_ide_table (disk / 2) in let n = disk - (disk / 2 * 2) in (* NB integers behave differently to reals *) - m <| 8 || n <| 6 || partition + (m lsl 8) || (n lsl 6) || partition let of_xenstore_int x = - let ( && ) = ( land ) in - if (x && 1 <| 28) <> 0 then - (Xen, x >| 8 && ((1 <| 20) - 1), x && ((1 <| 8) - 1)) + if x land (1 lsl 28) <> 0 then + (Xen, (x lsr 8) land ((1 lsl 20) - 1), x land ((1 lsl 8) - 1)) else - match x >| 8 with + match x lsr 8 with | 202 -> - (Xen, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + (Xen, (x lsr 4) land ((1 lsl 4) - 1), x land ((1 lsl 4) - 1)) | 8 -> - (Scsi, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + (Scsi, (x lsr 4) land ((1 lsl 4) - 1), x land ((1 lsl 4) - 1)) | 203 -> - (Floppy, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + (Floppy, (x lsr 4) land ((1 lsl 4) - 1), x land ((1 lsl 4) - 1)) | n -> let idx = snd @@ -88,8 +82,9 @@ let of_xenstore_int x = (0, -1) deprecated_ide_table ) in - if idx < 0 then failwith (Printf.sprintf "Unknown device number: %d" x) ; - (Ide, (x >| 6 && ((1 <| 2) - 1)) + (idx * 2), x && ((1 <| 6) - 1)) + let disk = ((x lsr 6) land ((1 lsl 2) - 1)) + (idx * 2) in + let partition = x land ((1 lsl 6) - 1) in + (Ide, disk, partition) let to_xenstore_key x = to_xenstore_int x From 4b691d1868aff06ebe129114ae78336258f7fde6 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 24 May 2024 12:24:34 +0100 Subject: [PATCH 3/3] xapi-idl: Refactor out find_index and add it to Listext The function is implemented using foldleft using a weird form, use a recursive form instead. Unfortunately the function was introduced in OCaml 5.1, so it had to be moved to Listext so it can be reused. Signed-off-by: Pau Ruiz Safont --- .../libs/xapi-stdext/lib/xapi-stdext-std/listext.ml | 11 +++++++++++ .../libs/xapi-stdext/lib/xapi-stdext-std/listext.mli | 7 +++++++ ocaml/xapi-idl/xen/device_number.ml | 12 +++++++----- ocaml/xapi-idl/xen/dune | 1 + 4 files changed, 26 insertions(+), 5 deletions(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml index e89cefba3da..c290ab8e569 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml @@ -208,4 +208,15 @@ module List = struct let find_minimum compare = let min a b = if compare a b <= 0 then a else b in function [] -> None | x :: xs -> Some (List.fold_left min x xs) + + let find_index f l = + let rec loop i = function + | [] -> + None + | x :: _ when f x -> + Some i + | _ :: xs -> + loop (i + 1) xs + in + loop 0 l end diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli index d836c751230..231c3891060 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli @@ -60,6 +60,13 @@ module List : sig the sort order of [cmp], or [None] if the list is empty. When two ore more elements match the lowest value, the left-most is returned. *) + val find_index : ('a -> bool) -> 'a list -> int option + (** [find_index f l] returns the position of the first element in [l] that + satisfies [f x]. If there is no such element, returns [None]. + + When using OCaml compilers 5.1 or later, please use the standard library + instead. *) + (** {1 Using indices to manipulate lists} *) val chop : int -> 'a list -> 'a list * 'a list diff --git a/ocaml/xapi-idl/xen/device_number.ml b/ocaml/xapi-idl/xen/device_number.ml index 31943b7e123..2233354b030 100644 --- a/ocaml/xapi-idl/xen/device_number.ml +++ b/ocaml/xapi-idl/xen/device_number.ml @@ -1,3 +1,5 @@ +module Listext = Xapi_stdext_std.Listext.List + type bus_type = Xen | Scsi | Floppy | Ide [@@deriving rpcty] type t = bus_type * int * int [@@deriving rpcty] @@ -76,11 +78,11 @@ let of_xenstore_int x = (Floppy, (x lsr 4) land ((1 lsl 4) - 1), x land ((1 lsl 4) - 1)) | n -> let idx = - snd - (List.fold_left - (fun (i, res) e -> (i + 1, if e = n then i else res)) - (0, -1) deprecated_ide_table - ) + match Listext.find_index (Int.equal n) deprecated_ide_table with + | Some idx -> + idx + | None -> + failwith (Printf.sprintf "Unknown device number: %d" x) in let disk = ((x lsr 6) land ((1 lsl 2) - 1)) + (idx * 2) in let partition = x land ((1 lsl 6) - 1) in diff --git a/ocaml/xapi-idl/xen/dune b/ocaml/xapi-idl/xen/dune index 7f19e4a2714..16ed23ecd22 100644 --- a/ocaml/xapi-idl/xen/dune +++ b/ocaml/xapi-idl/xen/dune @@ -11,6 +11,7 @@ sexplib0 threads xapi-idl + xapi-stdext-std ) (wrapped false) (preprocess (pps ppx_deriving_rpc ppx_sexp_conv)))