Only load the hackage index if necessary #1883

src/Stack/Build/ConstructPlan.hs

@@ -40,10 +40,10 @@ import           Stack.Build.Cache
 import           Stack.Build.Haddock
 import           Stack.Build.Installed
 import           Stack.Build.Source
-import           Stack.Types.Build
 import           Stack.BuildPlan
 import           Stack.Package
 import           Stack.PackageDump
+import           Stack.PackageIndex (getPackageCaches)
 import           Stack.Types
 
 data PackageInfo
@@ -132,11 +132,11 @@ constructPlan :: forall env m.
               -> m Plan
 constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap = do
     let locallyRegistered = Map.fromList $ map (dpGhcPkgId &&& dpPackageIdent) localDumpPkgs
-    bconfig <- asks getBuildConfig
+    caches <- getPackageCaches
     let versions =
             Map.fromListWith Set.union $
             map (second Set.singleton . toTuple) $
-            Map.keys (bcPackageCaches bconfig)
+            Map.keys caches
 
     econfig <- asks getEnvConfig
     let onWanted = void . addDep False . packageName . lpPackage

src/Stack/Build/Source.hs

@@ -61,6 +61,7 @@ import           Stack.BuildPlan (loadMiniBuildPlan, shadowMiniBuildPlan,
                                   parseCustomMiniBuildPlan)
 import           Stack.Constants (wiredInPackages)
 import           Stack.Package
+import           Stack.PackageIndex (getPackageCaches)
 import           Stack.Types
 
 import qualified System.Directory as D
@@ -80,10 +81,11 @@ loadSourceMap needTargets boptsCli = do
     bconfig <- asks getBuildConfig
     rawLocals <- getLocalPackageViews
     (mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOpts needTargets boptsCli
+    caches <- getPackageCaches
     let latestVersion =
             Map.fromListWith max $
             map toTuple $
-            Map.keys (bcPackageCaches bconfig)
+            Map.keys caches
 
     -- Extend extra-deps to encompass targets requested on the command line
     -- that are not in the snapshot.

src/Stack/BuildPlan.hs

@@ -45,8 +45,8 @@ import qualified Crypto.Hash.SHA256 as SHA256
 import           Data.Aeson.Extended (FromJSON (..), withObject, (.:), (.:?), (.!=))
 import           Data.Binary.VersionTagged (taggedDecodeOrLoad)
 import           Data.ByteString (ByteString)
-import qualified Data.ByteString.Base16 as B16
 import qualified Data.ByteString as S
+import qualified Data.ByteString.Base16 as B16
 import qualified Data.ByteString.Char8 as S8
 import           Data.Either (partitionEithers)
 import qualified Data.Foldable as F
@@ -64,28 +64,29 @@ import           Data.Text.Encoding (encodeUtf8)
 import qualified Data.Traversable as Tr
 import           Data.Typeable (Typeable)
 import           Data.Yaml (decodeEither', decodeFileEither)
+import qualified Distribution.Package as C
 import           Distribution.PackageDescription (GenericPackageDescription,
                                                   flagDefault, flagManual,
                                                   flagName, genPackageFlags,
                                                   executables, exeName, library, libBuildInfo, buildable)
-import           Distribution.System (Platform)
-import qualified Distribution.Package as C
 import qualified Distribution.PackageDescription as C
-import qualified Distribution.Version as C
+import           Distribution.System (Platform)
 import           Distribution.Text (display)
+import qualified Distribution.Version as C
+import           Network.HTTP.Client (checkStatus)
 import           Network.HTTP.Download
 import           Network.HTTP.Types (Status(..))
-import           Network.HTTP.Client (checkStatus)
 import           Path
 import           Path.IO
 import           Prelude -- Fix AMP warning
 import           Stack.Constants
 import           Stack.Fetch
 import           Stack.Package
+import           Stack.PackageIndex
 import           Stack.Types
 import           Stack.Types.StackT
 import qualified System.Directory as D
-import qualified System.FilePath  as FP
+import qualified System.FilePath as FP
 
 data BuildPlanException
     = UnknownPackages
@@ -190,10 +191,11 @@ resolveBuildPlan mbp isShadowed packages
     | Map.null (rsUnknown rs) && Map.null (rsShadowed rs) = return (rsToInstall rs, rsUsedBy rs)
     | otherwise = do
         bconfig <- asks getBuildConfig
+        caches <- getPackageCaches
         let maxVer =
                 Map.fromListWith max $
                 map toTuple $
-                Map.keys (bcPackageCaches bconfig)
+                Map.keys caches
             unknown = flip Map.mapWithKey (rsUnknown rs) $ \ident x ->
                 (Map.lookup ident maxVer, x)
         throwM $ UnknownPackages

src/Stack/Config.hs

@@ -55,6 +55,7 @@ import qualified Data.ByteString.Base16 as B16
 import qualified Data.ByteString.Lazy as L
 import           Data.Foldable (forM_)
 import qualified Data.IntMap as IntMap
+import           Data.IORef (newIORef)
 import qualified Data.Map as Map
 import           Data.Maybe
 import           Data.Monoid
@@ -81,7 +82,6 @@ import           Stack.Config.Docker
 import           Stack.Config.Nix
 import           Stack.Constants
 import qualified Stack.Image as Image
-import           Stack.PackageIndex
 import           Stack.Types
 import           Stack.Types.Internal
 import           System.Environment
@@ -303,6 +303,8 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject c
             Just True -> return True
             _ -> getInContainer
 
+     configPackageCaches <- liftIO $ newIORef Nothing
+
      return Config {..}
 
 -- | Get the default 'GHCVariant'.  On older Linux systems with libgmp4, returns 'GHCGMP4'.
@@ -514,8 +516,6 @@ loadBuildConfig mproject config mresolver mcompiler = do
 
     extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project)
 
-    packageCaches <- runReaderT (getMinimalEnvOverride >>= getPackageCaches) miniConfig
-
     return BuildConfig
         { bcConfig = config
         , bcResolver = projectResolver project
@@ -527,7 +527,6 @@ loadBuildConfig mproject config mresolver mcompiler = do
         , bcFlags = projectFlags project
         , bcImplicitGlobal = isNothing mproject
         , bcGHCVariant = getGHCVariant miniConfig
-        , bcPackageCaches = packageCaches
         }
 
 -- | Resolve a PackageEntry into a list of paths, downloading and cloning as

src/Stack/Fetch.hs

@@ -209,7 +209,7 @@ resolvePackagesAllowMissing
     -> Set PackageName
     -> m (Set PackageName, Set PackageIdentifier, Map PackageIdentifier ResolvedPackage)
 resolvePackagesAllowMissing menv idents0 names0 = do
-    caches <- getPackageCaches menv
+    caches <- getPackageCaches
     let versions = Map.fromListWith max $ map toTuple $ Map.keys caches
         (missingNames, idents1) = partitionEithers $ map
             (\name -> maybe (Left name ) (Right . PackageIdentifier name)
@@ -268,7 +268,7 @@ withCabalLoader
     -> ((PackageIdentifier -> IO ByteString) -> m a)
     -> m a
 withCabalLoader menv inner = do
-    icaches <- getPackageCaches menv >>= liftIO . newIORef
+    icaches <- getPackageCaches >>= liftIO . newIORef
     env <- ask
 
     -- Want to try updating the index once during a single run for missing
@@ -308,7 +308,8 @@ withCabalLoader menv inner = do
                                     , "Updating and trying again."
                                     ]
                                 updateAllIndices menv
-                                caches <- getPackageCaches menv
+                                clearPackageCaches
+                                caches <- getPackageCaches
                                 liftIO $ writeIORef icaches caches
                             return (False, doLookup ident)
                         else return (toUpdate,

src/Stack/PackageIndex.hs

@@ -19,6 +19,7 @@
 module Stack.PackageIndex
     ( updateAllIndices
     , getPackageCaches
+    , clearPackageCaches
     ) where
 
 import qualified Codec.Archive.Tar as Tar
@@ -41,6 +42,7 @@ import           Data.Conduit.Binary                   (sinkHandle,
                                                         sourceHandle)
 import           Data.Conduit.Zlib (ungzip)
 import           Data.Foldable (forM_)
+import           Data.IORef (readIORef, writeIORef)
 import           Data.Int (Int64)
 import           Data.Map (Map)
 import qualified Data.Map.Strict as Map
@@ -342,17 +344,34 @@ deleteCache indexName' = do
         Left e -> $logDebug $ "Could not delete cache: " <> T.pack (show e)
         Right () -> $logDebug $ "Deleted index cache at " <> T.pack (toFilePath fp)
 
+
 -- | Load the cached package URLs, or created the cache if necessary.
+--
+-- This has two levels of caching: in memory, and the on-disk cache. So,
+-- feel free to call this function multiple times.
 getPackageCaches :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)
-                 => EnvOverride
-                 -> m (Map PackageIdentifier (PackageIndex, PackageCache))
-getPackageCaches menv = do
+                 => m (Map PackageIdentifier (PackageIndex, PackageCache))
+getPackageCaches = do
+    menv <- getMinimalEnvOverride
     config <- askConfig
-    liftM mconcat $ forM (configPackageIndices config) $ \index -> do
-        fp <- configPackageIndexCache (indexName index)
-        PackageCacheMap pis' <- taggedDecodeOrLoad fp $ liftM PackageCacheMap $ populateCache menv index
-
-        return (fmap (index,) pis')
+    mcached <- liftIO $ readIORef (configPackageCaches config)
+    case mcached of
+        Just cached -> return cached
+        Nothing -> do
+            result <- liftM mconcat $ forM (configPackageIndices config) $ \index -> do
+                fp <- configPackageIndexCache (indexName index)
+                PackageCacheMap pis' <- taggedDecodeOrLoad fp $ liftM PackageCacheMap $ populateCache menv index
+                return (fmap (index,) pis')
+            liftIO $ writeIORef (configPackageCaches config) (Just result)
+            return result
+
+-- | Clear the in-memory hackage index cache. This is needed when the
+-- hackage index is updated.
+clearPackageCaches :: (MonadIO m, MonadLogger m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)
+                   => m ()
+clearPackageCaches = do
+    cacheRef <- asks (configPackageCaches . getConfig)
+    liftIO $ writeIORef cacheRef Nothing
 
 --------------- Lifted from cabal-install, Distribution.Client.Tar:
 -- | Return the number of blocks in an entry.

src/Stack/Types/Config.hs

@@ -140,6 +140,7 @@ import           Data.Binary (Binary)
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as S8
 import           Data.Either (partitionEithers)
+import           Data.IORef (IORef)
 import           Data.List (stripPrefix)
 import           Data.Hashable (Hashable)
 import           Data.Map (Map)
@@ -289,6 +290,8 @@ data Config =
          ,configAllowDifferentUser  :: !Bool
          -- ^ Allow users other than the stack root owner to use the stack
          -- installation.
+         ,configPackageCaches       :: !(IORef (Maybe (Map PackageIdentifier (PackageIndex, PackageCache))))
+         -- ^ In memory cache of hackage index.
          }
 
 -- | Which packages to ghc-options on the command line apply to?
@@ -482,8 +485,6 @@ data BuildConfig = BuildConfig
       -- for providing better error messages.
     , bcGHCVariant :: !GHCVariant
       -- ^ The variant of GHC used to select a GHC bindist.
-    , bcPackageCaches :: !(Map PackageIdentifier (PackageIndex, PackageCache))
-      -- ^ Shared package cache map
     }
 
 -- | Directory containing the project's stack.yaml file

src/Stack/Upgrade.hs

@@ -65,7 +65,7 @@ upgrade gitRepo mresolver builtHash =
                 return $ Just $ tmp </> $(mkRelDir "stack")
       Nothing -> do
         updateAllIndices menv
-        caches <- getPackageCaches menv
+        caches <- getPackageCaches
         let latest = Map.fromListWith max
                    $ map toTuple
                    $ Map.keys