haskell · gbaz · Dec 30, 2022 · Aug 18, 2022 · Aug 18, 2022 · Aug 18, 2022
diff --git a/datafiles/templates/Html/maintain.html.st b/datafiles/templates/Html/maintain.html.st
@@ -46,6 +46,11 @@ package after its been released.
   <p>$versions:{pkgid|<a href="/package/$pkgid$/$pkgname$.cabal/edit">$pkgid$</a>}; separator=", "$</p>
   </dd>
 
+<dt>Test settings</dt>
+  <dd>If your package contains tests that can't run on hackage, you can disable them here.
+  <p>$versions:{pkgid|<a href="/package/$pkgid$/reports/test">$pkgid$</a>}; separator=", "$</p>
+  </dd>
+
 <dt>Trigger rebuild</dt>
   <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.
   <p>$versions:{pkgid|<a href="/package/$pkgid$/reports/reset" onclick="return confirm('Are you sure you want to trigger rebuild?')" >$pkgid$</a>}; separator=", "$</p>

diff --git a/datafiles/templates/Html/reports-test.html.st b/datafiles/templates/Html/reports-test.html.st
@@ -0,0 +1,25 @@
+<!DOCTYPE html>
+<html>
+<head>
+$hackageCssTheme()$
+<title>Test settings</title>
+</head>
+<body>
+$hackagePageHeader()$
+
+<div id="content">
+<h2>Test settings for $pkgid$</h2>
+
+<form action="." method="post" enctype="multipart/form-data">
+
+<dl>
+<dt>Run tests</dt>
+    <dd><input type="checkbox" name="runTests" id="runTests" $if(runTests)$checked$endif$>
+        Whether hackage should run the tests.
+    </dd>
+
+<p><input type="submit" value="Save">
+</form>
+
+</div>
+</body></html>
diff --git 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, fromMaybe True $ 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
@@ -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 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")
@@ -201,12 +212,13 @@ buildReportsFeature name
     pkgReportDetails (pkgid, docs) = do
       failCnt   <- queryState reportsState $ LookupFailCount pkgid
       latestRpt <- queryState reportsState $ LookupLatestReport pkgid
+      runTests  <- fmap Just . 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)
+      return  (BuildReport.PkgDetails pkgid docs failCnt time ghcId runTests)
 
     queryLastReportStats :: MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg))
     queryLastReportStats pkgid = do
@@ -215,6 +227,8 @@ buildReportsFeature name
         Nothing -> return Nothing
         Just (rptId, rpt, _, covg) -> return (Just (rptId, rpt, covg))
 
+    queryRunTests :: MonadIO m =>  PackageId -> m Bool
+    queryRunTests pkgid = queryState reportsState $ LookupRunTests pkgid
 
     ---------------------------------------------------------------------------
 
@@ -318,6 +332,25 @@ 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)
+      runTest <- queryRunTests pkgid
+      pure $ toResponse $ toJSON runTest
+
+    postReportsTest :: DynamicPath -> ServerPartE Response
+    postReportsTest dpath = do
+      pkgid <- packageInPath dpath
+      runTests <- body $ looks "runTests"
+      guardValidPackageId pkgid
+      guardAuthorisedAsMaintainerOrTrustee (packageName pkgid)
+      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"]
+
 
     putAllReports :: DynamicPath -> ServerPartE Response
     putAllReports dpath = do

diff --git 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    :: Maybe 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