xapi-stdext: replace List's chop with split_at

Now users can use out-of-bounds limits without fear. I've used the
opportunity to consolidate code that sorts and splits lists in
db_gc_util.

Signed-off-by: Pau Ruiz Safont <pau.safont@vates.tech>

Author: psafont

ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml

@@ -92,8 +92,6 @@ module List = struct
     in
     loop 0 [] list
 
-  let chop = split_at
-
   let rec between e = function
     | [] ->
         []

ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli

@@ -73,11 +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] is an alias for [split_at k l]. *)
-
   (** {1 Association Lists} *)
 
   val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list

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, ([], []))
@@ -151,14 +151,14 @@ let test_chop =
   in
   let test (whole, number, expected) =
     let name =
-      Printf.sprintf "chop [%s] with %i"
+      Printf.sprintf "split_at [%s] with %i"
         (String.concat "; " (List.map string_of_int whole))
         number
     in
-    test_chopped_list (Listext.chop number) (name, whole, expected)
+    test_split_at_list (Listext.split_at number) (name, whole, expected)
   in
   let tests = List.map test specs in
-  ("chop", tests)
+  ("split_at", tests)
 
 let test_find_minimum (name, pp, typ, specs) =
   let test ((cmp, cmp_name), input, expected) =
@@ -214,7 +214,7 @@ let () =
     ; test_take
     ; test_drop
     ; test_last
-    ; test_chop
+    ; test_split_at
     ; test_find_minimum_int
     ; test_find_minimum_tuple
     ]

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

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