Merge #146: Split BuildPending into BuildStarted.

Approved-by: rudymatela
Auto-deploy: false

Author: OpsBotPrime

src/EventLoop.hs

@@ -73,11 +73,13 @@ eventFromCommentPayload payload =
     _ -> Nothing
 
 mapCommitStatus :: Github.CommitStatus -> Maybe Text.Text -> Project.BuildStatus
-mapCommitStatus status url = case status of
-  Github.Pending -> Project.BuildPending url
+mapCommitStatus status murl = case status of
+  Github.Pending -> case murl of
+                    Nothing -> Project.BuildPending
+                    Just url -> Project.BuildStarted url
   Github.Success -> Project.BuildSucceeded
-  Github.Failure -> Project.BuildFailed url
-  Github.Error   -> Project.BuildFailed url
+  Github.Failure -> Project.BuildFailed murl
+  Github.Error   -> Project.BuildFailed murl
 
 eventFromCommitStatusPayload :: CommitStatusPayload -> Logic.Event
 eventFromCommitStatusPayload payload =

src/Logic.hs

@@ -551,9 +551,9 @@ handleBuildStatusChanged buildSha newStatus = pure . Pr.updatePullRequests setBu
     Integrated candidateSha oldStatus | candidateSha == buildSha && newStatus /= oldStatus ->
       pr { Pr.integrationStatus = Integrated buildSha newStatus
          , Pr.needsFeedback = case newStatus of
-                              BuildPending (Just _) -> True
-                              BuildFailed _         -> True
-                              _                     -> Pr.needsFeedback pr -- unchanged
+                              BuildStarted _ -> True
+                              BuildFailed _  -> True
+                              _              -> Pr.needsFeedback pr -- unchanged
          }
     _ -> pr
 
@@ -655,7 +655,7 @@ tryIntegratePullRequest pr state =
         -- as pushing should have triggered a build.
         pure
           -- The build pending has no URL here, we need to wait for semaphore
-          $ Pr.setIntegrationStatus pr (Integrated (Sha sha) (BuildPending Nothing))
+          $ Pr.setIntegrationStatus pr (Integrated (Sha sha) BuildPending)
           $ Pr.setNeedsFeedback pr True
           $ state
 
@@ -734,11 +734,9 @@ describeStatus prId pr state = case Pr.classifyPullRequest pr of
       0 -> format "Pull request approved for {} by @{}, rebasing now." [approvalCommand, approvedBy]
       1 -> format "Pull request approved for {} by @{}, waiting for rebase behind one pull request." [approvalCommand, approvedBy]
       n -> format "Pull request approved for {} by @{}, waiting for rebase behind {} pull requests." (approvalCommand, approvedBy, n)
-  PrStatusBuildPending url ->
-    let Sha sha = fromJust $ getIntegrationSha pr
-    in case url of
-         Just url' -> Text.concat ["Waiting on CI job: ", url']
-         Nothing   -> Text.concat ["Rebased as ", sha, ", waiting for CI …"]
+  PrStatusBuildPending -> let Sha sha = fromJust $ getIntegrationSha pr
+                          in  Text.concat ["Rebased as ", sha, ", waiting for CI …"]
+  PrStatusBuildStarted url -> Text.concat ["[CI job](", url, ") started."]
   PrStatusIntegrated -> "The build succeeded."
   PrStatusIncorrectBaseBranch -> "Merge rejected: the target branch must be the integration branch."
   PrStatusWrongFixups -> "Pull request cannot be integrated as it contains fixup commits that do not belong to any other commits."

src/Project.hs

@@ -71,7 +71,8 @@ import qualified Data.IntMap.Strict as IntMap
 import Types (PullRequestId (..), Username)
 
 data BuildStatus
-  = BuildPending (Maybe Text)
+  = BuildPending
+  | BuildStarted Text
   | BuildSucceeded
   | BuildFailed (Maybe Text)
   deriving (Eq, Show, Generic)
@@ -97,7 +98,8 @@ data IntegrationStatus
 data PullRequestStatus
   = PrStatusAwaitingApproval          -- New, awaiting review.
   | PrStatusApproved                  -- Approved, but not yet integrated or built.
-  | PrStatusBuildPending (Maybe Text) -- Integrated, and build pending or in progress.
+  | PrStatusBuildPending              -- Integrated, and build pending or in progress.
+  | PrStatusBuildStarted Text         -- Integrated, and build pending or in progress.
   | PrStatusIntegrated                -- Integrated, build passed, merged into target branch.
   | PrStatusIncorrectBaseBranch       -- ^ Integration branch not being valid.
   | PrStatusWrongFixups               -- Failed to integrate due to the presence of orphan fixup commits.
@@ -294,7 +296,8 @@ classifyPullRequest pr = case approval pr of
     Conflicted _ EmptyRebase -> PrStatusEmptyRebase
     Conflicted _ _  -> PrStatusFailedConflict
     Integrated _ buildStatus -> case buildStatus of
-      BuildPending url -> PrStatusBuildPending url
+      BuildPending     -> PrStatusBuildPending
+      BuildStarted url -> PrStatusBuildStarted url
       BuildSucceeded   -> PrStatusIntegrated
       BuildFailed url  -> PrStatusFailedBuild url
     Promoted -> PrStatusIntegrated
@@ -364,7 +367,8 @@ isInProgress pr = case approval pr of
     IncorrectBaseBranch -> False
     Conflicted _ _ -> False
     Integrated _ buildStatus -> case buildStatus of
-      BuildPending _ -> True
+      BuildPending   -> True
+      BuildStarted _ -> True
       BuildSucceeded -> False
       BuildFailed _  -> False
     Promoted -> False
@@ -379,7 +383,8 @@ wasIntegrationAttemptFor commit pr = case integrationStatus pr of
 integratedPullRequests :: ProjectState -> [PullRequestId]
 integratedPullRequests = filterPullRequestsBy $ isIntegrated . integrationStatus
   where
-  isIntegrated (Integrated _ (BuildPending _)) = True
+  isIntegrated (Integrated _ BuildPending)     = True
+  isIntegrated (Integrated _ (BuildStarted _)) = True
   isIntegrated (Integrated _ BuildSucceeded)   = True
   isIntegrated _                               = False
 

src/WebInterface.hs

@@ -30,6 +30,7 @@ import qualified Data.ByteString.Lazy as LazyByteString
 import qualified Data.Text as Text
 
 import Format (format)
+import Git (Sha(..))
 import Project (Approval (..), BuildStatus (..), IntegrationStatus (..), Owner, ProjectInfo,
                 ProjectState, PullRequest (integrationStatus))
 import Types (PullRequestId (..), Username (..))
@@ -228,24 +229,27 @@ viewGroupedProjectQueues projects = do
 
 -- Renders the contents of a list item with a link for a pull request.
 viewPullRequest :: ProjectInfo -> PullRequestId -> PullRequest -> Html
-viewPullRequest info (PullRequestId n) pullRequest =
-  let
-    url = format "https://github.com/{}/{}/pull/{}"
-      (Project.owner info, Project.repository info, n)
-  in do
-    a ! href (toValue url) $ toHtml $ Project.title pullRequest
-    span ! class_ "prId" $ toHtml $ "#" <> (show n)
-
-    case integrationStatus pullRequest of
-      Integrated _ (BuildPending (Just ciUrl)) -> do
-        span "  | "
-        a ! href (toValue ciUrl) $ "View in CI"
-
-      Integrated _ (BuildFailed (Just ciUrl)) -> do
-        span "  | "
-        a ! href (toValue ciUrl) $ "View in CI"
-
-      _ -> pure ()
+viewPullRequest info pullRequestId pullRequest = do
+  a ! href (toValue $ pullRequestUrl info pullRequestId) $ toHtml $ Project.title pullRequest
+  span ! class_ "prId" $ toHtml $ prettyPullRequestId pullRequestId
+
+  case integrationStatus pullRequest of
+    Integrated sha buildStatus -> do
+      span "  | "
+      case buildStatus of
+        (BuildStarted ciUrl)       -> ciLink ciUrl "🟡"
+        (BuildFailed (Just ciUrl)) -> ciLink ciUrl "❌"
+        _                          -> pure ()
+      a ! href (toValue $ commitUrl info sha) $ toHtml $ prettySha sha
+      case buildStatus of
+        (BuildStarted ciUrl)       -> span " | " >> ciLink ciUrl "CI build"
+        (BuildFailed (Just ciUrl)) -> span " | " >> ciLink ciUrl "CI build"
+        _                          -> pure ()
+    _ -> pure ()
+  where
+  ciLink url text = do
+    a ! href (toValue url) $ text
+    span " "
 
 viewPullRequestWithApproval :: ProjectInfo -> PullRequestId -> PullRequest -> Html
 viewPullRequestWithApproval info prId pullRequest = do
@@ -270,11 +274,37 @@ viewList  :: (ProjectInfo -> PullRequestId -> PullRequest -> Html)
           -> Html
 viewList view info prs = forM_  prs $ \(prId, pr, _) -> p $ view info prId pr
 
+-- | Formats a pull request URL
+pullRequestUrl :: ProjectInfo -> PullRequestId -> Text
+pullRequestUrl info (PullRequestId n) =
+  format "https://github.com/{}/{}/pull/{}"
+    ( Project.owner info
+    , Project.repository info
+    , n
+    )
+
+commitUrl :: ProjectInfo -> Sha -> Text
+commitUrl info (Sha sha) =
+  format "https://github.com/{}/{}/commit/{}"
+    ( Project.owner info
+    , Project.repository info
+    , sha
+    )
+
+-- | Textual rendering of a PullRequestId as #number
+prettyPullRequestId :: PullRequestId -> String
+prettyPullRequestId (PullRequestId n) = "#" <> show n
+
+-- | Textual rendering of a Sha with just the first 7 characters
+prettySha :: Sha -> Text
+prettySha (Sha sha) = Text.take 7 sha
+
 prFailed :: Project.PullRequestStatus -> Bool
 prFailed Project.PrStatusFailedConflict  = True
 prFailed (Project.PrStatusFailedBuild _) = True
 prFailed _                               = False
 
 prPending :: Project.PullRequestStatus -> Bool
-prPending (Project.PrStatusBuildPending _) = True
+prPending Project.PrStatusBuildPending     = True
+prPending (Project.PrStatusBuildStarted _) = True
 prPending _                                = False

tests/EventLoopSpec.hs

@@ -849,7 +849,7 @@ eventLoopSpec = parallel $ do
         let Just pullRequest4 = Project.lookupPullRequest pr4 state
             Integrated _ buildStatus = Project.integrationStatus pullRequest4
         -- Expect no CI url
-        buildStatus `shouldBe` BuildPending Nothing
+        buildStatus `shouldBe` BuildPending
 
       -- We did not send a build status notification for c4, so it should not
       -- have been integrated.