Merge #134: Merge train: qualify the test branch by PR id

Approved-by: rudymatela
Auto-deploy: false

src/Git.hs

@@ -35,6 +35,8 @@ module Git
   callGit,
   clone,
   deleteTag,
+  deleteBranch,
+  deleteRemoteBranch,
   doesGitDirectoryExist,
   fetchBranch,
   fetchBranchWithTags,
@@ -200,6 +202,8 @@ 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)
 
@@ -260,6 +264,12 @@ 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
+
 checkOrphanFixups :: Sha -> RemoteBranch -> GitOperation Bool
 checkOrphanFixups sha branch = liftF $ CheckOrphanFixups sha branch id
 
@@ -355,6 +365,14 @@ runGit userConfig repoDir operation =
           pure . cont $ PushRejected message
         Right _ -> pure $ cont PushOk
 
+    DeleteRemoteBranch branch cont -> do
+      gitResult <- callGitInRepo ["push", "origin", "-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.
@@ -479,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
@@ -524,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
@@ -535,6 +556,10 @@ runGitReadOnly userConfig repoDir operation =
         let errorMsg = Text.concat ["Would have pushed ", sha, " to ", branch]
         logInfoN errorMsg
         pure . cont $ PushRejected errorMsg
+      DeleteRemoteBranch (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)

src/Logic.hs

@@ -78,12 +78,13 @@ 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
     }
   | 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)
@@ -117,7 +118,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.
@@ -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 ()
@@ -157,14 +161,20 @@ 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 (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
       sha
       (Git.RemoteBranch $ Config.branch config)
-      (Git.Branch $ Config.testBranch config)
+      (testBranch config pr)
       alwaysAddMergeCommit
 
     case shaOrFailed of
@@ -191,6 +201,12 @@ runAction config = foldFree $ \case
             -- Deleting tag after atomic push is important to maintain one "source of truth", namely
             -- the origin
 
+  CleanupTestBranch pr cont -> do
+    let branch = testBranch config pr
+    doGit $ Git.deleteBranch branch
+    _ <- doGit $ Git.deleteRemoteBranch branch
+    pure cont
+
   LeaveComment pr body cont -> do
     doGithub $ GithubApi.leaveComment pr body
     pure cont
@@ -617,7 +633,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)
       , ""
@@ -688,7 +704,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.
@@ -792,3 +810,9 @@ 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
+
+testBranch :: ProjectConfiguration -> PullRequestId -> Git.Branch
+testBranch config pullRequestId = Git.Branch $ Config.testBranch config <> "/" <> pullRequestIdToText pullRequestId

tests/EventLoopSpec.hs

@@ -409,7 +409,33 @@ 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"]
+
+    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
@@ -555,7 +581,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"]
 
     it "handles a non-conflicting non-fast-forwardable pull request with tag" $ do
       (history, _branches, tagRefs, tagAnns) <- withTestEnv' $ \ shas runLoop _git -> do
@@ -1210,4 +1236,4 @@ eventLoopSpec = parallel $ do
         , "* c0"
         ]
       branches `shouldMatchList`
-        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused", "integration"]
+        fmap Branch ["ahead", "intro", "master", "alternative", "fixup", "unused"]