CA-365059: Clear source pool messages after migrating VM

Looks like we weren't moving messages if the VM was on a supporter at all in the past.
This fixes both the issue in the ticket and moves VM messages if the VM was originally on a coordinator.
Using RPC calls since internal xapi calls fail, see #5216 and its revert PR #5239.

Signed-off-by: Danilo Del Busso <[email protected]>

ocaml/xapi/xapi_message.ml

@@ -526,8 +526,8 @@ let destroy ~__context ~self =
           )
     )
   in
-  let basefilename = List.hd (List.rev (String.split_on_char '/' fullpath)) in
-  destroy_real __context basefilename
+  let base_filename = Filename.basename fullpath in
+  destroy_real __context base_filename
 
 let destroy_many ~__context ~messages =
   List.iter (fun self -> destroy ~__context ~self) messages
@@ -817,13 +817,15 @@ let handler (req : Http.Request.t) fd _ =
           (ExnHelper.string_of_exn e)
   )
 
-(* Export messages and send to another host/pool over http. *)
-let send_messages ~__context ~cls ~obj_uuid ~session_id ~remote_address =
-  let msgs = get ~__context ~cls ~obj_uuid ~since:(Date.of_float 0.0) in
-  let body = export_xml msgs in
+(* Export and send given messages to another host/pool over http. *)
+let send_messages ~__context ~cls ~obj_uuid ~session_id ~remote_address
+    ~messages =
+  let body = export_xml messages in
   let query =
     [
-      ("session_id", Ref.string_of session_id); ("cls", "VM"); ("uuid", obj_uuid)
+      ("session_id", Ref.string_of session_id)
+    ; ("cls", Record_util.class_to_string cls)
+    ; ("uuid", obj_uuid)
     ]
   in
   let subtask_of = Context.string_of_task __context in

ocaml/xapi/xapi_vm_migrate.ml

@@ -1602,14 +1602,33 @@ let migrate_send' ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~vgpu_map
       if ha_always_run_reset then
         XenAPI.VM.set_ha_always_run ~rpc:remote.rpc ~session_id:remote.session
           ~self:new_vm ~value:true ;
+
       (* Send non-database metadata *)
-      Xapi_message.send_messages ~__context ~cls:`VM ~obj_uuid:vm_uuid
-        ~session_id:remote.session ~remote_address:remote.remote_master_ip ;
+
+      (* We fetch and destroy messages via RPC calls because they are stored on the master host *)
+      Helpers.call_api_functions ~__context (fun rpc session_id ->
+          let messages =
+            XenAPI.Message.get ~rpc ~session_id ~cls:`VM ~obj_uuid:vm_uuid
+              ~since:Date.epoch
+          in
+          Xapi_message.send_messages ~__context ~cls:`VM ~obj_uuid:vm_uuid
+            ~messages ~session_id:remote.session
+            ~remote_address:remote.remote_master_ip ;
+          info
+            "Destroying %s messages belonging to VM ref=%s uuid=%s from the \
+             source pool, after sending them to the remote pool"
+            (List.length messages |> Int.to_string)
+            (Ref.string_of vm) vm_uuid ;
+          let message_refs = List.rev_map fst messages in
+          XenAPI.Message.destroy_many ~rpc ~session_id ~messages:message_refs
+      ) ;
+
+      (* Signal the remote pool that we're done *)
       Xapi_blob.migrate_push ~__context ~rpc:remote.rpc
         ~remote_address:remote.remote_master_ip ~session_id:remote.session
         ~old_vm:vm ~new_vm
-      (* Signal the remote pool that we're done *)
     ) ;
+
     if (not is_intra_pool) && not copy then (
       info "Destroying VM ref=%s uuid=%s" (Ref.string_of vm) vm_uuid ;
       Xapi_vm_lifecycle.force_state_reset ~__context ~self:vm ~value:`Halted ;

quality-gate.sh

@@ -3,7 +3,7 @@
 set -e
 
 list-hd () {
-  N=318
+  N=317
   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"