Fix web display of merge trains

src/Project.hs

@@ -24,6 +24,7 @@ module Project
   integratedPullRequests,
   unfailedIntegratedPullRequests,
   unfailedIntegratedPullRequestsBefore,
+  speculativelyFailedPullRequests,
   candidatePullRequests,
   classifyPullRequest,
   classifyPullRequests,
@@ -115,7 +116,7 @@ data PullRequestStatus
   | PrStatusFailedConflict            -- Failed to integrate due to merge conflict.
   | PrStatusSpeculativeConflict       -- Failed to integrate but this was a speculative build
   | PrStatusFailedBuild (Maybe Text)  -- Integrated, but the build failed. Field should contain the URL to a page explaining the build failure.
-  deriving (Eq)
+  deriving (Eq, Show)
 
 -- A PR can be approved to be merged with "<prefix> merge", or it can be
 -- approved to be merged and also deployed with "<prefix> merge and deploy".
@@ -394,21 +395,39 @@ wasIntegrationAttemptFor commit pr = case integrationStatus pr of
 integratedPullRequests :: ProjectState -> [PullRequestId]
 integratedPullRequests = filterPullRequestsBy $ isIntegrated . integrationStatus
 
+-- | Lists all PR ids that are speculative failures.
+--
+-- In other words, this lists all failed PRs
+-- that come after the first non-failing PR
+-- in approval order.
+speculativelyFailedPullRequests :: ProjectState -> [PullRequestId]
+speculativelyFailedPullRequests state
+  = map fst
+  $ filter (isFailedIntegrated . integrationStatus . snd)
+  $ dropWhile (not . isUnfailedIntegrated . integrationStatus . snd)
+  [ (pid, pr)
+  | pid <- integratedPullRequests state
+  , Just pr <- [lookupPullRequest pid state]
+  ]
+
+-- | Lists all pull requests that were integrated and did not fail.
 unfailedIntegratedPullRequests :: ProjectState -> [PullRequestId]
 unfailedIntegratedPullRequests = filterPullRequestsBy $ isUnfailedIntegrated . integrationStatus
 
+-- | Lists all pull requests that were integrated, did not fail
+-- and that come before a given PR in approval order.
 unfailedIntegratedPullRequestsBefore :: PullRequest -> ProjectState -> [PullRequestId]
 unfailedIntegratedPullRequestsBefore referencePullRequest = filterPullRequestsBy $
   \pr -> isUnfailedIntegrated (integrationStatus pr)
       && referencePullRequest `approvedAfter` pr
 
--- Returns the pull requests that have not been integrated yet, in order of
--- ascending id.
+-- | Returns the pull requests that have not been integrated yet,
+--   in order of ascending id.
 unintegratedPullRequests :: ProjectState -> [PullRequestId]
 unintegratedPullRequests = filterPullRequestsBy $ (== NotIntegrated) . integrationStatus
 
--- Returns the pull requests that have been approved, but for which integration
--- and building has not yet been attempted.
+-- | Returns the pull requests that have been approved, but for which integration
+--   and building has not yet been attempted.
 candidatePullRequests :: ProjectState -> [PullRequestId]
 candidatePullRequests state =
   let
@@ -463,6 +482,14 @@ isIntegrated :: IntegrationStatus -> Bool
 isIntegrated (Integrated _ _) = True
 isIntegrated _                = False
 
+-- | Returns whether an 'IntegrationStatus' is integrated with a build failure:
+--   @ Integrated _ (BuildFailed _) @
+isFailedIntegrated :: IntegrationStatus -> Bool
+isFailedIntegrated (Integrated _ (BuildFailed _)) = True
+isFailedIntegrated _ = False
+
+-- | Returns whether an 'IntegrationStatus' is integrated
+--   without a build failure, i.e. build pending, started or succeeded.
 isUnfailedIntegrated :: IntegrationStatus -> Bool
 isUnfailedIntegrated (Integrated _ buildStatus) = case buildStatus of
                                                   BuildPending     -> True
@@ -471,6 +498,7 @@ isUnfailedIntegrated (Integrated _ buildStatus) = case buildStatus of
                                                   (BuildFailed _)  -> False
 isUnfailedIntegrated _ = False
 
+-- | Returns whether a 'PullRequest' is integrated or conflicted speculatively.
 isIntegratedOrSpeculativelyConflicted :: PullRequest -> Bool
 isIntegratedOrSpeculativelyConflicted pr =
   case integrationStatus pr of

src/WebInterface.hs

@@ -7,8 +7,20 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
-
-module WebInterface (renderPage, viewIndex, viewProject, viewOwner, stylesheet, stylesheetUrl) where
+{-# LANGUAGE RecordWildCards #-}
+
+module WebInterface
+  ( renderPage
+  , viewIndex
+  , viewProject
+  , viewOwner
+  , stylesheet
+  , stylesheetUrl
+  -- * The following are only exported for testing
+  , ClassifiedPullRequests (..)
+  , classifiedPullRequests
+  )
+ where
 
 import Control.Monad (forM_, unless, void)
 import Crypto.Hash (Digest, SHA256, hash)
@@ -33,7 +45,7 @@ import qualified Data.Text as Text
 import Format (format)
 import Git (Sha(..))
 import Project (Approval (..), BuildStatus (..), IntegrationStatus (..), Owner, ProjectInfo,
-                ProjectState, PullRequest (integrationStatus))
+                ProjectState, PullRequest (integrationStatus), speculativelyFailedPullRequests)
 import Types (PullRequestId (..), Username (..))
 
 import qualified Project
@@ -145,74 +157,85 @@ viewOwner owner projects = do
     a ! href (toValue ownerUrl) $ toHtml owner
   viewGroupedProjectQueues projects
 
+-- | This record structure contains pull requests classified
+--   by each corresponding section in the UI:
+--   building, failed, approved or awaiting.
+--
+-- Use 'classifiedPullRequests' to construct this structure
+-- from a 'ProjectState'.
+data ClassifiedPullRequests = ClassifiedPullRequests
+  { building
+  , failed
+  , approved
+  , awaiting :: [(PullRequestId, PullRequest, Project.PullRequestStatus)]
+  } deriving (Eq, Show)
+
+-- | Given a 'ProjectState', classifies pull requests into
+--   the four sections of the UI (building, failed, approved or awaiting)
+--   in a 'ClassifiedPullRequests' record.
+classifiedPullRequests :: ProjectState -> ClassifiedPullRequests
+classifiedPullRequests state = ClassifiedPullRequests
+  { building = sortPrs $ filterPrs prPending ++ speculativelyFailed
+  , failed   = sortPrs $ realFailed
+  , approved = sortPrs $ filterPrs (== Project.PrStatusApproved)
+  , awaiting =           filterPrs (== Project.PrStatusAwaitingApproval)
+  }
+  where
+  allFailed = filterPrs prFailed
+  realFailed          = filter (\(pid,_,_) -> pid `notElem` speculativelyFailedIds) allFailed
+  speculativelyFailed = filter (\(pid,_,_) -> pid   `elem`  speculativelyFailedIds) allFailed
+  speculativelyFailedIds = speculativelyFailedPullRequests state
+  sortPrs = sortOn (\(_, pr, _) -> approvalOrder <$> Project.approval pr)
+  filterPrs predicate = filter (\(_, _, status) -> predicate status) pullRequests
+  pullRequests = Project.classifyPullRequests state
+
 -- Render the html for the queues in a project, excluding the header and footer.
 viewProjectQueues :: ProjectInfo -> ProjectState -> Html
 viewProjectQueues info state = do
-  let
-    pullRequests :: [(PullRequestId, PullRequest, Project.PullRequestStatus)]
-    pullRequests = Project.classifyPullRequests state
-    filterPrs predicate = filter (\(_, _, status) -> predicate status) pullRequests
-
-  let building = filterPrs prPending
+  let ClassifiedPullRequests{..} = classifiedPullRequests state
   h2 "Building"
   if null building
     then p "There are no builds in progress at the moment."
     else viewList viewPullRequestWithApproval info building
 
-  let approved = filterPrs (== Project.PrStatusApproved)
   unless (null approved) $ do
     h2 "Approved"
-    let approvedSorted = sortOn (\(_, pr, _) -> approvalOrder <$> Project.approval pr) approved
-    viewList viewPullRequestWithApproval info approvedSorted
+    viewList viewPullRequestWithApproval info approved
 
-  let failed = filterPrs prFailed
   unless (null failed) $ do
     h2 "Failed"
-    -- TODO: Also render failure reason: conflicted or build failed.
     viewList viewPullRequestWithApproval info failed
 
-  let awaitingApproval = reverse $ filterPrs (== Project.PrStatusAwaitingApproval)
-  unless (null awaitingApproval) $ do
+  unless (null awaiting) $ do
     h2 "Awaiting approval"
-    viewList viewPullRequest info awaitingApproval
+    viewList viewPullRequest info awaiting
 
 -- Render the html for the queues in a project, excluding the header and footer.
 viewGroupedProjectQueues :: [(ProjectInfo, ProjectState)] -> Html
 viewGroupedProjectQueues projects = do
-  let
-    pullRequests :: [(ProjectInfo, [(PullRequestId, PullRequest, Project.PullRequestStatus)])]
-    pullRequests = map (second Project.classifyPullRequests) projects
-    filterPrs predicate = let
-      predicateTriple (_, _, status) = predicate status
-      in  filter (not . null . snd) $ map (second (filter predicateTriple)) pullRequests
-  let
-    building = filterPrs prPending
+  let prs = map (second classifiedPullRequests) projects
+      only what = filter (not . null . snd) $ map (second what) prs
+      onlyBuilding = only building
+      onlyApproved = only approved
+      onlyFailed   = only failed
+      onlyAwaiting = only awaiting
+
   h2 "Building"
-  if null building
+  if null onlyBuilding
     then p "There are no builds in progress at the moment."
-    else mapM_ (uncurry $ viewList' viewPullRequestWithApproval) building
-  let approved = filterPrs (== Project.PrStatusApproved)
-  unless (null approved) $ do
+    else mapM_ (uncurry $ viewList' viewPullRequestWithApproval) onlyBuilding
+
+  unless (null onlyApproved) $ do
     h2 "Approved"
-    mapM_ (uncurry $ viewList' viewPullRequestWithApproval) approved
+    mapM_ (uncurry $ viewList' viewPullRequestWithApproval) onlyApproved
 
-  let failed = filterPrs prFailed
-  unless (null failed) $ do
+  unless (null onlyFailed) $ do
     h2 "Failed"
-    -- TODO: Also render failure reason: conflicted or build failed.
-    mapM_ (uncurry $ viewList' viewPullRequestWithApproval) failed
-
-  -- TODO: Keep a list of the last n integrated pull requests, so they stay
-  -- around for a bit after they have been closed.
-  let integrated = filterPrs (== Project.PrStatusIntegrated)
-  unless (null integrated) $ do
-    h2 "Recently integrated"
-    mapM_ (uncurry $ viewList' viewPullRequestWithApproval) integrated
-
-  let awaitingApproval = reverse $ filterPrs (== Project.PrStatusAwaitingApproval)
-  unless (null awaitingApproval) $ do
+    mapM_ (uncurry $ viewList' viewPullRequestWithApproval) onlyFailed
+
+  unless (null onlyAwaiting) $ do
     h2 "Awaiting approval"
-    mapM_ (uncurry $ viewList' viewPullRequest) awaitingApproval
+    mapM_ (uncurry $ viewList' viewPullRequest) onlyAwaiting
 
   where
     viewList'
@@ -243,7 +266,10 @@ viewPullRequest info pullRequestId pullRequest = do
         (BuildStarted ciUrl)       -> span " | " >> ciLink ciUrl "CI build"
         (BuildFailed (Just ciUrl)) -> span " | " >> ciLink ciUrl "CI build"
         _                          -> pure ()
-    _ -> pure ()
+    Conflicted _ _      -> span "  | " >> span "‼️ conflicted"
+    Promoted            -> span "  | " >> span "🔷 promoted"
+    IncorrectBaseBranch -> span "  | " >> span "❗ incorrect base branch"
+    NotIntegrated       -> pure ()
   where
   ciLink url text = do
     a ! href (toValue url) $ text
@@ -298,17 +324,24 @@ prettySha :: Sha -> Text
 prettySha (Sha sha) = Text.take 7 sha
 
 prFailed :: Project.PullRequestStatus -> Bool
-prFailed Project.PrStatusFailedConflict  = True
-prFailed (Project.PrStatusFailedBuild _) = True
-prFailed _                               = False
+prFailed Project.PrStatusFailedConflict      = True
+prFailed Project.PrStatusEmptyRebase         = True
+prFailed Project.PrStatusWrongFixups         = True
+prFailed Project.PrStatusIncorrectBaseBranch = True
+prFailed (Project.PrStatusFailedBuild _)     = True
+prFailed _                                   = False
 
 prPending :: Project.PullRequestStatus -> Bool
-prPending Project.PrStatusBuildPending     = True
-prPending (Project.PrStatusBuildStarted _) = True
+prPending Project.PrStatusBuildPending        = True
+prPending (Project.PrStatusBuildStarted _)    = True
 -- PrStatusIntegrated here means that the PR successfully built
 -- but it has not been promoted to master yet for either of two reasons:
 -- 1. this is the split-second between receiving the status and promoting;
 -- 2. this PR is not at the head of the merge train,
 --    we are waiting for the build status of the previous PR.
-prPending Project.PrStatusIntegrated       = True
-prPending _                                = False
+prPending Project.PrStatusIntegrated          = True
+-- A speculative conflict means that the PR is also still "building".
+-- The conflict may have well been fault of a previous PR that will eventually
+-- fail.  At that moment, this PR will be reintegrated automatically.
+prPending Project.PrStatusSpeculativeConflict = True
+prPending _                                   = False