Merge pull request #7063 from phadej/backport-to-3.4-20200913

Backport to 3.4 20200913
haskell · Sep 13, 2020 · 5139d6e · 5139d6e
2 parents 40868ed + f39ef72
commit 5139d6e
Show file tree

Hide file tree

Showing 5 changed files with 35 additions and 19 deletions.
diff --git a/cabal-install/Distribution/Client/BuildReports/Storage.hs b/cabal-install/Distribution/Client/BuildReports/Storage.hs
@@ -74,11 +74,12 @@ storeAnonymous reports = sequence_
              -> [(Repo, [BuildReport])]
     separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))
              . map (concatMap toList)
-             . L.groupBy (equating (repoName . head))
-             . sortBy (comparing (repoName . head))
-             . groupBy (equating repoName)
+             . L.groupBy (equating (repoName' . head))
+             . sortBy (comparing (repoName' . head))
+             . groupBy (equating repoName')
              . onlyRemote
-    repoName (_,_,rrepo) = remoteRepoName rrepo
+
+    repoName' (_,_,rrepo) = remoteRepoName rrepo
 
     onlyRemote :: [(BuildReport, Maybe Repo)]
                -> [(BuildReport, Repo, RemoteRepo)]

diff --git a/cabal-install/Distribution/Client/CmdUpdate.hs b/cabal-install/Distribution/Client/CmdUpdate.hs
@@ -28,7 +28,7 @@ import Distribution.Client.ProjectConfig
 import Distribution.Client.ProjectFlags
          ( ProjectFlags (..) )
 import Distribution.Client.Types
-         ( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), isRepoRemote )
+         ( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), repoName )
 import Distribution.Client.HttpUtils
          ( DownloadResult(..) )
 import Distribution.Client.FetchUtils
@@ -49,7 +49,7 @@ import Distribution.Client.IndexUtils.Timestamp
 import Distribution.Client.IndexUtils.IndexState
 import Distribution.Client.IndexUtils
          ( updateRepoIndexCache, Index(..), writeIndexTimestamp
-         , currentIndexTimestamp, indexBaseName )
+         , currentIndexTimestamp, indexBaseName, updatePackageIndexCacheFile )
 
 import qualified Data.Maybe as Unsafe (fromJust)
 import qualified Distribution.Compat.CharParsing as P
@@ -126,13 +126,16 @@ updateAction flags@NixStyleFlags {..} extraArgs globalFlags = do
   projectConfigWithSolverRepoContext verbosity
     (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig)
     $ \repoCtxt -> do
-    let repos       = filter isRepoRemote $ repoContextRepos repoCtxt
-        repoName    = remoteRepoName . repoRemote
+
+    let repos :: [Repo]
+        repos = repoContextRepos repoCtxt
+
         parseArg :: String -> IO UpdateRequest
         parseArg s = case simpleParsec s of
           Just r -> return r
           Nothing -> die' verbosity $
                      "'v2-update' unable to parse repo: \"" ++ s ++ "\""
+
     updateRepoRequests <- traverse parseArg extraArgs
 
     unless (null updateRepoRequests) $ do
@@ -156,18 +159,20 @@ updateAction flags@NixStyleFlags {..} extraArgs globalFlags = do
                                | (UpdateRequest name state) <- updateRequests ]
 
     case reposToUpdate of
-      [] -> return ()
+      [] ->
+        notice verbosity "No remote repositories configured"
       [(remoteRepo, _)] ->
         notice verbosity $ "Downloading the latest package list from "
                         ++ unRepoName (repoName remoteRepo)
       _ -> notice verbosity . unlines
               $ "Downloading the latest package lists from: "
               : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate
 
-    jobCtrl <- newParallelJobControl (length reposToUpdate)
-    traverse_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)
-      reposToUpdate
-    traverse_ (\_ -> collectJob jobCtrl) reposToUpdate
+    unless (null reposToUpdate) $ do
+      jobCtrl <- newParallelJobControl (length reposToUpdate)
+      traverse_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)
+        reposToUpdate
+      traverse_ (\_ -> collectJob jobCtrl) reposToUpdate
 
   where
     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
@@ -179,7 +184,10 @@ updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, RepoIndexState)
 updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do
   transport <- repoContextGetTransport repoCtxt
   case repo of
-    RepoLocalNoIndex{} -> return ()
+    RepoLocalNoIndex{} -> do
+      let index = RepoIndex repoCtxt repo
+      updatePackageIndexCacheFile verbosity index
+
     RepoRemote{..} -> do
       downloadResult <- downloadIndex transport verbosity
                         repoRemote repoLocalDir

diff --git a/cabal-install/Distribution/Client/IndexUtils.hs b/cabal-install/Distribution/Client/IndexUtils.hs
@@ -230,10 +230,7 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
 
   pkgss <- for (repoContextRepos repoCtxt) $ \r -> do
       let rname :: RepoName
-          rname = case r of
-              RepoRemote remote _      -> remoteRepoName remote
-              RepoSecure remote _      -> remoteRepoName remote
-              RepoLocalNoIndex local _ -> localRepoName local
+          rname = repoName r
 
       info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...")
 
@@ -311,6 +308,8 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
       totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList
           [ (n, IndexStateTime ts)
           | (RepoData n ts _idx _prefs, _strategy) <- pkgss'
+          -- e.g. file+noindex have nullTimestamp as their timestamp
+          , ts /= nullTimestamp
           ]
 
   let addIndex

diff --git a/cabal-install/Distribution/Client/JobControl.hs b/cabal-install/Distribution/Client/JobControl.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Distribution.Client.JobControl
@@ -38,6 +39,7 @@ import Control.Concurrent.STM (STM, atomically)
 import Control.Concurrent.STM.TVar
 import Control.Concurrent.STM.TChan
 import Control.Exception (bracket_, try)
+import Distribution.Compat.Stack
 import Distribution.Client.Compat.Semaphore
 
 
@@ -99,7 +101,7 @@ newSerialJobControl = do
 -- that have already been executed or are currently executing cannot be
 -- cancelled.
 --
-newParallelJobControl :: Int -> IO (JobControl IO a)
+newParallelJobControl :: WithCallStack (Int -> IO (JobControl IO a))
 newParallelJobControl n | n < 1 || n > 1000 =
   error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n
 newParallelJobControl maxJobLimit = do

diff --git a/cabal-install/Distribution/Client/Types/Repo.hs b/cabal-install/Distribution/Client/Types/Repo.hs
@@ -9,6 +9,7 @@ module Distribution.Client.Types.Repo (
     localRepoCacheKey,
     -- * Repository
     Repo (..),
+    repoName,
     isRepoRemote,
     maybeRepoRemote,
 ) where
@@ -182,3 +183,8 @@ maybeRepoRemote :: Repo -> Maybe RemoteRepo
 maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing
 maybeRepoRemote (RepoRemote       r _localDir) = Just r
 maybeRepoRemote (RepoSecure       r _localDir) = Just r
+
+repoName :: Repo -> RepoName
+repoName (RepoLocalNoIndex r _) = localRepoName r
+repoName (RepoRemote r _)       = remoteRepoName r
+repoName (RepoSecure r _)       = remoteRepoName r