From 26e9f8261ec6991acff1b770dd1047a6983e1b01 Mon Sep 17 00:00:00 2001 From: Rudy Matela Date: Thu, 14 Jul 2022 15:38:55 +0200 Subject: [PATCH 01/12] infer the integrationCandidate (w/ failing tests) Infer the `integrationCandidate` instead of storing it explicitly on the project state. This may make it easier to implement the merge train as we will need to handle multiple integration candidates. This specific change tries to maintain backward compatibility where possible, this backwards compatibility will gradually be cleaned up in further commits. The code typechecks but the tests fail for now. --- src/Logic.hs | 10 ++++------ src/Project.hs | 28 ++++++++++++++++++---------- tests/Spec.hs | 9 +-------- 3 files changed, 23 insertions(+), 24 deletions(-) diff --git a/src/Logic.hs b/src/Logic.hs index 4549a1d0..1440cb18 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -353,12 +353,10 @@ handlePullRequestClosedByUser :: PullRequestId -> ProjectState -> Action Project handlePullRequestClosedByUser = handlePullRequestClosed User handlePullRequestClosed :: PRCloseCause -> PullRequestId -> ProjectState -> Action ProjectState -handlePullRequestClosed closingReason pr state = Pr.deletePullRequest pr <$> - case Pr.integrationCandidate state of - Just candidatePr | candidatePr == pr -> do - leaveComment pr $ prClosingMessage closingReason - pure state { Pr.integrationCandidate = Nothing } - _notCandidatePr -> pure state +handlePullRequestClosed closingReason pr state = do + when (pr `elem` Pr.candidatePullRequests state) $ + leaveComment pr $ prClosingMessage closingReason + pure $ Pr.deletePullRequest pr state handlePullRequestEdited :: PullRequestId -> Text -> BaseBranch -> ProjectState -> Action ProjectState handlePullRequestEdited prId newTitle newBaseBranch state = diff --git a/src/Project.hs b/src/Project.hs index c2bc7396..a60abdca 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -19,6 +19,7 @@ module Project PullRequest (..), PullRequestId (..), PullRequestStatus (..), + integrationCandidate, Owner, approvedPullRequests, candidatePullRequests, @@ -53,7 +54,7 @@ import Data.ByteString (readFile) import Data.ByteString.Lazy (writeFile) import Data.IntMap.Strict (IntMap) import Data.List (intersect, nub, sortBy) -import Data.Maybe (isJust) +import Data.Maybe (isJust, listToMaybe) import Data.Text (Text) import GHC.Generics import Git (Branch (..), BaseBranch (..), Sha (..), GitIntegrationFailure (..)) @@ -133,7 +134,6 @@ data PullRequest = PullRequest data ProjectState = ProjectState { pullRequests :: IntMap PullRequest - , integrationCandidate :: Maybe PullRequestId , pullRequestApprovalIndex :: Int } deriving (Eq, Show, Generic) @@ -187,7 +187,6 @@ saveProjectState fname state = do emptyProjectState :: ProjectState emptyProjectState = ProjectState { pullRequests = IntMap.empty, - integrationCandidate = Nothing, pullRequestApprovalIndex = 0 } @@ -260,16 +259,25 @@ setIntegrationStatus pr newStatus = updatePullRequest pr changeIntegrationStatus } _notIntegrated -> pullRequest { integrationStatus = newStatus } +-- Here for backwards compatibility (TODO: remove?) +integrationCandidate :: ProjectState -> Maybe PullRequestId +integrationCandidate = fmap fst . getIntegrationCandidate + +-- Gets the first integration candidate getIntegrationCandidate :: ProjectState -> Maybe (PullRequestId, PullRequest) -getIntegrationCandidate state = do - pullRequestId <- integrationCandidate state - candidate <- lookupPullRequest pullRequestId state - return (pullRequestId, candidate) +getIntegrationCandidate = listToMaybe . getIntegrationCandidates + +-- Same as 'candidatePullRequests' but paired with the underlying object. +getIntegrationCandidates :: ProjectState -> [(PullRequestId, PullRequest)] +getIntegrationCandidates state = + [ (pullRequestId, candidate) + | pullRequestId <- candidatePullRequests state + , Just candidate <- [lookupPullRequest pullRequestId state] + ] +-- TODO: remove setIntegrationCandidate (no-op) setIntegrationCandidate :: Maybe PullRequestId -> ProjectState -> ProjectState -setIntegrationCandidate pr state = state { - integrationCandidate = pr -} +setIntegrationCandidate _pr = id setNeedsFeedback :: PullRequestId -> Bool -> ProjectState -> ProjectState setNeedsFeedback pr value = updatePullRequest pr (\pullRequest -> pullRequest { needsFeedback = value }) diff --git a/tests/Spec.hs b/tests/Spec.hs index eece2e30..3deb16d6 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -83,7 +83,7 @@ candidateState pr prBranch baseBranch prSha prAuthor approvedBy candidateSha = $ Project.setApproval pr (Just (Approval approvedBy Project.Merge 0)) $ singlePullRequestState pr prBranch baseBranch prSha prAuthor in - state { Project.integrationCandidate = Just pr } + state -- Types and functions to mock running an action without actually doing anything. @@ -1095,7 +1095,6 @@ main = hspec $ do } state = ProjectState { Project.pullRequests = IntMap.singleton 1 pullRequest - , Project.integrationCandidate = Just $ PullRequestId 1 , Project.pullRequestApprovalIndex = 1 } results = defaultResults { resultIntegrate = [Right (Sha "38e")] } @@ -1120,7 +1119,6 @@ main = hspec $ do } state = ProjectState { Project.pullRequests = IntMap.singleton 1 pullRequest - , Project.integrationCandidate = Just $ PullRequestId 1 , Project.pullRequestApprovalIndex = 1 } results = defaultResults @@ -1153,7 +1151,6 @@ main = hspec $ do } state = ProjectState { Project.pullRequests = IntMap.singleton 1 pullRequest - , Project.integrationCandidate = Just $ PullRequestId 1 , Project.pullRequestApprovalIndex = 1 } results = defaultResults @@ -1186,7 +1183,6 @@ main = hspec $ do } state = ProjectState { Project.pullRequests = IntMap.singleton 1 pullRequest - , Project.integrationCandidate = Just $ PullRequestId 1 , Project.pullRequestApprovalIndex = 1 } results = defaultResults { resultIntegrate = [Right (Sha "38e")] @@ -1216,7 +1212,6 @@ main = hspec $ do } state = ProjectState { Project.pullRequests = IntMap.singleton 1 pullRequest - , Project.integrationCandidate = Just $ PullRequestId 1 , Project.pullRequestApprovalIndex = 1 } -- Run 'proceedUntilFixedPoint', and pretend that pushes fail (because @@ -1253,7 +1248,6 @@ main = hspec $ do } state = ProjectState { Project.pullRequests = IntMap.singleton 1 pullRequest - , Project.integrationCandidate = Just $ PullRequestId 1 , Project.pullRequestApprovalIndex = 1 } -- Run 'proceedUntilFixedPoint', and pretend that pushes fail (because @@ -1353,7 +1347,6 @@ main = hspec $ do state = ProjectState { Project.pullRequests = prMap, - Project.integrationCandidate = Nothing, Project.pullRequestApprovalIndex = 2 } -- Proceeding should pick the next pull request as candidate. From 5f54967157ea4321cf9505f40a6b1d7c810370b3 Mon Sep 17 00:00:00 2001 From: Rudy Matela Date: Thu, 14 Jul 2022 16:36:06 +0200 Subject: [PATCH 02/12] add and use integratedPullRequests where applicable to replace candidatePullRequests. In the code "candidate" can mean two different (but related things): * a candidate for integration, as returned by the function candidatePullRequests; * something that has been integrated and is waiting for build results to become master integrationCandidate field of ProjectState; If I understand correctly, the latter is perhaps better described as a PR that is "integrated-but-waiting-for-build-results" or an integratedCandidate. The names have not yet been updated to reflect this. cf: https://github.com/channable/hoff/issues/77#issuecomment-1184524328 This fixes some failing tests, but there are still quite a few to go... --- src/Logic.hs | 2 +- src/Project.hs | 9 ++++++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/src/Logic.hs b/src/Logic.hs index 1440cb18..42834577 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -354,7 +354,7 @@ handlePullRequestClosedByUser = handlePullRequestClosed User handlePullRequestClosed :: PRCloseCause -> PullRequestId -> ProjectState -> Action ProjectState handlePullRequestClosed closingReason pr state = do - when (pr `elem` Pr.candidatePullRequests state) $ + when (pr `elem` Pr.integratedPullRequests state) $ leaveComment pr $ prClosingMessage closingReason pure $ Pr.deletePullRequest pr state diff --git a/src/Project.hs b/src/Project.hs index a60abdca..5d3a8c24 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -22,6 +22,7 @@ module Project integrationCandidate, Owner, approvedPullRequests, + integratedPullRequests, candidatePullRequests, classifyPullRequest, classifyPullRequests, @@ -271,7 +272,7 @@ getIntegrationCandidate = listToMaybe . getIntegrationCandidates getIntegrationCandidates :: ProjectState -> [(PullRequestId, PullRequest)] getIntegrationCandidates state = [ (pullRequestId, candidate) - | pullRequestId <- candidatePullRequests state + | pullRequestId <- integratedPullRequests state , Just candidate <- [lookupPullRequest pullRequestId state] ] @@ -371,6 +372,12 @@ wasIntegrationAttemptFor commit pr = case integrationStatus pr of Integrated candidate _buildStatus -> commit `elem` (candidate : integrationAttempts pr) _ -> commit `elem` (integrationAttempts pr) +integratedPullRequests :: ProjectState -> [PullRequestId] +integratedPullRequests = filterPullRequestsBy $ isIntegrated . integrationStatus + where + isIntegrated (Integrated _ _) = True + isIntegrated _ = False + -- Returns the pull requests that have not been integrated yet, in order of -- ascending id. unintegratedPullRequests :: ProjectState -> [PullRequestId] From 17ed0326dcd0cb2cf8e129a8ae10e980b125baf5 Mon Sep 17 00:00:00 2001 From: Rudy Matela Date: Thu, 14 Jul 2022 17:16:03 +0200 Subject: [PATCH 03/12] Add and use the Promoted integration status ... this makes the tests pass again. --- src/Logic.hs | 4 +++- src/Project.hs | 18 ++++++++++++++---- tests/Spec.hs | 5 +++-- 3 files changed, 20 insertions(+), 7 deletions(-) diff --git a/src/Logic.hs b/src/Logic.hs index 42834577..a3492706 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -616,6 +616,8 @@ proceedCandidate (pullRequestId, pullRequest) state = pure $ Pr.setIntegrationCandidate Nothing $ Pr.setNeedsFeedback pullRequestId True state + Promoted -> pure state + -- Given a pull request id, returns the name of the GitHub ref for that pull -- request, so it can be fetched. getPullRequestRef :: PullRequestId -> Branch @@ -703,7 +705,7 @@ 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.setIntegrationCandidate Nothing state + PushOk -> 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/src/Project.hs b/src/Project.hs index 5d3a8c24..3cc204ea 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -77,13 +77,20 @@ data BuildStatus | BuildFailed (Maybe Text) deriving (Eq, Show, Generic) --- When attempting to integrated changes, there can be three states: no attempt --- has been made to integrate; integration (e.g. merge or rebase) was successful --- and the new commit has the given sha; and an attempt to integrate was made, --- but it wasn't successful. +-- When attempting to integrated changes, there can be five states: +-- +-- * no attempt has been made to integrate; +-- +-- * integration (e.g. merge or rebase) was successful +-- and the new commit has the given sha; +-- +-- * the PR has been promoted to be the new master; +-- +-- * and an attempt to integrate was made, but it wasn't successful. data IntegrationStatus = NotIntegrated | Integrated Sha BuildStatus + | Promoted | Conflicted BaseBranch GitIntegrationFailure | IncorrectBaseBranch deriving (Eq, Show, Generic) @@ -296,6 +303,7 @@ classifyPullRequest pr = case approval pr of BuildPending -> PrStatusBuildPending BuildSucceeded -> PrStatusIntegrated BuildFailed url -> PrStatusFailedBuild url + Promoted -> PrStatusIntegrated -- TODO: state-of-its-own? -- Classify every pull request into one status. Orders pull requests by id in -- ascending order. @@ -350,6 +358,7 @@ isQueued pr = case approval pr of IncorrectBaseBranch -> False Conflicted _ _ -> False Integrated _ _ -> False + Promoted -> False -- Returns whether a pull request is in the process of being integrated (pending -- build results). @@ -364,6 +373,7 @@ isInProgress pr = case approval pr of BuildPending -> True BuildSucceeded -> False BuildFailed _ -> False + Promoted -> False -- Return whether the given commit is, or in this approval cycle ever was, an -- integration candidate of this pull request. diff --git a/tests/Spec.hs b/tests/Spec.hs index 3deb16d6..4d6ac1cc 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -418,7 +418,7 @@ main = hspec $ do state = candidateState (PullRequestId 1) (Branch "p") masterBranch (Sha "a38") "johanna" "deckard" (Sha "84c") state' = fst $ runAction $ handleEventTest event state pr = fromJust $ Project.lookupPullRequest (PullRequestId 1) state' - Project.integrationStatus pr `shouldBe` Project.Integrated (Sha "84c") Project.BuildSucceeded + Project.integrationStatus pr `shouldBe` Project.Promoted it "ignores a build status change for commits that are not the integration candidate" $ do let @@ -1355,7 +1355,8 @@ main = hspec $ do Just (cId, _candidate) = Project.getIntegrationCandidate state' cId `shouldBe` PullRequestId 2 actions `shouldBe` - [ ATryIntegrate "Merge #2: Add my test results\n\nApproved-by: deckard\nAuto-deploy: false\n" (Branch "refs/pull/2/head", Sha "f37") False + [ 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 , ALeaveComment (PullRequestId 2) "Rebased as 38e, waiting for CI \x2026" ] From 856930f6d25104c43cab8a6d7d93561e6ef65194 Mon Sep 17 00:00:00 2001 From: Rudy Matela Date: Thu, 14 Jul 2022 17:24:02 +0200 Subject: [PATCH 04/12] remove the setIntegrationCandidate function ... as it was now a no-op. --- src/Logic.hs | 24 ++++++++---------------- src/Project.hs | 5 ----- 2 files changed, 8 insertions(+), 21 deletions(-) diff --git a/src/Logic.hs b/src/Logic.hs index a3492706..0ca01155 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -599,25 +599,18 @@ proceedCandidate (pullRequestId, pullRequest) state = NotIntegrated -> tryIntegratePullRequest pullRequestId state - IncorrectBaseBranch -> - -- It shouldn't come to this point; a PR with an incorrect base branch is - -- never considered as a candidate. - pure $ Pr.setIntegrationCandidate Nothing state - - Conflicted _branch _ -> - -- If it conflicted, it should no longer be the integration candidate. - pure $ Pr.setIntegrationCandidate Nothing state - Integrated sha buildStatus -> case buildStatus of BuildPending -> pure state BuildSucceeded -> pushCandidate (pullRequestId, pullRequest) sha state - BuildFailed _ -> do - -- If the build failed, this is no longer a candidate. - pure $ Pr.setIntegrationCandidate Nothing $ - Pr.setNeedsFeedback pullRequestId True state + -- If the build failed, give feedback on the PR + BuildFailed _ -> pure $ Pr.setNeedsFeedback pullRequestId True state Promoted -> pure state + Conflicted _branch _ -> pure state + + IncorrectBaseBranch -> pure state + -- Given a pull request id, returns the name of the GitHub ref for that pull -- request, so it can be fetched. getPullRequestRef :: PullRequestId -> Branch @@ -652,11 +645,10 @@ tryIntegratePullRequest pr state = Pr.setNeedsFeedback pr True state Right (Sha sha) -> do - -- If it succeeded, update the integration candidate, and set the build - -- to pending, as pushing should have triggered a build. + -- If it succeeded, set the build to pending, + -- as pushing should have triggered a build. pure $ Pr.setIntegrationStatus pr (Integrated (Sha sha) BuildPending) - $ Pr.setIntegrationCandidate (Just pr) $ Pr.setNeedsFeedback pr True $ state diff --git a/src/Project.hs b/src/Project.hs index 3cc204ea..e1478bc4 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -41,7 +41,6 @@ module Project displayApproval, setApproval, newApprovalOrder, - setIntegrationCandidate, setIntegrationStatus, setNeedsFeedback, updatePullRequest, @@ -283,10 +282,6 @@ getIntegrationCandidates state = , Just candidate <- [lookupPullRequest pullRequestId state] ] --- TODO: remove setIntegrationCandidate (no-op) -setIntegrationCandidate :: Maybe PullRequestId -> ProjectState -> ProjectState -setIntegrationCandidate _pr = id - setNeedsFeedback :: PullRequestId -> Bool -> ProjectState -> ProjectState setNeedsFeedback pr value = updatePullRequest pr (\pullRequest -> pullRequest { needsFeedback = value }) From bdb17bcc5fb0927b5b2a7d21126b4da232ec13e4 Mon Sep 17 00:00:00 2001 From: Rudy Matela Date: Thu, 14 Jul 2022 17:39:55 +0200 Subject: [PATCH 05/12] Add and use updatePullRequests --- src/Logic.hs | 15 ++++++--------- src/Project.hs | 6 ++++++ 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/src/Logic.hs b/src/Logic.hs index 0ca01155..04f1c054 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -528,18 +528,15 @@ handleMergeRequested projectConfig prId author state pr approvalType = do handleBuildStatusChanged :: Sha -> BuildStatus -> ProjectState -> ProjectState handleBuildStatusChanged buildSha newStatus state = + Pr.updatePullRequests setBuildStatus state + where -- If there is an integration candidate, and its integration sha matches that -- of the build, then update the build status for that pull request. Otherwise -- do nothing. - let - setBuildStatus pullRequest = case Pr.integrationStatus pullRequest of - Integrated candidateSha _oldStatus | candidateSha == buildSha -> - pullRequest { Pr.integrationStatus = Integrated buildSha newStatus } - _ -> pullRequest - in - case Pr.integrationCandidate state of - Just candidateId -> Pr.updatePullRequest candidateId setBuildStatus state - Nothing -> state + setBuildStatus pullRequest = case Pr.integrationStatus pullRequest of + Integrated candidateSha _oldStatus | candidateSha == buildSha -> + pullRequest { Pr.integrationStatus = Integrated buildSha newStatus } + _ -> pullRequest -- Query the GitHub API to resolve inconsistencies between our state and GitHub. synchronizeState :: ProjectState -> Action ProjectState diff --git a/src/Project.hs b/src/Project.hs index e1478bc4..88f38694 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -44,6 +44,7 @@ module Project setIntegrationStatus, setNeedsFeedback, updatePullRequest, + updatePullRequests, getOwners, wasIntegrationAttemptFor, MergeWindow(..)) @@ -242,6 +243,11 @@ updatePullRequest (PullRequestId n) f state = state { pullRequests = IntMap.adjust f n $ pullRequests state } +updatePullRequests :: (PullRequest -> PullRequest) -> ProjectState -> ProjectState +updatePullRequests f state = state { + pullRequests = IntMap.map f $ pullRequests state +} + -- Marks the pull request as approved by somebody or nobody. setApproval :: PullRequestId -> Maybe Approval -> ProjectState -> ProjectState setApproval pr newApproval = updatePullRequest pr changeApproval From f06d9658f9e24c04c5d1355178a4e968abba6059 Mon Sep 17 00:00:00 2001 From: Rudy Matela Date: Thu, 14 Jul 2022 17:41:29 +0200 Subject: [PATCH 06/12] fix documentation of getIntegrationCandidates --- src/Project.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Project.hs b/src/Project.hs index 88f38694..d7b9622e 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -280,7 +280,7 @@ integrationCandidate = fmap fst . getIntegrationCandidate getIntegrationCandidate :: ProjectState -> Maybe (PullRequestId, PullRequest) getIntegrationCandidate = listToMaybe . getIntegrationCandidates --- Same as 'candidatePullRequests' but paired with the underlying object. +-- Same as 'integratedPullRequests' but paired with the underlying object. getIntegrationCandidates :: ProjectState -> [(PullRequestId, PullRequest)] getIntegrationCandidates state = [ (pullRequestId, candidate) From 9086652cd82cd3f6262e35c5a9bb64983ab5ba25 Mon Sep 17 00:00:00 2001 From: Rudy Matela Date: Thu, 14 Jul 2022 17:45:38 +0200 Subject: [PATCH 07/12] remove deprecated integrationCandidate function --- src/Project.hs | 5 ----- tests/Spec.hs | 10 +++++----- 2 files changed, 5 insertions(+), 10 deletions(-) diff --git a/src/Project.hs b/src/Project.hs index d7b9622e..23fbfbea 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -19,7 +19,6 @@ module Project PullRequest (..), PullRequestId (..), PullRequestStatus (..), - integrationCandidate, Owner, approvedPullRequests, integratedPullRequests, @@ -272,10 +271,6 @@ setIntegrationStatus pr newStatus = updatePullRequest pr changeIntegrationStatus } _notIntegrated -> pullRequest { integrationStatus = newStatus } --- Here for backwards compatibility (TODO: remove?) -integrationCandidate :: ProjectState -> Maybe PullRequestId -integrationCandidate = fmap fst . getIntegrationCandidate - -- Gets the first integration candidate getIntegrationCandidate :: ProjectState -> Maybe (PullRequestId, PullRequest) getIntegrationCandidate = listToMaybe . getIntegrationCandidates diff --git a/tests/Spec.hs b/tests/Spec.hs index 4d6ac1cc..f17d1d7b 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -281,13 +281,13 @@ main = hspec $ do let event = PullRequestClosed (PullRequestId 1) state = candidateState (PullRequestId 1) (Branch "p") masterBranch (Sha "ea0") "frank" "deckard" (Sha "cf4") state' = fst $ runAction $ handleEventTest event state - Project.integrationCandidate state' `shouldBe` Nothing + Project.integratedPullRequests state' `shouldBe` [] it "does not modify the integration candidate if a different PR was closed" $ do let event = PullRequestClosed (PullRequestId 1) state = candidateState (PullRequestId 2) (Branch "p") masterBranch (Sha "a38") "franz" "deckard" (Sha "ed0") state' = fst $ runAction $ handleEventTest event state - Project.integrationCandidate state' `shouldBe` (Just $ PullRequestId 2) + Project.integratedPullRequests state' `shouldBe` [PullRequestId 2] it "loses approval after the PR commit has changed" $ do let event = PullRequestCommitChanged (PullRequestId 1) (Sha "def") @@ -584,7 +584,7 @@ main = hspec $ do -- The first pull request should be dropped, and a comment should be -- left indicating why. Then the second pull request should be at the -- front of the queue. - Project.integrationCandidate state' `shouldBe` Just (PullRequestId 2) + Project.integratedPullRequests state' `shouldBe` [PullRequestId 2] actions `shouldBe` [ AIsReviewer "deckard" , ALeaveComment (PullRequestId 1) "Pull request approved for merge by @deckard, rebasing now." @@ -1011,7 +1011,7 @@ main = hspec $ do ] Project.approval pr `shouldBe` Nothing - Project.integrationCandidate state' `shouldBe` Nothing + Project.integratedPullRequests state' `shouldBe` [] it "shows an appropriate message when the commit is changed on an approved PR" $ do let @@ -1036,7 +1036,7 @@ main = hspec $ do ] Project.approval pr `shouldBe` Nothing - Project.integrationCandidate state' `shouldBe` Nothing + Project.integratedPullRequests state' `shouldBe` [] describe "Logic.proceedUntilFixedPoint" $ do From 1251a84ff57ffe5b76237211391ded024d9400d5 Mon Sep 17 00:00:00 2001 From: Rudy Matela Date: Thu, 14 Jul 2022 17:55:02 +0200 Subject: [PATCH 08/12] mark unreachable / dead code clearly ... and simplify one of the unreachable cases. --- src/Logic.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Logic.hs b/src/Logic.hs index 04f1c054..c975147f 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -593,8 +593,7 @@ proceed state = do proceedCandidate :: (PullRequestId, PullRequest) -> ProjectState -> Action ProjectState proceedCandidate (pullRequestId, pullRequest) state = case Pr.integrationStatus pullRequest of - NotIntegrated -> - tryIntegratePullRequest pullRequestId state + NotIntegrated -> pure state -- dead code / unreachable Integrated sha buildStatus -> case buildStatus of BuildPending -> pure state @@ -602,11 +601,11 @@ proceedCandidate (pullRequestId, pullRequest) state = -- If the build failed, give feedback on the PR BuildFailed _ -> pure $ Pr.setNeedsFeedback pullRequestId True state - Promoted -> pure state + Promoted -> pure state -- dead code / unreachable - Conflicted _branch _ -> pure state + Conflicted _branch _ -> pure state -- dead code / unreachable - IncorrectBaseBranch -> pure state + IncorrectBaseBranch -> pure state -- dead code / unreachable -- Given a pull request id, returns the name of the GitHub ref for that pull -- request, so it can be fetched. From 2e1d58f5975df3452694b36e430807e84a9dd337 Mon Sep 17 00:00:00 2001 From: Rudy Matela Date: Thu, 14 Jul 2022 18:03:11 +0200 Subject: [PATCH 09/12] remove use of getIntegrationCandidate ... in actual code. It is now only used in tests. --- src/Logic.hs | 15 +++++++-------- src/Project.hs | 1 + 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Logic.hs b/src/Logic.hs index c975147f..28e626b8 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -580,14 +580,13 @@ synchronizeState stateInitial = proceed :: ProjectState -> Action ProjectState proceed state = do state' <- provideFeedback state - case Pr.getIntegrationCandidate state' of - Just candidate -> proceedCandidate candidate state' - -- No current integration candidate, find the next one. - Nothing -> case Pr.candidatePullRequests state' of - -- No pull requests eligible, do nothing. - [] -> return state' - -- Found a new candidate, try to integrate it. - pr : _ -> tryIntegratePullRequest pr state' + case (Pr.getIntegrationCandidates state', Pr.candidatePullRequests state') of + -- Proceed with an already integrated candidate + (candidate:_, _) -> proceedCandidate candidate state' + -- Found a new candidate, try to integrate it. + (_, pr:_) -> tryIntegratePullRequest pr state' + -- No pull requests eligible, do nothing. + (_, _) -> return state' -- TODO: Get rid of the tuple; just pass the ID and do the lookup with fromJust. proceedCandidate :: (PullRequestId, PullRequest) -> ProjectState -> Action ProjectState diff --git a/src/Project.hs b/src/Project.hs index 23fbfbea..20599bc6 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -29,6 +29,7 @@ module Project emptyProjectState, existsPullRequest, getIntegrationCandidate, + getIntegrationCandidates, getQueuePosition, insertPullRequest, loadProjectState, From 28e2640030238eb309b5ab0a1f691e4d795605bf Mon Sep 17 00:00:00 2001 From: Rudy Matela Date: Fri, 15 Jul 2022 09:45:26 +0200 Subject: [PATCH 10/12] refactor: use getIntegrationCandidates in favour of getIntegrationCandidate --- src/Project.hs | 9 ++------ tests/EventLoopSpec.hs | 49 +++++++++++++++++++++--------------------- tests/Spec.hs | 34 ++++++++++++++--------------- 3 files changed, 43 insertions(+), 49 deletions(-) diff --git a/src/Project.hs b/src/Project.hs index 20599bc6..989ca32f 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -28,7 +28,6 @@ module Project deletePullRequest, emptyProjectState, existsPullRequest, - getIntegrationCandidate, getIntegrationCandidates, getQueuePosition, insertPullRequest, @@ -55,7 +54,7 @@ import Data.ByteString (readFile) import Data.ByteString.Lazy (writeFile) import Data.IntMap.Strict (IntMap) import Data.List (intersect, nub, sortBy) -import Data.Maybe (isJust, listToMaybe) +import Data.Maybe (isJust) import Data.Text (Text) import GHC.Generics import Git (Branch (..), BaseBranch (..), Sha (..), GitIntegrationFailure (..)) @@ -272,11 +271,7 @@ setIntegrationStatus pr newStatus = updatePullRequest pr changeIntegrationStatus } _notIntegrated -> pullRequest { integrationStatus = newStatus } --- Gets the first integration candidate -getIntegrationCandidate :: ProjectState -> Maybe (PullRequestId, PullRequest) -getIntegrationCandidate = listToMaybe . getIntegrationCandidates - --- Same as 'integratedPullRequests' but paired with the underlying object. +-- Same as 'integratedPullRequests' but paired with the underlying objects. getIntegrationCandidates :: ProjectState -> [(PullRequestId, PullRequest)] getIntegrationCandidates state = [ (pullRequestId, candidate) diff --git a/tests/EventLoopSpec.hs b/tests/EventLoopSpec.hs index 52b26b57..d3aae9d7 100644 --- a/tests/EventLoopSpec.hs +++ b/tests/EventLoopSpec.hs @@ -21,7 +21,6 @@ import Control.Monad (forM_, void, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (runNoLoggingT) import Data.Map (Map) -import Data.Maybe (isJust) import Data.Set (Set) import Data.Text (Text) import Prelude hiding (appendFile, writeFile) @@ -469,7 +468,7 @@ eventLoopSpec = parallel $ do -- Extract the sha of the rebased commit from the project state. let - Just (_prId, pullRequest) = Project.getIntegrationCandidate state + [(_prId, pullRequest)] = Project.getIntegrationCandidates state Project.Integrated rebasedSha _ = Project.integrationStatus pullRequest -- The rebased commit should have been pushed to the remote repository @@ -529,7 +528,7 @@ eventLoopSpec = parallel $ do -- Extract the sha of the rebased commit from the project state. let - Just (_prId, pullRequest) = Project.getIntegrationCandidate state + [(_prId, pullRequest)] = Project.getIntegrationCandidates state Project.Integrated rebasedSha _ = Project.integrationStatus pullRequest -- The rebased commit should have been pushed to the remote repository @@ -570,7 +569,7 @@ eventLoopSpec = parallel $ do ] let - Just (_prId, pullRequest) = Project.getIntegrationCandidate state + [(_prId, pullRequest)] = Project.getIntegrationCandidates state Project.Integrated rebasedSha _ = Project.integrationStatus pullRequest void $ runLoop state [Logic.BuildStatusChanged rebasedSha BuildSucceeded] @@ -630,7 +629,7 @@ eventLoopSpec = parallel $ do ] let - Just (_prId, pullRequest) = Project.getIntegrationCandidate state + [(_prId, pullRequest)] = Project.getIntegrationCandidates state Project.Integrated rebasedSha _ = Project.integrationStatus pullRequest void $ runLoop state [Logic.BuildStatusChanged rebasedSha BuildSucceeded] @@ -694,7 +693,7 @@ eventLoopSpec = parallel $ do -- Extract the sha of the rebased commit from the project state. let - Just (_prId, pullRequest6) = Project.getIntegrationCandidate state + [(_prId, pullRequest6)] = Project.getIntegrationCandidates state Project.Integrated rebasedSha _ = Project.integrationStatus pullRequest6 -- The rebased commit should have been pushed to the remote repository @@ -704,7 +703,7 @@ eventLoopSpec = parallel $ do -- Repeat for the other pull request, which should be the candidate by -- now. let - Just (_prId, pullRequest4) = Project.getIntegrationCandidate state' + [(_prId, pullRequest4)] = Project.getIntegrationCandidates state' Project.Integrated rebasedSha' _ = Project.integrationStatus pullRequest4 void $ runLoop state' [Logic.BuildStatusChanged rebasedSha' BuildSucceeded] @@ -739,13 +738,13 @@ eventLoopSpec = parallel $ do ] let - Just (_prId, pullRequest6) = Project.getIntegrationCandidate state + [(_prId, pullRequest6)] = Project.getIntegrationCandidates state Project.Integrated rebasedSha _ = Project.integrationStatus pullRequest6 state' <- runLoop state [Logic.BuildStatusChanged rebasedSha BuildSucceeded] let - Just (_prId, pullRequest4) = Project.getIntegrationCandidate state' + [(_prId, pullRequest4)] = Project.getIntegrationCandidates state' Project.Integrated rebasedSha' _ = Project.integrationStatus pullRequest4 void $ runLoop state' [Logic.BuildStatusChanged rebasedSha' BuildSucceeded] @@ -828,7 +827,7 @@ eventLoopSpec = parallel $ do -- The second pull request should still be pending, awaiting the build -- result. - let Just (prId, pullRequest4) = Project.getIntegrationCandidate state + let [(prId, pullRequest4)] = Project.getIntegrationCandidates state prId `shouldBe` pr4 let Integrated _ buildStatus = Project.integrationStatus pullRequest4 buildStatus `shouldBe` BuildPending @@ -868,23 +867,23 @@ eventLoopSpec = parallel $ do -- Extract the sha of the rebased commit from the project state, and -- tell the loop that building the commit succeeded. let - Just (_prId, pullRequest) = Project.getIntegrationCandidate state + [(_prId, pullRequest)] = Project.getIntegrationCandidates state Project.Integrated rebasedSha _ = Project.integrationStatus pullRequest state' <- runLoop state [Logic.BuildStatusChanged rebasedSha BuildSucceeded] -- The push should have failed, hence there should still be an -- integration candidate. - Project.getIntegrationCandidate state' `shouldSatisfy` isJust + Project.getIntegrationCandidates state' `shouldSatisfy` (not . null) -- Again notify build success, now for the new commit. let - Just (_prId, pullRequest') = Project.getIntegrationCandidate state' + [(_prId, pullRequest')] = Project.getIntegrationCandidates state' Project.Integrated rebasedSha' _ = Project.integrationStatus pullRequest' state'' <- runLoop state' [Logic.BuildStatusChanged rebasedSha' BuildSucceeded] -- After the second build success, the pull request should have been -- integrated properly, so there should not be a new candidate. - Project.getIntegrationCandidate state'' `shouldBe` Nothing + Project.getIntegrationCandidates state'' `shouldBe` [] history `shouldBe` [ "* Merge #6" @@ -923,13 +922,13 @@ eventLoopSpec = parallel $ do git ["push", "origin", refSpec (c4, masterBranch)] let - Just (_prId, pullRequest) = Project.getIntegrationCandidate state + [(_prId, pullRequest)] = Project.getIntegrationCandidates state Project.Integrated rebasedSha _ = Project.integrationStatus pullRequest state' <- runLoop state [Logic.BuildStatusChanged rebasedSha BuildSucceeded] -- Again notify build success, now for the new commit. let - Just (_prId, pullRequest') = Project.getIntegrationCandidate state' + [(_prId, pullRequest')] = Project.getIntegrationCandidates state' Project.Integrated rebasedSha' _ = Project.integrationStatus pullRequest' void $ runLoop state' [Logic.BuildStatusChanged rebasedSha' BuildSucceeded] @@ -999,13 +998,13 @@ eventLoopSpec = parallel $ do git ["push", "origin", refSpec (Git.TagName "v2")] let - Just (_prId, pullRequest) = Project.getIntegrationCandidate state + [(_prId, pullRequest)] = Project.getIntegrationCandidates state Project.Integrated rebasedSha _ = Project.integrationStatus pullRequest state' <- runLoop state [Logic.BuildStatusChanged rebasedSha BuildSucceeded] -- Again notify build success, now for the new commit. let - Just (_prId, pullRequest') = Project.getIntegrationCandidate state' + [(_prId, pullRequest')] = Project.getIntegrationCandidates state' Project.Integrated rebasedSha' _ = Project.integrationStatus pullRequest' void $ runLoop state' [Logic.BuildStatusChanged rebasedSha' BuildSucceeded] @@ -1072,7 +1071,7 @@ eventLoopSpec = parallel $ do -- Extract the sha of the rebased commit from the project state, and -- tell the loop that building the commit succeeded. let - Just (_prId, pullRequest) = Project.getIntegrationCandidate state + [(_prId, pullRequest)] = Project.getIntegrationCandidates state Project.Integrated rebasedSha _ = Project.integrationStatus pullRequest void $ runLoop state [Logic.BuildStatusChanged rebasedSha BuildSucceeded] @@ -1114,13 +1113,13 @@ eventLoopSpec = parallel $ do -- Extract the sha of the rebased commit from the project state, and -- tell the loop that building the commit succeeded. let - Just (_prId, pullRequest) = Project.getIntegrationCandidate state + [(_prId, pullRequest)] = Project.getIntegrationCandidates state Project.Integrated rebasedSha _ = Project.integrationStatus pullRequest state' <- runLoop state [Logic.BuildStatusChanged rebasedSha BuildSucceeded] -- Again notify build success, now for the new commit. let - Just (_prId, pullRequest') = Project.getIntegrationCandidate state' + [(_prId, pullRequest')] = Project.getIntegrationCandidates state' Project.Integrated rebasedSha' _ = Project.integrationStatus pullRequest' void $ runLoop state' [Logic.BuildStatusChanged rebasedSha' BuildSucceeded] @@ -1168,14 +1167,14 @@ eventLoopSpec = parallel $ do -- tell the loop that building the commit succeeded. let - Just (_prId, pullRequest) = Project.getIntegrationCandidate state + [(_prId, pullRequest)] = Project.getIntegrationCandidates state Project.Integrated rebasedSha _ = Project.integrationStatus pullRequest state' <- runLoop state [Logic.BuildStatusChanged rebasedSha BuildSucceeded] --The pull request should not be integrated. Moreover, the presence of --orphan fixups should make the PR ineligible for being a candidate for integration. --That is, we expect no candidates for integration. - Project.getIntegrationCandidate state' `shouldBe` Nothing + Project.getIntegrationCandidates state' `shouldBe` [] -- Here we expect that the fixup commit is not present. history `shouldBe` @@ -1205,7 +1204,7 @@ eventLoopSpec = parallel $ do ] let - Just (prId, pullRequest) = Project.getIntegrationCandidate state + [(prId, pullRequest)] = Project.getIntegrationCandidates state Project.Integrated rebasedSha _ = Project.integrationStatus pullRequest prId `shouldBe` pr8 @@ -1218,7 +1217,7 @@ eventLoopSpec = parallel $ do Logic.CommentAdded pr6 "rachael" "@bot merge" ] - Project.getIntegrationCandidate state' `shouldBe` Nothing + Project.getIntegrationCandidates state' `shouldBe` [] let Just pullRequest' = Project.lookupPullRequest pr6 state' Project.integrationStatus pullRequest' `shouldBe` diff --git a/tests/Spec.hs b/tests/Spec.hs index f17d1d7b..51050c9a 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -1051,7 +1051,7 @@ main = hspec $ do , resultPush = [PushRejected "test"] } (state', actions) = runActionCustom results $ Logic.proceedUntilFixedPoint state - (prId, pullRequest) = fromJust $ Project.getIntegrationCandidate state' + [(prId, pullRequest)] = Project.getIntegrationCandidates state' Project.integrationStatus pullRequest `shouldBe` Project.Integrated (Sha "38c") Project.BuildPending prId `shouldBe` PullRequestId 1 actions `shouldBe` @@ -1072,7 +1072,7 @@ main = hspec $ do , resultPush = [PushRejected "test"] } (state', actions) = runActionCustom results $ Logic.proceedUntilFixedPoint state - (prId, pullRequest) = fromJust $ Project.getIntegrationCandidate state' + [(prId, pullRequest)] = Project.getIntegrationCandidates state' Project.integrationStatus pullRequest `shouldBe` Project.Integrated (Sha "38c") Project.BuildPending prId `shouldBe` PullRequestId 2 actions `shouldBe` @@ -1099,10 +1099,10 @@ main = hspec $ do } results = defaultResults { resultIntegrate = [Right (Sha "38e")] } (state', actions) = runActionCustom results $ Logic.proceedUntilFixedPoint state - candidate = Project.getIntegrationCandidate state' + candidates = Project.getIntegrationCandidates state' -- After a successful push, the candidate should be gone. - candidate `shouldBe` Nothing - actions `shouldBe` [ATryPromote (Branch "results/rachael") (Sha "38d")] + candidates `shouldBe` [] + actions `shouldBe` [ATryPromote (Branch "results/rachael") (Sha "38d")] it "pushes and tags with a new version after a successful build (merge and tag)" $ do let @@ -1126,10 +1126,10 @@ main = hspec $ do , resultGetChangelog = [Just "changelog"] } (state', actions) = runActionCustom results $ Logic.proceedUntilFixedPoint state - candidate = Project.getIntegrationCandidate state' + candidates = Project.getIntegrationCandidates state' -- After a successful push, the candidate should be gone. - candidate `shouldBe` Nothing - actions `shouldBe` + candidates `shouldBe` [] + actions `shouldBe` [ ATryPromoteWithTag (Branch "results/rachael") (Sha "38d") (TagName "v2") (TagMessage "v2\n\nchangelog") , ALeaveComment (PullRequestId 1) @@ -1158,10 +1158,10 @@ main = hspec $ do , resultGetChangelog = [Just "changelog"] } (state', actions) = runActionCustom results $ Logic.proceedUntilFixedPoint state - candidate = Project.getIntegrationCandidate state' + candidates = Project.getIntegrationCandidates state' -- After a successful push, the candidate should be gone. - candidate `shouldBe` Nothing - actions `shouldBe` + candidates `shouldBe` [] + actions `shouldBe` [ ATryPromoteWithTag (Branch "results/rachael") (Sha "38d") (TagName "v2") (TagMessage "v2 (autodeploy)\n\nchangelog") , ALeaveComment (PullRequestId 1) @@ -1188,10 +1188,10 @@ main = hspec $ do results = defaultResults { resultIntegrate = [Right (Sha "38e")] , resultGetLatestVersion = [Left (TagName "abcdef")] } (state', actions) = runActionCustom results $ Logic.proceedUntilFixedPoint state - candidate = Project.getIntegrationCandidate state' + candidates = Project.getIntegrationCandidates state' -- After a successful push, the candidate should be gone. - candidate `shouldBe` Nothing - actions `shouldBe` [ ALeaveComment (PullRequestId 1) "@deckard Sorry, I could not tag your PR. The previous tag `abcdef` seems invalid" + 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")] @@ -1221,7 +1221,7 @@ main = hspec $ do , resultPush = [PushRejected "test"] } (state', actions) = runActionCustom results $ Logic.proceedUntilFixedPoint state - (_, pullRequest') = fromJust $ Project.getIntegrationCandidate state' + [(_, pullRequest')] = Project.getIntegrationCandidates state' Project.integrationStatus pullRequest' `shouldBe` Project.Integrated (Sha "38e") Project.BuildPending Project.integrationAttempts pullRequest' `shouldBe` [Sha "38d"] @@ -1258,7 +1258,7 @@ main = hspec $ do , resultGetChangelog = [Just "changelog"] } (state', actions) = runActionCustom results $ Logic.proceedUntilFixedPoint state - (_, pullRequest') = fromJust $ Project.getIntegrationCandidate state' + [(_, pullRequest')] = Project.getIntegrationCandidates state' Project.integrationStatus pullRequest' `shouldBe` Project.Integrated (Sha "38e") Project.BuildPending Project.integrationAttempts pullRequest' `shouldBe` [Sha "38d"] @@ -1352,7 +1352,7 @@ main = hspec $ do -- Proceeding should pick the next pull request as candidate. results = defaultResults { resultIntegrate = [Right (Sha "38e")] } (state', actions) = runActionCustom results $ Logic.proceedUntilFixedPoint state - Just (cId, _candidate) = Project.getIntegrationCandidate state' + [(cId, _candidate)] = Project.getIntegrationCandidates state' cId `shouldBe` PullRequestId 2 actions `shouldBe` [ ATryPromote (Branch "results/leon") (Sha "38d") From 9188ef9b965bf5cf2ce819080cd6a512dd747cd3 Mon Sep 17 00:00:00 2001 From: Rudy Matela Date: Fri, 15 Jul 2022 09:57:30 +0200 Subject: [PATCH 11/12] tests/Spec: reindent candidateState --- tests/Spec.hs | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/tests/Spec.hs b/tests/Spec.hs index 51050c9a..155e1879 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -75,15 +75,12 @@ singlePullRequestState pr prBranch baseBranch prSha prAuthor = in fst $ runAction $ handleEventTest event Project.emptyProjectState -candidateState :: PullRequestId -> Branch -> BaseBranch -> Sha -> Username -> Username -> Sha -> ProjectState -candidateState pr prBranch baseBranch prSha prAuthor approvedBy candidateSha = - let - state = Project.setIntegrationStatus pr - (Project.Integrated candidateSha Project.BuildPending) - $ Project.setApproval pr (Just (Approval approvedBy Project.Merge 0)) - $ singlePullRequestState pr prBranch baseBranch prSha prAuthor - in - state +candidateState + :: PullRequestId -> Branch -> BaseBranch -> Sha -> Username -> Username -> Sha -> ProjectState +candidateState pr prBranch baseBranch prSha prAuthor approvedBy candidateSha + = Project.setIntegrationStatus pr (Project.Integrated candidateSha Project.BuildPending) + $ Project.setApproval pr (Just (Approval approvedBy Project.Merge 0)) + $ singlePullRequestState pr prBranch baseBranch prSha prAuthor -- Types and functions to mock running an action without actually doing anything. From e6c9da17d60dfb649185d4231de4c5b3781fe5f9 Mon Sep 17 00:00:00 2001 From: Rudy Matela Date: Wed, 20 Jul 2022 13:06:02 +0200 Subject: [PATCH 12/12] Commit to Promoted -> PrStatusIntegrated (rm TODO) --- src/Project.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Project.hs b/src/Project.hs index 989ca32f..749d081a 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -295,7 +295,7 @@ classifyPullRequest pr = case approval pr of BuildPending -> PrStatusBuildPending BuildSucceeded -> PrStatusIntegrated BuildFailed url -> PrStatusFailedBuild url - Promoted -> PrStatusIntegrated -- TODO: state-of-its-own? + Promoted -> PrStatusIntegrated -- Classify every pull request into one status. Orders pull requests by id in -- ascending order.