diff --git a/dune-project b/dune-project index 7f78d332818..9e7f1f9b299 100644 --- a/dune-project +++ b/dune-project @@ -612,6 +612,8 @@ (= :version)) (xapi-stdext-pervasives (= :version)) + (xapi-stdext-std + (= :version)) (xapi-stdext-threads (= :version)) (xapi-stdext-unix diff --git a/ocaml/libs/stunnel/dune b/ocaml/libs/stunnel/dune index 21803706ce4..776f4a8c7ed 100644 --- a/ocaml/libs/stunnel/dune +++ b/ocaml/libs/stunnel/dune @@ -13,6 +13,7 @@ xapi-inventory xapi-log xapi-stdext-pervasives + xapi-stdext-std xapi-stdext-threads xapi-stdext-unix ) diff --git a/ocaml/libs/stunnel/stunnel_cache.ml b/ocaml/libs/stunnel/stunnel_cache.ml index be865a216dc..5a88f8c1079 100644 --- a/ocaml/libs/stunnel/stunnel_cache.ml +++ b/ocaml/libs/stunnel/stunnel_cache.ml @@ -27,6 +27,8 @@ open Safe_resources let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute +let list_drop = Xapi_stdext_std.Listext.List.drop + (* Disable debug-level logging but leave higher-priority enabled. It would be * better to handle this sort of configuration in the Debug module itself. *) @@ -93,17 +95,6 @@ let unlocked_gc () = !index "" ) ) ; - (* Split a list at the given index to give a pair of lists. - * From Xapi_stdext_std.Listext *) - let rec chop i l = - match (i, l) with - | 0, l -> - ([], l) - | i, h :: t -> - (fun (fr, ba) -> (h :: fr, ba)) (chop (i - 1) t) - | _ -> - invalid_arg "chop" - in let all_ids = Tbl.fold !stunnels (fun k _ acc -> k :: acc) [] in let to_gc = ref [] in (* Find the ones which are too old *) @@ -134,8 +125,8 @@ let unlocked_gc () = List.filter (fun (idx, _) -> not (List.mem idx !to_gc)) times' in (* Sort into descending order of donation time, ie youngest first *) - let times' = List.sort (fun x y -> compare (fst y) (fst x)) times' in - let _youngest, oldest = chop max_stunnel times' in + let times' = List.sort (fun (_, x) (_, y) -> Float.compare y x) times' in + let oldest = list_drop max_stunnel times' in let oldest_ids = List.map fst oldest in List.iter (fun x -> diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune index dd8393a4427..67d48233bc4 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/dune @@ -7,5 +7,5 @@ (names xstringext_test listext_test) (package xapi-stdext-std) (modules xstringext_test listext_test) - (libraries xapi_stdext_std alcotest) + (libraries xapi_stdext_std fmt alcotest) ) 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 c290ab8e569..9336429ee3b 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml @@ -22,8 +22,7 @@ module List = struct | x :: xs -> if mem x xs then setify xs else x :: setify xs - let subset s1 s2 = - List.fold_left ( && ) true (List.map (fun s -> List.mem s s2) s1) + let subset s1 s2 = List.for_all (fun s -> List.mem s s2) s1 let set_equiv s1 s2 = subset s1 s2 && subset s2 s1 @@ -84,61 +83,14 @@ module List = struct | _ :: xs -> last xs - let sub i j l = drop i l |> take (j - max i 0) - - let rec chop i l = - match (i, l) with - | j, _ when j < 0 -> - invalid_arg "chop: index cannot be negative" - | 0, l -> - ([], l) - | _, h :: t -> - (fun (fr, ba) -> (h :: fr, ba)) (chop (i - 1) t) - | _, [] -> - invalid_arg "chop: index not in list" - - let rev_chop i l = - let rec aux i fr ba = - match (i, fr, ba) with - | i, _, _ when i < 0 -> - invalid_arg "rev_chop: index cannot be negative" - | 0, fr, ba -> - (fr, ba) - | i, fr, h :: t -> - aux (i - 1) (h :: fr) t - | _ -> - invalid_arg "rev_chop" + let split_at n list = + let rec loop i acc = function + | x :: xs when i < n -> + loop (i + 1) (x :: acc) xs + | xs -> + (List.rev acc, xs) in - aux i [] l - - let chop_tr i l = (fun (fr, ba) -> (rev fr, ba)) (rev_chop i l) - - let rec dice m l = - match chop m l with l, [] -> [l] | l1, l2 -> l1 :: dice m l2 - - let remove i l = - match rev_chop i l with - | rfr, _ :: t -> - rev_append rfr t - | _ -> - invalid_arg "remove" - - let insert i e l = - match rev_chop i l with rfr, ba -> rev_append rfr (e :: ba) - - let replace i e l = - match rev_chop i l with - | rfr, _ :: t -> - rev_append rfr (e :: t) - | _ -> - invalid_arg "replace" - - let morph i f l = - match rev_chop i l with - | rfr, h :: t -> - rev_append rfr (f h :: t) - | _ -> - invalid_arg "morph" + loop 0 [] list let rec between e = function | [] -> 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 231c3891060..3de05254e70 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli @@ -27,6 +27,12 @@ module List : sig (** [drop n list] returns the list without the first [n] elements of [list] (or [] if list is shorter). *) + val split_at : int -> 'a list -> 'a list * 'a list + (** [split_at n list] returns a tuple with the first element being the first + [n] elements of [list] (or less if the list is shorter); and the second + element being the rest of elements of the list (or [] if the list is + shorter). The results with negative values of [n] are the same as using 0. *) + val last : 'a list -> 'a (** [last l] returns the last element of a list or raise Invalid_argument if the list is empty *) @@ -67,42 +73,6 @@ module List : sig 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 - (** [chop k l] splits [l] at index [k] to return a pair of lists. Raises - invalid_arg when [i] is negative or greater than the length of [l]. *) - - val rev_chop : int -> 'a list -> 'a list * 'a list - (** [rev_chop k l] splits [l] at index [k] to return a pair of lists, the - first in reverse order. Raises invalid_arg when [i] is negative or - greater than the length of [l]. *) - - val chop_tr : int -> 'a list -> 'a list * 'a list - (** Tail-recursive {!chop}. *) - - val dice : int -> 'a list -> 'a list list - (** [dice k l] splits [l] into lists with [k] elements each. Raises - {!Invalid_arg} if [List.length l] is not divisible by [k]. *) - - val sub : int -> int -> 'a list -> 'a list - (** [sub from to l] returns the sub-list of [l] that starts at index [from] - and ends at [to] or an empty list if [to] is equal or less than [from]. - Negative indices are treated as 0 and indeces higher than [List.length l - - 1] are treated as [List.length l - 1]. *) - - val remove : int -> 'a list -> 'a list - (** Remove the element at the given index. *) - - val insert : int -> 'a -> 'a list -> 'a list - (** Insert the given element at the given index. *) - - val replace : int -> 'a -> 'a list -> 'a list - (** Replace the element at the given index with the given value. *) - - val morph : int -> ('a -> 'a) -> 'a list -> 'a list - (** Apply the given function to the element at the given index. *) - (** {1 Association Lists} *) val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml index 852b0d7a83d..39224f40be6 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml @@ -25,7 +25,7 @@ let test_option typ tested_f (name, case, expected) = let check () = Alcotest.(check @@ option typ) name expected (tested_f case) in (name, `Quick, check) -let test_chopped_list tested_f (name, case, expected) = +let test_split_at_list tested_f (name, case, expected) = let check () = Alcotest.(check @@ pair (list int) (list int)) name expected (tested_f case) in @@ -135,7 +135,7 @@ let test_last = let error_tests = List.map error_test error_specs in ("last", tests @ error_tests) -let test_chop = +let test_split_at = let specs = [ ([], 0, ([], [])) @@ -144,67 +144,21 @@ let test_chop = ; ([0; 1], 0, ([], [0; 1])) ; ([0; 1], 1, ([0], [1])) ; ([0; 1], 2, ([0; 1], [])) - ] - in - let error_specs = - [ - ([0], -1, Invalid_argument "chop: index cannot be negative") - ; ([0], 2, Invalid_argument "chop: index not in list") + (* test invalid arguments *) [@ocamlformat "disable"] + ; ([0], -1, ([], [0])) + ; ([0], 2, ([0], [])) ] in let test (whole, number, expected) = let name = - Printf.sprintf "chop [%s] with %i" - (String.concat "; " (List.map string_of_int whole)) - number - in - test_chopped_list (Listext.chop number) (name, whole, expected) - in - let tests = List.map test specs in - let error_test (whole, number, error) = - let name = - Printf.sprintf "chop [%s] with %i fails" + Printf.sprintf "split_at [%s] with %i" (String.concat "; " (List.map string_of_int whole)) number in - test_error - (fun ls () -> ignore (Listext.chop number ls)) - (name, whole, error) - in - let error_tests = List.map error_test error_specs in - ("chop", tests @ error_tests) - -let test_sub = - let specs = - [ - ([], 0, 0, []) - ; ([], 0, 1, []) - ; ([0], 0, 0, []) - ; ([0], 0, 1, [0]) - ; ([0], 1, 1, []) - ; ([0], 0, 2, [0]) - ; ([0; 1], 0, 0, []) - ; ([0; 1], 0, 1, [0]) - ; ([0; 1], 0, 2, [0; 1]) - ; ([0; 1], 1, 1, []) - ; ([0; 1], 1, 2, [1]) - ; ([0; 1], 2, 2, []) - (* test_cases below used to fail *) [@ocamlformat "disable"] - ; ([0], -1, 0, []) - ; ([0], 0, -1, []) - ; ([0; 1], 1, 0, []) - ] - in - let test (whole, from, until, expected) = - let name = - Printf.sprintf "sub [%s] from %i to %i" - (String.concat "; " (List.map string_of_int whole)) - from until - in - test_list (Listext.sub from until) (name, whole, expected) + test_split_at_list (Listext.split_at number) (name, whole, expected) in let tests = List.map test specs in - ("sub", tests) + ("split_at", tests) let test_find_minimum (name, pp, typ, specs) = let test ((cmp, cmp_name), input, expected) = @@ -260,8 +214,7 @@ let () = ; test_take ; test_drop ; test_last - ; test_chop - ; test_sub + ; test_split_at ; test_find_minimum_int ; test_find_minimum_tuple ] diff --git a/ocaml/xapi/binpack.ml b/ocaml/xapi/binpack.ml index 14c0405bd7b..c805e535657 100644 --- a/ocaml/xapi/binpack.ml +++ b/ocaml/xapi/binpack.ml @@ -98,7 +98,7 @@ let choose l n = (** Return all permutations of a list *) let rec permutations : 'a list -> 'a list list = let rotate n xs = - let a, b = Xapi_stdext_std.Listext.List.chop n xs in + let a, b = Xapi_stdext_std.Listext.List.split_at n xs in b @ a in let insert_at n x xs = rotate (List.length xs - n + 1) (x :: rotate n xs) in diff --git a/ocaml/xapi/db_gc_util.ml b/ocaml/xapi/db_gc_util.ml index bcacc7d86c0..8a8f116b55e 100644 --- a/ocaml/xapi/db_gc_util.ml +++ b/ocaml/xapi/db_gc_util.ml @@ -293,6 +293,12 @@ let gc_vtpms ~__context = let probation_pending_tasks = Hashtbl.create 53 +let sort_and_split compare n tasks = + if List.length tasks <= n then + (tasks, []) + else + Listext.List.split_at n (List.sort compare tasks) + let timeout_tasks ~__context = let all_tasks = Db.Task.get_internal_records_where ~__context @@ -368,32 +374,20 @@ let timeout_tasks ~__context = let lucky, unlucky = if List.length young <= Xapi_globs.max_tasks then (young, []) (* keep them all *) - else (* Compute how many we'd like to delete *) - let overflow = List.length young - Xapi_globs.max_tasks in - (* We only consider deleting completed tasks *) + else (* We only consider deleting completed tasks *) let completed, pending = List.partition (fun (_, t) -> TaskHelper.status_is_completed t.Db_actions.task_status) young in - (* Sort the completed tasks so we delete oldest tasks in preference *) - let completed = - List.sort - (fun (_, t1) (_, t2) -> - compare - (Date.to_unix_time t1.Db_actions.task_finished) - (Date.to_unix_time t2.Db_actions.task_finished) - ) - completed - in - (* From the completes set, choose up to 'overflow' *) - let unlucky, lucky = - if List.length completed > overflow then - Listext.List.chop overflow completed - else - (completed, []) + (* pending tasks limit the amount of completed tasks to keep, negatives + values are equivalent to 0 *) + let limit = Xapi_globs.max_tasks - List.length completed in + (* Reverse compare order so oldest dates (earliest) are sorted last *) + let compare (_, t1) (_, t2) = + Date.compare t2.Db_actions.task_finished t1.Db_actions.task_finished in - (* not enough to delete, oh well *) + let lucky, unlucky = sort_and_split compare limit completed in (* Keep all pending and any which were not chosen from the completed set *) (pending @ lucky, unlucky) in @@ -456,11 +450,8 @@ let timeout_sessions_common ~__context sessions limit session_group = in (* If there are too many young sessions then we need to delete the oldest *) let _, unlucky = - if List.length young <= limit then - (young, []) (* keep them all *) - else (* Need to reverse sort by last active and drop the oldest *) - Listext.List.chop limit - (List.sort (fun (_, a, _) (_, b, _) -> compare b a) young) + let compare (_, a, _) (_, b, _) = compare b a in + sort_and_split compare limit young in let cancel doc sessions = List.iter diff --git a/opam/stunnel.opam b/opam/stunnel.opam index 0c91aa3de36..4f0a5d76406 100644 --- a/opam/stunnel.opam +++ b/opam/stunnel.opam @@ -18,6 +18,7 @@ depends: [ "xapi-inventory" "xapi-log" {= version} "xapi-stdext-pervasives" {= version} + "xapi-stdext-std" {= version} "xapi-stdext-threads" {= version} "xapi-stdext-unix" {= version} "odoc" {with-doc}