From e7a0657ab3f0fcc5eaa8bcbec8b7075e1d5039ea Mon Sep 17 00:00:00 2001
From: Rudy Matela <rudy.matela@channable.com>
Date: Fri, 15 Jul 2022 15:57:43 +0200
Subject: [PATCH 01/12] Pass PullRequestId to tryIntegrate

... this is for now ignored so there are no changes in app behaviour.

In the future, this will be used to qualify the test branch with the id of the
originating PR.
---
 src/Logic.hs  | 10 +++---
 tests/Spec.hs | 85 +++++++++++++++++++++++++++++++++------------------
 2 files changed, 61 insertions(+), 34 deletions(-)

diff --git a/src/Logic.hs b/src/Logic.hs
index cac66ecc..f82b9a29 100644
--- a/src/Logic.hs
+++ b/src/Logic.hs
@@ -78,7 +78,7 @@ data ActionFree a
   = TryIntegrate
     -- This is a record type, but the names are currently only used for documentation.
     { _mergeCommitMessage   :: Text
-    , _integrationCandidate :: (Branch, Sha)
+    , _integrationCandidate :: (PullRequestId, Branch, Sha)
     , _alwaysAddMergeCommit :: Bool
     , _cont                 :: Either IntegrationFailure Sha -> a
     }
@@ -117,7 +117,7 @@ doGit = hoistFree (InR . InL)
 doGithub :: GithubOperation a -> Operation a
 doGithub = hoistFree (InR . InR)
 
-tryIntegrate :: Text -> (Branch, Sha) -> Bool -> Action (Either IntegrationFailure Sha)
+tryIntegrate :: Text -> (PullRequestId, Branch, Sha) -> Bool -> Action (Either IntegrationFailure Sha)
 tryIntegrate mergeMessage candidate alwaysAddMergeCommit = liftF $ TryIntegrate mergeMessage candidate alwaysAddMergeCommit id
 
 -- Try to fast-forward the remote target branch (usually master) to the new sha.
@@ -157,14 +157,14 @@ getDateTime = liftF $ GetDateTime id
 -- Interpreter that translates high-level actions into more low-level ones.
 runAction :: ProjectConfiguration -> Action a -> Operation a
 runAction config = foldFree $ \case
-  TryIntegrate message (ref, sha) alwaysAddMergeCommit cont -> do
+  TryIntegrate message (PullRequestId _, ref, sha) alwaysAddMergeCommit cont -> do
     doGit $ ensureCloned config
     shaOrFailed <- doGit $ Git.tryIntegrate
       message
       ref
       sha
       (Git.RemoteBranch $ Config.branch config)
-      (Git.Branch $ Config.testBranch config)
+      (Git.Branch $ Config.testBranch config) -- TODO: use PullRequestId here
       alwaysAddMergeCommit
 
     case shaOrFailed of
@@ -617,7 +617,7 @@ tryIntegratePullRequest pr state =
     Approval (Username approvedBy) approvalType _prOrder = fromJust $ Pr.approval pullRequest
     candidateSha = Pr.sha pullRequest
     candidateRef = getPullRequestRef pr
-    candidate = (candidateRef, candidateSha)
+    candidate = (pr, candidateRef, candidateSha)
     mergeMessageLines =
       [ format "Merge #{}: {}" (prNumber, title)
       , ""
diff --git a/tests/Spec.hs b/tests/Spec.hs
index c7e93752..7a2ee0ef 100644
--- a/tests/Spec.hs
+++ b/tests/Spec.hs
@@ -1,4 +1,5 @@
--- Hoff -- A gatekeeper for your commits
+-- Hoff
+-- A gatekeeper for your commits
 -- Copyright 2016 Ruud van Asseldonk
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
@@ -87,7 +88,7 @@ candidateState pr prBranch baseBranch prSha prAuthor approvedBy candidateSha
 data ActionFlat
   = ATryIntegrate
     { mergeMessage         :: Text
-    , integrationCandidate :: (Branch, Sha)
+    , integrationCandidate :: (PullRequestId, Branch, Sha)
     , alwaysAddMergeCommit :: Bool
     }
   | ATryPromote Branch Sha
@@ -449,7 +450,8 @@ main = hspec $ do
       actions1 `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment (PullRequestId 1) "Pull request approved for merge by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "a38") False
+        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "a38") False
         , ALeaveComment (PullRequestId 1)
             "Failed to rebase, please rebase manually using\n\n\
             \    git rebase --interactive --autosquash origin/master p"
@@ -475,7 +477,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment (PullRequestId 1) "Pull request approved for merge by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Add Nexus 7 experiment\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "a38") False
+        , ATryIntegrate "Merge #1: Add Nexus 7 experiment\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "a38") False
         , ALeaveComment (PullRequestId 1) "Rebased as b71, waiting for CI …"
         , AIsReviewer "deckard"
         , ALeaveComment (PullRequestId 2) "Pull request approved for merge by @deckard, waiting for rebase behind one pull request."
@@ -502,7 +505,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment (PullRequestId 1) "Pull request approved for merge by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Add Nexus 7 experiment\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "a38") False
+        , ATryIntegrate "Merge #1: Add Nexus 7 experiment\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "a38") False
         , ALeaveComment (PullRequestId 1) "Rebased as b71, waiting for CI …"
         , AIsReviewer "deckard"
         , ALeaveComment (PullRequestId 3) "Pull request approved for merge by @deckard, waiting for rebase behind one pull request."
@@ -559,7 +563,8 @@ main = hspec $ do
       actionsPermuted `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment (PullRequestId 2) "Pull request approved for merge by @deckard, rebasing now."
-        , ATryIntegrate "Merge #2: Some PR\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/2/head", Sha "dec") False
+        , ATryIntegrate "Merge #2: Some PR\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 2, Branch "refs/pull/2/head", Sha "dec") False
         , ALeaveComment (PullRequestId 2) "Rebased as b71, waiting for CI …"
         , AIsReviewer "deckard"
         , ALeaveComment (PullRequestId 1) "Pull request approved for merge by @deckard, waiting for rebase behind one pull request."
@@ -593,12 +598,14 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment (PullRequestId 1) "Pull request approved for merge by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Add Nexus 7 experiment\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "a38") False
+        , ATryIntegrate "Merge #1: Add Nexus 7 experiment\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "a38") False
         , ALeaveComment (PullRequestId 1) "Rebased as b71, waiting for CI …"
         , AIsReviewer "deckard"
         , ALeaveComment (PullRequestId 2) "Pull request approved for merge by @deckard, waiting for rebase behind one pull request."
         , ALeaveComment (PullRequestId 1) "Abandoning this pull request because it was closed."
-        , ATryIntegrate "Merge #2: Some PR\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/2/head", Sha "dec") False
+        , ATryIntegrate "Merge #2: Some PR\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 2, Branch "refs/pull/2/head", Sha "dec") False
         , ALeaveComment (PullRequestId 2) "Rebased as b72, waiting for CI …"
         ]
 
@@ -705,7 +712,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment prId "Pull request approved for merge and deploy by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: true\n" (Branch "refs/pull/1/head", Sha "abc1234") True
+        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: true\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "abc1234") True
         , ALeaveComment prId "Rebased as def2345, waiting for CI \x2026"
         ]
 
@@ -725,7 +733,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment prId "Pull request approved for merge and deploy by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: true\n" (Branch "refs/pull/1/head", Sha "abc1234") True
+        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: true\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "abc1234") True
         , ALeaveComment prId "Rebased as def2345, waiting for CI \x2026"
         ]
 
@@ -745,7 +754,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment prId "Pull request approved for merge and tag by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "abc1234") False
+        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "abc1234") False
         , ALeaveComment prId "Rebased as def2345, waiting for CI \x2026"
         ]
 
@@ -765,7 +775,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment prId "Pull request approved for merge and tag by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "abc1234") False
+        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "abc1234") False
         , ALeaveComment prId "Rebased as def2345, waiting for CI \x2026"
         ]
 
@@ -785,7 +796,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment prId "Pull request approved for merge and tag by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "abc1234") False
+        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "abc1234") False
         , ALeaveComment prId "Rebased as def2345, waiting for CI \x2026"
         ]
 
@@ -805,7 +817,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment prId "Pull request approved for merge and tag by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "abc1234") False
+        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "abc1234") False
         , ALeaveComment prId "Rebased as def2345, waiting for CI \x2026"
         ]
 
@@ -825,7 +838,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment prId "Pull request approved for merge by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "abc1234") False
+        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "abc1234") False
         , ALeaveComment prId "Rebased as def2345, waiting for CI \x2026"
         ]
 
@@ -845,7 +859,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment prId "Pull request approved for merge by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "abc1234") False
+        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "abc1234") False
         , ALeaveComment prId "Rebased as def2345, waiting for CI \x2026"
         ]
 
@@ -878,7 +893,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "bot"
         , ALeaveComment prId "Pull request approved for merge by @bot, rebasing now."
-        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: bot\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "abc1234") False
+        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: bot\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "abc1234") False
         , ALeaveComment prId "Rebased as def2345, waiting for CI \x2026"
         ]
 
@@ -944,7 +960,7 @@ main = hspec $ do
         , ALeaveComment prId "Pull request approved for merge by @deckard, rebasing now."
         , ATryIntegrate
             { mergeMessage = "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n"
-            , integrationCandidate = (Branch "refs/pull/1/head", Sha "abc1234")
+            , integrationCandidate = (PullRequestId 1, Branch "refs/pull/1/head", Sha "abc1234")
             , alwaysAddMergeCommit = False
             }
         , ALeaveComment (PullRequestId 1)
@@ -986,7 +1002,8 @@ main = hspec $ do
         , ALeaveComment (PullRequestId 1) "Merge rejected: the target branch must be the integration branch."
         , AIsReviewer (Username "deckard")
         , ALeaveComment (PullRequestId 1) "Pull request approved for merge by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "abc1234") False
+        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "abc1234") False
         , ALeaveComment (PullRequestId 1) "Rebased as def2345, waiting for CI \8230"
         ]
 
@@ -1010,7 +1027,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer (Username "deckard")
         , ALeaveComment (PullRequestId 1) "Pull request approved for merge by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "abc1234") False
+        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "abc1234") False
         , ALeaveComment (PullRequestId 1) "Rebased as def2345, waiting for CI \8230"
         , ALeaveComment (PullRequestId 1) "Stopping integration because the PR changed after approval."
         ]
@@ -1035,7 +1053,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer (Username "deckard")
         , ALeaveComment (PullRequestId 1) "Pull request approved for merge by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "abc1234") False
+        , ATryIntegrate "Merge #1: Untitled\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "abc1234") False
         , ALeaveComment (PullRequestId 1) "Rebased as def2345, waiting for CI \8230"
         , ALeaveComment (PullRequestId 1) "Stopping integration because the PR changed after approval."
         ]
@@ -1060,7 +1079,8 @@ main = hspec $ do
       Project.integrationStatus pullRequest `shouldBe` Project.Integrated (Sha "38c") (Project.BuildPending Nothing)
       prId    `shouldBe` PullRequestId 1
       actions `shouldBe`
-        [ ATryIntegrate "Merge #1: Untitled\n\nApproved-by: fred\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "f34") False
+        [ ATryIntegrate "Merge #1: Untitled\n\nApproved-by: fred\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "f34") False
         , ALeaveComment (PullRequestId 1) "Rebased as 38c, waiting for CI \x2026"
         ]
     it "finds a new candidate with multiple PRs" $ do
@@ -1081,7 +1101,8 @@ main = hspec $ do
       Project.integrationStatus pullRequest `shouldBe` Project.Integrated (Sha "38c") (Project.BuildPending Nothing)
       prId    `shouldBe` PullRequestId 2
       actions `shouldBe`
-        [ ATryIntegrate "Merge #2: Another untitled\n\nApproved-by: fred\nAuto-deploy: false\n" (Branch "refs/pull/2/head", Sha "g35") False
+        [ ATryIntegrate "Merge #2: Another untitled\n\nApproved-by: fred\nAuto-deploy: false\n"
+                        (PullRequestId 2, Branch "refs/pull/2/head", Sha "g35") False
         , ALeaveComment (PullRequestId 2) "Rebased as 38c, waiting for CI \x2026"
         ]
 
@@ -1232,7 +1253,8 @@ main = hspec $ do
       Project.integrationAttempts pullRequest' `shouldBe` [Sha "38d"]
       actions `shouldBe`
         [ ATryPromote (Branch "results/rachael") (Sha "38d")
-        , ATryIntegrate "Merge #1: Add my test results\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "f35") False
+        , ATryIntegrate "Merge #1: Add my test results\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "f35") False
         , ALeaveComment (PullRequestId 1) "Rebased as 38e, waiting for CI \x2026"
         ]
 
@@ -1269,7 +1291,8 @@ main = hspec $ do
       Project.integrationAttempts pullRequest' `shouldBe` [Sha "38d"]
       actions `shouldBe`
         [ ATryPromoteWithTag (Branch "results/rachael") (Sha "38d") (TagName "v2") (TagMessage "v2\n\nchangelog")
-        , ATryIntegrate "Merge #1: Add my test results\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "f35") False
+        , ATryIntegrate "Merge #1: Add my test results\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "f35") False
         , ALeaveComment (PullRequestId 1) "Rebased as 38e, waiting for CI \x2026"
         ]
 
@@ -1309,13 +1332,15 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment (PullRequestId 1) "Pull request approved for merge by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Add Nexus 7 experiment\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "a39") False
+        , ATryIntegrate "Merge #1: Add Nexus 7 experiment\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "a39") False
           -- The first rebase succeeds.
         , ALeaveComment (PullRequestId 1) "Rebased as b71, waiting for CI \x2026"
           -- The first promotion attempt fails
         , ATryPromote (Branch "n7") (Sha "b71")
           -- The second rebase fails.
-        , ATryIntegrate "Merge #1: Add Nexus 7 experiment\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "a39") False
+        , ATryIntegrate "Merge #1: Add Nexus 7 experiment\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "a39") False
         , ALeaveComment (PullRequestId 1)
             "Failed to rebase, please rebase manually using\n\n\
             \    git rebase --interactive --autosquash origin/master n7"
@@ -1361,7 +1386,8 @@ main = hspec $ do
       cId     `shouldBe` PullRequestId 2
       actions `shouldBe`
         [ ATryPromote (Branch "results/leon") (Sha "38d")
-        , ATryIntegrate "Merge #2: Add my test results\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/2/head", Sha "f37") False
+        , ATryIntegrate "Merge #2: Add my test results\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 2, Branch "refs/pull/2/head", Sha "f37") False
         , ALeaveComment (PullRequestId 2) "Rebased as 38e, waiting for CI \x2026"
         ]
 
@@ -1393,7 +1419,8 @@ main = hspec $ do
       actions `shouldBe`
         [ AIsReviewer "deckard"
         , ALeaveComment (PullRequestId 1) "Pull request approved for merge by @deckard, rebasing now."
-        , ATryIntegrate "Merge #1: Add Nexus 7 experiment\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/1/head", Sha "a39") False
+        , ATryIntegrate "Merge #1: Add Nexus 7 experiment\n\nApproved-by: deckard\nAuto-deploy: false\n"
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "a39") False
         , ALeaveComment (PullRequestId 1) "Rebased as b71, waiting for CI \x2026"
         , ALeaveComment (PullRequestId 1) "Waiting on CI job: https://status.example.com/b71"
         , ALeaveComment (PullRequestId 1) "The build failed: https://example.com/build-status\nIf this is the result of a flaky test, close and reopen the PR, then tag me again.\nOtherwise, push a new commit and tag me again."

From ee767c6b1eb6dc6f6c2c5c5c42b3820e92d3643a Mon Sep 17 00:00:00 2001
From: Rudy Matela <rudy.matela@channable.com>
Date: Fri, 15 Jul 2022 16:09:16 +0200
Subject: [PATCH 02/12] Qualify testing branch name by PullRequestId

... in order to support CI parallel execution of testing branches (merge train)
---
 src/Logic.hs           | 7 +++++--
 tests/EventLoopSpec.hs | 6 +++---
 2 files changed, 8 insertions(+), 5 deletions(-)

diff --git a/src/Logic.hs b/src/Logic.hs
index f82b9a29..5fe1f596 100644
--- a/src/Logic.hs
+++ b/src/Logic.hs
@@ -157,14 +157,14 @@ getDateTime = liftF $ GetDateTime id
 -- Interpreter that translates high-level actions into more low-level ones.
 runAction :: ProjectConfiguration -> Action a -> Operation a
 runAction config = foldFree $ \case
-  TryIntegrate message (PullRequestId _, ref, sha) alwaysAddMergeCommit cont -> do
+  TryIntegrate message (pr, ref, sha) alwaysAddMergeCommit cont -> do
     doGit $ ensureCloned config
     shaOrFailed <- doGit $ Git.tryIntegrate
       message
       ref
       sha
       (Git.RemoteBranch $ Config.branch config)
-      (Git.Branch $ Config.testBranch config) -- TODO: use PullRequestId here
+      (Git.Branch $ Config.testBranch config <> "/" <> pullRequestIdToText pr)
       alwaysAddMergeCommit
 
     case shaOrFailed of
@@ -792,3 +792,6 @@ messageForTag :: TagName -> ApprovedFor -> Text -> TagMessage
 messageForTag (TagName tagName) tagOrDeploy changelog =
   TagMessage $ tagName <> mark <> "\n\n" <> changelog
   where mark = if Pr.needsDeploy tagOrDeploy then " (autodeploy)" else ""
+
+pullRequestIdToText :: PullRequestId -> Text
+pullRequestIdToText (PullRequestId prid) = Text.pack $ show prid
diff --git a/tests/EventLoopSpec.hs b/tests/EventLoopSpec.hs
index da9deddc..e1172625 100644
--- a/tests/EventLoopSpec.hs
+++ b/tests/EventLoopSpec.hs
@@ -409,7 +409,7 @@ eventLoopSpec = parallel $ do
       -- if there are no other PRs depending on it.
       -- The other branches should be left untouched.
       branches `shouldMatchList`
-        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused", "integration"]
+        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused", "integration/4"]
 
     it "handles a fast-forwardable pull request with tag" $ do
       (history, _branches, tagRefs, tagAnns) <- withTestEnv' $ \ shas runLoop _git -> do
@@ -555,7 +555,7 @@ eventLoopSpec = parallel $ do
       -- if there are no other PRs depending on it.
       -- The other branches should be left untouched.
       branches `shouldMatchList`
-        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused", "integration"]
+        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused", "integration/6"]
 
     it "handles a non-conflicting non-fast-forwardable pull request with tag" $ do
       (history, _branches, tagRefs, tagAnns) <- withTestEnv' $ \ shas runLoop _git -> do
@@ -1210,4 +1210,4 @@ eventLoopSpec = parallel $ do
         , "* c0"
         ]
       branches `shouldMatchList`
-        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused", "integration"]
+        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused", "integration/8"]

From bc272731ff28fe088b71cf84b006698cbb3334c7 Mon Sep 17 00:00:00 2001
From: Rudy Matela <rudy.matela@channable.com>
Date: Fri, 15 Jul 2022 17:04:25 +0200
Subject: [PATCH 03/12] Add (unused) DeleteBranch operation

---
 src/Git.hs | 17 +++++++++++++++++
 1 file changed, 17 insertions(+)

diff --git a/src/Git.hs b/src/Git.hs
index fd402075..9bafb7d2 100644
--- a/src/Git.hs
+++ b/src/Git.hs
@@ -35,6 +35,7 @@ module Git
   callGit,
   clone,
   deleteTag,
+  deleteBranch,
   doesGitDirectoryExist,
   fetchBranch,
   fetchBranchWithTags,
@@ -200,6 +201,7 @@ data GitOperationFree a
   | ShortLog SomeRefSpec SomeRefSpec (Maybe Text -> a)
   | Tag Sha TagName TagMessage (TagResult -> a)
   | DeleteTag TagName a
+  | DeleteBranch Branch (PushResult -> a)
   | CheckOrphanFixups Sha RemoteBranch (Bool -> a)
   deriving (Functor)
 
@@ -260,6 +262,9 @@ tag' sha t@(TagName name) = tag sha t (TagMessage name)
 deleteTag :: TagName -> GitOperation ()
 deleteTag t = liftF $ DeleteTag t ()
 
+deleteBranch :: Branch -> GitOperation PushResult
+deleteBranch branch = liftF $ DeleteBranch branch id
+
 checkOrphanFixups :: Sha -> RemoteBranch -> GitOperation Bool
 checkOrphanFixups sha branch = liftF $ CheckOrphanFixups sha branch id
 
@@ -355,6 +360,14 @@ runGit userConfig repoDir operation =
           pure . cont $ PushRejected message
         Right _ -> pure $ cont PushOk
 
+    DeleteBranch branch cont -> do
+      gitResult <- callGitInRepo ["push", "-d", refSpec branch]
+      case gitResult of
+        Right _ -> pure $ cont PushOk
+        Left (_, message) -> do
+          logWarnN $ "error: git push -d failed. Reason: " <> message
+          pure $ cont $ PushRejected message
+
     Rebase sha remoteBranch cont -> do
       -- Do an interactive rebase with editor set to /usr/bin/true, so we just
       -- accept the default action, which is effectively a non-interactive rebase.
@@ -535,6 +548,10 @@ runGitReadOnly userConfig repoDir operation =
         let errorMsg = Text.concat ["Would have pushed ", sha, " to ", branch]
         logInfoN errorMsg
         pure . cont $ PushRejected errorMsg
+      DeleteBranch (Branch branch) cont -> do
+        let errorMsg = Text.concat ["Would have deleted remote branch ", branch]
+        logInfoN errorMsg
+        pure . cont $ PushRejected errorMsg
       PushAtomic refs cont -> do
         let errorMsg = "Would have pushed atomically the following refs: "
                     <> Text.intercalate "," (map (Text.pack . refSpec) refs)

From 89ee9b440005bd3484ddc778921dc4dcf41eb687 Mon Sep 17 00:00:00 2001
From: Rudy Matela <rudy.matela@channable.com>
Date: Tue, 19 Jul 2022 12:01:27 +0200
Subject: [PATCH 04/12] initial version of test branch cleaning up

---
 src/Logic.hs  | 12 +++++++++++-
 tests/Spec.hs | 15 +++++++++++++--
 2 files changed, 24 insertions(+), 3 deletions(-)

diff --git a/src/Logic.hs b/src/Logic.hs
index 5fe1f596..7ae4c39d 100644
--- a/src/Logic.hs
+++ b/src/Logic.hs
@@ -84,6 +84,7 @@ data ActionFree a
     }
   | TryPromote Branch Sha (PushResult -> a)
   | TryPromoteWithTag Branch Sha TagName TagMessage (PushWithTagResult -> a)
+  | CleanupTestBranch PullRequestId a
   | LeaveComment PullRequestId Text a
   | IsReviewer Username (Bool -> a)
   | GetPullRequest PullRequestId (Maybe GithubApi.PullRequest -> a)
@@ -131,6 +132,9 @@ tryPromoteWithTag :: Branch -> Sha -> TagName -> TagMessage -> Action PushWithTa
 tryPromoteWithTag prBranch newHead tagName tagMessage =
   liftF $ TryPromoteWithTag prBranch newHead tagName tagMessage id
 
+cleanupTestBranch :: PullRequestId -> Action ()
+cleanupTestBranch pullRequestId = liftF $ CleanupTestBranch pullRequestId ()
+
 -- Leave a comment on the given pull request.
 leaveComment :: PullRequestId -> Text -> Action ()
 leaveComment pr body = liftF $ LeaveComment pr body ()
@@ -191,6 +195,10 @@ runAction config = foldFree $ \case
             -- Deleting tag after atomic push is important to maintain one "source of truth", namely
             -- the origin
 
+  CleanupTestBranch pr cont -> do
+    _ <- doGit $ Git.deleteBranch (Git.Branch $ Config.testBranch config <> "/" <> pullRequestIdToText pr) -- TODO: DRY!
+    pure cont
+
   LeaveComment pr body cont -> do
     doGithub $ GithubApi.leaveComment pr body
     pure cont
@@ -688,7 +696,9 @@ pushCandidate (pullRequestId, pullRequest) newHead state =
       -- GitHub will mark the pull request as closed, and when we receive that
       -- event, we delete the pull request from the state. Until then, reset
       -- the integration candidate, so we proceed with the next pull request.
-      PushOk -> pure $ Pr.setIntegrationStatus pullRequestId Promoted state
+      PushOk -> do
+        cleanupTestBranch pullRequestId
+        pure $ Pr.setIntegrationStatus pullRequestId Promoted state
       -- If something was pushed to the target branch while the candidate was
       -- being tested, try to integrate again and hope that next time the push
       -- succeeds.
diff --git a/tests/Spec.hs b/tests/Spec.hs
index 7a2ee0ef..5d479be7 100644
--- a/tests/Spec.hs
+++ b/tests/Spec.hs
@@ -95,6 +95,7 @@ data ActionFlat
   | ATryPromoteWithTag Branch Sha TagName TagMessage
   | ALeaveComment PullRequestId Text
   | AIsReviewer Username
+  | ACleanupTestBranch PullRequestId
   | AGetPullRequest PullRequestId
   | AGetOpenPullRequests
   deriving (Eq, Show)
@@ -210,6 +211,9 @@ runActionRws =
       TryPromoteWithTag prBranch headSha newTag tagMessage cont -> do
         Rws.tell [ATryPromoteWithTag prBranch headSha newTag tagMessage]
         cont . (Right newTag, ) <$> takeResultPush
+      CleanupTestBranch pr cont -> do
+        Rws.tell [ACleanupTestBranch pr]
+        pure cont
       LeaveComment pr body cont -> do
         Rws.tell [ALeaveComment pr body]
         pure cont
@@ -1128,7 +1132,9 @@ main = hspec $ do
         candidates = getIntegrationCandidates state'
       -- After a successful push, the candidate should be gone.
       candidates `shouldBe` []
-      actions    `shouldBe` [ATryPromote (Branch "results/rachael") (Sha "38d")]
+      actions    `shouldBe` [ ATryPromote (Branch "results/rachael") (Sha "38d")
+                            , ACleanupTestBranch (PullRequestId 1)
+                            ]
 
     it "pushes and tags with a new version after a successful build (merge and tag)" $ do
       let
@@ -1160,6 +1166,7 @@ main = hspec $ do
             (TagMessage "v2\n\nchangelog")
         , ALeaveComment (PullRequestId 1)
             "@deckard I tagged your PR with `v2`. Don't forget to deploy it!"
+        , ACleanupTestBranch (PullRequestId 1)
         ]
 
     it "pushes and tags with a new version after a successful build (merge and deploy)" $ do
@@ -1192,6 +1199,7 @@ main = hspec $ do
             (TagMessage "v2 (autodeploy)\n\nchangelog")
         , ALeaveComment (PullRequestId 1)
             "@deckard I tagged your PR with `v2`. It is scheduled for autodeploy!"
+        , ACleanupTestBranch (PullRequestId 1)
         ]
 
     it "pushes after successful build even if tagging failed" $ do
@@ -1218,7 +1226,9 @@ main = hspec $ do
       -- After a successful push, the candidate should be gone.
       candidates `shouldBe` []
       actions    `shouldBe` [ ALeaveComment (PullRequestId 1) "@deckard Sorry, I could not tag your PR. The previous tag `abcdef` seems invalid"
-                           , ATryPromote (Branch "results/rachael") (Sha "38d")]
+                            , ATryPromote (Branch "results/rachael") (Sha "38d")
+                            , ACleanupTestBranch (PullRequestId 1)
+                            ]
 
 
     it "restarts the sequence after a rejected push" $ do
@@ -1386,6 +1396,7 @@ main = hspec $ do
       cId     `shouldBe` PullRequestId 2
       actions `shouldBe`
         [ ATryPromote (Branch "results/leon") (Sha "38d")
+        , ACleanupTestBranch (PullRequestId 1)
         , ATryIntegrate "Merge #2: Add my test results\n\nApproved-by: deckard\nAuto-deploy: false\n"
                         (PullRequestId 2, Branch "refs/pull/2/head", Sha "f37") False
         , ALeaveComment (PullRequestId 2) "Rebased as 38e, waiting for CI \x2026"

From 7106c70a53b2713a96114fc828b5f2dc6eca5134 Mon Sep 17 00:00:00 2001
From: Rudy Matela <rudy.matela@channable.com>
Date: Tue, 19 Jul 2022 13:43:54 +0200
Subject: [PATCH 05/12] src/Git: rename DeleteBranch to DeleteRemoteBranch

... in preparation for an actual DeleteBranch operation that deletes a branch
locally.
---
 src/Git.hs   | 12 ++++++------
 src/Logic.hs |  2 +-
 2 files changed, 7 insertions(+), 7 deletions(-)

diff --git a/src/Git.hs b/src/Git.hs
index 9bafb7d2..dfba0c5a 100644
--- a/src/Git.hs
+++ b/src/Git.hs
@@ -35,7 +35,7 @@ module Git
   callGit,
   clone,
   deleteTag,
-  deleteBranch,
+  deleteRemoteBranch,
   doesGitDirectoryExist,
   fetchBranch,
   fetchBranchWithTags,
@@ -201,7 +201,7 @@ data GitOperationFree a
   | ShortLog SomeRefSpec SomeRefSpec (Maybe Text -> a)
   | Tag Sha TagName TagMessage (TagResult -> a)
   | DeleteTag TagName a
-  | DeleteBranch Branch (PushResult -> a)
+  | DeleteRemoteBranch Branch (PushResult -> a)
   | CheckOrphanFixups Sha RemoteBranch (Bool -> a)
   deriving (Functor)
 
@@ -262,8 +262,8 @@ tag' sha t@(TagName name) = tag sha t (TagMessage name)
 deleteTag :: TagName -> GitOperation ()
 deleteTag t = liftF $ DeleteTag t ()
 
-deleteBranch :: Branch -> GitOperation PushResult
-deleteBranch branch = liftF $ DeleteBranch branch id
+deleteRemoteBranch :: Branch -> GitOperation PushResult
+deleteRemoteBranch branch = liftF $ DeleteRemoteBranch branch id
 
 checkOrphanFixups :: Sha -> RemoteBranch -> GitOperation Bool
 checkOrphanFixups sha branch = liftF $ CheckOrphanFixups sha branch id
@@ -360,7 +360,7 @@ runGit userConfig repoDir operation =
           pure . cont $ PushRejected message
         Right _ -> pure $ cont PushOk
 
-    DeleteBranch branch cont -> do
+    DeleteRemoteBranch branch cont -> do
       gitResult <- callGitInRepo ["push", "-d", refSpec branch]
       case gitResult of
         Right _ -> pure $ cont PushOk
@@ -548,7 +548,7 @@ runGitReadOnly userConfig repoDir operation =
         let errorMsg = Text.concat ["Would have pushed ", sha, " to ", branch]
         logInfoN errorMsg
         pure . cont $ PushRejected errorMsg
-      DeleteBranch (Branch branch) cont -> do
+      DeleteRemoteBranch (Branch branch) cont -> do
         let errorMsg = Text.concat ["Would have deleted remote branch ", branch]
         logInfoN errorMsg
         pure . cont $ PushRejected errorMsg
diff --git a/src/Logic.hs b/src/Logic.hs
index 7ae4c39d..3e1c7194 100644
--- a/src/Logic.hs
+++ b/src/Logic.hs
@@ -196,7 +196,7 @@ runAction config = foldFree $ \case
             -- the origin
 
   CleanupTestBranch pr cont -> do
-    _ <- doGit $ Git.deleteBranch (Git.Branch $ Config.testBranch config <> "/" <> pullRequestIdToText pr) -- TODO: DRY!
+    _ <- doGit $ Git.deleteRemoteBranch (Git.Branch $ Config.testBranch config <> "/" <> pullRequestIdToText pr) -- TODO: DRY!
     pure cont
 
   LeaveComment pr body cont -> do

From 62308f7d87515ecdba2b22b7c940412959513fea Mon Sep 17 00:00:00 2001
From: Rudy Matela <rudy.matela@channable.com>
Date: Tue, 19 Jul 2022 13:48:25 +0200
Subject: [PATCH 06/12] add and use the deleteBranch operation

... that deletes a branch locally
---
 src/Git.hs   | 8 ++++++++
 src/Logic.hs | 1 +
 2 files changed, 9 insertions(+)

diff --git a/src/Git.hs b/src/Git.hs
index dfba0c5a..d395dda0 100644
--- a/src/Git.hs
+++ b/src/Git.hs
@@ -35,6 +35,7 @@ module Git
   callGit,
   clone,
   deleteTag,
+  deleteBranch,
   deleteRemoteBranch,
   doesGitDirectoryExist,
   fetchBranch,
@@ -201,6 +202,7 @@ data GitOperationFree a
   | ShortLog SomeRefSpec SomeRefSpec (Maybe Text -> a)
   | Tag Sha TagName TagMessage (TagResult -> a)
   | DeleteTag TagName a
+  | DeleteBranch Branch a
   | DeleteRemoteBranch Branch (PushResult -> a)
   | CheckOrphanFixups Sha RemoteBranch (Bool -> a)
   deriving (Functor)
@@ -262,6 +264,9 @@ tag' sha t@(TagName name) = tag sha t (TagMessage name)
 deleteTag :: TagName -> GitOperation ()
 deleteTag t = liftF $ DeleteTag t ()
 
+deleteBranch :: Branch -> GitOperation ()
+deleteBranch t = liftF $ DeleteBranch t ()
+
 deleteRemoteBranch :: Branch -> GitOperation PushResult
 deleteRemoteBranch branch = liftF $ DeleteRemoteBranch branch id
 
@@ -492,6 +497,8 @@ runGit userConfig repoDir operation =
           logInfoN $ format "tagged {} with {}" [show sha, show t]
           pure $ cont $ TagOk t
 
+    DeleteBranch branch cont -> cont <$ callGitInRepo ["branch", "-d", refSpec branch]
+
     DeleteTag t cont -> cont <$ callGitInRepo ["tag", "-d", refSpec t]
 
     CheckOrphanFixups sha branch cont -> do
@@ -537,6 +544,7 @@ runGitReadOnly userConfig repoDir operation =
       ShortLog {} -> unsafeResult
       Tag {} -> unsafeResult
       DeleteTag {} -> unsafeResult
+      DeleteBranch {} -> unsafeResult
       CheckOrphanFixups {} -> unsafeResult
 
       -- These operations mutate the remote, so we don't execute them in
diff --git a/src/Logic.hs b/src/Logic.hs
index 3e1c7194..36197933 100644
--- a/src/Logic.hs
+++ b/src/Logic.hs
@@ -196,6 +196,7 @@ runAction config = foldFree $ \case
             -- the origin
 
   CleanupTestBranch pr cont -> do
+    doGit $ Git.deleteBranch (Git.Branch $ Config.testBranch config <> "/" <> pullRequestIdToText pr) -- TODO: DRY!
     _ <- doGit $ Git.deleteRemoteBranch (Git.Branch $ Config.testBranch config <> "/" <> pullRequestIdToText pr) -- TODO: DRY!
     pure cont
 

From b6a2eeb11b9b0b690ca59ecca63e603177b3e09c Mon Sep 17 00:00:00 2001
From: Rudy Matela <rudy.matela@channable.com>
Date: Tue, 19 Jul 2022 13:53:58 +0200
Subject: [PATCH 07/12] refactor: add and use Logic.testBranch (DRY code)

---
 src/Logic.hs | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

diff --git a/src/Logic.hs b/src/Logic.hs
index 36197933..adef2215 100644
--- a/src/Logic.hs
+++ b/src/Logic.hs
@@ -168,7 +168,7 @@ runAction config = foldFree $ \case
       ref
       sha
       (Git.RemoteBranch $ Config.branch config)
-      (Git.Branch $ Config.testBranch config <> "/" <> pullRequestIdToText pr)
+      (testBranch config pr)
       alwaysAddMergeCommit
 
     case shaOrFailed of
@@ -196,8 +196,9 @@ runAction config = foldFree $ \case
             -- the origin
 
   CleanupTestBranch pr cont -> do
-    doGit $ Git.deleteBranch (Git.Branch $ Config.testBranch config <> "/" <> pullRequestIdToText pr) -- TODO: DRY!
-    _ <- doGit $ Git.deleteRemoteBranch (Git.Branch $ Config.testBranch config <> "/" <> pullRequestIdToText pr) -- TODO: DRY!
+    let branch = testBranch config pr
+    doGit $ Git.deleteBranch branch
+    _ <- doGit $ Git.deleteRemoteBranch branch
     pure cont
 
   LeaveComment pr body cont -> do
@@ -806,3 +807,6 @@ messageForTag (TagName tagName) tagOrDeploy changelog =
 
 pullRequestIdToText :: PullRequestId -> Text
 pullRequestIdToText (PullRequestId prid) = Text.pack $ show prid
+
+testBranch :: ProjectConfiguration -> PullRequestId -> Git.Branch
+testBranch config pullRequestId = Git.Branch $ Config.testBranch config <> "/" <> pullRequestIdToText pullRequestId

From 9aeb27f07cf866b4c202fb863f8332d685cce485 Mon Sep 17 00:00:00 2001
From: Rudy Matela <rudy.matela@channable.com>
Date: Tue, 19 Jul 2022 14:56:12 +0200
Subject: [PATCH 08/12] fix bug in deleteRemoteBranch

---
 src/Git.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Git.hs b/src/Git.hs
index d395dda0..b26ea45f 100644
--- a/src/Git.hs
+++ b/src/Git.hs
@@ -366,7 +366,7 @@ runGit userConfig repoDir operation =
         Right _ -> pure $ cont PushOk
 
     DeleteRemoteBranch branch cont -> do
-      gitResult <- callGitInRepo ["push", "-d", refSpec branch]
+      gitResult <- callGitInRepo ["push", "origin", "-d", refSpec branch]
       case gitResult of
         Right _ -> pure $ cont PushOk
         Left (_, message) -> do

From 9e31d7fb0b4ea5a585a8c342c6a78a8022eeacb1 Mon Sep 17 00:00:00 2001
From: Rudy Matela <rudy.matela@channable.com>
Date: Tue, 19 Jul 2022 16:00:09 +0200
Subject: [PATCH 09/12] src/Logic: delete unqualified testing branch

... to maintain backwards compatibility with existing Hoff maintained repos.
---
 src/Logic.hs | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/src/Logic.hs b/src/Logic.hs
index adef2215..2994bb1d 100644
--- a/src/Logic.hs
+++ b/src/Logic.hs
@@ -163,6 +163,12 @@ runAction :: ProjectConfiguration -> Action a -> Operation a
 runAction config = foldFree $ \case
   TryIntegrate message (pr, ref, sha) alwaysAddMergeCommit cont -> do
     doGit $ ensureCloned config
+
+    -- Needed for backwards compatibility with existing repositories
+    -- as we now test at testing/<pr_id> instead of testing.
+    -- When no repositories have a testing branch, this can safely be removed.
+    _ <- doGit $ Git.deleteRemoteBranch $ Git.Branch $ Config.testBranch config
+
     shaOrFailed <- doGit $ Git.tryIntegrate
       message
       ref

From 7a6a694893e7b10a13a8e6ee35870176f3e76a1b Mon Sep 17 00:00:00 2001
From: Rudy Matela <rudy.matela@channable.com>
Date: Tue, 19 Jul 2022 16:06:01 +0200
Subject: [PATCH 10/12] fix failing tests: cleanup of integration branches

---
 tests/EventLoopSpec.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/tests/EventLoopSpec.hs b/tests/EventLoopSpec.hs
index e1172625..b36eff04 100644
--- a/tests/EventLoopSpec.hs
+++ b/tests/EventLoopSpec.hs
@@ -409,7 +409,7 @@ eventLoopSpec = parallel $ do
       -- if there are no other PRs depending on it.
       -- The other branches should be left untouched.
       branches `shouldMatchList`
-        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused", "integration/4"]
+        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused"]
 
     it "handles a fast-forwardable pull request with tag" $ do
       (history, _branches, tagRefs, tagAnns) <- withTestEnv' $ \ shas runLoop _git -> do
@@ -555,7 +555,7 @@ eventLoopSpec = parallel $ do
       -- if there are no other PRs depending on it.
       -- The other branches should be left untouched.
       branches `shouldMatchList`
-        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused", "integration/6"]
+        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused"]
 
     it "handles a non-conflicting non-fast-forwardable pull request with tag" $ do
       (history, _branches, tagRefs, tagAnns) <- withTestEnv' $ \ shas runLoop _git -> do
@@ -1210,4 +1210,4 @@ eventLoopSpec = parallel $ do
         , "* c0"
         ]
       branches `shouldMatchList`
-        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused", "integration/8"]
+        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused"]

From 43b0991cd12b403822b2e09c2de4e15f7ded1678 Mon Sep 17 00:00:00 2001
From: Rudy Matela <rudy.matela@channable.com>
Date: Tue, 19 Jul 2022 16:10:56 +0200
Subject: [PATCH 11/12] EventLoopSpec: add test for a failing build

---
 tests/EventLoopSpec.hs | 26 ++++++++++++++++++++++++++
 1 file changed, 26 insertions(+)

diff --git a/tests/EventLoopSpec.hs b/tests/EventLoopSpec.hs
index b36eff04..32b3dcb0 100644
--- a/tests/EventLoopSpec.hs
+++ b/tests/EventLoopSpec.hs
@@ -411,6 +411,32 @@ eventLoopSpec = parallel $ do
       branches `shouldMatchList`
         fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused"]
 
+    it "keeps the integration test branch on a failing build" $ do
+      (history, branches, _tagRefs, _tagAnns) <- withTestEnv' $ \ shas runLoop _git -> do
+        let
+          [_c0, _c1, _c2, _c3, _c3', c4, _c5, _c6, _c7, _c7f, _c8] = shas
+          -- Note that at the remote, refs/pull/4/head points to c4.
+          pr4 = PullRequestId 4
+          branch = Branch "ahead"
+          baseBranch = masterBranch
+
+        void $ runLoop Project.emptyProjectState
+          [
+            Logic.PullRequestOpened pr4 branch baseBranch c4 "Add Leon test results" "deckard",
+            Logic.CommentAdded pr4 "rachael" "@bot merge",
+            Logic.BuildStatusChanged c4 (BuildFailed Nothing)
+          ]
+      -- the build failed, so master's history is unchanged
+      -- ... and the integration/4 branch is kept for inpection of the CI build
+      history `shouldBe`
+        [ "* c3"
+        , "* c2"
+        , "* c1"
+        , "* c0"
+        ]
+      branches `shouldMatchList`
+        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused", "integration/4"]
+
     it "handles a fast-forwardable pull request with tag" $ do
       (history, _branches, tagRefs, tagAnns) <- withTestEnv' $ \ shas runLoop _git -> do
         let

From 4f43cced94ada44e66e0fd2daca73e10d718cfc6 Mon Sep 17 00:00:00 2001
From: Rudy Matela <rudy.matela@channable.com>
Date: Wed, 27 Jul 2022 17:22:12 +0200
Subject: [PATCH 12/12] fix build of tests/Spec.hs

... which was broken after a rebase
---
 tests/Spec.hs | 17 +++++++++++------
 1 file changed, 11 insertions(+), 6 deletions(-)

diff --git a/tests/Spec.hs b/tests/Spec.hs
index 5d479be7..d27c25f7 100644
--- a/tests/Spec.hs
+++ b/tests/Spec.hs
@@ -1788,7 +1788,7 @@ main = hspec $ do
         , ATryIntegrate "Merge #1: First PR\n\n\
                         \Approved-by: deckard\n\
                         \Auto-deploy: false\n"
-                        (Branch "refs/pull/1/head", Sha "ab1")
+                        (PullRequestId 1, Branch "refs/pull/1/head", Sha "ab1")
                         False
         , ALeaveComment (PullRequestId 1) "Rebased as 1ab, waiting for CI …"
         , AIsReviewer "deckard"
@@ -1801,22 +1801,25 @@ main = hspec $ do
                         "Pull request approved for merge by @deckard, \
                         \waiting for rebase behind 2 pull requests."
         , ATryPromote (Branch "fst") (Sha "1ab")
+        , ACleanupTestBranch (PullRequestId 1)
         , ATryIntegrate "Merge #2: Second PR\n\n\
                         \Approved-by: deckard\n\
                         \Auto-deploy: false\n"
-                        (Branch "refs/pull/2/head", Sha "cd2")
+                        (PullRequestId 2, Branch "refs/pull/2/head", Sha "cd2")
                         False
         , ALeaveComment (PullRequestId 2) "Rebased as 2bc, waiting for CI …"
         , ALeaveComment (PullRequestId 2) "Waiting on CI job: example.com/2bc"
         , ATryPromote (Branch "snd") (Sha "2bc")
+        , ACleanupTestBranch (PullRequestId 2)
         , ATryIntegrate "Merge #3: Third PR\n\n\
                         \Approved-by: deckard\n\
                         \Auto-deploy: false\n"
-                        (Branch "refs/pull/3/head", Sha "ef3")
+                        (PullRequestId 3, Branch "refs/pull/3/head", Sha "ef3")
                         False
         , ALeaveComment (PullRequestId 3) "Rebased as 3cd, waiting for CI …"
         , ALeaveComment (PullRequestId 3) "Waiting on CI job: example.com/3cd"
         , ATryPromote (Branch "trd") (Sha "3cd")
+        , ACleanupTestBranch (PullRequestId 3)
         ]
 
     it "handles a sequence of merges: success, failure, success" $ do
@@ -1875,7 +1878,7 @@ main = hspec $ do
         , ATryIntegrate "Merge #9: Ninth PR\n\n\
                         \Approved-by: deckard\n\
                         \Auto-deploy: false\n"
-                        (Branch "refs/pull/9/head", Sha "ab9")
+                        (PullRequestId 9, Branch "refs/pull/9/head", Sha "ab9")
                         False
         , ALeaveComment (PullRequestId 9) "Rebased as 1ab, waiting for CI …"
         , AIsReviewer "deckard"
@@ -1888,10 +1891,11 @@ main = hspec $ do
                         "Pull request approved for merge by @deckard, \
                         \waiting for rebase behind 2 pull requests."
         , ATryPromote (Branch "nth") (Sha "1ab")
+        , ACleanupTestBranch (PullRequestId 9)
         , ATryIntegrate "Merge #8: Eighth PR\n\n\
                         \Approved-by: deckard\n\
                         \Auto-deploy: false\n"
-                        (Branch "refs/pull/8/head", Sha "cd8")
+                        (PullRequestId 8, Branch "refs/pull/8/head", Sha "cd8")
                         False
         , ALeaveComment (PullRequestId 8) "Rebased as 2bc, waiting for CI …"
         , ALeaveComment (PullRequestId 8) "Waiting on CI job: example.com/2bc"
@@ -1903,9 +1907,10 @@ main = hspec $ do
         , ATryIntegrate "Merge #7: Seventh PR\n\n\
                         \Approved-by: deckard\n\
                         \Auto-deploy: false\n"
-                        (Branch "refs/pull/7/head", Sha "ef7")
+                        (PullRequestId 7, Branch "refs/pull/7/head", Sha "ef7")
                         False
         , ALeaveComment (PullRequestId 7) "Rebased as 3cd, waiting for CI …"
         , ALeaveComment (PullRequestId 7) "Waiting on CI job: example.com/3cd"
         , ATryPromote (Branch "sth") (Sha "3cd")
+        , ACleanupTestBranch (PullRequestId 7)
         ]