From 43f17b237ea0222a31dea71fa43382c1b9efe01c Mon Sep 17 00:00:00 2001 From: Alias Qli <2576814881@qq.com> Date: Thu, 14 Jul 2022 00:11:55 +0800 Subject: [PATCH 1/2] Add test log --- datafiles/templates/Html/report.html.st | 11 ++ exes/BuildClient.hs | 24 ++-- .../Server/Features/BuildReports.hs | 72 ++++++++++-- .../Server/Features/BuildReports/Backup.hs | 6 +- .../Features/BuildReports/BuildReport.hs | 3 + .../Features/BuildReports/BuildReports.hs | 108 ++++++++++++++---- .../Server/Features/BuildReports/State.hs | 35 ++++-- src/Distribution/Server/Features/Html.hs | 4 +- .../Server/Framework/ResponseContentTypes.hs | 6 + 9 files changed, 210 insertions(+), 59 deletions(-) diff --git a/datafiles/templates/Html/report.html.st b/datafiles/templates/Html/report.html.st index 8c2e604e1..0a273bf18 100644 --- a/datafiles/templates/Html/report.html.st +++ b/datafiles/templates/Html/report.html.st @@ -100,5 +100,16 @@ $else$

No log was submitted for this report.

$endif$ +

Test log

+ +$if(test)$ +

[view raw]

+
+$test$
+$else$ +

No test log was submitted for this report.

+$endif$ + + diff --git a/exes/BuildClient.hs b/exes/BuildClient.hs index f72d6e251..c07c5c4e4 100644 --- a/exes/BuildClient.hs +++ b/exes/BuildClient.hs @@ -363,6 +363,7 @@ data DocInfo = DocInfo { , docInfoHasDocs :: HasDocs , docInfoIsCandidate :: Bool } + deriving Show docInfoPackageName :: DocInfo -> PackageName docInfoPackageName = pkgName . docInfoPackage @@ -570,9 +571,9 @@ 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) <- case installOk of + (testOutcome, hpcLoc, testfile) <- case installOk of True -> testPackage verbosity opts docInfo - False -> return (Nothing, Nothing) + False -> return (Nothing, Nothing, Nothing) coverageFile <- mapM (coveragePackage verbosity opts docInfo) hpcLoc -- Modify test-outcome and rewrite report file. @@ -581,7 +582,7 @@ processPkg verbosity opts config docInfo = do case bo_dryRun opts of True -> return () False -> uploadResults verbosity config docInfo - mTgz mRpt logfile coverageFile installOk + mTgz mRpt logfile testfile coverageFile installOk where prepareTempBuildDir :: IO () prepareTempBuildDir = do @@ -630,7 +631,7 @@ coveragePackage verbosity opts docInfo loc = do return coverageFile -testPackage :: Verbosity -> BuildOpts -> DocInfo -> IO (Maybe String, Maybe FilePath) +testPackage :: Verbosity -> BuildOpts -> DocInfo -> IO (Maybe String, Maybe FilePath, Maybe FilePath) testPackage verbosity opts docInfo = do let pkgid = docInfoPackage docInfo testLogFile = (installDirectory opts) display pkgid <.> "test" @@ -663,7 +664,7 @@ testPackage verbosity opts docInfo = do [ "Test results for " ++ display pkgid ++ ":" , testResultFile ] - return (testOutcome, hpcLoc) + return (testOutcome, hpcLoc, Just testResultFile) -- | Build documentation and return @(Just tgz)@ for the built tgz file @@ -855,9 +856,9 @@ tarGzDirectory dir = do where (containing_dir, nested_dir) = splitFileName dir uploadResults :: Verbosity -> BuildConfig -> DocInfo -> Maybe FilePath - -> Maybe FilePath -> FilePath -> Maybe FilePath -> Bool -> IO () + -> Maybe FilePath -> FilePath -> Maybe FilePath -> Maybe FilePath -> Bool -> IO () uploadResults verbosity config docInfo - mdocsTarballFile buildReportFile buildLogFile coverageFile installOk = + mdocsTarballFile buildReportFile buildLogFile testLogFile coverageFile installOk = httpSession verbosity "hackage-build" version $ do -- Make sure we authenticate to Hackage setAuthorityGen (provideAuthInfo (bc_srcURI config) @@ -867,7 +868,7 @@ uploadResults verbosity config docInfo Just docsTarballFile -> putDocsTarball config docInfo docsTarballFile - putBuildFiles config docInfo buildReportFile buildLogFile coverageFile installOk + putBuildFiles config docInfo buildReportFile buildLogFile testLogFile coverageFile installOk putDocsTarball :: BuildConfig -> DocInfo -> FilePath -> HttpSession () putDocsTarball config docInfo docsTarballFile = @@ -875,13 +876,14 @@ putDocsTarball config docInfo docsTarballFile = "application/x-tar" (Just "gzip") docsTarballFile putBuildFiles :: BuildConfig -> DocInfo -> Maybe FilePath - -> FilePath -> Maybe FilePath -> Bool -> HttpSession () -putBuildFiles config docInfo reportFile buildLogFile coverageFile installOk = do + -> FilePath -> Maybe FilePath -> Maybe FilePath -> Bool -> HttpSession () +putBuildFiles config docInfo reportFile buildLogFile testLogFile coverageFile installOk = do reportContent <- liftIO $ traverse readFile reportFile logContent <- liftIO $ readFile buildLogFile + testContent <- liftIO $ traverse readFile testLogFile coverageContent <- liftIO $ traverse readFile coverageFile let uri = docInfoReports config docInfo - body = encode $ BR.BuildFiles reportContent (Just logContent) coverageContent (not installOk) + body = encode $ BR.BuildFiles reportContent (Just logContent) testContent coverageContent (not installOk) setAllowRedirects False (_, response) <- request Request { rqURI = uri, diff --git a/src/Distribution/Server/Features/BuildReports.hs b/src/Distribution/Server/Features/BuildReports.hs index 73985286c..789c31bac 100644 --- a/src/Distribution/Server/Features/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports.hs @@ -6,7 +6,7 @@ module Distribution.Server.Features.BuildReports ( initBuildReportsFeature ) where -import Distribution.Server.Framework hiding (BuildLog, BuildCovg) +import Distribution.Server.Framework hiding (BuildLog, TestLog, BuildCovg) import Distribution.Server.Features.Users import Distribution.Server.Features.Upload @@ -16,7 +16,7 @@ import Distribution.Server.Features.BuildReports.Backup import Distribution.Server.Features.BuildReports.State 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(..)) +import Distribution.Server.Features.BuildReports.BuildReports (BuildReports, BuildReportId(..), BuildCovg(..), BuildLog(..), TestLog(..)) import qualified Distribution.Server.Framework.ResponseContentTypes as Resource import Distribution.Server.Packages.Types @@ -41,10 +41,11 @@ data ReportsFeature = ReportsFeature { reportsFeatureInterface :: HackageFeature, packageReports :: DynamicPath -> ([(BuildReportId, BuildReport)] -> ServerPartE Response) -> ServerPartE Response, - packageReport :: DynamicPath -> ServerPartE (BuildReportId, BuildReport, Maybe BuildLog, Maybe BuildCovg), + packageReport :: DynamicPath -> ServerPartE (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg), 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, pkgReportDetails :: forall m. MonadIO m => (PackageIdentifier, Bool) -> m BuildReport.PkgDetails, queryLastReportStats:: forall m. MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg)), reportsResource :: ReportsResource @@ -58,6 +59,7 @@ data ReportsResource = ReportsResource { reportsList :: Resource, reportsPage :: Resource, reportsLog :: Resource, + reportsTest :: Resource, reportsReset:: Resource, reportsListUri :: String -> PackageId -> String, reportsPageUri :: String -> PackageId -> BuildReportId -> String, @@ -118,6 +120,7 @@ buildReportsFeature name reportsList , reportsPage , reportsLog + , reportsTest , reportsReset ] , featureState = [abstractAcidStateComponent reportsState] @@ -156,6 +159,15 @@ buildReportsFeature name , resourceDelete = [ ("", deleteBuildLog )] , 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") + ] + , resourceGet = [ ("txt", serveTestLog) ] + , resourceDelete = [ ("", deleteTestLog )] + , resourcePut = [ ("", putTestLog) ] + } , 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] @@ -176,7 +188,7 @@ buildReportsFeature name guardValidPackageId pkgid queryPackageReports pkgid >>= continue - packageReport :: DynamicPath -> ServerPartE (BuildReportId, BuildReport, Maybe BuildLog, Maybe BuildCovg) + packageReport :: DynamicPath -> ServerPartE (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg) packageReport dpath = do pkgid <- packageInPath dpath guardValidPackageId pkgid @@ -184,18 +196,22 @@ buildReportsFeature name mreport <- queryState reportsState $ LookupReportCovg pkgid reportId case mreport of Nothing -> errNotFound "Report not found" [MText "Build report does not exist"] - Just (report, mlog, covg) -> return (reportId, report, mlog, covg) + Just (report, mlog, mtest, covg) -> return (reportId, report, mlog, mtest, covg) queryPackageReports :: MonadIO m => PackageId -> m [(BuildReportId, BuildReport)] queryPackageReports pkgid = do reports <- queryState reportsState $ LookupPackageReports pkgid - return $ map (second fst) reports + return $ map (second (\(a, _, _) -> a)) reports queryBuildLog :: MonadIO m => BuildLog -> m Resource.BuildLog queryBuildLog (BuildLog blobId) = do file <- liftIO $ BlobStorage.fetch store blobId return $ Resource.BuildLog file + queryTestLog :: MonadIO m => TestLog -> m Resource.TestLog + queryTestLog (TestLog blobId) = do + file <- liftIO $ BlobStorage.fetch store blobId + return $ Resource.TestLog file pkgReportDetails :: MonadIO m => (PackageIdentifier, Bool) -> m BuildReport.PkgDetails--(PackageIdentifier, Bool, Maybe (BuildStatus, Maybe UTCTime, Maybe Version)) pkgReportDetails (pkgid, docs) = do @@ -203,7 +219,7 @@ 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) @@ -213,7 +229,7 @@ buildReportsFeature name lookupRes <- queryState reportsState $ LookupLatestReport pkgid case lookupRes of Nothing -> return Nothing - Just (rptId, rpt, _, covg) -> return (Just (rptId, rpt, covg)) + Just (rptId, rpt, _, _, covg) -> return (Just (rptId, rpt, covg)) --------------------------------------------------------------------------- @@ -221,18 +237,29 @@ 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 cacheControlWithoutETag [Public, maxAgeDays 30] toResponse <$> queryBuildLog logId + + -- result: not-found error or text file + serveTestLog :: DynamicPath -> ServerPartE Response + serveTestLog dpath = do + (repid, _, _, mtest, _) <- packageReport dpath + case mtest of + Nothing -> errNotFound "Test log not found" [MText $ "Test log for report " ++ display repid ++ " not found"] + Just logId -> do + cacheControlWithoutETag [Public, maxAgeDays 30] + toResponse <$> queryTestLog logId + -- result: auth error, not-found error, parse error, or redirect submitBuildReport :: DynamicPath -> ServerPartE Response @@ -286,6 +313,18 @@ buildReportsFeature name void $ updateState reportsState $ SetBuildLog pkgid reportId (Just $ BuildLog buildLog) noContent (toResponse ()) + putTestLog :: DynamicPath -> ServerPartE Response + putTestLog dpath = do + pkgid <- packageInPath dpath + guardValidPackageId pkgid + reportId <- reportIdInPath dpath + -- logged in users + guardAuthorised_ [AnyKnownUser] + blogbody <- expectTextPlain + testLog <- liftIO $ BlobStorage.add store blogbody + void $ updateState reportsState $ SetTestLog pkgid reportId (Just $ TestLog testLog) + noContent (toResponse ()) + {- Example using curl: (TODO: why is this PUT, while logs are POST?) @@ -305,6 +344,15 @@ buildReportsFeature name void $ updateState reportsState $ SetBuildLog pkgid reportId Nothing noContent (toResponse ()) + deleteTestLog :: DynamicPath -> ServerPartE Response + deleteTestLog dpath = do + pkgid <- packageInPath dpath + guardValidPackageId pkgid + reportId <- reportIdInPath dpath + guardAuthorised_ [InGroup trusteesGroup] + void $ updateState reportsState $ SetTestLog pkgid reportId Nothing + noContent (toResponse ()) + guardAuthorisedAsMaintainerOrTrustee pkgname = guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup] @@ -327,6 +375,7 @@ buildReportsFeature name buildFiles <- expectAesonContent::ServerPartE BuildReport.BuildFiles let reportBody = BuildReport.reportContent buildFiles logBody = BuildReport.logContent buildFiles + testBody = BuildReport.testContent buildFiles covgBody = BuildReport.coverageContent buildFiles failStatus = BuildReport.buildFail buildFiles @@ -341,8 +390,9 @@ buildReportsFeature name guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) 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 reportId <- updateState reportsState $ - AddRptLogCovg pkgid (report', (fmap BuildLog logBlob), (fmap BuildReport.parseCovg covgBody)) + AddRptLogTestCovg pkgid (report', (fmap BuildLog logBlob), (fmap TestLog testBlob), (fmap BuildReport.parseCovg covgBody)) -- redirect to new reports page seeOther (reportsPageUri reportsResource "" pkgid reportId) $ toResponse () diff --git a/src/Distribution/Server/Features/BuildReports/Backup.hs b/src/Distribution/Server/Features/BuildReports/Backup.hs index 5ba7f8081..09e9fe4c5 100644 --- a/src/Distribution/Server/Features/BuildReports/Backup.hs +++ b/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(..)) +import Distribution.Server.Features.BuildReports.BuildReports (BuildReports(..), BuildCovg(..), PkgBuildReports(..), BuildReportId(..), BuildLog(..), TestLog(..)) 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 BuildCovg ) -> [BackupEntry] -reportToExport prefix reportId (report, mlog, _) = BackupByteString (getPath ".txt") (packUTF8 $ Report.show report) : +reportToExport :: [FilePath] -> BuildReportId -> (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg ) -> [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] diff --git a/src/Distribution/Server/Features/BuildReports/BuildReport.hs b/src/Distribution/Server/Features/BuildReports/BuildReport.hs index 1d85cce5f..9ad761f45 100644 --- a/src/Distribution/Server/Features/BuildReports/BuildReport.hs +++ b/src/Distribution/Server/Features/BuildReports/BuildReport.hs @@ -599,6 +599,7 @@ instance Migrate InstallOutcome where data BuildFiles = BuildFiles { reportContent :: Maybe String, logContent :: Maybe String, + testContent :: Maybe String, coverageContent :: Maybe String, buildFail :: Bool } deriving Show @@ -608,6 +609,7 @@ instance Data.Aeson.FromJSON BuildFiles where BuildFiles <$> o .:? "report" <*> o .:? "log" + <*> o .:? "test" <*> o .:? "coverage" <*> o .: "buildFail" @@ -615,6 +617,7 @@ instance Data.Aeson.ToJSON BuildFiles where toJSON p = object [ "report" .= reportContent p, "log" .= logContent p, + "test" .= testContent p, "coverage" .= coverageContent p, "buildFail" .= buildFail p ] diff --git a/src/Distribution/Server/Features/BuildReports/BuildReports.hs b/src/Distribution/Server/Features/BuildReports/BuildReports.hs index ae6d724ab..ae8a820f4 100644 --- a/src/Distribution/Server/Features/BuildReports/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports/BuildReports.hs @@ -4,18 +4,21 @@ module Distribution.Server.Features.BuildReports.BuildReports ( BuildReport(..), BuildReports(..), + BuildReports_v3, BuildReportId(..), PkgBuildReports(..), BuildLog(..), + TestLog(..), BuildCovg(..), BuildStatus(..), - addRptLogCovg, + addRptLogTestCovg, lookupReportCovg, emptyReports, emptyPkgReports, addReport, deleteReport, setBuildLog, + setTestLog, lookupReport, lookupPackageReports, unsafeSetReport, @@ -77,13 +80,15 @@ instance Parsec BuildReportId where newtype BuildLog = BuildLog BlobStorage.BlobId deriving (Eq, Typeable, Show, MemSize) +newtype TestLog = TestLog BlobStorage.BlobId + deriving (Eq, Typeable, Show, MemSize) data PkgBuildReports = PkgBuildReports { -- for each report, other useful information: Maybe UserId, UTCTime -- perhaps deserving its own data structure (SubmittedReport?) -- When a report was submitted is very useful information. -- also, use IntMap instead of Map BuildReportId? - reports :: !(Map BuildReportId (BuildReport, Maybe BuildLog, Maybe BuildCovg )), + reports :: !(Map BuildReportId (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg )), -- one more than the maximum report id used nextReportId :: !BuildReportId, buildStatus :: !BuildStatus @@ -105,26 +110,26 @@ emptyReports = BuildReports { reportsIndex = Map.empty } -lookupReport :: PackageId -> BuildReportId -> BuildReports -> Maybe (BuildReport, Maybe BuildLog) +lookupReport :: PackageId -> BuildReportId -> BuildReports -> Maybe (BuildReport, Maybe BuildLog, Maybe TestLog) lookupReport pkgid reportId buildReports = remCvg.Map.lookup reportId . reports =<< Map.lookup pkgid (reportsIndex buildReports) where remCvg Nothing = Nothing - remCvg (Just (brpt,blog,_)) = Just (brpt,blog) + remCvg (Just (brpt,blog,btest,_)) = Just (brpt,blog,btest) -lookupPackageReports :: PackageId -> BuildReports -> [(BuildReportId, (BuildReport, Maybe BuildLog))] +lookupPackageReports :: PackageId -> BuildReports -> [(BuildReportId, (BuildReport, Maybe BuildLog, Maybe TestLog))] lookupPackageReports pkgid buildReports = case Map.lookup pkgid (reportsIndex buildReports) of Nothing -> [] Just rs -> map removeCovg $ Map.toList (reports rs) where - removeCovg (brid,(brpt,blog,_)) = (brid,(brpt,blog)) + removeCovg (brid,(brpt,blog,btest,_)) = (brid,(brpt,blog,btest)) ------------------------- -- PackageIds should /not/ have empty Versions. Caller should ensure this. -addReport :: PackageId -> (BuildReport, Maybe BuildLog) -> BuildReports -> (BuildReports, BuildReportId) -addReport pkgid (brpt,blog) buildReports = +addReport :: PackageId -> (BuildReport, Maybe BuildLog, Maybe TestLog) -> BuildReports -> (BuildReports, BuildReportId) +addReport pkgid (brpt,blog,btest) buildReports = let pkgReports = Map.findWithDefault emptyPkgReports pkgid (reportsIndex buildReports) reportId = nextReportId pkgReports - pkgReports' = PkgBuildReports { reports = Map.insert reportId (brpt,blog,Nothing) (reports pkgReports) + pkgReports' = PkgBuildReports { reports = Map.insert reportId (brpt,blog,btest,Nothing) (reports pkgReports) , nextReportId = incrementReportId reportId , buildStatus = buildStatus pkgReports } in (buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) }, reportId) @@ -132,7 +137,7 @@ addReport pkgid (brpt,blog) buildReports = unsafeSetReport :: PackageId -> BuildReportId -> (BuildReport, Maybe BuildLog) -> BuildReports -> BuildReports unsafeSetReport pkgid reportId (brpt,blog) buildReports = let pkgReports = Map.findWithDefault emptyPkgReports pkgid (reportsIndex buildReports) - pkgReports' = PkgBuildReports { reports = Map.insert reportId (brpt,blog,Nothing) (reports pkgReports) + pkgReports' = PkgBuildReports { reports = Map.insert reportId (brpt,blog,Nothing,Nothing) (reports pkgReports) , nextReportId = max (incrementReportId reportId) (nextReportId pkgReports) , buildStatus = buildStatus pkgReports } in buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) } @@ -150,11 +155,19 @@ setBuildLog pkgid reportId buildLog buildReports = case Map.lookup pkgid (report Nothing -> Nothing Just pkgReports -> case Map.lookup reportId (reports pkgReports) of Nothing -> Nothing - Just (rlog, _, covg) -> let pkgReports' = pkgReports { reports = Map.insert reportId (rlog, buildLog, covg) (reports pkgReports) } + Just (rlog, _, btest, covg) -> let pkgReports' = pkgReports { reports = Map.insert reportId (rlog, buildLog, btest, covg) (reports pkgReports) } + in Just $ buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) } + +setTestLog :: PackageId -> BuildReportId -> Maybe TestLog -> BuildReports -> Maybe BuildReports +setTestLog pkgid reportId testLog buildReports = case Map.lookup pkgid (reportsIndex buildReports) of + Nothing -> Nothing + Just pkgReports -> case Map.lookup reportId (reports pkgReports) of + Nothing -> Nothing + Just (rlog, blog, _, covg) -> let pkgReports' = pkgReports { reports = Map.insert reportId (rlog, blog, testLog, covg) (reports pkgReports) } in Just $ buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) } -addRptLogCovg :: PackageId -> (BuildReport, Maybe BuildLog, Maybe BuildCovg ) -> BuildReports -> (BuildReports, BuildReportId) -addRptLogCovg pkgid report buildReports = +addRptLogTestCovg :: PackageId -> (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg ) -> BuildReports -> (BuildReports, BuildReportId) +addRptLogTestCovg pkgid report buildReports = let pkgReports = Map.findWithDefault emptyPkgReports pkgid (reportsIndex buildReports) reportId = nextReportId pkgReports pkgReports' = PkgBuildReports { reports = Map.insert reportId report (reports pkgReports) @@ -162,7 +175,7 @@ addRptLogCovg pkgid report buildReports = , buildStatus = buildStatus pkgReports } in (buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) }, reportId) -lookupReportCovg :: PackageId -> BuildReportId -> BuildReports -> Maybe (BuildReport, Maybe BuildLog, Maybe BuildCovg ) +lookupReportCovg :: PackageId -> BuildReportId -> BuildReports -> Maybe (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg ) lookupReportCovg pkgid reportId buildReports = Map.lookup reportId . reports =<< Map.lookup pkgid (reportsIndex buildReports) setFailStatus :: PackageId -> Bool -> BuildReports -> BuildReports @@ -193,15 +206,15 @@ lookupFailCount pkgid buildReports = do rp <- Map.lookup pkgid (reportsIndex buildReports) return $ buildStatus rp -lookupLatestReport :: PackageId -> BuildReports -> Maybe (BuildReportId, BuildReport, Maybe BuildLog, Maybe BuildCovg) +lookupLatestReport :: PackageId -> BuildReports -> Maybe (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg) lookupLatestReport pkgid buildReports = do rp <- Map.lookup pkgid (reportsIndex buildReports) let rs = reports rp - (maxKey, (rep, buildLog, covg)) <- + (maxKey, (rep, buildLog, testLog, covg)) <- if Map.null rs then Nothing else Just $ Map.findMax rs - Just (maxKey, rep, buildLog, covg) + Just (maxKey, rep, buildLog, testLog, covg) -- addPkg::` ------------------- @@ -242,12 +255,14 @@ instance Migrate BuildLog where deriveSafeCopy 2 'extension ''BuildLog +deriveSafeCopy 0 'base ''TestLog + -- note: if the set of report ids is [1, 2, 3], then nextReportId = 4 -- after calling deleteReport for 3, the set is [1, 2] and nextReportId is still 4. -- however, upon importing, nextReportId will = 3, one more than the maximum present -- this is also a problem in ReportsBackup.hs. but it's not a major issue I think. instance SafeCopy PkgBuildReports where - version = 3 + version = 4 kind = extension putCopy (PkgBuildReports x _ y) = contain $ safePut (x,y) getCopy = contain $ mkReports <$> safeGet @@ -262,6 +277,27 @@ instance MemSize PkgBuildReports where memSize (PkgBuildReports a b c) = memSize3 a b c +data PkgBuildReports_v3 = PkgBuildReports_v3 { + reports_v3 :: !(Map BuildReportId (BuildReport, Maybe BuildLog, Maybe BuildCovg)), + nextReportId_v3 :: !BuildReportId, + buildStatus_v3 :: !BuildStatus +} deriving (Eq, Typeable, Show) + +instance SafeCopy PkgBuildReports_v3 where + version = 3 + kind = extension + putCopy (PkgBuildReports_v3 x _ y) = contain $ safePut (x, y) + getCopy = contain $ mkReports <$> safeGet + where + mkReports (rs,f) = PkgBuildReports_v3 rs + (if Map.null rs + then BuildReportId 1 + else incrementReportId (fst $ Map.findMax rs)) + f + +instance MemSize PkgBuildReports_v3 where + memSize (PkgBuildReports_v3 a b c) = memSize3 a b c + data PkgBuildReports_v2 = PkgBuildReports_v2 { reports_v2 :: !(Map BuildReportId (BuildReport, Maybe BuildLog)), nextReportId_v2 :: !BuildReportId @@ -309,16 +345,26 @@ instance Migrate PkgBuildReports_v2 where . Map.map (\(br, l) -> (migrate (migrate br), fmap migrate l)) -instance Migrate PkgBuildReports where - type MigrateFrom PkgBuildReports = PkgBuildReports_v2 +instance Migrate PkgBuildReports_v3 where + type MigrateFrom PkgBuildReports_v3 = PkgBuildReports_v2 migrate (PkgBuildReports_v2 m n) = - PkgBuildReports (migrateMap m) n BuildOK + PkgBuildReports_v3 (migrateMap m) n BuildOK where migrateMap :: Map BuildReportId (BuildReport, Maybe BuildLog) -> Map BuildReportId (BuildReport, Maybe BuildLog, Maybe BuildCovg) migrateMap = Map.mapKeys (\x->x) . Map.map (\(br, l) -> (br, l, Nothing)) +instance Migrate PkgBuildReports where + type MigrateFrom PkgBuildReports = PkgBuildReports_v3 + migrate (PkgBuildReports_v3 m n o) = + PkgBuildReports (migrateMap m) n o + where + migrateMap :: Map BuildReportId (BuildReport, Maybe BuildLog, Maybe BuildCovg) + -> Map BuildReportId (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg) + migrateMap = Map.mapKeys id + . Map.map (\(br, l, c) -> (br, l, Nothing, c)) + data BuildReports_v0 = BuildReports_v0 !(Map.Map PackageIdentifier_v0 PkgBuildReports_v0) @@ -345,12 +391,26 @@ instance MemSize BuildReports_v2 where deriveSafeCopy 2 'extension ''BuildReports_v2 +data BuildReports_v3 = BuildReports_v3 + { reportsIndex_v3 :: !(Map.Map PackageId PkgBuildReports_v3) + } deriving (Eq, Typeable, Show) + +instance Migrate BuildReports_v3 where + type MigrateFrom BuildReports_v3 = BuildReports_v2 + migrate (BuildReports_v2 m) = + BuildReports_v3 (Map.mapKeys id $ Map.map migrate m) + +instance MemSize BuildReports_v3 where + memSize (BuildReports_v3 a) = memSize1 a + +deriveSafeCopy 3 'extension ''BuildReports_v3 + instance Migrate BuildReports where - type MigrateFrom BuildReports = BuildReports_v2 - migrate (BuildReports_v2 m) = + type MigrateFrom BuildReports = BuildReports_v3 + migrate (BuildReports_v3 m) = BuildReports (Map.mapKeys id $ Map.map migrate m) instance MemSize BuildReports where memSize (BuildReports a) = memSize1 a -deriveSafeCopy 3 'extension ''BuildReports +deriveSafeCopy 4 'extension ''BuildReports diff --git a/src/Distribution/Server/Features/BuildReports/State.hs b/src/Distribution/Server/Features/BuildReports/State.hs index 0895a95a7..747798095 100644 --- a/src/Distribution/Server/Features/BuildReports/State.hs +++ b/src/Distribution/Server/Features/BuildReports/State.hs @@ -5,7 +5,7 @@ module Distribution.Server.Features.BuildReports.State where import Distribution.Server.Features.BuildReports.BuildReports - (BuildReportId, BuildLog, BuildReport, BuildReports,BuildCovg, BuildStatus) + (BuildReportId, BuildLog, TestLog, BuildReport, BuildReports,BuildCovg, BuildStatus) import qualified Distribution.Server.Features.BuildReports.BuildReports as BuildReports import Distribution.Package @@ -19,9 +19,9 @@ initialBuildReports = BuildReports.emptyReports -- and defined methods addReport :: PackageId -> (BuildReport, Maybe BuildLog) -> Update BuildReports BuildReportId -addReport pkgid report = do +addReport pkgid (bRpt, blog) = do buildReports <- State.get - let (reports, reportId) = BuildReports.addReport pkgid report buildReports + let (reports, reportId) = BuildReports.addReport pkgid (bRpt, blog, Nothing) buildReports State.put reports return reportId @@ -39,10 +39,10 @@ deleteReport pkgid reportId = do Nothing -> return False Just reports -> State.put reports >> return True -lookupReport :: PackageId -> BuildReportId -> Query BuildReports (Maybe (BuildReport, Maybe BuildLog)) +lookupReport :: PackageId -> BuildReportId -> Query BuildReports (Maybe (BuildReport, Maybe BuildLog, Maybe TestLog)) lookupReport pkgid reportId = asks (BuildReports.lookupReport pkgid reportId) -lookupPackageReports :: PackageId -> Query BuildReports [(BuildReportId, (BuildReport, Maybe BuildLog))] +lookupPackageReports :: PackageId -> Query BuildReports [(BuildReportId, (BuildReport, Maybe BuildLog, Maybe TestLog))] lookupPackageReports pkgid = asks (BuildReports.lookupPackageReports pkgid) getBuildReports :: Query BuildReports BuildReports @@ -52,13 +52,13 @@ replaceBuildReports :: BuildReports -> Update BuildReports () replaceBuildReports = State.put addRptLogCovg :: PackageId -> (BuildReport, Maybe BuildLog, Maybe BuildCovg ) -> Update BuildReports BuildReportId -addRptLogCovg pkgid report = do +addRptLogCovg pkgid (bRpt, blog, bcovg) = do buildReports <- State.get - let (reports, reportId) = BuildReports.addRptLogCovg pkgid report buildReports + let (reports, reportId) = BuildReports.addRptLogTestCovg pkgid (bRpt, blog, Nothing, bcovg) buildReports State.put reports return reportId -lookupReportCovg :: PackageId -> BuildReportId -> Query BuildReports (Maybe (BuildReport, Maybe BuildLog, Maybe BuildCovg)) +lookupReportCovg :: PackageId -> BuildReportId -> Query BuildReports (Maybe (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg)) lookupReportCovg pkgid reportId = asks (BuildReports.lookupReportCovg pkgid reportId) setFailStatus :: PackageId -> Bool -> Update BuildReports () @@ -77,9 +77,23 @@ resetFailCount pkgid = do lookupFailCount :: PackageId -> Query BuildReports (Maybe BuildStatus) lookupFailCount pkgid = asks (BuildReports.lookupFailCount pkgid) -lookupLatestReport :: PackageId -> Query BuildReports (Maybe (BuildReportId, BuildReport, Maybe BuildLog, Maybe BuildCovg)) +lookupLatestReport :: PackageId -> Query BuildReports (Maybe (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg)) lookupLatestReport pkgid = asks (BuildReports.lookupLatestReport pkgid) +addRptLogTestCovg :: PackageId -> (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg ) -> Update BuildReports BuildReportId +addRptLogTestCovg pkgid (bRpt, blog, btest, bcovg) = do + buildReports <- State.get + let (reports, reportId) = BuildReports.addRptLogTestCovg pkgid (bRpt, blog, btest, bcovg) buildReports + State.put reports + return reportId + +setTestLog :: PackageId -> BuildReportId -> Maybe TestLog -> Update BuildReports Bool +setTestLog pkgid reportId testLog = do + buildReports <- State.get + case BuildReports.setTestLog pkgid reportId testLog buildReports of + Nothing -> return False + Just reports -> State.put reports >> return True + makeAcidic ''BuildReports ['addReport ,'setBuildLog ,'deleteReport @@ -93,5 +107,8 @@ makeAcidic ''BuildReports ['addReport ,'resetFailCount ,'lookupFailCount ,'lookupLatestReport + + ,'addRptLogTestCovg + ,'setTestLog ] diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index 7155f62e4..077a95c98 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -1048,8 +1048,9 @@ mkHtmlReports HtmlUtilities{..} CoreFeature{..} ReportsFeature{..} templates = H servePackageReport :: DynamicPath -> ServerPartE Response servePackageReport dpath = do - (repid, report, mlog, covg) <- packageReport dpath + (repid, report, mlog, mtest, covg) <- packageReport dpath mlog' <- traverse queryBuildLog mlog + mtest' <- traverse queryTestLog mtest let covg' = fmap getCvgDet covg pkgid <- packageInPath dpath cacheControlWithoutETag [Public, maxAgeDays 30] @@ -1058,6 +1059,7 @@ mkHtmlReports HtmlUtilities{..} CoreFeature{..} ReportsFeature{..} templates = H [ "pkgid" $= (pkgid :: PackageIdentifier) , "report" $= (repid, report) , "log" $= toMessage <$> mlog' + , "test" $= toMessage <$> mtest' , "covg" $= covg' ] where diff --git a/src/Distribution/Server/Framework/ResponseContentTypes.hs b/src/Distribution/Server/Framework/ResponseContentTypes.hs index f42fee51c..fd20d7fe2 100644 --- a/src/Distribution/Server/Framework/ResponseContentTypes.hs +++ b/src/Distribution/Server/Framework/ResponseContentTypes.hs @@ -180,6 +180,12 @@ instance ToMessage BuildLog where toContentType _ = "text/plain" toMessage (BuildLog bs) = bs +newtype TestLog = TestLog BS.Lazy.ByteString + +instance ToMessage TestLog where + toContentType _ = "text/plain" + toMessage (TestLog bs) = bs + newtype BuildCovg = BuildCovg BS.Lazy.ByteString instance ToMessage BuildCovg where From 45eba028f4bc001b2c0e952d4ce63f577aac9249 Mon Sep 17 00:00:00 2001 From: Alias Qli <2576814881@qq.com> Date: Thu, 14 Jul 2022 00:12:19 +0800 Subject: [PATCH 2/2] Fix hackage-build using user's cabal folder --- exes/BuildClient.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/exes/BuildClient.hs b/exes/BuildClient.hs index c07c5c4e4..3552fa02d 100644 --- a/exes/BuildClient.hs +++ b/exes/BuildClient.hs @@ -38,7 +38,7 @@ import System.Exit(exitFailure, ExitCode(..)) import System.FilePath import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist, doesDirectoryExist, getDirectoryContents, - renameFile, removeFile, getAppUserDataDirectory, + renameFile, removeFile, createDirectory, removeDirectoryRecursive, createDirectoryIfMissing, makeAbsolute) import System.Console.GetOpt @@ -156,9 +156,9 @@ initialise opts uri auxUris readMissingOpt prompt = maybe (putStrLn prompt >> getLine) return -- | Parse the @00-index.cache@ file of the available package repositories. -parseRepositoryIndices :: Verbosity -> IO (M.Map PackageIdentifier Tar.EpochTime) -parseRepositoryIndices verbosity = do - cabalDir <- getAppUserDataDirectory "cabal/packages" +parseRepositoryIndices :: BuildOpts -> Verbosity -> IO (M.Map PackageIdentifier Tar.EpochTime) +parseRepositoryIndices opts verbosity = do + let cabalDir = bo_stateDir opts "cached-tarballs" cacheDirs <- listDirectory cabalDir indexFiles <- filterM doesFileExist $ map (\dir -> cabalDir dir "01-index.tar") cacheDirs M.unions <$> mapM readIndex indexFiles @@ -480,7 +480,7 @@ buildOnce opts pkgs = keepGoing $ do -- documentation index. Consequently, we make sure that the packages we are -- going to build actually appear in the repository before building. See -- #543. - repoIndex <- parseRepositoryIndices verbosity + repoIndex <- parseRepositoryIndices opts verbosity pkgIdsHaveDocs <- getDocumentationStats verbosity opts config (Just pkgs) infoStats verbosity Nothing pkgIdsHaveDocs