Skip to content

Commit fea0f67

Browse files
AliasQliAliasQli
committed
implement tests opt
1 parent 955c736 commit fea0f67

File tree

6 files changed

+92
-12
lines changed

6 files changed

+92
-12
lines changed

‎datafiles/templates/Html/maintain.html.st‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -46,6 +46,11 @@ package after its been released.
4646
<p>$versions:{pkgid|<a href="/package/$pkgid$/$pkgname$.cabal/edit">$pkgid$</a>}; separator=", "$</p>
4747
</dd>
4848

49+
<dt>Test settings</dt>
50+
<dd>If your package contains tests that can't run on hackage, you can disable them here.
51+
<p>$versions:{pkgid|<a href="/package/$pkgid$/reports/test">$pkgid$</a>}; separator=", "$</p>
52+
</dd>
53+
4954
<dt>Trigger rebuild</dt>
5055
<dd>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.
5156
<p>$versions:{pkgid|<a href="/package/$pkgid$/reports/reset" onclick="return confirm('Are you sure you want to trigger rebuild?')" >$pkgid$</a>}; separator=", "$</p>

‎datafiles/templates/Html/reports-test.html.st‎

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
<!DOCTYPE html>
2+
<html>
3+
<head>
4+
$hackageCssTheme()$
5+
<title>Test settings</title>
6+
</head>
7+
<body>
8+
$hackagePageHeader()$
9+
10+
<div id="content">
11+
<h2>Test settings for $pkgid$</h2>
12+
13+
<form action="." method="post" enctype="multipart/form-data">
14+
15+
<dl>
16+
<dt>Run tests</dt>
17+
<dd><input type="checkbox" name="runTests" id="runTests" $if(runTests)$checked$endif$>
18+
Whether hackage should run the tests.
19+
</dd>
20+
21+
<p><input type="submit" value="Save">
22+
</form>
23+
24+
</div>
25+
</body></html>

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

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import Data.ByteString.Lazy (toStrict)
3232
import Data.String (fromString)
3333
import Data.Maybe
3434
import Distribution.Compiler ( CompilerId(..) )
35+
import Data.Aeson (toJSON)
3536

3637

3738
-- TODO:
@@ -47,6 +48,7 @@ data ReportsFeature = ReportsFeature {
4748
queryBuildLog :: forall m. MonadIO m => BuildLog -> m Resource.BuildLog,
4849
pkgReportDetails :: forall m. MonadIO m => (PackageIdentifier, Bool) -> m BuildReport.PkgDetails,
4950
queryLastReportStats:: forall m. MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg)),
51+
queryRunTests :: forall m. MonadIO m => PackageId -> m (Maybe Bool),
5052
reportsResource :: ReportsResource
5153
}
5254

@@ -59,6 +61,7 @@ data ReportsResource = ReportsResource {
5961
reportsPage :: Resource,
6062
reportsLog :: Resource,
6163
reportsReset:: Resource,
64+
reportsTest :: Resource,
6265
reportsListUri :: String -> PackageId -> String,
6366
reportsPageUri :: String -> PackageId -> BuildReportId -> String,
6467
reportsLogUri :: PackageId -> BuildReportId -> String
@@ -119,6 +122,7 @@ buildReportsFeature name
119122
, reportsPage
120123
, reportsLog
121124
, reportsReset
125+
, reportsTest
122126
]
123127
, featureState = [abstractAcidStateComponent reportsState]
124128
}
@@ -140,6 +144,13 @@ buildReportsFeature name
140144
]
141145
, resourceGet = [ ("", resetBuildFails) ]
142146
}
147+
, reportsTest = (extendResourcePath "/reports/test/" corePackagePage) {
148+
resourceDesc = [ (GET, "Get reports test settings")
149+
, (POST, "Set reports test settings")
150+
]
151+
, resourceGet = [ ("json", getReportsTest) ]
152+
, resourcePost = [ ("", postReportsTest) ]
153+
}
143154
, reportsPage = (extendResourcePath "/reports/:id.:format" corePackagePage) {
144155
resourceDesc = [ (GET, "Get a specific build report")
145156
, (DELETE, "Delete a specific build report")
@@ -216,6 +227,8 @@ buildReportsFeature name
216227
Nothing -> return Nothing
217228
Just (rptId, rpt, _, covg) -> return (Just (rptId, rpt, covg))
218229

230+
queryRunTests :: MonadIO m => PackageId -> m (Maybe Bool)
231+
queryRunTests pkgid = queryState reportsState $ LookupRunTests pkgid
219232

220233
---------------------------------------------------------------------------
221234

@@ -319,6 +332,27 @@ buildReportsFeature name
319332
then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse ()
320333
else errNotFound "Report not found" [MText "Build report does not exist"]
321334

335+
getReportsTest :: DynamicPath -> ServerPartE Response
336+
getReportsTest dpath = do
337+
pkgid <- packageInPath dpath
338+
guardValidPackageId pkgid
339+
guardAuthorisedAsMaintainerOrTrustee (packageName pkgid)
340+
mRunTest <- queryRunTests pkgid
341+
case mRunTest of
342+
Nothing -> errNotFound "Package not found" [MText "Package does not exist"]
343+
Just runTest -> pure $ toResponse $ toJSON runTest
344+
345+
postReportsTest :: DynamicPath -> ServerPartE Response
346+
postReportsTest dpath = do
347+
pkgid <- packageInPath dpath
348+
runTests <- body $ look "runTests"
349+
guardValidPackageId pkgid
350+
guardAuthorisedAsMaintainerOrTrustee (packageName pkgid)
351+
success <- updateState reportsState $ SetRunTests pkgid (runTests == "on")
352+
if success
353+
then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse ()
354+
else errNotFound "Package not found" [MText "Package does not exist"]
355+
322356

323357
putAllReports :: DynamicPath -> ServerPartE Response
324358
putAllReports dpath = do

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

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -218,10 +218,10 @@ lookupRunTests pkgid buildReports = do
218218
rp <- Map.lookup pkgid (reportsIndex buildReports)
219219
pure (runTests rp)
220220

221-
setRunTests :: PackageId -> Bool -> BuildReports -> BuildReports
222-
setRunTests pkgid b buildReports =
223-
let rp = Map.findWithDefault emptyPkgReports pkgid (reportsIndex buildReports)
224-
in BuildReports (Map.insert pkgid rp{runTests = b} (reportsIndex buildReports))
221+
setRunTests :: PackageId -> Bool -> BuildReports -> Maybe BuildReports
222+
setRunTests pkgid b buildReports = do
223+
rp <- Map.lookup pkgid (reportsIndex buildReports)
224+
pure $ BuildReports (Map.insert pkgid rp{runTests = b} (reportsIndex buildReports))
225225

226226
-- addPkg::`
227227
-------------------

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

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -83,11 +83,12 @@ lookupLatestReport pkgid = asks (BuildReports.lookupLatestReport pkgid)
8383
lookupRunTests :: PackageId -> Query BuildReports (Maybe Bool)
8484
lookupRunTests pkgid = asks (BuildReports.lookupRunTests pkgid)
8585

86-
setRunTests :: PackageId -> Bool -> Update BuildReports ()
86+
setRunTests :: PackageId -> Bool -> Update BuildReports Bool
8787
setRunTests pkgid b = do
8888
buildReports <- State.get
89-
let reports = BuildReports.setRunTests pkgid b buildReports
90-
State.put reports
89+
case BuildReports.setRunTests pkgid b buildReports of
90+
Nothing -> pure False
91+
Just reports -> State.put reports >> pure True
9192

9293
makeAcidic ''BuildReports ['addReport
9394
,'setBuildLog

‎src/Distribution/Server/Features/Html.hs‎

Lines changed: 20 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -123,7 +123,7 @@ initHtmlFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode,
123123
templates <- loadTemplates serverTemplatesMode
124124
[serverTemplatesDir, serverTemplatesDir </> "Html"]
125125
[ "maintain.html", "maintain-candidate.html"
126-
, "reports.html", "report.html"
126+
, "reports.html", "report.html", "reports-test.html"
127127
, "maintain-docs.html"
128128
, "distro-monitor.html"
129129
, "revisions.html"
@@ -283,7 +283,7 @@ htmlFeature env@ServerEnv{..}
283283
htmlUploads = mkHtmlUploads utilities upload
284284
htmlDocUploads = mkHtmlDocUploads utilities core docsCore templates
285285
htmlDownloads = mkHtmlDownloads utilities download
286-
htmlReports = mkHtmlReports utilities core reportsCore templates
286+
htmlReports = mkHtmlReports utilities core upload user reportsCore templates
287287
htmlCandidates = mkHtmlCandidates utilities core versions upload
288288
docsCandidates tarIndexCache
289289
candidates user templates
@@ -1014,10 +1014,10 @@ data HtmlReports = HtmlReports {
10141014
htmlReportsResources :: [Resource]
10151015
}
10161016

1017-
mkHtmlReports :: HtmlUtilities -> CoreFeature -> ReportsFeature -> Templates -> HtmlReports
1018-
mkHtmlReports HtmlUtilities{..} CoreFeature{..} ReportsFeature{..} templates = HtmlReports{..}
1017+
mkHtmlReports :: HtmlUtilities -> CoreFeature -> UploadFeature -> UserFeature -> ReportsFeature -> Templates -> HtmlReports
1018+
mkHtmlReports HtmlUtilities{..} CoreFeature{..} UploadFeature{..} UserFeature{..} ReportsFeature{..} templates = HtmlReports{..}
10191019
where
1020-
CoreResource{packageInPath} = coreResource
1020+
CoreResource{packageInPath, guardValidPackageId} = coreResource
10211021
ReportsResource{..} = reportsResource
10221022

10231023
htmlReportsResources = [
@@ -1027,6 +1027,9 @@ mkHtmlReports HtmlUtilities{..} CoreFeature{..} ReportsFeature{..} templates = H
10271027
, (extendResource reportsPage) {
10281028
resourceGet = [ ("html", servePackageReport) ]
10291029
}
1030+
, (extendResource reportsTest) {
1031+
resourceGet = [ ("html", servePackageReportTests) ]
1032+
}
10301033
]
10311034

10321035
servePackageReports :: DynamicPath -> ServerPartE Response
@@ -1074,6 +1077,18 @@ mkHtmlReports HtmlUtilities{..} CoreFeature{..} ReportsFeature{..} templates = H
10741077
det::(Int,Int)->(Int,Int,Int)
10751078
det (_,0) = (100,0,0)
10761079
det (a,b) = ((a * 100) `div` b ,a,b)
1080+
1081+
servePackageReportTests :: DynamicPath -> ServerPartE Response
1082+
servePackageReportTests dpath = do
1083+
pkgid <- packageInPath dpath
1084+
guardValidPackageId pkgid
1085+
guardAuthorised_ [InGroup (maintainersGroup (packageName pkgid)), InGroup trusteesGroup]
1086+
template <- getTemplate templates "reports-test.html"
1087+
runTests <- queryRunTests pkgid
1088+
return $ toResponse $ template
1089+
[ "pkgid" $= pkgid
1090+
, "runTests" $= runTests
1091+
]
10771092

10781093
{-------------------------------------------------------------------------------
10791094
Candidates

0 commit comments

Comments
 (0)