From f0b4dcde5856fcb2144c5632e23625bb59a9f3f1 Mon Sep 17 00:00:00 2001
From: Kate <kit-ty-kate@outlook.com>
Date: Thu, 26 Sep 2024 16:36:15 +0100
Subject: [PATCH] Fix the install cache storing the wrong version of the opam
 file after a build or fetch failure

---
 master_changes.md          |  1 +
 src/client/opamSolution.ml | 49 +++++++++++++++++++++++++++++++-------
 tests/reftests/cache.test  | 15 +++---------
 3 files changed, 44 insertions(+), 21 deletions(-)

diff --git a/master_changes.md b/master_changes.md
index 934de6e31a6..0c29a5d423b 100644
--- a/master_changes.md
+++ b/master_changes.md
@@ -22,6 +22,7 @@ users)
 ## Config report
 
 ## Actions
+  * Fix the install cache storing the wrong version of the opam file after a build failure [#6213 @kit-ty-kate]
 
 ## Install
 
diff --git a/src/client/opamSolution.ml b/src/client/opamSolution.ml
index 905d53cd82d..60280adf916 100644
--- a/src/client/opamSolution.ml
+++ b/src/client/opamSolution.ml
@@ -824,15 +824,46 @@ let parallel_apply t
 
   (* 2/ Display errors and finalize *)
 
-  OpamSwitchState.Installed_cache.save
-    (OpamPath.Switch.installed_opams_cache t.switch_global.root t.switch)
-    (OpamPackage.Set.fold (fun nv opams ->
-         let opam =
-           OpamSwitchState.opam t nv |>
-           OpamFile.OPAM.with_metadata_dir None
-         in
-         OpamPackage.Map.add nv opam opams)
-        t.installed OpamPackage.Map.empty);
+  let save_installed_cache failed =
+    OpamSwitchState.Installed_cache.save
+      (OpamPath.Switch.installed_opams_cache t.switch_global.root t.switch)
+      (OpamPackage.Set.fold (fun nv opams ->
+           (* NOTE: We need to know whether an action was successful
+              or not to know which version of the opam file to store
+              in the case: the previous one if it failed, or the new
+              one if it succeeded. *)
+           let pkg_failed =
+             List.exists (function
+                 | `Fetch ps -> List.for_all (OpamPackage.equal nv) ps
+                 | `Build p | `Change (_, _, p) | `Install p
+                 | `Reinstall p | `Remove p -> OpamPackage.equal nv p)
+               failed
+           in
+           let add_to_opams opam =
+             let opam = OpamFile.OPAM.with_metadata_dir None opam in
+             OpamPackage.Map.add nv opam opams
+           in
+           if pkg_failed then
+             match OpamPackage.Map.find_opt nv t.installed_opams with
+             | None -> opams
+             | Some opam -> add_to_opams opam
+           else
+             add_to_opams (OpamSwitchState.opam t nv))
+          t.installed OpamPackage.Map.empty);
+  in
+  begin match action_results with
+  | `Exception _ | `Error Aborted -> ()
+  | `Error (Nothing_to_do | OK _) -> assert false
+  | `Error (Partial_error res) ->
+    let { actions_successes = _;
+          actions_errors;
+          actions_aborted;
+        } = res
+    in
+    save_installed_cache (List.map fst actions_errors @ actions_aborted)
+  | `Successful _ ->
+    save_installed_cache []
+  end;
 
   let cleanup_artefacts graph =
     PackageActionGraph.iter_vertex (function
diff --git a/tests/reftests/cache.test b/tests/reftests/cache.test
index eacc1a0b8e8..8e8012a3852 100644
--- a/tests/reftests/cache.test
+++ b/tests/reftests/cache.test
@@ -76,20 +76,14 @@ build: "true"
 opam-version: "2.0"
 name: "upgrade"
 version: "1"
-build: "false"
+build: "true"
 => always-here.1 <=
 opam-version: "2.0"
 name: "always-here"
 version: "1"
 ### opam upgrade
-The following actions will be performed:
-=== recompile 1 package
-  - recompile upgrade 1 [upstream or system changes]
-
-<><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><>
--> removed   upgrade.1
--> installed upgrade.1
-Done.
+Already up-to-date.
+Nothing to do.
 ### opam-cache installed action-failure
 => upgrade.1 <=
 opam-version: "2.0"
@@ -319,9 +313,6 @@ opam-version: "2.0"
 opam-version: "2.0"
 name: "upgrade"
 version: "1"
-url {
-  src: "file:///inexistent/path"
-}
 => always-here.1 <=
 opam-version: "2.0"
 name: "always-here"