[rfc] only unpack package versions within preferred-versions #1391

src/Stack/Config.hs

@@ -510,7 +510,7 @@ loadBuildConfig mproject config mresolver mcompiler = do
 
     extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project)
 
-    packageCaches <- runReaderT (getMinimalEnvOverride >>= getPackageCaches) miniConfig
+    packageCaches <- runReaderT (fst <$> (getMinimalEnvOverride >>= getPackageCaches)) miniConfig
 
     return BuildConfig
         { bcConfig = config

src/Stack/Fetch.hs

@@ -63,13 +63,18 @@ import qualified Data.Text                      as T
 import           Data.Text.Encoding             (decodeUtf8)
 import           Data.Typeable                  (Typeable)
 import           Data.Word                      (Word64)
+import qualified Data.Yaml                      as Yaml
+import           Network.HTTP.Client            (checkStatus)
 import           Network.HTTP.Download
+import           Network.HTTP.Types.Status
 import           Path
 import           Path.IO
 import           Prelude -- Fix AMP warning
+import           Stack.Constants
 import           Stack.GhcPkg
 import           Stack.PackageIndex
 import           Stack.Types
+import           Stack.Types.StackT
 import qualified System.Directory               as D
 import           System.FilePath                ((<.>))
 import qualified System.FilePath                as FP
@@ -130,18 +135,71 @@ fetchPackages menv idents = do
     nowUnpacked <- fetchPackages' Nothing toFetch
     assert (Map.null nowUnpacked) (return ())
 
+
+-- TODO(luigy) don't copy this from Stack.BuildPlan
+------------------------------------------------------------------------------------
+-- | Load the 'BuildPlan' for the given snapshot. Will load from a local copy
+-- if available, otherwise downloading from Github.
+loadBuildPlan :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasStackRoot env)
+              => SnapName
+              -> m BuildPlan
+loadBuildPlan name = do
+    env <- ask
+    let stackage = getStackRoot env
+    file' <- parseRelFile $ T.unpack file
+    let fp = buildPlanDir stackage </> file'
+    $logDebug $ "Decoding build plan from: " <> T.pack (toFilePath fp)
+    eres <- liftIO $ Yaml.decodeFileEither $ toFilePath fp
+    case eres of
+        Right bp -> return bp
+        Left e -> do
+            $logDebug $ "Decoding build plan from file failed: " <> T.pack (show e)
+            ensureDir (parent fp)
+            req <- parseUrl $ T.unpack url
+            $logSticky $ "Downloading " <> renderSnapName name <> " build plan ..."
+            $logDebug $ "Downloading build plan from: " <> url
+            _ <- redownload req { checkStatus = handle404 } fp
+            $logStickyDone $ "Downloaded " <> renderSnapName name <> " build plan."
+            liftIO (Yaml.decodeFileEither $ toFilePath fp) >>= either throwM return
+
+  where
+    file = renderSnapName name <> ".yaml"
+    reponame =
+        case name of
+            LTS _ _ -> "lts-haskell"
+            Nightly _ -> "stackage-nightly"
+    url = rawGithubUrl "fpco" reponame "master" file
+    handle404 (Status 404 _) _ _ = Just $ SomeException $ C name
+    handle404 _ _ _              = Nothing
+
+data Coulnd'tDownloadSnap = C SnapName deriving (Typeable, Show)
+instance Exception Coulnd'tDownloadSnap
+------------------------------------------------------------------------------------
+
 -- | Intended to work for the command line command.
-unpackPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m)
+unpackPackages :: (MonadIO m, HasBuildConfig env, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m)
                => EnvOverride
                -> FilePath -- ^ destination
                -> [String] -- ^ names or identifiers
+               -> Bool     -- ^ get latest version
                -> m ()
-unpackPackages menv dest input = do
+unpackPackages menv dest input useLatest = do
     dest' <- resolveDir' dest
-    (names, idents) <- case partitionEithers $ map parse input of
+    (names0, idents0) <- case partitionEithers $ map parse input of
         ([], x) -> return $ partitionEithers x
         (errs, _) -> throwM $ CouldNotParsePackageSelectors errs
-    resolved <- resolvePackages menv (Set.fromList idents) (Set.fromList names)
+    resolver <- asks $ bcResolver . getBuildConfig
+    (names1, idents1) <- case resolver of
+        ResolverSnapshot snapName | not useLatest -> do
+            planPackages <- bpPackages <$> loadBuildPlan snapName
+            let (names', idents') = partitionEithers $ map
+                    (\name -> maybe (Left name) (Right . PackageIdentifier name . ppVersion)
+                        (Map.lookup name planPackages))
+                    names0
+            return (names', idents0 ++ idents')
+        _ -> return (names0, idents0)
+
+    resolved <- resolvePackages menv (Set.fromList idents1) (Set.fromList names1)
     ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved
     unless (Map.null alreadyUnpacked) $
         throwM $ UnpackDirectoryAlreadyExists $ Set.fromList $ map toFilePath $ Map.elems alreadyUnpacked
@@ -209,10 +267,10 @@ resolvePackagesAllowMissing
     -> Set PackageName
     -> m (Set PackageName, Set PackageIdentifier, Map PackageIdentifier ResolvedPackage)
 resolvePackagesAllowMissing menv idents0 names0 = do
-    caches <- getPackageCaches menv
-    let versions = Map.fromListWith max $ map toTuple $ Map.keys caches
-        (missingNames, idents1) = partitionEithers $ map
-            (\name -> maybe (Left name ) (Right . PackageIdentifier name)
+    (caches, _preferred) <- getPackageCaches menv
+    versions <- getLatestApplicablePackageCache menv
+    let (missingNames, idents1) = partitionEithers $ map
+            (\name -> maybe (Left name) (Right . PackageIdentifier name)
                 (Map.lookup name versions))
             (Set.toList names0)
         (missingIdents, resolved) = partitionEithers $ map (goIdent caches)
@@ -228,6 +286,7 @@ resolvePackagesAllowMissing menv idents0 names0 = do
                 , rpIndex = index
                 })
 
+
 data ToFetch = ToFetch
     { tfTarball :: !(Path Abs File)
     , tfDestDir :: !(Maybe (Path Abs Dir))
@@ -268,7 +327,7 @@ withCabalLoader
     -> ((PackageIdentifier -> IO ByteString) -> m a)
     -> m a
 withCabalLoader menv inner = do
-    icaches <- getPackageCaches menv >>= liftIO . newIORef
+    icaches <- fmap fst (getPackageCaches menv) >>= liftIO . newIORef
     env <- ask
 
     -- Want to try updating the index once during a single run for missing
@@ -308,7 +367,7 @@ withCabalLoader menv inner = do
                                     , "Updating and trying again."
                                     ]
                                 updateAllIndices menv
-                                caches <- getPackageCaches menv
+                                (caches, _pvcaches) <- getPackageCaches menv
                                 liftIO $ writeIORef icaches caches
                             return (False, doLookup ident)
                         else return (toUpdate,

src/Stack/PackageIndex.hs

@@ -19,9 +19,11 @@
 module Stack.PackageIndex
     ( updateAllIndices
     , getPackageCaches
+    , getLatestApplicablePackageCache
     ) where
 
 import qualified Codec.Archive.Tar as Tar
+import           Control.Applicative
 import           Control.Exception (Exception)
 import           Control.Exception.Enclosed (tryIO)
 import           Control.Monad (unless, when, liftM)
@@ -44,15 +46,21 @@ import           Data.Foldable (forM_)
 import           Data.Int (Int64)
 import           Data.Map (Map)
 import qualified Data.Map.Strict as Map
+import           Data.Maybe (fromMaybe)
 import           Data.Monoid
+import qualified Data.Set as Set
 import           Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import           Data.Text.Unsafe (unsafeTail)
 
 import           Data.Traversable (forM)
 
 import           Data.Typeable (Typeable)
 
+import           Distribution.Text              (simpleParse)
+import           Distribution.Version           (anyVersion)
+
 import           Network.HTTP.Download
 import           Path                                  (mkRelDir, parent,
                                                         parseRelDir, toFilePath,
@@ -72,7 +80,7 @@ populateCache
     :: (MonadIO m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
     => EnvOverride
     -> PackageIndex
-    -> m (Map PackageIdentifier PackageCache)
+    -> m (Map PackageIdentifier PackageCache, Map PackageName PreferredVersionsCache)
 populateCache menv index = do
     requireIndex menv index
     -- This uses full on lazy I/O instead of ResourceT to provide some
@@ -81,8 +89,8 @@ populateCache menv index = do
     let loadPIS = do
             $logSticky "Populating index cache ..."
             lbs <- liftIO $ L.readFile $ Path.toFilePath path
-            loop 0 Map.empty (Tar.read lbs)
-    pis <- loadPIS `C.catch` \e -> do
+            loop 0 (Map.empty, Map.empty) (Tar.read lbs)
+    caches@(pis, _) <- loadPIS `C.catch` \e -> do
         $logWarn $ "Exception encountered when parsing index tarball: "
                 <> T.pack (show (e :: Tar.FormatError))
         $logWarn "Automatically updating index and trying again"
@@ -96,36 +104,41 @@ populateCache menv index = do
 
     $logStickyDone "Populated index cache."
 
-    return pis
+    return caches
   where
-    loop !blockNo !m (Tar.Next e es) =
-        loop (blockNo + entrySizeInBlocks e) (goE blockNo m e) es
-    loop _ m Tar.Done = return m
+    loop !blockNo !ms (Tar.Next e es) =
+        loop (blockNo + entrySizeInBlocks e) (goE blockNo ms e) es
+    loop _ ms Tar.Done = return ms
     loop _ _ (Tar.Fail e) = throwM e
 
-    goE blockNo m e =
+    goE blockNo ms@(mpc,mpvc) e =
         case Tar.entryContent e of
             Tar.NormalFile lbs size ->
-                case parseNameVersion $ Tar.entryPath e of
-                    Just (ident, ".cabal") -> addCabal ident size
-                    Just (ident, ".json") -> addJSON ident lbs
-                    _ -> m
-            _ -> m
+                case parseFilePath $ Tar.entryPath e of
+                    Just (Right (ident, ".cabal")) -> (addCabal ident size, mpvc)
+                    Just (Right (ident, ".json")) -> (addJSON ident lbs, mpvc)
+                    Just (Left !pkg) -> (mpc, addPreferredVersion pkg lbs)
+                    _ -> ms
+            _ -> ms
       where
+        addPreferredVersion name lbs =
+            Map.insert name (PreferredVersionsCache (T.decodeUtf8 $ L.toStrict lbs)) mpvc
+
         addCabal ident size = Map.insertWith
             (\_ pcOld -> pcNew { pcDownload = pcDownload pcOld })
             ident
             pcNew
-            m
+            mpc
           where
             pcNew = PackageCache
                 { pcOffset = (blockNo + 1) * 512
                 , pcSize = size
                 , pcDownload = Nothing
                 }
+
         addJSON ident lbs =
             case decode lbs of
-                Nothing -> m
+                Nothing -> mpc
                 Just !pd -> Map.insertWith
                     (\_ pc -> pc { pcDownload = Just pd })
                     ident
@@ -134,25 +147,29 @@ populateCache menv index = do
                         , pcSize = 0
                         , pcDownload = Just pd
                         }
-                    m
+                    mpc
 
     breakSlash x
         | T.null z = Nothing
         | otherwise = Just (y, unsafeTail z)
       where
         (y, z) = T.break (== '/') x
 
-    parseNameVersion t1 = do
-        (p', t3) <- breakSlash
-                  $ T.map (\c -> if c == '\\' then '/' else c)
-                  $ T.pack t1
+    formatPath = T.map (\c -> if c == '\\' then '/' else c) . T.pack
+
+    parseFilePath f1 = do
+        (p', t3) <- breakSlash (formatPath f1)
         p <- parsePackageName p'
-        (v', t5) <- breakSlash t3
-        v <- parseVersion v'
-        let (t6, suffix) = T.break (== '.') t5
-        if t6 == p'
-            then return (PackageIdentifier p v, suffix)
-            else Nothing
+        if t3 == "preferred-versions"
+            then Just (Left p)
+            else do
+                (v', t5) <- breakSlash t3
+                v <- parseVersion v'
+                let (t6, suffix) = T.break (== '.') t5
+                if t6 == p'
+                    then Just $ Right (PackageIdentifier p v, suffix)
+                    else Nothing
+
 
 data PackageIndexException
   = GitNotAvailable IndexName
@@ -332,17 +349,41 @@ 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.
+-- | Load latest package versions within preferred-versions.
+getLatestApplicablePackageCache
+    :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadThrow m, MonadBaseControl IO m, MonadCatch m)
+    => EnvOverride
+    -> m (Map PackageName Version)
+getLatestApplicablePackageCache menv = do
+    (caches, preferred) <- getPackageCaches menv
+    let preferredVersion = maybe anyVersion toVersionRange . flip Map.lookup preferred
+        latestApplicable name vs =
+            fromMaybe (Set.findMax vs) $ latestApplicableVersion (preferredVersion name) vs
+    return $ Map.mapWithKey latestApplicable $ groupByPackageName caches
+  where
+    toTuple' (PackageIdentifier name version) = (name, [version])
+
+    groupByPackageName = fmap Set.fromList . Map.fromListWith (<>) . map toTuple' . Map.keys
+
+    toVersionRange (_, PreferredVersionsCache raw) = fromMaybe anyVersion $ parse raw
+      where parse = simpleParse . T.unpack . T.dropWhile (/= ' ')
+
+-- | Load the cached package URLs, or create the cache if necessary.
 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))
+                 -- Option 1
+                 -- -> m (Map PackageName (Map Version (PackageIndex, PackageCache), (PackageIndex, PreferredVersionsCache)))
+                 -> m (Map PackageIdentifier (PackageIndex, PackageCache), Map PackageName (PackageIndex, PreferredVersionsCache))
 getPackageCaches menv = do
     config <- askConfig
     liftM mconcat $ forM (configPackageIndices config) $ \index -> do
         fp <- configPackageIndexCache (indexName index)
-        PackageCacheMap pis' <- taggedDecodeOrLoad fp $ liftM PackageCacheMap $ populateCache menv index
+        fppvc <- configPreferredVersionsCache (indexName index)
+
+        PackageCacheMap pis' <- taggedDecodeOrLoad fp $ liftM PackageCacheMap (fst <$> populateCache menv index)
+        PreferredVersionsCacheMap pvc' <- taggedDecodeOrLoad fppvc $ liftM PreferredVersionsCacheMap (snd <$> populateCache menv index)
 
-        return (fmap (index,) pis')
+        return (fmap (index,) pis', fmap (index,) pvc')
 
 --------------- Lifted from cabal-install, Distribution.Client.Tar:
 -- | Return the number of blocks in an entry.

src/Stack/Types/Config.hs

@@ -72,6 +72,7 @@ module Stack.Types.Config
   ,configPackageIndexGz
   ,configPackageIndexRoot
   ,configPackageTarball
+  ,configPreferredVersionsCache
   ,indexNameText
   ,IndexLocation(..)
   -- ** Project & ProjectAndConfigMonoid
@@ -1223,6 +1224,10 @@ configPackageIndexRoot (IndexName name) = do
 configPackageIndexCache :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
 configPackageIndexCache = liftM (</> $(mkRelFile "00-index.cache")) . configPackageIndexRoot
 
+-- | Location of the preferred-versions.cache file
+configPreferredVersionsCache :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
+configPreferredVersionsCache = liftM (</> $(mkRelFile "preferred-versions.cache")) . configPackageIndexRoot
+
 -- | Location of the 00-index.tar file
 configPackageIndex :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
 configPackageIndex = liftM (</> $(mkRelFile "00-index.tar")) . configPackageIndexRoot

src/Stack/Types/PackageIndex.hs

@@ -6,6 +6,8 @@ module Stack.Types.PackageIndex
     ( PackageDownload (..)
     , PackageCache (..)
     , PackageCacheMap (..)
+    , PreferredVersionsCache (..)
+    , PreferredVersionsCacheMap (..)
     ) where
 
 import           Control.Monad (mzero)
@@ -21,6 +23,20 @@ import           Data.Text.Encoding (encodeUtf8)
 import           Data.Word (Word64)
 import           GHC.Generics (Generic)
 import           Stack.Types.PackageIdentifier
+import           Stack.Types.PackageName
+
+data PreferredVersionsCache = PreferredVersionsCache Text
+    deriving (Show, Generic)
+
+instance Binary PreferredVersionsCache
+instance NFData PreferredVersionsCache
+instance HasStructuralInfo PreferredVersionsCache
+
+newtype PreferredVersionsCacheMap = PreferredVersionsCacheMap (Map PackageName PreferredVersionsCache)
+    deriving (Generic, Binary, NFData)
+instance HasStructuralInfo PreferredVersionsCacheMap
+instance HasSemanticVersion PreferredVersionsCacheMap
+
 
 data PackageCache = PackageCache
     { pcOffset :: !Int64