From e2f5f8d5bcf635cdf4f9d349fe35e94b43636d56 Mon Sep 17 00:00:00 2001 From: Alias Qli <2576814881@qq.com> Date: Thu, 18 Aug 2022 21:58:38 +0800 Subject: [PATCH 1/4] allow disable tests on client side --- exes/BuildClient.hs | 31 ++++++++++--------- .../Server/Features/BuildReports.hs | 2 +- .../Features/BuildReports/BuildReport.hs | 7 +++-- 3 files changed, 23 insertions(+), 17 deletions(-) diff --git a/exes/BuildClient.hs b/exes/BuildClient.hs index f72d6e251..ca314a1b6 100644 --- a/exes/BuildClient.hs +++ b/exes/BuildClient.hs @@ -362,6 +362,7 @@ data DocInfo = DocInfo { docInfoPackage :: PackageIdentifier , docInfoHasDocs :: HasDocs , docInfoIsCandidate :: Bool + , docInfoRunTests :: Bool } docInfoPackageName :: DocInfo -> PackageName @@ -410,8 +411,8 @@ getDocumentationStats verbosity opts config pkgs = do (Just (perrs, packages), Just (cerrs, candidates)) -> do liftIO . when (not . null $ perrs) . putStrLn $ "failed package json parses: " ++ show perrs liftIO . when (not . null $ cerrs) . putStrLn $ "failed candidate json parses: " ++ show cerrs - packages' <- liftIO $ mapM checkFailed packages - candidates' <- liftIO $ mapM checkFailed candidates + let packages' = map checkFailed packages + candidates' = map checkFailed candidates return $ map (setIsCandidate False) packages' ++ map (setIsCandidate True) candidates' where @@ -447,21 +448,23 @@ getDocumentationStats verbosity opts config pkgs = do addEnd (Just pkgs') Nothing uri = uri "docs.json" ++ "?pkgs=" ++ (getQry pkgs') addEnd Nothing Nothing uri = uri "docs.json" - checkFailed :: BR.PkgDetails -> IO (PackageIdentifier, HasDocs) - checkFailed pkgDetails = do + checkFailed :: BR.PkgDetails -> (PackageIdentifier, HasDocs, Bool) + checkFailed pkgDetails = let pkgId = BR.pkid pkgDetails - case (BR.docs pkgDetails, BR.failCnt pkgDetails) of - (True , _) -> return (pkgId, HasDocs) - (False, Just BR.BuildOK) -> return (pkgId, DocsFailed) - (False, Just (BR.BuildFailCnt a)) - | a >= bo_buildAttempts opts -> return (pkgId, DocsFailed) - (False, _) -> return (pkgId, DocsNotBuilt) - - setIsCandidate :: Bool -> (PackageIdentifier, HasDocs) -> DocInfo - setIsCandidate isCandidate (pId, hasDocs) = DocInfo { + hasDocs = case (BR.docs pkgDetails, BR.failCnt pkgDetails) of + (True , _) -> HasDocs + (False, Just BR.BuildOK) -> DocsFailed + (False, Just (BR.BuildFailCnt a)) + | a >= bo_buildAttempts opts -> DocsFailed + (False, _) -> DocsNotBuilt + in (pkgId, hasDocs, BR.runTests pkgDetails) + + setIsCandidate :: Bool -> (PackageIdentifier, HasDocs, Bool) -> DocInfo + setIsCandidate isCandidate (pId, hasDocs, runTests) = DocInfo { docInfoPackage = pId , docInfoHasDocs = hasDocs , docInfoIsCandidate = isCandidate + , docInfoRunTests = runTests } @@ -570,7 +573,7 @@ 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) <- case installOk && docInfoRunTests docInfo of True -> testPackage verbosity opts docInfo False -> return (Nothing, Nothing) coverageFile <- mapM (coveragePackage verbosity opts docInfo) hpcLoc diff --git a/src/Distribution/Server/Features/BuildReports.hs b/src/Distribution/Server/Features/BuildReports.hs index 73985286c..cec2e781f 100644 --- a/src/Distribution/Server/Features/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports.hs @@ -206,7 +206,7 @@ buildReportsFeature name Just (_, brp, _, _) -> do let (CompilerId _ vrsn) = compiler brp return (time brp, Just vrsn) - return (BuildReport.PkgDetails pkgid docs failCnt time ghcId) + return (BuildReport.PkgDetails pkgid docs failCnt time ghcId {- TODO -}True) queryLastReportStats :: MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg)) queryLastReportStats pkgid = do diff --git a/src/Distribution/Server/Features/BuildReports/BuildReport.hs b/src/Distribution/Server/Features/BuildReports/BuildReport.hs index 1d85cce5f..6e56aceb9 100644 --- a/src/Distribution/Server/Features/BuildReports/BuildReport.hs +++ b/src/Distribution/Server/Features/BuildReports/BuildReport.hs @@ -623,7 +623,8 @@ data PkgDetails = PkgDetails { docs :: Bool, failCnt :: Maybe BuildStatus, buildTime :: Maybe UTCTime, - ghcId :: Maybe Version + ghcId :: Maybe Version, + runTests :: Bool } deriving(Show) instance Data.Aeson.ToJSON PkgDetails where @@ -632,7 +633,8 @@ instance Data.Aeson.ToJSON PkgDetails where "docs" .= docs p, "failCnt" .= failCnt p, "buildTime" .= buildTime p, - "ghcId" .= k (ghcId p) ] + "ghcId" .= k (ghcId p), + "runTests" .= runTests p ] where k (Just a) = Just $ DT.display a k Nothing = Nothing @@ -645,6 +647,7 @@ instance Data.Aeson.FromJSON PkgDetails where <*> o .:? "failCnt" <*> o .:? "buildTime" <*> fmap parseVersion (o .:? "ghcId") + <*> o .: "runTests" where parseVersion :: Maybe String -> Maybe Version parseVersion Nothing = Nothing From 955c736c5161b0d860e2cb3c2cf550300170559b Mon Sep 17 00:00:00 2001 From: Alias Qli <2576814881@qq.com> Date: Thu, 18 Aug 2022 22:57:22 +0800 Subject: [PATCH 2/4] add runTests to acid state --- exes/BuildClient.hs | 2 +- .../Server/Features/BuildReports.hs | 3 +- .../Features/BuildReports/BuildReport.hs | 2 +- .../Features/BuildReports/BuildReports.hs | 97 +++++++++++++++---- .../Server/Features/BuildReports/State.hs | 11 +++ 5 files changed, 93 insertions(+), 22 deletions(-) diff --git a/exes/BuildClient.hs b/exes/BuildClient.hs index ca314a1b6..a8565b46b 100644 --- a/exes/BuildClient.hs +++ b/exes/BuildClient.hs @@ -457,7 +457,7 @@ getDocumentationStats verbosity opts config pkgs = do (False, Just (BR.BuildFailCnt a)) | a >= bo_buildAttempts opts -> DocsFailed (False, _) -> DocsNotBuilt - in (pkgId, hasDocs, BR.runTests pkgDetails) + in (pkgId, hasDocs, fromMaybe True $ BR.runTests pkgDetails) setIsCandidate :: Bool -> (PackageIdentifier, HasDocs, Bool) -> DocInfo setIsCandidate isCandidate (pId, hasDocs, runTests) = DocInfo { diff --git a/src/Distribution/Server/Features/BuildReports.hs b/src/Distribution/Server/Features/BuildReports.hs index cec2e781f..1c625425e 100644 --- a/src/Distribution/Server/Features/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports.hs @@ -201,12 +201,13 @@ buildReportsFeature name pkgReportDetails (pkgid, docs) = do failCnt <- queryState reportsState $ LookupFailCount pkgid latestRpt <- queryState reportsState $ LookupLatestReport pkgid + runTests <- queryState reportsState $ LookupRunTests pkgid (time, ghcId) <- case latestRpt of Nothing -> return (Nothing,Nothing) Just (_, brp, _, _) -> do let (CompilerId _ vrsn) = compiler brp return (time brp, Just vrsn) - return (BuildReport.PkgDetails pkgid docs failCnt time ghcId {- TODO -}True) + return (BuildReport.PkgDetails pkgid docs failCnt time ghcId runTests) queryLastReportStats :: MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg)) queryLastReportStats pkgid = do diff --git a/src/Distribution/Server/Features/BuildReports/BuildReport.hs b/src/Distribution/Server/Features/BuildReports/BuildReport.hs index 6e56aceb9..1e2f554c1 100644 --- a/src/Distribution/Server/Features/BuildReports/BuildReport.hs +++ b/src/Distribution/Server/Features/BuildReports/BuildReport.hs @@ -624,7 +624,7 @@ data PkgDetails = PkgDetails { failCnt :: Maybe BuildStatus, buildTime :: Maybe UTCTime, ghcId :: Maybe Version, - runTests :: Bool + runTests :: Maybe Bool } deriving(Show) instance Data.Aeson.ToJSON PkgDetails where diff --git a/src/Distribution/Server/Features/BuildReports/BuildReports.hs b/src/Distribution/Server/Features/BuildReports/BuildReports.hs index ae6d724ab..76b04e6da 100644 --- a/src/Distribution/Server/Features/BuildReports/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports/BuildReports.hs @@ -22,7 +22,9 @@ module Distribution.Server.Features.BuildReports.BuildReports ( setFailStatus, resetFailCount, lookupLatestReport, - lookupFailCount + lookupFailCount, + lookupRunTests, + setRunTests ) where import qualified Distribution.Server.Framework.BlobStorage as BlobStorage @@ -86,18 +88,21 @@ data PkgBuildReports = PkgBuildReports { reports :: !(Map BuildReportId (BuildReport, Maybe BuildLog, Maybe BuildCovg )), -- one more than the maximum report id used nextReportId :: !BuildReportId, - buildStatus :: !BuildStatus + buildStatus :: !BuildStatus, + runTests :: !Bool } deriving (Eq, Typeable, Show) data BuildReports = BuildReports { reportsIndex :: !(Map.Map PackageId PkgBuildReports) + } deriving (Eq, Typeable, Show) emptyPkgReports :: PkgBuildReports emptyPkgReports = PkgBuildReports { reports = Map.empty, nextReportId = BuildReportId 1, - buildStatus = BuildFailCnt 0 + buildStatus = BuildFailCnt 0, + runTests = True } emptyReports :: BuildReports @@ -126,7 +131,8 @@ addReport pkgid (brpt,blog) buildReports = reportId = nextReportId pkgReports pkgReports' = PkgBuildReports { reports = Map.insert reportId (brpt,blog,Nothing) (reports pkgReports) , nextReportId = incrementReportId reportId - , buildStatus = buildStatus pkgReports } + , buildStatus = buildStatus pkgReports + , runTests = runTests pkgReports } in (buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) }, reportId) unsafeSetReport :: PackageId -> BuildReportId -> (BuildReport, Maybe BuildLog) -> BuildReports -> BuildReports @@ -134,7 +140,8 @@ 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) , nextReportId = max (incrementReportId reportId) (nextReportId pkgReports) - , buildStatus = buildStatus pkgReports } + , buildStatus = buildStatus pkgReports + , runTests = runTests pkgReports } in buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) } deleteReport :: PackageId -> BuildReportId -> BuildReports -> Maybe BuildReports @@ -159,7 +166,8 @@ addRptLogCovg pkgid report buildReports = reportId = nextReportId pkgReports pkgReports' = PkgBuildReports { reports = Map.insert reportId report (reports pkgReports) , nextReportId = incrementReportId reportId - , buildStatus = buildStatus pkgReports } + , buildStatus = buildStatus pkgReports + , runTests = runTests pkgReports } in (buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) }, reportId) lookupReportCovg :: PackageId -> BuildReportId -> BuildReports -> Maybe (BuildReport, Maybe BuildLog, Maybe BuildCovg ) @@ -170,7 +178,8 @@ setFailStatus pkgid fStatus buildReports = let pkgReports = Map.findWithDefault emptyPkgReports pkgid (reportsIndex buildReports) pkgReports' = PkgBuildReports { reports = (reports pkgReports) , nextReportId = (nextReportId pkgReports) - , buildStatus = (getfst fStatus (buildStatus pkgReports)) } + , buildStatus = (getfst fStatus (buildStatus pkgReports)) + , runTests = runTests pkgReports } in buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) } where getfst nfst cfst = do @@ -185,7 +194,8 @@ resetFailCount pkgid buildReports = case Map.lookup pkgid (reportsIndex buildRep Just pkgReports -> do let pkgReports' = PkgBuildReports { reports = (reports pkgReports) , nextReportId = (nextReportId pkgReports) - , buildStatus = BuildFailCnt 0 } + , buildStatus = BuildFailCnt 0 + , runTests = runTests pkgReports } return buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) } lookupFailCount :: PackageId -> BuildReports -> Maybe BuildStatus @@ -203,6 +213,16 @@ lookupLatestReport pkgid buildReports = do else Just $ Map.findMax rs Just (maxKey, rep, buildLog, covg) +lookupRunTests :: PackageId -> BuildReports -> Maybe Bool +lookupRunTests pkgid buildReports = do + rp <- Map.lookup pkgid (reportsIndex buildReports) + pure (runTests rp) + +setRunTests :: PackageId -> Bool -> BuildReports -> BuildReports +setRunTests pkgid b buildReports = + let rp = Map.findWithDefault emptyPkgReports pkgid (reportsIndex buildReports) + in BuildReports (Map.insert pkgid rp{runTests = b} (reportsIndex buildReports)) + -- addPkg::` ------------------- -- HStringTemplate instances @@ -247,20 +267,41 @@ deriveSafeCopy 2 'extension ''BuildLog -- 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) + putCopy (PkgBuildReports x _ y z) = contain $ safePut (x,y,z) getCopy = contain $ mkReports <$> safeGet where - mkReports (rs,f) = PkgBuildReports rs + mkReports (rs,f,b) = PkgBuildReports rs (if Map.null rs then BuildReportId 1 else incrementReportId (fst $ Map.findMax rs)) - f + f b instance MemSize PkgBuildReports where - memSize (PkgBuildReports a b c) = memSize3 a b c + memSize (PkgBuildReports a b c d) = memSize4 a b c d + + +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)), @@ -309,16 +350,20 @@ 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 c) = + PkgBuildReports m n c True data BuildReports_v0 = BuildReports_v0 !(Map.Map PackageIdentifier_v0 PkgBuildReports_v0) @@ -345,12 +390,26 @@ instance MemSize BuildReports_v2 where deriveSafeCopy 2 'extension ''BuildReports_v2 -instance Migrate BuildReports where - type MigrateFrom BuildReports = 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_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 \ No newline at end of file diff --git a/src/Distribution/Server/Features/BuildReports/State.hs b/src/Distribution/Server/Features/BuildReports/State.hs index 0895a95a7..4259b737f 100644 --- a/src/Distribution/Server/Features/BuildReports/State.hs +++ b/src/Distribution/Server/Features/BuildReports/State.hs @@ -80,6 +80,15 @@ lookupFailCount pkgid = asks (BuildReports.lookupFailCount pkgid) lookupLatestReport :: PackageId -> Query BuildReports (Maybe (BuildReportId, BuildReport, Maybe BuildLog, Maybe BuildCovg)) lookupLatestReport pkgid = asks (BuildReports.lookupLatestReport pkgid) +lookupRunTests :: PackageId -> Query BuildReports (Maybe Bool) +lookupRunTests pkgid = asks (BuildReports.lookupRunTests pkgid) + +setRunTests :: PackageId -> Bool -> Update BuildReports () +setRunTests pkgid b = do + buildReports <- State.get + let reports = BuildReports.setRunTests pkgid b buildReports + State.put reports + makeAcidic ''BuildReports ['addReport ,'setBuildLog ,'deleteReport @@ -93,5 +102,7 @@ makeAcidic ''BuildReports ['addReport ,'resetFailCount ,'lookupFailCount ,'lookupLatestReport + ,'lookupRunTests + ,'setRunTests ] From fea0f675f476787f20b5bce78e3328bac8ab54f2 Mon Sep 17 00:00:00 2001 From: Alias Qli <2576814881@qq.com> Date: Fri, 19 Aug 2022 01:45:13 +0800 Subject: [PATCH 3/4] implement tests opt --- datafiles/templates/Html/maintain.html.st | 5 +++ datafiles/templates/Html/reports-test.html.st | 25 ++++++++++++++ .../Server/Features/BuildReports.hs | 34 +++++++++++++++++++ .../Features/BuildReports/BuildReports.hs | 8 ++--- .../Server/Features/BuildReports/State.hs | 7 ++-- src/Distribution/Server/Features/Html.hs | 25 +++++++++++--- 6 files changed, 92 insertions(+), 12 deletions(-) create mode 100644 datafiles/templates/Html/reports-test.html.st diff --git a/datafiles/templates/Html/maintain.html.st b/datafiles/templates/Html/maintain.html.st index 5b7500b00..2a39e0cdc 100644 --- a/datafiles/templates/Html/maintain.html.st +++ b/datafiles/templates/Html/maintain.html.st @@ -46,6 +46,11 @@ package after its been released.

$versions:{pkgid|$pkgid$}; separator=", "$

+
Test settings
+
If your package contains tests that can't run on hackage, you can disable them here. +

$versions:{pkgid|$pkgid$}; separator=", "$

+
+
Trigger rebuild
Reset the fail count and trigger rebuild. Choose this option only if you believe our build process didn't go right for some reason. Reseting fail count won't trigger rebuild if your package has documentation.

$versions:{pkgid|$pkgid$}; separator=", "$

diff --git a/datafiles/templates/Html/reports-test.html.st b/datafiles/templates/Html/reports-test.html.st new file mode 100644 index 000000000..72a4eaee1 --- /dev/null +++ b/datafiles/templates/Html/reports-test.html.st @@ -0,0 +1,25 @@ + + + +$hackageCssTheme()$ +Test settings + + +$hackagePageHeader()$ + +
+

Test settings for $pkgid$

+ +
+ +
+
Run tests
+
+ Whether hackage should run the tests. +
+ +

+

+ +
+ diff --git a/src/Distribution/Server/Features/BuildReports.hs b/src/Distribution/Server/Features/BuildReports.hs index 1c625425e..f5eb6dfa2 100644 --- a/src/Distribution/Server/Features/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports.hs @@ -32,6 +32,7 @@ import Data.ByteString.Lazy (toStrict) import Data.String (fromString) import Data.Maybe import Distribution.Compiler ( CompilerId(..) ) +import Data.Aeson (toJSON) -- TODO: @@ -47,6 +48,7 @@ data ReportsFeature = ReportsFeature { 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 (BuildReportId, BuildReport, Maybe BuildCovg)), + queryRunTests :: forall m. MonadIO m => PackageId -> m (Maybe Bool), reportsResource :: ReportsResource } @@ -59,6 +61,7 @@ data ReportsResource = ReportsResource { reportsPage :: Resource, reportsLog :: Resource, reportsReset:: Resource, + reportsTest :: Resource, reportsListUri :: String -> PackageId -> String, reportsPageUri :: String -> PackageId -> BuildReportId -> String, reportsLogUri :: PackageId -> BuildReportId -> String @@ -119,6 +122,7 @@ buildReportsFeature name , reportsPage , reportsLog , reportsReset + , reportsTest ] , featureState = [abstractAcidStateComponent reportsState] } @@ -140,6 +144,13 @@ buildReportsFeature name ] , resourceGet = [ ("", resetBuildFails) ] } + , reportsTest = (extendResourcePath "/reports/test/" corePackagePage) { + resourceDesc = [ (GET, "Get reports test settings") + , (POST, "Set reports test settings") + ] + , resourceGet = [ ("json", getReportsTest) ] + , resourcePost = [ ("", postReportsTest) ] + } , reportsPage = (extendResourcePath "/reports/:id.:format" corePackagePage) { resourceDesc = [ (GET, "Get a specific build report") , (DELETE, "Delete a specific build report") @@ -216,6 +227,8 @@ buildReportsFeature name Nothing -> return Nothing Just (rptId, rpt, _, covg) -> return (Just (rptId, rpt, covg)) + queryRunTests :: MonadIO m => PackageId -> m (Maybe Bool) + queryRunTests pkgid = queryState reportsState $ LookupRunTests pkgid --------------------------------------------------------------------------- @@ -319,6 +332,27 @@ buildReportsFeature name then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse () else errNotFound "Report not found" [MText "Build report does not exist"] + getReportsTest :: DynamicPath -> ServerPartE Response + getReportsTest dpath = do + pkgid <- packageInPath dpath + guardValidPackageId pkgid + guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) + mRunTest <- queryRunTests pkgid + case mRunTest of + Nothing -> errNotFound "Package not found" [MText "Package does not exist"] + Just runTest -> pure $ toResponse $ toJSON runTest + + postReportsTest :: DynamicPath -> ServerPartE Response + postReportsTest dpath = do + pkgid <- packageInPath dpath + runTests <- body $ look "runTests" + guardValidPackageId pkgid + guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) + success <- updateState reportsState $ SetRunTests pkgid (runTests == "on") + if success + then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse () + else errNotFound "Package not found" [MText "Package does not exist"] + putAllReports :: DynamicPath -> ServerPartE Response putAllReports dpath = do diff --git a/src/Distribution/Server/Features/BuildReports/BuildReports.hs b/src/Distribution/Server/Features/BuildReports/BuildReports.hs index 76b04e6da..8740c84ee 100644 --- a/src/Distribution/Server/Features/BuildReports/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports/BuildReports.hs @@ -218,10 +218,10 @@ lookupRunTests pkgid buildReports = do rp <- Map.lookup pkgid (reportsIndex buildReports) pure (runTests rp) -setRunTests :: PackageId -> Bool -> BuildReports -> BuildReports -setRunTests pkgid b buildReports = - let rp = Map.findWithDefault emptyPkgReports pkgid (reportsIndex buildReports) - in BuildReports (Map.insert pkgid rp{runTests = b} (reportsIndex buildReports)) +setRunTests :: PackageId -> Bool -> BuildReports -> Maybe BuildReports +setRunTests pkgid b buildReports = do + rp <- Map.lookup pkgid (reportsIndex buildReports) + pure $ BuildReports (Map.insert pkgid rp{runTests = b} (reportsIndex buildReports)) -- addPkg::` ------------------- diff --git a/src/Distribution/Server/Features/BuildReports/State.hs b/src/Distribution/Server/Features/BuildReports/State.hs index 4259b737f..ca60c3d9d 100644 --- a/src/Distribution/Server/Features/BuildReports/State.hs +++ b/src/Distribution/Server/Features/BuildReports/State.hs @@ -83,11 +83,12 @@ lookupLatestReport pkgid = asks (BuildReports.lookupLatestReport pkgid) lookupRunTests :: PackageId -> Query BuildReports (Maybe Bool) lookupRunTests pkgid = asks (BuildReports.lookupRunTests pkgid) -setRunTests :: PackageId -> Bool -> Update BuildReports () +setRunTests :: PackageId -> Bool -> Update BuildReports Bool setRunTests pkgid b = do buildReports <- State.get - let reports = BuildReports.setRunTests pkgid b buildReports - State.put reports + case BuildReports.setRunTests pkgid b buildReports of + Nothing -> pure False + Just reports -> State.put reports >> pure True makeAcidic ''BuildReports ['addReport ,'setBuildLog diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index 7155f62e4..8e279497b 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -123,7 +123,7 @@ initHtmlFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode, templates <- loadTemplates serverTemplatesMode [serverTemplatesDir, serverTemplatesDir "Html"] [ "maintain.html", "maintain-candidate.html" - , "reports.html", "report.html" + , "reports.html", "report.html", "reports-test.html" , "maintain-docs.html" , "distro-monitor.html" , "revisions.html" @@ -283,7 +283,7 @@ htmlFeature env@ServerEnv{..} htmlUploads = mkHtmlUploads utilities upload htmlDocUploads = mkHtmlDocUploads utilities core docsCore templates htmlDownloads = mkHtmlDownloads utilities download - htmlReports = mkHtmlReports utilities core reportsCore templates + htmlReports = mkHtmlReports utilities core upload user reportsCore templates htmlCandidates = mkHtmlCandidates utilities core versions upload docsCandidates tarIndexCache candidates user templates @@ -1014,10 +1014,10 @@ data HtmlReports = HtmlReports { htmlReportsResources :: [Resource] } -mkHtmlReports :: HtmlUtilities -> CoreFeature -> ReportsFeature -> Templates -> HtmlReports -mkHtmlReports HtmlUtilities{..} CoreFeature{..} ReportsFeature{..} templates = HtmlReports{..} +mkHtmlReports :: HtmlUtilities -> CoreFeature -> UploadFeature -> UserFeature -> ReportsFeature -> Templates -> HtmlReports +mkHtmlReports HtmlUtilities{..} CoreFeature{..} UploadFeature{..} UserFeature{..} ReportsFeature{..} templates = HtmlReports{..} where - CoreResource{packageInPath} = coreResource + CoreResource{packageInPath, guardValidPackageId} = coreResource ReportsResource{..} = reportsResource htmlReportsResources = [ @@ -1027,6 +1027,9 @@ mkHtmlReports HtmlUtilities{..} CoreFeature{..} ReportsFeature{..} templates = H , (extendResource reportsPage) { resourceGet = [ ("html", servePackageReport) ] } + , (extendResource reportsTest) { + resourceGet = [ ("html", servePackageReportTests) ] + } ] servePackageReports :: DynamicPath -> ServerPartE Response @@ -1074,6 +1077,18 @@ mkHtmlReports HtmlUtilities{..} CoreFeature{..} ReportsFeature{..} templates = H det::(Int,Int)->(Int,Int,Int) det (_,0) = (100,0,0) det (a,b) = ((a * 100) `div` b ,a,b) + + servePackageReportTests :: DynamicPath -> ServerPartE Response + servePackageReportTests dpath = do + pkgid <- packageInPath dpath + guardValidPackageId pkgid + guardAuthorised_ [InGroup (maintainersGroup (packageName pkgid)), InGroup trusteesGroup] + template <- getTemplate templates "reports-test.html" + runTests <- queryRunTests pkgid + return $ toResponse $ template + [ "pkgid" $= pkgid + , "runTests" $= runTests + ] {------------------------------------------------------------------------------- Candidates From 837069051a04a4528d6521b826b5e44f0e294b6a Mon Sep 17 00:00:00 2001 From: Gershom Bazerman Date: Fri, 30 Dec 2022 15:34:50 -0500 Subject: [PATCH 4/4] fix logic for form --- src/Distribution/Server/Features/BuildReports.hs | 16 +++++++--------- .../Server/Features/BuildReports/BuildReports.hs | 15 +++++++-------- .../Server/Features/BuildReports/State.hs | 3 +-- 3 files changed, 15 insertions(+), 19 deletions(-) diff --git a/src/Distribution/Server/Features/BuildReports.hs b/src/Distribution/Server/Features/BuildReports.hs index f5eb6dfa2..c443bbab2 100644 --- a/src/Distribution/Server/Features/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports.hs @@ -48,7 +48,7 @@ data ReportsFeature = ReportsFeature { 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 (BuildReportId, BuildReport, Maybe BuildCovg)), - queryRunTests :: forall m. MonadIO m => PackageId -> m (Maybe Bool), + queryRunTests :: forall m. MonadIO m => PackageId -> m Bool, reportsResource :: ReportsResource } @@ -212,7 +212,7 @@ buildReportsFeature name pkgReportDetails (pkgid, docs) = do failCnt <- queryState reportsState $ LookupFailCount pkgid latestRpt <- queryState reportsState $ LookupLatestReport pkgid - runTests <- queryState reportsState $ LookupRunTests pkgid + runTests <- fmap Just . queryState reportsState $ LookupRunTests pkgid (time, ghcId) <- case latestRpt of Nothing -> return (Nothing,Nothing) Just (_, brp, _, _) -> do @@ -227,7 +227,7 @@ buildReportsFeature name Nothing -> return Nothing Just (rptId, rpt, _, covg) -> return (Just (rptId, rpt, covg)) - queryRunTests :: MonadIO m => PackageId -> m (Maybe Bool) + queryRunTests :: MonadIO m => PackageId -> m Bool queryRunTests pkgid = queryState reportsState $ LookupRunTests pkgid --------------------------------------------------------------------------- @@ -337,18 +337,16 @@ buildReportsFeature name pkgid <- packageInPath dpath guardValidPackageId pkgid guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) - mRunTest <- queryRunTests pkgid - case mRunTest of - Nothing -> errNotFound "Package not found" [MText "Package does not exist"] - Just runTest -> pure $ toResponse $ toJSON runTest + runTest <- queryRunTests pkgid + pure $ toResponse $ toJSON runTest postReportsTest :: DynamicPath -> ServerPartE Response postReportsTest dpath = do pkgid <- packageInPath dpath - runTests <- body $ look "runTests" + runTests <- body $ looks "runTests" guardValidPackageId pkgid guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) - success <- updateState reportsState $ SetRunTests pkgid (runTests == "on") + success <- updateState reportsState $ SetRunTests pkgid ("on" `elem` runTests) if success then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse () else errNotFound "Package not found" [MText "Package does not exist"] diff --git a/src/Distribution/Server/Features/BuildReports/BuildReports.hs b/src/Distribution/Server/Features/BuildReports/BuildReports.hs index 8740c84ee..611f7d23e 100644 --- a/src/Distribution/Server/Features/BuildReports/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports/BuildReports.hs @@ -50,6 +50,7 @@ import Data.SafeCopy import Data.Typeable (Typeable) import qualified Data.List as L import qualified Data.Char as Char +import Data.Maybe (fromMaybe) import Text.StringTemplate (ToSElem(..)) @@ -94,7 +95,7 @@ data PkgBuildReports = PkgBuildReports { data BuildReports = BuildReports { reportsIndex :: !(Map.Map PackageId PkgBuildReports) - + } deriving (Eq, Typeable, Show) emptyPkgReports :: PkgBuildReports @@ -213,15 +214,13 @@ lookupLatestReport pkgid buildReports = do else Just $ Map.findMax rs Just (maxKey, rep, buildLog, covg) -lookupRunTests :: PackageId -> BuildReports -> Maybe Bool -lookupRunTests pkgid buildReports = do - rp <- Map.lookup pkgid (reportsIndex buildReports) - pure (runTests rp) +lookupRunTests :: PackageId -> BuildReports -> Bool +lookupRunTests pkgid buildReports = maybe True runTests $ Map.lookup pkgid (reportsIndex buildReports) setRunTests :: PackageId -> Bool -> BuildReports -> Maybe BuildReports -setRunTests pkgid b buildReports = do - rp <- Map.lookup pkgid (reportsIndex buildReports) - pure $ BuildReports (Map.insert pkgid rp{runTests = b} (reportsIndex buildReports)) +setRunTests pkgid b buildReports = + let rp = fromMaybe emptyPkgReports $ Map.lookup pkgid (reportsIndex buildReports) + in Just $ BuildReports (Map.insert pkgid rp{runTests = b} (reportsIndex buildReports)) -- addPkg::` ------------------- diff --git a/src/Distribution/Server/Features/BuildReports/State.hs b/src/Distribution/Server/Features/BuildReports/State.hs index ca60c3d9d..ce6ed6d7c 100644 --- a/src/Distribution/Server/Features/BuildReports/State.hs +++ b/src/Distribution/Server/Features/BuildReports/State.hs @@ -80,7 +80,7 @@ lookupFailCount pkgid = asks (BuildReports.lookupFailCount pkgid) lookupLatestReport :: PackageId -> Query BuildReports (Maybe (BuildReportId, BuildReport, Maybe BuildLog, Maybe BuildCovg)) lookupLatestReport pkgid = asks (BuildReports.lookupLatestReport pkgid) -lookupRunTests :: PackageId -> Query BuildReports (Maybe Bool) +lookupRunTests :: PackageId -> Query BuildReports (Bool) lookupRunTests pkgid = asks (BuildReports.lookupRunTests pkgid) setRunTests :: PackageId -> Bool -> Update BuildReports Bool @@ -106,4 +106,3 @@ makeAcidic ''BuildReports ['addReport ,'lookupRunTests ,'setRunTests ] -