add runTests to acid state

Author: AliasQli

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 {

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

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

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,15 +131,17 @@ 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
 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

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
                           ]