CA-420987: xapi_message: Add message-destroy-all API

ocaml/idl/datamodel.ml

@@ -8915,6 +8915,40 @@ module Message = struct
       ~params:[(Set (Ref _message), "messages", "Messages to destroy")]
       ~allowed_roles:_R_POOL_OP ()
 
+  let destroy_all =
+    call ~name:"destroy_all" ~lifecycle:[]
+      ~versioned_params:
+        [
+          {
+            param_type= DateTime
+          ; param_name= "before"
+          ; param_doc=
+              "Cutoff time for destroyed messages - only destroy messages with \
+               an earlier timestamp. When no timezone is specified UTC is \
+               assumed."
+          ; param_release= numbered_release "25.39.0-next"
+          ; param_default= Some (VDateTime (Date.of_ptime Ptime.max))
+          }
+        ; {
+            param_type= DateTime
+          ; param_name= "after"
+          ; param_doc=
+              "Cutoff time for destroyed messages - only destroy messages with \
+               a later timestamp. When no timezone is specified UTC is \
+               assumed."
+          ; param_release= numbered_release "25.39.0-next"
+          ; param_default= Some (VDateTime Date.epoch)
+          }
+        ; {
+            param_type= Int
+          ; param_name= "priority"
+          ; param_doc= "Priority of messages to be destroyed"
+          ; param_release= numbered_release "25.39.0-next"
+          ; param_default= Some (VInt (-1L))
+          }
+        ]
+      ~allowed_roles:_R_POOL_OP ()
+
   let get_all =
     call ~name:"get_all"
       ~lifecycle:[(Published, rel_orlando, "")]
@@ -9002,6 +9036,7 @@ module Message = struct
           create
         ; destroy
         ; destroy_many
+        ; destroy_all
         ; get
         ; get_all
         ; get_since

ocaml/idl/datamodel_lifecycle.ml

@@ -223,6 +223,8 @@ let prototyped_of_message = function
       Some "24.14.0"
   | "PCI", "disable_dom0_access" ->
       Some "24.14.0"
+  | "message", "destroy_all" ->
+      Some "25.39.0-next"
   | "message", "destroy_many" ->
       Some "22.19.0"
   | "VTPM", "set_contents" ->

ocaml/xapi-cli-server/cli_frontend.ml

@@ -128,6 +128,15 @@ let rec cmdtable_data : (string * cmd_spec) list =
       ; flags= []
       }
     )
+  ; ( "message-destroy-all"
+    , {
+        reqd= []
+      ; optn= ["before"; "after"; "priority"]
+      ; help= "Destroy all existing messages matching the given conditions."
+      ; implementation= No_fd Cli_operations.message_destroy_all
+      ; flags= []
+      }
+    )
   ; ( "pool-enable-binary-storage"
     , {
         reqd= []

ocaml/xapi-cli-server/cli_operations.ml

@@ -550,20 +550,18 @@ let make_param_funs getallrecs getbyuuid record class_name def_filters
             )
             all
         in
-        (* Filter on everything on the cmd line except params=... *)
         let filter_params =
-          List.filter
-            (fun (p, _) -> not (List.mem p ("params" :: stdparams)))
-            params
-        in
-        (* Filter out all params beginning with "database:" *)
-        let filter_params =
-          List.filter
-            (fun (p, _) -> not (Astring.String.is_prefix ~affix:"database:" p))
-            filter_params
+          (* Add in the default filters *)
+          def_filters
+          @ List.filter
+              (fun (p, _) ->
+                (* Filter on everything on the cmd line except params=... *)
+                (not (List.mem p ("params" :: stdparams)))
+                (* Filter out all params beginning with "database:" *)
+                && not (Astring.String.is_prefix ~affix:"database:" p)
+              )
+              params
         in
-        (* Add in the default filters *)
-        let filter_params = def_filters @ filter_params in
         (* Filter all the records *)
         let records =
           List.fold_left filter_records_on_fields all_recs filter_params
@@ -573,22 +571,20 @@ let make_param_funs getallrecs getbyuuid record class_name def_filters
           select_fields params
             (if print_all then all_recs else records)
             def_list_params
-        in
-        let print_params =
-          List.map
-            (fun fields -> List.filter (fun field -> not field.hidden) fields)
-            print_params
-        in
-        let print_params =
-          List.map
-            (fun fields ->
-              List.map
-                (fun field ->
-                  if field.expensive then makeexpensivefield field else field
+          (* Hide hidden fields, redact expensive fields *)
+          |> List.map
+               (List.filter_map (fun field ->
+                    if field.hidden then
+                      None
+                    else
+                      Some
+                        ( if field.expensive then
+                            makeexpensivefield field
+                          else
+                            field
+                        )
                 )
-                fields
-            )
-            print_params
+               )
         in
         printer
           (Cli_printer.PTable (List.map (List.map print_field) print_params))
@@ -1428,6 +1424,28 @@ let message_destroy (_ : printer) rpc session_id params =
   in
   Client.Message.destroy_many ~rpc ~session_id ~messages
 
+let message_destroy_all (_ : printer) rpc session_id params =
+  let fail msg = raise (Cli_util.Cli_failure msg) in
+  let before_str = List.assoc_opt "before" params in
+  let after_str = List.assoc_opt "after" params in
+  let priority_str = List.assoc_opt "priority" params in
+  let before =
+    try
+      Option.map Date.of_iso8601 before_str
+      |> Option.value ~default:(Date.of_ptime Ptime.max)
+      (* Default value is Ptime.max - everything is before it *)
+    with _ -> fail "invalid timestamp format for 'before' (expected RFC3339)"
+  in
+  let after =
+    try Option.map Date.of_iso8601 after_str |> Option.value ~default:Date.epoch
+    with _ -> fail "Invalid timestamp format for 'after' (expected RFC3339)"
+  in
+  let priority =
+    try Option.map Int64.of_string priority_str |> Option.value ~default:(-1L)
+    with _ -> fail "Invalid priority format (expected integer)"
+  in
+  Client.Message.destroy_all ~rpc ~session_id ~before ~after ~priority
+
 (* Pool operations *)
 
 let get_pool_with_default rpc session_id params key =

ocaml/xapi/xapi_message.ml

@@ -730,6 +730,24 @@ let get_record ~__context ~self =
 
 let get_all_records ~__context = get_real message_dir (fun _ -> true) 0.0
 
+let destroy_all ~__context ~before ~after ~priority =
+  let filter_timestamp ts =
+    Date.is_earlier ts ~than:before && Date.is_later ts ~than:after
+  in
+  let priority_filter =
+    (* Default priority is -1, which stands for any priority *)
+    if priority = -1L then fun _ -> true else fun p -> p = priority
+  in
+  let message_filter msg =
+    filter_timestamp msg.API.message_timestamp
+    && priority_filter msg.API.message_priority
+  in
+  let messages =
+    get_real_inner message_dir message_filter (fun _ -> true)
+    |> List.map (fun (_, msg, _) -> msg)
+  in
+  destroy_many ~__context ~messages
+
 let get_all_records_where ~__context ~expr =
   let open Xapi_database in
   let expr = Db_filter.expr_of_string expr in