Merge pull request #1043 from ysangkok/link-build-report

Link build report from badge

Author: gbaz

datafiles/templates/Html/package-page.html.st

@@ -56,10 +56,20 @@
         </div>
 
         <div id="badges" style="margin-top: 20px;">
-            $if(install.0)$<img src="https://img.shields.io/static/v1?label=Build&message=$install.2$&color=$install.1$" />$endif$
-            $if(test.0)$<img src="https://img.shields.io/static/v1?label=Tests&message=$test.2$&color=$test.1$" />$endif$
-            $if(covg.0)$<img src="https://img.shields.io/static/v1?label=Coverage&message=$covg.2$%&color=$covg.1$" />$endif$
-            $if(!hasExecOnly)$<img src="https://img.shields.io/static/v1?label=Documentation&message=$if(hasDocs)$Available$else$Unavailable$endif$&color=$if(hasDocs)$success$else$critical$endif$" />$endif$
+            $if(install.0)$
+              <a href="$install.3$">
+                <img src="https://img.shields.io/static/v1?label=Build&message=$install.2$&color=$install.1$" />
+              </a>
+            $endif$
+            $if(test.0)$
+              <img src="https://img.shields.io/static/v1?label=Tests&message=$test.2$&color=$test.1$" />
+            $endif$
+            $if(covg.0)$
+              <img src="https://img.shields.io/static/v1?label=Coverage&message=$covg.2$%&color=$covg.1$" />
+            $endif$
+            $if(!hasExecOnly)$
+              <img src="https://img.shields.io/static/v1?label=Documentation&message=$if(hasDocs)$Available$else$Unavailable$endif$&color=$if(hasDocs)$success$else$critical$endif$" />
+            $endif$
         </div>
 
         <div id="modules">

src/Distribution/Server/Features/BuildReports.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-}
 module Distribution.Server.Features.BuildReports (
+    BuildReportId(..),
     ReportsFeature(..),
     ReportsResource(..),
     initBuildReportsFeature
@@ -45,7 +46,7 @@ data ReportsFeature = ReportsFeature {
     queryPackageReports :: forall m. MonadIO m => PackageId -> m [(BuildReportId, BuildReport)],
     queryBuildLog       :: forall m. MonadIO m => BuildLog  -> m Resource.BuildLog,
     pkgReportDetails    :: forall m. MonadIO m => (PackageIdentifier, Bool) -> m BuildReport.PkgDetails,
-    queryLastReportStats:: forall m. MonadIO m => PackageIdentifier -> m (Maybe BuildReport, Maybe BuildCovg),
+    queryLastReportStats:: forall m. MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg)),
     reportsResource :: ReportsResource
 }
 
@@ -202,17 +203,17 @@ buildReportsFeature name
       latestRpt <- queryState reportsState $ LookupLatestReport pkgid
       (time, ghcId) <- case latestRpt of
         Nothing -> return (Nothing,Nothing)
-        Just (brp, _, _) -> do
+        Just (_, brp, _, _) -> do
           let (CompilerId _ vrsn) = compiler brp
           return (time brp, Just vrsn)
       return  (BuildReport.PkgDetails pkgid docs failCnt time ghcId)
 
-    queryLastReportStats :: MonadIO m => PackageIdentifier -> m (Maybe BuildReport, Maybe BuildCovg)
+    queryLastReportStats :: MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg))
     queryLastReportStats pkgid = do
-      rpt <- queryState reportsState $ LookupLatestReport pkgid
-      case rpt of
-        Nothing -> return (Nothing, Nothing)
-        Just (a,_,b) -> return (Just a, b)
+      lookupRes <- queryState reportsState $ LookupLatestReport pkgid
+      case lookupRes of
+        Nothing -> return Nothing
+        Just (rptId, rpt, _, covg) -> return (Just (rptId, rpt, covg))
 
 
     ---------------------------------------------------------------------------

src/Distribution/Server/Features/BuildReports/BuildReports.hs

@@ -193,14 +193,15 @@ lookupFailCount pkgid buildReports = do
   rp <- Map.lookup pkgid (reportsIndex buildReports)
   return $ buildStatus rp
 
-lookupLatestReport :: PackageId -> BuildReports -> Maybe (BuildReport, Maybe BuildLog, Maybe BuildCovg)
+lookupLatestReport :: PackageId -> BuildReports -> Maybe (BuildReportId, BuildReport, Maybe BuildLog, Maybe BuildCovg)
 lookupLatestReport pkgid buildReports = do
   rp <- Map.lookup pkgid (reportsIndex buildReports)
   let rs = reports rp
-  a  <- if Map.null rs
-          then Nothing
-          else Just $ fst $ Map.findMax rs
-  Map.lookup a rs
+  (maxKey, (rep, buildLog, covg)) <-
+    if Map.null rs
+      then Nothing
+      else Just $ Map.findMax rs
+  Just (maxKey, rep, buildLog, covg)
 
 -- addPkg::`
 -------------------

src/Distribution/Server/Features/BuildReports/State.hs

@@ -77,7 +77,7 @@ resetFailCount pkgid = do
 lookupFailCount :: PackageId -> Query BuildReports (Maybe BuildStatus)
 lookupFailCount pkgid = asks (BuildReports.lookupFailCount pkgid)
 
-lookupLatestReport :: PackageId -> Query BuildReports (Maybe (BuildReport, Maybe BuildLog, Maybe BuildCovg))
+lookupLatestReport :: PackageId -> Query BuildReports (Maybe (BuildReportId, BuildReport, Maybe BuildLog, Maybe BuildCovg))
 lookupLatestReport pkgid = asks (BuildReports.lookupLatestReport pkgid)
 
 makeAcidic ''BuildReports ['addReport

src/Distribution/Server/Features/Html.hs

@@ -4,6 +4,7 @@ module Distribution.Server.Features.Html (
     initHtmlFeature
   ) where
 
+import Control.Arrow ((&&&))
 import Prelude ()
 import Distribution.Server.Prelude
 
@@ -578,8 +579,11 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
           documentationFeature reportsFeature realpkg
         mdocIndex     <- maybe (return Nothing)
           (liftM Just . liftIO . cachedTarIndex) mdoctarblob
-        let (install, test, covg) = getBadgeStats rptStats
         let
+          idAndReport = fmap (\(rptId, rpt, _) -> (rptId, rpt)) rptStats
+          install = getInstall $ fmap (fst &&& BR.installOutcome . snd) idAndReport
+          test    = getTest    $ fmap (        BR.testsOutcome   . snd) idAndReport
+          covg = getAvgCovg $ (\(_, _, cvg) -> cvg) =<< rptStats
           loadDocMeta
             | Just doctarblob <- mdoctarblob
             , Just docIndex   <- mdocIndex
@@ -632,12 +636,16 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
             utilities
             False
       where
-        getBadgeStats (rpt, cvg) = (getInstall (fmap BR.installOutcome rpt), getTest (fmap BR.testsOutcome rpt), getAvgCovg cvg)
-
-        getInstall Nothing                        = (False, "", "")
-        getInstall (Just BR.InstallOk)            = (True, "success", "InstallOk")
-        getInstall (Just (BR.DependencyFailed _)) = (True, "critical", "DependencyFailed")
-        getInstall (Just k)                       = (True, "critical", show k)
+        getInstall Nothing = (False, "", "", "")
+        getInstall (Just (rptId, buildStatus)) =
+          (isBadgeShowing, badgeColor, badgeText, rptUrl)
+          where
+            BuildReportId rawId = rptId
+            rptUrl = "reports/" <> show rawId
+            badgeContent BR.InstallOk            = (True, "success", "InstallOk")
+            badgeContent (BR.DependencyFailed _) = (True, "critical", "DependencyFailed")
+            badgeContent k                       = (True, "critical", show k)
+            (isBadgeShowing, badgeColor, badgeText) = badgeContent buildStatus
 
         getTest (Just BR.Ok)      = (True, "success", "Passed")
         getTest (Just BR.Failed)  = (True, "critical", "Failed")