xapi: Add new message-destroy-all API call

We've seen issues where a client will try to dismiss all their alerts
and fail due to the message-destroy call hitting the maximum XAPI
request size at ~5000 messages.

A new message-destroy-all API avoids this issue while saving the
bandwidth required to send a ref for each message. Users of the new
API call can choose to dismiss messages that arrived before or after
a certain date, or only those with a given priority.

Signed-off-by: Christian Pardillo Laursen <christian.pardillolaursen@citrix.com>

Author: cplaursen

ocaml/idl/datamodel.ml

@@ -8915,6 +8915,24 @@ module Message = struct
       ~params:[(Set (Ref _message), "messages", "Messages to destroy")]
       ~allowed_roles:_R_POOL_OP ()
 
+  let destroy_all =
+    call ~name:"destroy_all" ~lifecycle:[]
+      ~params:
+        [
+          ( Option DateTime
+          , "before"
+          , "Cutoff time for destroyed messages - any messages dated after \
+             this will not be destroyed"
+          )
+        ; ( Option DateTime
+          , "after"
+          , "Cutoff time for destroyed messages - any messages dated before \
+             this timestamp will not be destroyed"
+          )
+        ; (Option Int, "priority", "Priority of messages to destroy")
+        ]
+      ~allowed_roles:_R_POOL_OP ()
+
   let get_all =
     call ~name:"get_all"
       ~lifecycle:[(Published, rel_orlando, "")]
@@ -9002,6 +9020,7 @@ module Message = struct
           create
         ; destroy
         ; destroy_many
+        ; destroy_all
         ; get
         ; get_all
         ; get_since

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

@@ -1418,6 +1418,25 @@ 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
+    with _ -> fail "invalid timestamp format for 'before' (expected RFC3339)"
+  in
+  let after =
+    try Option.map Date.of_iso8601 after_str
+    with _ -> fail "Invalid timestamp format for 'after' (expected RFC3339)"
+  in
+  let priority =
+    try Option.map Int64.of_string priority_str
+    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,41 @@ 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_before_timestamp =
+    match before with
+    | None ->
+        fun _ -> true
+    | Some timestamp ->
+        Date.is_later ~than:timestamp
+  in
+  let filter_after_timestamp =
+    match after with
+    | None ->
+        fun _ -> true
+    | Some timestamp ->
+        Date.is_earlier ~than:timestamp
+  in
+  let filter_timestamp ts =
+    filter_before_timestamp ts && filter_after_timestamp ts
+  in
+  let priority_filter =
+    match priority with
+    | None ->
+        fun _ -> true
+    | Some p ->
+        fun prio -> prio == p
+  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