Synchronize commits shas and build status on a timer

doc/example-dev-config.json

@@ -38,6 +38,7 @@
   },
   "timeouts": {
     "promotionTimeout": 60,
-    "rememberTimeout": 600
+    "rememberTimeout": 600,
+    "syncTimeout": 600
   }
 }

hoff.cabal

@@ -110,6 +110,8 @@ test-suite spec
   other-modules:
     ParserSpec
     ProjectSpec
+    Sync
+    TestSetup
 
   hs-source-dirs:   tests
   ghc-options:      -Wall -Werror

package/example-config.json

@@ -57,6 +57,7 @@
   },
   "timeouts": {
     "promotionTimeout": 60,
-    "rememberTimeout": 600
+    "rememberTimeout": 600,
+    "syncTimeout": 600
   }
 }

src/Configuration.hs

@@ -98,6 +98,7 @@ newtype MergeWindowExemptionConfiguration = MergeWindowExemptionConfiguration [T
 data Timeouts = Timeouts
   { promotionTimeout :: DiffTime
   , rememberTimeout :: DiffTime
+  , syncTimeout :: DiffTime
   }
   deriving (Generic, Show)
 

src/GithubApi.hs

@@ -18,6 +18,7 @@ module GithubApi (
   ReactionContent (..),
   getOpenPullRequests,
   getPullRequest,
+  getBuildStatus,
   hasPushAccess,
   leaveComment,
   addReaction,
@@ -43,16 +44,18 @@ 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
 
 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)

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.

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,

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