BuildReports: Add test report log

datafiles/templates/Html/report.html.st

@@ -100,16 +100,25 @@ $else$
 <p>No log was submitted for this report.</p>
 $endif$
 
-<h3>Test log</h3>
+<h3>Test build log</h3>
 
 $if(test)$
 <p style="font-size: small">[<a href="/package/$pkgid$/reports/$report.0$/test">view raw</a>]</p>
 <pre>
 $test$</pre>
 $else$
-<p>No test log was submitted for this report.</p>
+<p>No test build log was submitted for this report.</p>
 $endif$
 
+<h3>Test report log</h3>
+
+$if(testReport)$
+<p style="font-size: small">[<a href="/package/$pkgid$/reports/$report.0$/testReport">view raw</a>]</p>
+<pre>
+$testReport$</pre>
+$else$
+<p>No test report log was submitted for this report.</p>
+$endif$
 
 </div>
 </body></html>

exes/BuildClient.hs

@@ -590,9 +590,10 @@ processPkg verbosity opts config docInfo = do
     let installOk = fmap ("install-outcome: InstallOk" `isInfixOf`) buildReport == Just True
 
     -- Run Tests if installOk, Run coverage is Tests runs
-    (testOutcome, hpcLoc, testfile)   <- case installOk && docInfoRunTests docInfo of
+    (testOutcome, hpcLoc, testfile, testReportFile) <-
+      case installOk && docInfoRunTests docInfo of
       True  -> testPackage verbosity opts docInfo
-      False -> return (Nothing, Nothing, Nothing)
+      False -> return (Nothing, Nothing, Nothing, Nothing)
     coverageFile <- mapM (coveragePackage verbosity opts docInfo) hpcLoc
 
     -- Modify test-outcome and rewrite report file.
@@ -601,7 +602,8 @@ processPkg verbosity opts config docInfo = do
     case bo_dryRun opts of
       True -> return ()
       False -> uploadResults verbosity config docInfo
-                                    mTgz mRpt logfile testfile coverageFile installOk
+                                    mTgz mRpt logfile testfile coverageFile
+                                    testReportFile installOk
   where
     prepareTempBuildDir :: IO ()
     prepareTempBuildDir = do
@@ -651,7 +653,7 @@ coveragePackage verbosity opts docInfo loc = do
   return coverageFile
 
 
-testPackage :: Verbosity -> BuildOpts -> DocInfo -> IO (Maybe String, Maybe FilePath, Maybe FilePath)
+testPackage :: Verbosity -> BuildOpts -> DocInfo -> IO (Maybe String, Maybe FilePath, Maybe FilePath, Maybe FilePath)
 testPackage verbosity opts docInfo = do
   let pkgid = docInfoPackage docInfo
       testLogFile = (installDirectory opts) </> display pkgid <.> "test"
@@ -684,7 +686,7 @@ testPackage verbosity opts docInfo = do
       [ "Test results for " ++ display pkgid ++ ":"
       , testResultFile
       ]
-  return (testOutcome, hpcLoc, Just testResultFile)
+  return (testOutcome, hpcLoc, Just testResultFile, Just testReportFile)
 
 
 -- | Build documentation and return @(Just tgz)@ for the built tgz file
@@ -882,16 +884,19 @@ tarGzDirectory dir = do
   where (containing_dir, nested_dir) = splitFileName dir
 
 uploadResults :: Verbosity -> BuildConfig -> DocInfo -> Maybe FilePath
-                    -> Maybe FilePath -> FilePath -> Maybe FilePath -> Maybe FilePath -> Bool -> IO ()
+                    -> Maybe FilePath -> FilePath -> Maybe FilePath
+                    -> Maybe FilePath -> Maybe FilePath -> Bool -> IO ()
 uploadResults verbosity config docInfo
-              mdocsTarballFile buildReportFile buildLogFile testLogFile coverageFile installOk =
+              mdocsTarballFile buildReportFile buildLogFile testLogFile
+              coverageFile testReportFile installOk =
     httpSession verbosity "hackage-build" version $ do
       case mdocsTarballFile of
         Nothing              -> return ()
         Just docsTarballFile ->
           putDocsTarball config docInfo docsTarballFile
 
-      putBuildFiles config docInfo buildReportFile buildLogFile testLogFile coverageFile installOk
+      putBuildFiles config docInfo buildReportFile buildLogFile testLogFile
+        coverageFile testReportFile installOk
 
 withAuth :: BuildConfig -> Request -> Request
 withAuth config req =
@@ -910,14 +915,24 @@ putDocsTarball config docInfo docsTarballFile = do
     mEncoding = Just "gzip"
 
 putBuildFiles :: BuildConfig -> DocInfo -> Maybe FilePath
-                    -> FilePath -> Maybe FilePath -> Maybe FilePath -> Bool -> HttpSession ()
-putBuildFiles config docInfo reportFile buildLogFile testLogFile coverageFile installOk = do
+                    -> FilePath -> Maybe FilePath -> Maybe FilePath
+                    -> Maybe FilePath -> Bool -> HttpSession ()
+putBuildFiles config docInfo reportFile buildLogFile testLogFile coverageFile
+              testReportFile installOk = do
     reportContent   <- liftIO $ traverse readFile reportFile
     logContent      <- liftIO $ readFile buildLogFile
     testContent     <- liftIO $ traverse readFile testLogFile
     coverageContent <- liftIO $ traverse readFile coverageFile
+    testReportCntnt <-
+      case testReportFile of
+        Nothing -> pure Nothing
+        Just fname -> do
+          exists <- liftIO $ doesFileExist fname
+          if exists
+             then Just <$> liftIO (readFile fname)
+             else pure Nothing
     let uri   = docInfoReports config docInfo
-        body  = encode $ BR.BuildFiles reportContent (Just logContent) testContent coverageContent (not installOk)
+        body  = encode $ BR.BuildFiles reportContent (Just logContent) testContent coverageContent testReportCntnt (not installOk)
     let headers = [ (hAccept, BSS.pack "application/json") ]
     req <- withAuth config <$> mkUploadRequest (BSS.pack "PUT") uri "application/json" Nothing headers body
     runRequest req $ \rsp -> do

src/Distribution/Server/Features/BuildReports.hs

@@ -6,7 +6,7 @@ module Distribution.Server.Features.BuildReports (
     initBuildReportsFeature
   ) where
 
-import Distribution.Server.Framework hiding (BuildLog, TestLog, BuildCovg)
+import Distribution.Server.Framework hiding (BuildLog, TestLog, TestReportLog, BuildCovg)
 
 import Distribution.Server.Features.Users
 import Distribution.Server.Features.Upload
@@ -16,7 +16,7 @@ import Distribution.Server.Features.BuildReports.Backup
 import qualified Distribution.Server.Features.BuildReports.State as Acid
 import qualified Distribution.Server.Features.BuildReports.BuildReport as BuildReport
 import Distribution.Server.Features.BuildReports.BuildReport (BuildReport(..))
-import Distribution.Server.Features.BuildReports.BuildReports (BuildReports, BuildReportId(..), BuildCovg(..), BuildLog(..), TestLog(..))
+import Distribution.Server.Features.BuildReports.BuildReports (BuildReports, BuildReportId(..), BuildCovg(..), BuildLog(..), TestLog(..), TestReportLog(..))
 import qualified Distribution.Server.Framework.ResponseContentTypes as Resource
 
 import Distribution.Server.Packages.Types
@@ -42,13 +42,14 @@ data ReportsFeature = ReportsFeature {
     reportsFeatureInterface :: HackageFeature,
 
     packageReports :: DynamicPath -> ([(BuildReportId, BuildReport)] -> ServerPartE Response) -> ServerPartE Response,
-    packageReport  :: DynamicPath -> ServerPartE (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg),
+    packageReport  :: DynamicPath -> ServerPartE (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog),
 
     queryPackageReports :: forall m. MonadIO m => PackageId -> m [(BuildReportId, BuildReport)],
     queryBuildLog       :: forall m. MonadIO m => BuildLog  -> m Resource.BuildLog,
     queryTestLog        :: forall m. MonadIO m => TestLog   -> m Resource.TestLog,
+    queryTestReportLog  :: forall m. MonadIO m => TestReportLog -> m Resource.TestReportLog,
     pkgReportDetails    :: forall m. MonadIO m => (PackageIdentifier, Bool) -> m BuildReport.PkgDetails,
-    queryLastReportStats:: forall m. MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg)),
+    queryLastReportStats:: forall m. MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg, Maybe TestReportLog)),
     queryRunTests       :: forall m. MonadIO m =>  PackageId -> m Bool,
     reportsResource :: ReportsResource
 }
@@ -62,6 +63,7 @@ data ReportsResource = ReportsResource {
     reportsPage :: Resource,
     reportsLog  :: Resource,
     reportsTest :: Resource,
+    reportsTestReport :: Resource,
     reportsReset:: Resource,
     reportsTestsEnabled :: Resource,
     reportsListUri :: String -> PackageId -> String,
@@ -124,6 +126,7 @@ buildReportsFeature name
             , reportsPage
             , reportsLog
             , reportsTest
+            , reportsTestReport
             , reportsReset
             , reportsTestsEnabled
             ]
@@ -171,14 +174,19 @@ buildReportsFeature name
               , resourcePut    = [ ("",    putBuildLog) ]
               }
           , reportsTest = (extendResourcePath "/reports/:id/test" corePackagePage) {
-                resourceDesc   = [ (GET, "Get the test log associated with a build report")
-                                 , (DELETE, "Delete a test log")
-                                 , (PUT, "Upload a test log for a build report")
+                resourceDesc   = [ (GET, "Get the test build log associated with a build report")
+                                 , (DELETE, "Delete a test build log")
+                                 , (PUT, "Upload a test build log for a build report")
                                  ]
               , resourceGet    = [ ("txt", serveTestLog) ]
               , resourceDelete = [ ("",    deleteTestLog )]
               , resourcePut    = [ ("",    putTestLog) ]
               }
+          , reportsTestReport = (extendResourcePath "/reports/:id/testReport" corePackagePage) {
+                resourceDesc   = [ (GET, "Get the test report log associated with a build report")
+                                 ]
+              , resourceGet    = [ ("txt", serveTestReportLog) ]
+              }
           , reportsListUri = \format pkgid -> renderResource (reportsList reportsResource) [display pkgid, format]
           , reportsPageUri = \format pkgid repid -> renderResource (reportsPage reportsResource) [display pkgid, display repid, format]
           , reportsLogUri  = \pkgid repid -> renderResource (reportsLog reportsResource) [display pkgid, display repid]
@@ -199,20 +207,20 @@ buildReportsFeature name
           guardValidPackageId pkgid
           queryPackageReports pkgid >>= continue
 
-    packageReport :: DynamicPath -> ServerPartE (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg)
+    packageReport :: DynamicPath -> ServerPartE (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog)
     packageReport dpath = do
       pkgid <- packageInPath dpath
       guardValidPackageId pkgid
       reportId <- reportIdInPath dpath
       mreport  <- queryState reportsState $ Acid.LookupReportCovg pkgid reportId
       case mreport of
         Nothing -> errNotFound "Report not found" [MText "Build report does not exist"]
-        Just (report, mlog, mtest, covg) -> return (reportId, report, mlog, mtest, covg)
+        Just (report, mlog, mtest, covg, testReportLog) -> return (reportId, report, mlog, mtest, covg, testReportLog)
 
     queryPackageReports :: MonadIO m => PackageId -> m [(BuildReportId, BuildReport)]
     queryPackageReports pkgid = do
         reports <- queryState reportsState $ Acid.LookupPackageReports pkgid
-        return $ map (second (\(a, _, _) -> a)) reports
+        return $ map (second (\(a, _, _, _) -> a)) reports
 
     queryBuildLog :: MonadIO m => BuildLog -> m Resource.BuildLog
     queryBuildLog (BuildLog blobId) = do
@@ -224,24 +232,29 @@ buildReportsFeature name
         file <- liftIO $ BlobStorage.fetch store blobId
         return $ Resource.TestLog file
 
+    queryTestReportLog :: MonadIO m => TestReportLog -> m Resource.TestReportLog
+    queryTestReportLog (TestReportLog blobId) = do
+        file <- liftIO $ BlobStorage.fetch store blobId
+        return $ Resource.TestReportLog file
+
     pkgReportDetails :: MonadIO m => (PackageIdentifier, Bool) -> m BuildReport.PkgDetails--(PackageIdentifier, Bool, Maybe (BuildStatus, Maybe UTCTime, Maybe Version))
     pkgReportDetails (pkgid, docs) = do
       failCnt   <- queryState reportsState $ Acid.LookupFailCount pkgid
       latestRpt <- queryState reportsState $ Acid.LookupLatestReport pkgid
       runTests  <- fmap Just . queryState reportsState $ Acid.LookupRunTests 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 runTests)
 
-    queryLastReportStats :: MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg))
+    queryLastReportStats :: MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg, Maybe TestReportLog))
     queryLastReportStats pkgid = do
       lookupRes <- queryState reportsState $ Acid.LookupLatestReport pkgid
       case lookupRes of
         Nothing -> return Nothing
-        Just (rptId, rpt, _, _, covg) -> return (Just (rptId, rpt, covg))
+        Just (rptId, rpt, _, _, covg, testReportLog) -> return (Just (rptId, rpt, covg, testReportLog))
 
     queryRunTests :: MonadIO m =>  PackageId -> m Bool
     queryRunTests pkgid = queryState reportsState $ Acid.LookupRunTests pkgid
@@ -251,13 +264,13 @@ buildReportsFeature name
     textPackageReports dpath = packageReports dpath $ return . toResponse . show
 
     textPackageReport dpath = do
-      (_, report, _, _, _) <- packageReport dpath
+      (_, report, _, _, _, _) <- packageReport dpath
       return . toResponse $ BuildReport.show report
 
     -- result: not-found error or text file
     serveBuildLog :: DynamicPath -> ServerPartE Response
     serveBuildLog dpath = do
-      (repid, _, mlog, _, _) <- packageReport dpath
+      (repid, _, mlog, _, _, _) <- packageReport dpath
       case mlog of
         Nothing -> errNotFound "Log not found" [MText $ "Build log for report " ++ display repid ++ " not found"]
         Just logId -> do
@@ -267,13 +280,22 @@ buildReportsFeature name
     -- result: not-found error or text file
     serveTestLog :: DynamicPath -> ServerPartE Response
     serveTestLog dpath = do
-      (repid, _, _, mtest, _) <- packageReport dpath
+      (repid, _, _, mtest, _, _) <- packageReport dpath
       case mtest of
-        Nothing -> errNotFound "Test log not found" [MText $ "Test log for report " ++ display repid ++ " not found"]
+        Nothing -> errNotFound "Test build log not found" [MText $ "Test build log for report " ++ display repid ++ " not found"]
         Just logId -> do
           cacheControlWithoutETag [Public, maxAgeDays 30]
           toResponse <$> queryTestLog logId
 
+    serveTestReportLog :: DynamicPath -> ServerPartE Response
+    serveTestReportLog dpath = do
+      (repid, _, _, _, _, mtestReport) <- packageReport dpath
+      case mtestReport of
+        Nothing -> errNotFound "Test report log not found" [MText $ "Test report log for report " ++ display repid ++ " not found"]
+        Just logId -> do
+          cacheControlWithoutETag [Public, maxAgeDays 30]
+          toResponse <$> queryTestReportLog logId
+
 
     -- result: auth error, not-found error, parse error, or redirect
     submitBuildReport :: DynamicPath -> ServerPartE Response
@@ -410,6 +432,7 @@ buildReportsFeature name
           logBody     = BuildReport.logContent buildFiles
           testBody    = BuildReport.testContent buildFiles
           covgBody    = BuildReport.coverageContent buildFiles
+          testReportBody = BuildReport.testReportContent buildFiles
           failStatus  = BuildReport.buildFail buildFiles
 
       updateState reportsState $ Acid.SetFailStatus pkgid failStatus
@@ -424,8 +447,9 @@ buildReportsFeature name
               report'   <- liftIO $ BuildReport.affixTimestamp report
               logBlob   <- liftIO $ traverse (\x -> BlobStorage.add store $ fromString x) logBody
               testBlob  <- liftIO $ traverse (\x -> BlobStorage.add store $ fromString x) testBody
+              testReportBlob <- liftIO $ traverse (\x -> BlobStorage.add store $ fromString x) testReportBody
               reportId  <- updateState reportsState $
-                                  Acid.AddRptLogTestCovg pkgid (report', (fmap BuildLog logBlob), (fmap TestLog testBlob),  (fmap BuildReport.parseCovg covgBody))
+                                  Acid.AddRptAllLogsCovg pkgid (report', (fmap BuildLog logBlob), (fmap TestLog testBlob), (fmap BuildReport.parseCovg covgBody), (fmap TestReportLog testReportBlob))
               -- redirect to new reports page
               seeOther (reportsPageUri reportsResource "" pkgid reportId) $ toResponse ()
 

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

@@ -8,7 +8,7 @@ module Distribution.Server.Features.BuildReports.Backup (
 
 import Distribution.Server.Features.BuildReports.BuildReport (BuildReport)
 import qualified Distribution.Server.Features.BuildReports.BuildReport as Report
-import Distribution.Server.Features.BuildReports.BuildReports (BuildReports(..), BuildCovg(..), PkgBuildReports(..), BuildReportId(..), BuildLog(..), TestLog(..))
+import Distribution.Server.Features.BuildReports.BuildReports (BuildReports(..), BuildCovg(..), PkgBuildReports(..), BuildReportId(..), BuildLog(..), TestLog(..), TestReportLog)
 import qualified Distribution.Server.Features.BuildReports.BuildReports as Reports
 
 import qualified Distribution.Server.Framework.BlobStorage as BlobStorage
@@ -94,8 +94,8 @@ packageReportsToExport :: PackageId -> PkgBuildReports -> [BackupEntry]
 packageReportsToExport pkgId pkgReports = concatMap (uncurry $ reportToExport prefix) (Map.toList $ Reports.reports pkgReports)
     where prefix = ["package", display pkgId]
 
-reportToExport :: [FilePath] -> BuildReportId -> (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg ) -> [BackupEntry]
-reportToExport prefix reportId (report, mlog, _, _) = BackupByteString (getPath ".txt") (packUTF8 $ Report.show report) :
+reportToExport :: [FilePath] -> BuildReportId -> (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog) -> [BackupEntry]
+reportToExport prefix reportId (report, mlog, _, _, _) = BackupByteString (getPath ".txt") (packUTF8 $ Report.show report) :
     case mlog of Nothing -> []; Just (BuildLog blobId) -> [blobToBackup (getPath ".log") blobId]
   where
     getPath ext = prefix ++ [display reportId ++ ext]

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

@@ -274,6 +274,16 @@ data BuildCovg = BuildCovg {
   topLevel          :: (Int,Int)
 } deriving (Eq, Show)
 
+instance Arbitrary BuildCovg where
+  arbitrary =
+    BuildCovg
+      <$> intPair
+      <*> liftA3 BooleanCovg intPair intPair intPair
+      <*> intPair
+      <*> intPair
+      <*> intPair
+    where intPair = liftA2 (,) arbitrary arbitrary
+
 instance MemSize BuildCovg where
     memSize (BuildCovg a (BooleanCovg b c d) e f g) = memSize7 a b c d e f g
 
@@ -498,6 +508,10 @@ instance Arbitrary Outcome where
 
 data BuildStatus = BuildOK | BuildFailCnt Int
   deriving (Eq, Ord, Show)
+
+instance Arbitrary BuildStatus where
+  arbitrary = oneof [ pure BuildOK, BuildFailCnt <$> arbitrary ]
+
 instance ToJSON BuildStatus where
   toJSON (BuildFailCnt a) = toJSON a
   toJSON BuildOK          = toJSON ((-1)::Int)
@@ -618,6 +632,7 @@ data BuildFiles = BuildFiles {
   logContent :: Maybe String,
   testContent :: Maybe String,
   coverageContent :: Maybe String,
+  testReportContent :: Maybe String,
   buildFail :: Bool
 } deriving Show
 
@@ -628,6 +643,7 @@ instance Data.Aeson.FromJSON BuildFiles where
       <*> o .:? "log"
       <*> o .:? "test"
       <*> o .:? "coverage"
+      <*> o .:? "testReport"
       <*> o .: "buildFail"
 
 instance Data.Aeson.ToJSON BuildFiles where
@@ -636,6 +652,7 @@ instance Data.Aeson.ToJSON BuildFiles where
     "log"       .= logContent  p,
     "test"      .= testContent p,
     "coverage"  .= coverageContent  p,
+    "testReport".= testReportContent p,
     "buildFail" .= buildFail  p ]
 
 data PkgDetails = PkgDetails {