diff --git a/doc/example-dev-config.json b/doc/example-dev-config.json index 9073ef5c..2b70cf2a 100644 --- a/doc/example-dev-config.json +++ b/doc/example-dev-config.json @@ -38,6 +38,7 @@ }, "timeouts": { "promotionTimeout": 60, - "rememberTimeout": 600 + "rememberTimeout": 600, + "syncTimeout": 600 } } diff --git a/hoff.cabal b/hoff.cabal index d909f2b9..20906d7b 100644 --- a/hoff.cabal +++ b/hoff.cabal @@ -110,6 +110,8 @@ test-suite spec other-modules: ParserSpec ProjectSpec + Sync + TestSetup hs-source-dirs: tests ghc-options: -Wall -Werror diff --git a/package/example-config.json b/package/example-config.json index 15cc6d91..24d7fd4b 100644 --- a/package/example-config.json +++ b/package/example-config.json @@ -57,6 +57,7 @@ }, "timeouts": { "promotionTimeout": 60, - "rememberTimeout": 600 + "rememberTimeout": 600, + "syncTimeout": 600 } } diff --git a/src/Configuration.hs b/src/Configuration.hs index 80d74fd2..4d3ebdbb 100644 --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -98,6 +98,7 @@ newtype MergeWindowExemptionConfiguration = MergeWindowExemptionConfiguration [T data Timeouts = Timeouts { promotionTimeout :: DiffTime , rememberTimeout :: DiffTime + , syncTimeout :: DiffTime } deriving (Generic, Show) diff --git a/src/GithubApi.hs b/src/GithubApi.hs index 4d0e2f76..1a69e18b 100644 --- a/src/GithubApi.hs +++ b/src/GithubApi.hs @@ -18,6 +18,7 @@ module GithubApi ( ReactionContent (..), getOpenPullRequests, getPullRequest, + getBuildStatus, hasPushAccess, leaveComment, addReaction, @@ -43,6 +44,7 @@ import GitHub.Endpoints.Issues.Comments qualified as Github3 import GitHub.Endpoints.PullRequests qualified as Github3 import GitHub.Endpoints.Reactions qualified as Github3 import GitHub.Endpoints.Repos.Collaborators qualified as Github3 +import GitHub.Endpoints.Repos.Statuses qualified as Github3 import GitHub.Request qualified as Github3 import Network.HTTP.Client qualified as Http import Network.HTTP.Types.Status qualified as Http @@ -50,9 +52,10 @@ import Network.HTTP.Types.Status qualified as Http import Format (format) import Git (BaseBranch (..), Branch (..), Sha (..)) import MonadLoggerEffect (MonadLoggerEffect) -import Project (ProjectInfo) +import Project (BuildStatus (..), Check (..), ProjectInfo) import Types (CommentId (..), PullRequestId (..), ReactableId (..), Username (..)) +import Data.Maybe (fromMaybe) import Project qualified -- A stripped-down version of the `Github3.PullRequest` type, with only the @@ -71,6 +74,8 @@ data GithubOperation :: Effect where HasPushAccess :: Username -> GithubOperation m Bool GetPullRequest :: PullRequestId -> GithubOperation m (Maybe PullRequest) GetOpenPullRequests :: GithubOperation m (Maybe IntSet) + -- TODO: do we ever use 'checks'? + GetBuildStatus :: Sha -> GithubOperation m (Maybe [(Check, BuildStatus)]) type instance DispatchOf GithubOperation = 'Dynamic @@ -89,6 +94,9 @@ getPullRequest pr = send $ GetPullRequest pr getOpenPullRequests :: GithubOperation :> es => Eff es (Maybe IntSet) getOpenPullRequests = send GetOpenPullRequests +getBuildStatus :: GithubOperation :> es => Sha -> Eff es (Maybe [(Check, BuildStatus)]) +getBuildStatus sha = send $ GetBuildStatus sha + isPermissionToPush :: Github3.CollaboratorPermission -> Bool isPermissionToPush perm = case perm of Github3.CollaboratorPermissionAdmin -> True @@ -218,6 +226,41 @@ runGithub auth projectInfo = $ foldMap (IntSet.singleton . Github3.unIssueNumber . Github3.simplePullRequestNumber) $ prs + GetBuildStatus sha -> do + logDebugN $ format "Getting build status for {} in {}." (show sha, projectInfo) + + let unSha (Sha sha') = sha' + + result <- + liftIO $ + Github3.github auth $ + Github3.statusesForR + (Github3.N $ Project.owner projectInfo) + (Github3.N $ Project.repository projectInfo) + (Github3.N $ unSha sha) + Github3.FetchAll + case result of + Left err -> do + logWarnN $ format "Failed to retrieve build status for {} in {}: {}" (show sha, projectInfo, show err) + pure Nothing + Right statuses -> do + logDebugN $ format "Got {} build statuses for {} in {}." (Vector.length statuses, show sha, projectInfo) + pure $ Just $ map toBuildStatus $ Vector.toList statuses + +toBuildStatus :: Github3.Status -> (Check, BuildStatus) +toBuildStatus status = + -- Note: the `context` field is supposed to be a string according the GitHub API documentation. + -- Because the library types it as Maybe, we set a default value in the case it is Nothing. This + -- should not happen in practice. + let + check = Check $ fromMaybe "default" $ Github3.statusContext status + buildStatus = case Github3.statusState status of + Github3.StatusError -> BuildFailed (Github3.statusDescription status) + Github3.StatusFailure -> BuildFailed (Github3.statusDescription status) + Github3.StatusPending -> BuildPending + Github3.StatusSuccess -> BuildSucceeded + in + (check, buildStatus) -- Like runGithub, but does not execute operations that have side effects, in -- the sense of being observable by Github users. We will still make requests @@ -235,6 +278,7 @@ runGithubReadOnly auth projectInfo = runGithub auth projectInfo . augmentedGithu HasPushAccess username -> send $ HasPushAccess username GetPullRequest pullRequestId -> send $ GetPullRequest pullRequestId GetOpenPullRequests -> send GetOpenPullRequests + GetBuildStatus sha -> send $ GetBuildStatus sha -- These operations have side effects, we fake them. LeaveComment pr body -> logInfoN $ format "Would have posted comment on {}: {}" (show pr, body) diff --git a/src/Logic.hs b/src/Logic.hs index 544a4f3c..0bab5c52 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -32,6 +32,7 @@ module Logic ( readStateVar, runAction, runRetrieveEnvironment, + synchronizeState, tryIntegratePullRequest, updateStateVar, ) @@ -136,6 +137,7 @@ data Action :: Effect where IsReviewer :: Username -> Action m Bool GetPullRequest :: PullRequestId -> Action m (Maybe GithubApi.PullRequest) GetOpenPullRequests :: Action m (Maybe IntSet) + GetBuildStatus :: Sha -> Action m (Maybe [(Check, BuildStatus)]) GetLatestVersion :: Sha -> Action m (Either TagName Integer) GetChangelog :: TagName -> Sha -> Action m (Maybe Text) IncreaseMergeAttemptedMetric :: Priority -> Action m () @@ -216,6 +218,9 @@ getPullRequest pr = send $ GetPullRequest pr getOpenPullRequests :: Action :> es => Eff es (Maybe IntSet) getOpenPullRequests = send GetOpenPullRequests +getBuildStatus :: Action :> es => Sha -> Eff es (Maybe [(Check, BuildStatus)]) +getBuildStatus sha = send $ GetBuildStatus sha + getLatestVersion :: Action :> es => Sha -> Eff es (Either TagName Integer) getLatestVersion sha = send $ GetLatestVersion sha @@ -304,6 +309,8 @@ runAction config = GithubApi.getPullRequest pr GetOpenPullRequests -> do GithubApi.getOpenPullRequests + GetBuildStatus sha -> do + GithubApi.getBuildStatus sha GetLatestVersion sha -> do Git.fetchBranchWithTags $ Branch (Config.branch config) maybe (Right 0) (\t -> maybeToEither t $ parseVersion t) <$> Git.lastTag sha @@ -669,7 +676,15 @@ handleTargetChanged (BaseBranch baseBranch) sha state handleTargetChanged _ _ state = pure state handleClockTickUpdate :: (Action :> es, RetrieveEnvironment :> es, TimeOperation :> es) => Timeouts -> UTCTime -> ProjectState -> Eff es ProjectState -handleClockTickUpdate = handleStalePromotions +handleClockTickUpdate timeouts currTime state = do + state' <- handleStalePromotions timeouts currTime state + + if Time.addTime (lastSyncTime state') (Config.syncTimeout timeouts) < currTime + then do + state'' <- synchronizeState state' + currentTime <- getDateTime + return state''{lastSyncTime = currentTime} + else pure state' handleStalePromotions :: (Action :> es, RetrieveEnvironment :> es, TimeOperation :> es) => Timeouts -> UTCTime -> ProjectState -> Eff es ProjectState handleStalePromotions timeouts currTime state = do @@ -983,11 +998,18 @@ handleBuildStatusChanged :: Sha -> Context -> BuildStatus -> ProjectState -> Eff handleBuildStatusChanged buildSha context newStatus state = pure $ compose - [ unintegratePullRequestIfNeeded (Pr.pullRequestId pr) - . Pr.updatePullRequest (Pr.pullRequestId pr) setBuildStatus + [ handleBuildStatusChangedForPR context newStatus pr | pr <- Pr.filterPullRequestsBy shouldUpdate state ] state + where + shouldUpdate pr = case Pr.integrationStatus pr of + Integrated candidateSha _ -> candidateSha == buildSha + _ -> False + +handleBuildStatusChangedForPR :: Context -> BuildStatus -> PullRequest -> ProjectState -> ProjectState +handleBuildStatusChangedForPR context newStatus pull state = + unintegratePullRequestIfNeeded (Pr.pullRequestId pull) . Pr.updatePullRequest (Pr.pullRequestId pull) setBuildStatus $ state where satisfiedCheck = contextSatisfiesChecks (Pr.mandatoryChecks state) context getNewStatus new old = if new `supersedes` old then new else old @@ -998,13 +1020,9 @@ handleBuildStatusChanged buildSha context newStatus state = -- Ignore status updates that aren't relevant to the mandatory checks Nothing -> Pr.SpecificChecks checks - shouldUpdate pr = case Pr.integrationStatus pr of - Integrated candidateSha _ -> candidateSha == buildSha - _ -> False - -- We need to do edge detection for failures on the summarized status of the -- pull request, as we only want to trigger unintegration once. The nature of - -- webhooks make arrival guarentees annoying to deal with, so we opt for + -- webhooks make arrival guarantees annoying to deal with, so we opt for -- only dealing with the first appearance of a status. unintegratePullRequestIfNeeded pid newState | Just oldPr <- Pr.lookupPullRequest pid state @@ -1022,13 +1040,13 @@ handleBuildStatusChanged buildSha context newStatus state = -- Like unintegration, we also need edge detection to avoid commenting -- multiple times on the same PR. setBuildStatus pr - | Integrated _ oldStatus <- Pr.integrationStatus pr = + | Integrated sha oldStatus <- Pr.integrationStatus pr = let newStatus' = newStatusState oldStatus wasSuperseded = summarize newStatus' `supersedes` summarize oldStatus in pr - { Pr.integrationStatus = Integrated buildSha newStatus' + { Pr.integrationStatus = Integrated sha newStatus' , Pr.needsFeedback = case newStatus of BuildStarted _ -> wasSuperseded BuildFailed _ -> wasSuperseded @@ -1048,7 +1066,10 @@ contextSatisfiesChecks (Pr.MandatoryChecks checks) (Git.Context context) = in go (Set.toList checks) -- Query the GitHub API to resolve inconsistencies between our state and GitHub. -synchronizeState :: Action :> es => ProjectState -> Eff es ProjectState +synchronizeState + :: (Action :> es, RetrieveEnvironment :> es, TimeOperation :> es) + => ProjectState + -> Eff es ProjectState synchronizeState stateInitial = getOpenPullRequests >>= \case -- If we fail to obtain the currently open pull requests from GitHub, then @@ -1061,6 +1082,7 @@ synchronizeState stateInitial = toList = fmap PullRequestId . IntSet.toList prsToClose = toList $ IntSet.difference internalOpenPrIds externalOpenPrIds prsToOpen = toList $ IntSet.difference externalOpenPrIds internalOpenPrIds + prsToSync = toList $ IntSet.intersection internalOpenPrIds externalOpenPrIds insertMissingPr state pr = getPullRequest pr >>= \case @@ -1082,7 +1104,41 @@ synchronizeState stateInitial = stateClosed <- foldM (flip handlePullRequestClosedByUser) stateInitial prsToClose -- Then get the details for all pull requests that are open on GitHub, but -- which are not yet in our state, and add them. - foldM insertMissingPr stateClosed prsToOpen + stateOpened <- foldM insertMissingPr stateClosed prsToOpen + -- Refresh commit SHAs of pull requests to make sure we complete pending promotions after a + -- successful force-push. + stateSynced <- foldM syncPullRequestSha stateOpened prsToSync + -- Update the build status for all pull requests that are still open, based on the + -- latest build status for their commit SHA. + foldM updateBuildStatus stateSynced (IntMap.elems $ Pr.pullRequests stateSynced) + +syncPullRequestSha + :: (Action :> es, RetrieveEnvironment :> es, TimeOperation :> es) + => ProjectState + -> PullRequestId + -> Eff es ProjectState +syncPullRequestSha state pr = + getPullRequest pr >>= \case + -- On error, keep current state for this pull request. + Nothing -> pure state + Just details -> + case Pr.lookupPullRequest pr state of + Just localPr + | Pr.sha localPr /= GithubApi.sha details -> + handlePullRequestCommitChanged pr (GithubApi.sha details) state + _ -> pure state + +updateBuildStatus :: Action :> es => ProjectState -> PullRequest -> Eff es ProjectState +updateBuildStatus state pr = + case Pr.integrationStatus pr of + Integrated sha _ -> + getBuildStatus sha >>= \case + Nothing -> pure state + Just buildStatuses -> + pure $ foldr (\(Check check, buildStatus) -> handleBuildStatusChangedForPR (Git.Context check) buildStatus pr) state buildStatuses + _ -> do + -- If the PR is not integrated, we don't need to update its build status. + pure state -- | Determines if there is anything to do, and if there is, generates the right -- actions and updates the state accordingly. diff --git a/src/Project.hs b/src/Project.hs index 8319a9dc..34d2e5bd 100644 --- a/src/Project.hs +++ b/src/Project.hs @@ -108,7 +108,7 @@ import Data.IntMap.Strict qualified as IntMap import Data.Map.Strict qualified as Map import Data.Text qualified as T -import Data.Time (UTCTime) +import Data.Time (UTCTime (..)) import Types (PullRequestId (..), ReactableId, Username) -- For any integrated sha, we either wait for the first check, or for @@ -270,6 +270,7 @@ data ProjectState = ProjectState , mandatoryChecks :: MandatoryChecks , recentlyPromoted :: [PromotedPullRequest] , paused :: Bool + , lastSyncTime :: UTCTime } deriving (Eq, Show, Generic) @@ -348,6 +349,7 @@ emptyProjectState = , mandatoryChecks = mempty , recentlyPromoted = [] , paused = False + , lastSyncTime = UTCTime{utctDay = toEnum 0, utctDayTime = 0} } -- Inserts a new pull request into the project, with approval set to Nothing, diff --git a/tests/EventLoopSpec.hs b/tests/EventLoopSpec.hs index 34cde9c6..18f0f995 100644 --- a/tests/EventLoopSpec.hs +++ b/tests/EventLoopSpec.hs @@ -252,7 +252,7 @@ featureFreezeWindow :: Maybe FeatureFreezeWindow featureFreezeWindow = Nothing testTimeouts :: Config.Timeouts -testTimeouts = Config.Timeouts 600 600 +testTimeouts = Config.Timeouts 600 600 600 -- An interpreter for the GitHub API free monad that ignores most API calls, and -- provides fake inputs. We don't want to require a Github repository and API @@ -263,9 +263,10 @@ fakeRunGithub = interpret $ \_ -> \case GithubApi.LeaveComment _pr _body -> pure () GithubApi.AddReaction _reactable _reaction -> pure () GithubApi.HasPushAccess username -> pure $ username `elem` ["rachael", "deckard"] - -- Pretend that these two GitHub API calls always fail in these tests. + -- Pretend that these GitHub API calls always fail in these tests. GithubApi.GetPullRequest _pr -> pure Nothing GithubApi.GetOpenPullRequests -> pure Nothing + GithubApi.GetBuildStatus _sha -> pure Nothing fakeRunTime :: Eff (Time.TimeOperation : es) a -> Eff es a fakeRunTime = interpret $ \_ -> \case diff --git a/tests/Spec.hs b/tests/Spec.hs index c919264d..a1562af9 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -18,7 +18,6 @@ import Data.ByteString.Lazy (readFile) import Data.Either (isRight) import Data.Foldable (foldlM, for_) import Data.Function ((&)) -import Data.IntSet (IntSet) import Data.List (group) import Data.Maybe (fromJust, isNothing) import Data.Text (Text, pack) @@ -32,7 +31,6 @@ import Test.Hspec import Prelude hiding (readFile) import Data.IntMap.Strict qualified as IntMap -import Data.IntSet qualified as IntSet import Data.UUID.V4 qualified as Uuid import Effectful.State.Static.Local qualified as State import Effectful.Writer.Static.Local qualified as Writer @@ -60,6 +58,8 @@ import Project ( PullRequest (PullRequest), ) import ProjectSpec (projectSpec) +import Sync (syncSpec) +import TestSetup (fakeRunTime, testProjectConfig, testTime, testTimeouts, testTriggerConfig) import Time (TimeOperation) import Types (CommentId (..), PullRequestId (..), ReactableId (..), Username (..)) @@ -78,29 +78,6 @@ import Data.Time.Calendar.OrdinalDate qualified as T masterBranch :: BaseBranch masterBranch = BaseBranch "master" --- Trigger config used throughout these tests. -testTriggerConfig :: Config.TriggerConfiguration -testTriggerConfig = - Config.TriggerConfiguration - { Config.commentPrefix = "@bot" - } - -testProjectConfig :: Config.ProjectConfiguration -testProjectConfig = - Config.ProjectConfiguration - { Config.owner = "peter" - , Config.repository = "rep" - , Config.branch = "master" - , Config.testBranch = "testing" - , Config.checkout = "/var/lib/hoff/checkouts/peter/rep" - , Config.stateFile = "/var/lib/hoff/state/peter/rep.json" - , Config.checks = Just (Config.ChecksConfiguration mempty) - , Config.deployEnvironments = Just ["staging", "production"] - , Config.deploySubprojects = Just ["aaa", "bbb"] - , Config.safeForFriday = Nothing - , Config.allowPlainMerge = Just True - } - testmergeWindowExemptionConfig :: Config.MergeWindowExemptionConfiguration testmergeWindowExemptionConfig = Config.MergeWindowExemptionConfiguration ["bot"] @@ -112,15 +89,12 @@ testFeatureFreezeWindow = , end = T.UTCTime (T.fromMondayStartWeek 2021 2 7) (T.secondsToDiffTime 0) } -testTimeouts :: Config.Timeouts -testTimeouts = Config.Timeouts 600 600 - -- Functions to prepare certain test states. singlePullRequestState :: PullRequestId -> Branch -> BaseBranch -> Sha -> Username -> ProjectState singlePullRequestState pr prBranch baseBranch prSha prAuthor = let event = PullRequestOpened pr prBranch baseBranch prSha "Untitled" prAuthor Nothing - in fst $ runAction $ handleEventTest event Project.emptyProjectState + in fst $ runAction $ handleEventTest event Project.emptyProjectState{Project.lastSyncTime = testTime} candidateState :: PullRequestId -> Branch -> BaseBranch -> Sha -> Username -> Username -> Sha -> ProjectState @@ -147,6 +121,7 @@ data ActionFlat | ACleanupTestBranch PullRequestId | AGetPullRequest PullRequestId | AGetOpenPullRequests + | AGetBuildStatus Sha deriving (Eq, Show) -- Results to return from various operations during the tests. There is a @@ -154,8 +129,6 @@ data ActionFlat data Results = Results { resultIntegrate :: [Either IntegrationFailure Sha] , resultPush :: [PushResult] - , resultGetPullRequest :: [Maybe GithubApi.PullRequest] - , resultGetOpenPullRequests :: [Maybe IntSet] , resultGetLatestVersion :: [Either TagName Integer] , resultGetChangelog :: [Maybe Text] , resultGetDateTime :: [T.UTCTime] @@ -169,9 +142,6 @@ defaultResults = resultIntegrate = repeat $ Left $ Logic.IntegrationFailure (BaseBranch "master") MergeFailed , -- Pretend that pushing is always successful. resultPush = repeat PushOk - , -- Pretend that these two calls to GitHub always fail. - resultGetPullRequest = repeat Nothing - , resultGetOpenPullRequests = repeat Nothing , -- And pretend that latest version just grows incrementally resultGetLatestVersion = Right <$> [1 ..] , resultGetChangelog = repeat Nothing @@ -208,20 +178,6 @@ takeResultPush = resultPush (\v res -> res{resultPush = v}) -takeResultGetPullRequest :: (HasCallStack, State Results :> es) => Eff es (Maybe GithubApi.PullRequest) -takeResultGetPullRequest = - takeFromList - "resultGetPullRequest" - resultGetPullRequest - (\v res -> res{resultGetPullRequest = v}) - -takeResultGetOpenPullRequests :: (HasCallStack, State Results :> es) => Eff es (Maybe IntSet) -takeResultGetOpenPullRequests = - takeFromList - "resultGetOpenPullRequests" - resultGetOpenPullRequests - (\v res -> res{resultGetOpenPullRequests = v}) - takeResultGetLatestVersion :: (HasCallStack, State Results :> es) => Eff es (Either TagName Integer) takeResultGetLatestVersion = takeFromList @@ -293,10 +249,13 @@ runActionResults = pure $ isReviewer username GetPullRequest pr -> do Writer.tell [AGetPullRequest pr] - takeResultGetPullRequest + pure Nothing GetOpenPullRequests -> do Writer.tell [AGetOpenPullRequests] - takeResultGetOpenPullRequests + pure Nothing + GetBuildStatus sha -> do + Writer.tell [AGetBuildStatus sha] + pure Nothing GetLatestVersion _ -> takeResultGetLatestVersion GetChangelog _ _ -> takeResultGetChangelog IncreaseMergeAttemptedMetric _ -> pure () @@ -307,13 +266,6 @@ runActionResults = State.put $ results{resultTrainSizeUpdates = n : resultTrainSizeUpdates results} pure () -testTime :: T.UTCTime -testTime = T.UTCTime (T.fromMondayStartWeek 2021 2 1) (T.secondsToDiffTime 0) - -fakeRunTime :: Eff (TimeOperation : es) a -> Eff es a -fakeRunTime = interpret $ \_ -> \case - Time.GetDateTime -> pure $ testTime - runActionEff :: (State Results :> es, Writer [ActionFlat] :> es) => Config.ProjectConfiguration @@ -361,7 +313,7 @@ handleEventsTest events state = foldlM (flip $ Logic.handleEvent testTriggerConf -- Handle events (advancing the state until a fixed point in between) and simulate their side -- effects. Set a timeout of 0 to make sure all actions are done immediately handleEventsTestNoTimeout :: (Action :> es, RetrieveEnvironment :> es, TimeOperation :> es) => [Event] -> ProjectState -> Eff es ProjectState -handleEventsTestNoTimeout events state = foldlM (flip $ Logic.handleEvent testTriggerConfig testmergeWindowExemptionConfig Nothing (Config.Timeouts (-1) (-1))) state events +handleEventsTestNoTimeout events state = foldlM (flip $ Logic.handleEvent testTriggerConfig testmergeWindowExemptionConfig Nothing (Config.Timeouts (-1) (-1) (-1))) state events -- | Like 'classifiedPullRequests' but just with ids. -- This should match 'WebInterface.ClassifiedPullRequests' @@ -413,6 +365,7 @@ main :: IO () main = hspec $ do parserSpec projectSpec + syncSpec describe "Logic.handleEvent" $ do it "handles PullRequestOpened" $ do let @@ -926,92 +879,6 @@ main = hspec $ do state `shouldBe` Project.emptyProjectState actions `shouldBe` [] - it "checks whether pull requests are still open on synchronize" $ do - let - state = singlePullRequestState (PullRequestId 1) (Branch "p") masterBranch (Sha "b7332ba") "tyrell" - results = - defaultResults - { resultGetOpenPullRequests = [Just $ IntSet.singleton 1] - } - (state', actions) = runActionCustom results $ handleEventTest Synchronize state - -- Pull request 1 is open, so the state should not have changed. - state' `shouldBe` state - -- We should have queried GitHub about open pull requests. - actions `shouldBe` [AGetOpenPullRequests] - - it "closes pull requests that are no longer open on synchronize" $ do - let - state = singlePullRequestState (PullRequestId 10) (Branch "p") masterBranch (Sha "b7332ba") "tyrell" - results = - defaultResults - { resultGetOpenPullRequests = [Just $ IntSet.empty] - } - (state', actions) = runActionCustom results $ handleEventTest Synchronize state - -- No pull requests are open on GitHub, so synchronize should have removed - -- the single initial PR. - state' `shouldBe` Project.emptyProjectState - actions `shouldBe` [AGetOpenPullRequests] - - it "does not modify the state on an error during synchronize" $ do - let - state = singlePullRequestState (PullRequestId 19) (Branch "p") masterBranch (Sha "b7332ba") "tyrell" - -- Set up some custom results where we simulate that the GitHub API fails. - results = - defaultResults - { resultGetOpenPullRequests = [Nothing] - } - (state', actions) = runActionCustom results $ handleEventTest Synchronize state - -- We should not have modified anything on error. - state' `shouldBe` state - actions `shouldBe` [AGetOpenPullRequests] - - it "adds missing pull requests during synchronize" $ do - let - state = Project.emptyProjectState - results = - defaultResults - { resultGetOpenPullRequests = [Just $ IntSet.singleton 17] - , resultGetPullRequest = - [ Just $ - GithubApi.PullRequest - { GithubApi.sha = Sha "7faa52318" - , GithubApi.branch = Branch "nexus-7" - , GithubApi.baseBranch = masterBranch - , GithubApi.title = "Add Nexus 7 experiment" - , GithubApi.author = Username "tyrell" - } - ] - } - (state', actions) = runActionCustom results $ handleEventTest Synchronize state - Just pr17 = Project.lookupPullRequest (PullRequestId 17) state' - - -- PR 17 should have been added, with the details defined above. - Project.title pr17 `shouldBe` "Add Nexus 7 experiment" - Project.author pr17 `shouldBe` Username "tyrell" - Project.branch pr17 `shouldBe` Branch "nexus-7" - Project.sha pr17 `shouldBe` Sha "7faa52318" - - -- Approval and integration status should be set to their initial values, - -- we do not go back and scan for approval comments on missing PRs. - Project.approval pr17 `shouldBe` Nothing - Project.integrationStatus pr17 `shouldBe` Project.NotIntegrated - Project.integrationAttempts pr17 `shouldBe` [] - actions `shouldBe` [AGetOpenPullRequests, AGetPullRequest (PullRequestId 17)] - - it "does not query details of existing pull requests on synchronize" $ do - let - state = singlePullRequestState (PullRequestId 19) (Branch "p") masterBranch (Sha "b7332ba") "tyrell" - results = - defaultResults - { resultGetOpenPullRequests = [Just $ IntSet.singleton 19] - } - actions = snd $ runActionCustom results $ handleEventTest Synchronize state - - -- We should only obtain pull request details for pull requests that were - -- missing. In this case, PR 19 was already present, so we should not have - -- obtained its details. - actions `shouldBe` [AGetOpenPullRequests] - it "stores the comment ID of a 'merge' command" $ do let prId = PullRequestId 1 @@ -2357,7 +2224,7 @@ main = hspec $ do (Sha "ab2") "... Of the ..." (Username "dewey") - $ Project.emptyProjectState + $ Project.emptyProjectState{Project.lastSyncTime = testTime} events = [ CommentAdded (PullRequestId 1) "deckard" Nothing "@bot merge" , BuildStatusChanged (Sha "1b2") "default" (Project.BuildStarted "example.com/1b2") @@ -2721,7 +2588,7 @@ main = hspec $ do (Sha "ab1") "Improvements..." (Username "huey") - $ Project.emptyProjectState + $ Project.emptyProjectState{Project.lastSyncTime = testTime} events = [ CommentAdded (PullRequestId 1) "deckard" Nothing "@bot merge" , BuildStatusChanged (Sha "1b2") "default" (Project.BuildStarted "example.com/1b2") @@ -2833,6 +2700,7 @@ main = hspec $ do , Project.mandatoryChecks = mempty , Project.recentlyPromoted = [] , Project.paused = False + , Project.lastSyncTime = testTime } results = defaultResults{resultIntegrate = [Right (Sha "38e")]} actions = snd $ runActionCustom results $ Logic.proceedUntilFixedPoint state @@ -2863,6 +2731,7 @@ main = hspec $ do , Project.mandatoryChecks = mempty , Project.recentlyPromoted = [] , Project.paused = False + , Project.lastSyncTime = testTime } results = defaultResults @@ -2900,6 +2769,7 @@ main = hspec $ do , Project.mandatoryChecks = mempty , Project.recentlyPromoted = [] , Project.paused = False + , Project.lastSyncTime = testTime } -- Run 'proceedUntilFixedPoint', and pretend that pushes fail (because -- something was pushed in the mean time, for instance). @@ -2948,6 +2818,7 @@ main = hspec $ do , Project.mandatoryChecks = mempty , Project.recentlyPromoted = [] , Project.paused = False + , Project.lastSyncTime = testTime } -- Run 'proceedUntilFixedPoint', and pretend that pushes fail (because -- something was pushed in the mean time, for instance). @@ -3070,6 +2941,7 @@ main = hspec $ do , Project.mandatoryChecks = mempty , Project.recentlyPromoted = [] , Project.paused = False + , Project.lastSyncTime = testTime } -- Proceeding should pick the next pull request as candidate. results = defaultResults{resultIntegrate = [Right (Sha "38e")]} diff --git a/tests/Sync.hs b/tests/Sync.hs new file mode 100644 index 00000000..5b71c89f --- /dev/null +++ b/tests/Sync.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Sync (syncSpec) where + +import Data.IntSet (IntSet) +import Effectful (Eff, runPureEff, (:>)) +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.State.Static.Local (State) +import Effectful.Writer.Static.Local (Writer) +import GHC.Stack (HasCallStack) +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +import Data.IntSet qualified as IntSet +import Effectful.State.Static.Local qualified as State +import Effectful.Writer.Static.Local qualified as Writer + +import Configuration qualified as Config +import Git (BaseBranch (..), Branch (..), Sha (..)) +import Git qualified +import Logic (Action (..), Event (..), RetrieveEnvironment (..)) +import Logic qualified +import Project (Approval (..), BuildStatus (..), Check (..), IntegrationStatus (..), Priority (..), PullRequest) +import TestSetup (fakeRunTime, testProjectConfig, testTime, testTimeouts, testTriggerConfig) +import Time (TimeOperation) +import Types (PullRequestId (..), Username (..)) + +import GithubApi qualified +import Project qualified + +data ActionFlat + = AGetPullRequest PullRequestId + | AGetOpenPullRequests + | AGetBuildStatus Sha + | ALeaveComment PullRequestId String + | ATryPromote Sha + | ATryForcePush Branch Sha + | ACleanupTestBranch PullRequestId + deriving (Eq, Show) + +data GithubResults = GithubResults + { resultGetPullRequest :: [Maybe GithubApi.PullRequest] + , resultGetOpenPullRequests :: [Maybe IntSet] + , resultGetBuildStatus :: [Maybe [(Check, BuildStatus)]] + , resultPromote :: [Git.PushResult] + } + +defaultGithubResults :: GithubResults +defaultGithubResults = + GithubResults + { resultGetPullRequest = repeat Nothing + , resultGetOpenPullRequests = repeat Nothing + , resultGetBuildStatus = repeat Nothing + , resultPromote = repeat Git.PushOk + } + +takeFromList + :: HasCallStack + => State GithubResults :> es + => String + -> (GithubResults -> [a]) + -> ([a] -> GithubResults -> GithubResults) + -> Eff es a +takeFromList name getField setField = do + values <- State.gets getField + State.modify $ setField $ tail values + case values of + [] -> error $ "Not enough results supplied for " <> name <> "." + v : _ -> pure v + +takeResultGetPullRequest :: (HasCallStack, State GithubResults :> es) => Eff es (Maybe GithubApi.PullRequest) +takeResultGetPullRequest = + takeFromList + "resultGetPullRequest" + resultGetPullRequest + (\v res -> res{resultGetPullRequest = v}) + +takeResultGetOpenPullRequests :: (HasCallStack, State GithubResults :> es) => Eff es (Maybe IntSet) +takeResultGetOpenPullRequests = + takeFromList + "resultGetOpenPullRequests" + resultGetOpenPullRequests + (\v res -> res{resultGetOpenPullRequests = v}) + +takeResultGetBuildStatus :: (HasCallStack, State GithubResults :> es) => Eff es (Maybe [(Check, BuildStatus)]) +takeResultGetBuildStatus = + takeFromList + "resultGetBuildStatus" + resultGetBuildStatus + (\v res -> res{resultGetBuildStatus = v}) + +runMockGithub + :: State GithubResults :> es + => Eff (GithubApi.GithubOperation : es) a + -> Eff es a +runMockGithub = + interpret $ \_ -> \case + GithubApi.LeaveComment _ _ -> pure () + GithubApi.AddReaction _ _ -> pure () + GithubApi.HasPushAccess _ -> pure False + GithubApi.GetPullRequest _ -> takeResultGetPullRequest + GithubApi.GetOpenPullRequests -> takeResultGetOpenPullRequests + GithubApi.GetBuildStatus _ -> takeResultGetBuildStatus + +runSyncAction + :: (GithubApi.GithubOperation :> es, Writer [ActionFlat] :> es) + => Eff (Action : es) a + -> Eff es a +runSyncAction = + interpret $ \_ -> \case + GetPullRequest pr -> do + Writer.tell [AGetPullRequest pr] + GithubApi.getPullRequest pr + GetOpenPullRequests -> do + Writer.tell [AGetOpenPullRequests] + GithubApi.getOpenPullRequests + GetBuildStatus sha -> do + Writer.tell [AGetBuildStatus sha] + GithubApi.getBuildStatus sha + TryPromote sha -> do + Writer.tell [ATryPromote sha] + pure Git.PushOk + TryForcePush branch sha -> do + Writer.tell [ATryForcePush branch sha] + pure Git.PushOk + LeaveComment pr _ -> do + Writer.tell [ALeaveComment pr "message"] + pure () + CleanupTestBranch pr -> do + Writer.tell [ACleanupTestBranch pr] + pure () + -- Stub out other actions that might be called during proceedUntilFixedPoint + IsReviewer _ -> pure False + AddReaction _ _ -> pure () + TryIntegrate _ _ _ _ -> pure $ Left (Logic.IntegrationFailure (BaseBranch "master") Git.MergeFailed) + TryPromoteWithTag _ _ _ -> pure (Left "error", Git.PushOk) + GetLatestVersion _ -> pure $ Right 1 + GetChangelog _ _ -> pure Nothing + IncreaseMergeAttemptedMetric _ -> pure () + IncreaseMergeFailedMetric _ _ -> pure () + IncreaseMergeMetric _ -> pure () + UpdateTrainSizeMetric _ -> pure () + +runRetrieveInfo + :: State GithubResults :> es + => Eff (RetrieveEnvironment : es) a + -> Eff es a +runRetrieveInfo = interpret $ \_ -> \case + Logic.GetProjectConfig -> pure testProjectConfig + Logic.GetDateTime -> pure testTime + Logic.GetBaseBranch -> pure (BaseBranch $ Config.branch testProjectConfig) + +runSyncWithHandle + :: GithubResults + -> (forall es. (Action :> es, TimeOperation :> es, RetrieveEnvironment :> es, GithubApi.GithubOperation :> es, State GithubResults :> es, Writer [ActionFlat] :> es) => Eff es a) + -> (a, [ActionFlat]) +runSyncWithHandle results eff = + runPureEff $ Writer.runWriter $ State.evalState results $ runMockGithub $ runRetrieveInfo $ fakeRunTime $ runSyncAction eff + +mkExternalPullRequest :: PullRequestId -> GithubApi.PullRequest +mkExternalPullRequest _ = + GithubApi.PullRequest + { GithubApi.sha = Sha "7faa52318" + , GithubApi.branch = Branch "nexus-7" + , GithubApi.baseBranch = BaseBranch "master" + , GithubApi.title = "Add Nexus 7 experiment" + , GithubApi.author = Username "tyrell" + } + +insertInitialPr :: PullRequestId -> Project.ProjectState -> Project.ProjectState +insertInitialPr prId = + Project.insertPullRequest + prId + (Branch "existing") + (BaseBranch "master") + (Sha "abc1234") + "Existing" + (Username "deckard") + +lookupPr :: PullRequestId -> Project.ProjectState -> PullRequest +lookupPr prId state = + case Project.lookupPullRequest prId state of + Just pr -> pr + Nothing -> error "Expected pull request to exist." + +syncSpec :: Spec +syncSpec = + describe "Logic.synchronizeState via handleEvent" $ do + it "keeps existing PRs when they are still open on GitHub" $ do + let + prId = PullRequestId 1 + state0 = insertInitialPr prId Project.emptyProjectState + results = + defaultGithubResults + { resultGetOpenPullRequests = [Just $ IntSet.singleton 1] + , resultGetPullRequest = + [ Just + GithubApi.PullRequest + { GithubApi.sha = Sha "abc1234" + , GithubApi.branch = Branch "existing" + , GithubApi.baseBranch = BaseBranch "master" + , GithubApi.title = "Existing" + , GithubApi.author = Username "deckard" + } + ] + } + (state', actions) = + runSyncWithHandle results $ + Logic.handleEvent testTriggerConfig (Config.MergeWindowExemptionConfiguration []) Nothing testTimeouts Synchronize state0 + + state' `shouldBe` state0 + actions `shouldBe` [AGetOpenPullRequests, AGetPullRequest prId] + + it "synchronizes when no PRs exist locally" $ do + let + prId = PullRequestId 17 + results = + defaultGithubResults + { resultGetOpenPullRequests = [Just $ IntSet.singleton 17] + , resultGetPullRequest = [Just $ mkExternalPullRequest prId] + } + (state', actions) = + runSyncWithHandle results $ + Logic.handleEvent testTriggerConfig (Config.MergeWindowExemptionConfiguration []) Nothing testTimeouts Synchronize Project.emptyProjectState + + state' `shouldSatisfy` Project.existsPullRequest prId + let pr = lookupPr prId state' + Project.title pr `shouldBe` "Add Nexus 7 experiment" + Project.author pr `shouldBe` Username "tyrell" + Project.branch pr `shouldBe` Branch "nexus-7" + Project.sha pr `shouldBe` Sha "7faa52318" + Project.approval pr `shouldBe` Nothing + Project.integrationStatus pr `shouldBe` Project.NotIntegrated + Project.integrationAttempts pr `shouldBe` [] + actions `shouldBe` [AGetOpenPullRequests, AGetPullRequest prId] + + it "removes PRs that are no longer open on GitHub" $ do + let + prId = PullRequestId 1 + state0 = insertInitialPr prId Project.emptyProjectState + results = + defaultGithubResults + { resultGetOpenPullRequests = [Just IntSet.empty] + } + (state, _actions) = + runSyncWithHandle results $ + Logic.handleEvent testTriggerConfig (Config.MergeWindowExemptionConfiguration []) Nothing testTimeouts Synchronize state0 + + state `shouldBe` Project.emptyProjectState + + it "does not modify the state when querying open pull requests fails" $ do + let + prId = PullRequestId 19 + state0 = insertInitialPr prId Project.emptyProjectState + results = + defaultGithubResults + { resultGetOpenPullRequests = [Nothing] + } + (state', actions) = + runSyncWithHandle results $ + Logic.handleEvent testTriggerConfig (Config.MergeWindowExemptionConfiguration []) Nothing testTimeouts Synchronize state0 + + state' `shouldBe` state0 + actions `shouldBe` [AGetOpenPullRequests] + + it "queries details of existing pull requests during synchronize" $ do + let + prId = PullRequestId 19 + state0 = insertInitialPr prId Project.emptyProjectState + results = + defaultGithubResults + { resultGetOpenPullRequests = [Just $ IntSet.singleton 19] + , resultGetPullRequest = + [ Just + GithubApi.PullRequest + { GithubApi.sha = Sha "abc1234" + , GithubApi.branch = Branch "existing" + , GithubApi.baseBranch = BaseBranch "master" + , GithubApi.title = "Existing" + , GithubApi.author = Username "deckard" + } + ] + } + (_state, actions) = + runSyncWithHandle results $ + Logic.handleEvent testTriggerConfig (Config.MergeWindowExemptionConfiguration []) Nothing testTimeouts Synchronize state0 + + actions `shouldBe` [AGetOpenPullRequests, AGetPullRequest prId] + + it "force-pushes after successful build is detected via sync" $ do + let + prId = PullRequestId 1 + integratedSha = Sha "84c" + approval = Approval (Username "deckard") Nothing Project.Merge 0 Nothing Normal + state0 = + Project.setApproval prId (Just approval) $ + Project.setIntegrationStatus prId (Integrated integratedSha (Project.AnyCheck BuildPending)) $ + insertInitialPr prId Project.emptyProjectState + results = + defaultGithubResults + { resultGetOpenPullRequests = [Just $ IntSet.singleton 1] + , resultGetBuildStatus = [Just [(Check "build", BuildSucceeded)]] + , resultPromote = [Git.PushOk] + } + (_state, actions) = + runSyncWithHandle results $ + Logic.handleEvent testTriggerConfig (Config.MergeWindowExemptionConfiguration []) Nothing testTimeouts Synchronize state0 + + actions `shouldBe` [AGetOpenPullRequests, AGetPullRequest prId, AGetBuildStatus integratedSha, ATryForcePush (Branch "existing") integratedSha] + + it "promotes PR when sync reveals force-pushed commit on the PR branch" $ do + let + prId = PullRequestId 1 + integratedSha = Sha "84c" + approval = Approval (Username "deckard") Nothing Project.Merge 0 Nothing Normal + state0 = + Project.setApproval prId (Just approval) $ + Project.setIntegrationStatus prId (Promote testTime integratedSha) $ + insertInitialPr prId Project.emptyProjectState + results = + defaultGithubResults + { resultGetOpenPullRequests = [Just $ IntSet.singleton 1] + , resultGetPullRequest = + [ Just + GithubApi.PullRequest + { GithubApi.sha = integratedSha + , GithubApi.branch = Branch "existing" + , GithubApi.baseBranch = BaseBranch "master" + , GithubApi.title = "Existing" + , GithubApi.author = Username "deckard" + } + ] + } + (_state, actions) = + runSyncWithHandle results $ + Logic.handleEvent testTriggerConfig (Config.MergeWindowExemptionConfiguration []) Nothing testTimeouts Synchronize state0 + + actions `shouldBe` [AGetOpenPullRequests, AGetPullRequest prId, ATryPromote integratedSha, ACleanupTestBranch prId] + + it "leaves feedback comment when sync detects build failure" $ do + let + prId = PullRequestId 1 + integratedSha = Sha "84c" + approval = Approval (Username "deckard") Nothing Project.Merge 0 Nothing Normal + state0 = + Project.setApproval prId (Just approval) $ + Project.setIntegrationStatus prId (Integrated integratedSha (Project.AnyCheck BuildPending)) $ + insertInitialPr prId Project.emptyProjectState + results = + defaultGithubResults + { resultGetOpenPullRequests = [Just $ IntSet.singleton 1] + , resultGetBuildStatus = [Just [(Check "build", BuildFailed Nothing)]] + } + (_state, actions) = + runSyncWithHandle results $ + Logic.handleEvent testTriggerConfig (Config.MergeWindowExemptionConfiguration []) Nothing testTimeouts Synchronize state0 + + actions `shouldBe` [AGetOpenPullRequests, AGetPullRequest prId, AGetBuildStatus integratedSha, ALeaveComment prId "message"] diff --git a/tests/TestSetup.hs b/tests/TestSetup.hs new file mode 100644 index 00000000..38bad7ea --- /dev/null +++ b/tests/TestSetup.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module TestSetup (testProjectConfig, testTriggerConfig, testTimeouts, testTime, fakeRunTime) where + +import Data.Time qualified as T +import Data.Time.Calendar.OrdinalDate qualified as T +import Effectful (Eff) +import Effectful.Dispatch.Dynamic (interpret) + +import Configuration qualified as Config +import Time (TimeOperation) +import Time qualified + +testTriggerConfig :: Config.TriggerConfiguration +testTriggerConfig = + Config.TriggerConfiguration + { Config.commentPrefix = "@bot" + } + +testProjectConfig :: Config.ProjectConfiguration +testProjectConfig = + Config.ProjectConfiguration + { Config.owner = "peter" + , Config.repository = "rep" + , Config.branch = "master" + , Config.testBranch = "testing" + , Config.checkout = "/var/lib/hoff/checkouts/peter/rep" + , Config.stateFile = "/var/lib/hoff/state/peter/rep.json" + , Config.checks = Just (Config.ChecksConfiguration mempty) + , Config.deployEnvironments = Just ["staging", "production"] + , Config.deploySubprojects = Just ["aaa", "bbb"] + , Config.safeForFriday = Nothing + , Config.allowPlainMerge = Just True + } + +testTime :: T.UTCTime +testTime = T.UTCTime (T.fromMondayStartWeek 2021 2 1) (T.secondsToDiffTime 0) + +testTimeouts :: Config.Timeouts +testTimeouts = Config.Timeouts 600 600 6000 + +fakeRunTime :: Eff (TimeOperation : es) a -> Eff es a +fakeRunTime = interpret $ \_ -> \case + Time.GetDateTime -> pure testTime