[rfc] first pass at commercialhaskell#1391

* fetches version present in snapshot otherwise falls back to hackage
* caches `preferred-versions` from index
* only versions within `preferred-versions` are fetched unless explicitly asked by package identifier
* added --latest flag to fetch latest version from hackage regardless of resolver

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

@@ -55,21 +55,26 @@ import           Data.List.NonEmpty             (NonEmpty)
 import qualified Data.List.NonEmpty             as NE
 import           Data.Map                       (Map)
 import qualified Data.Map                       as Map
-import           Data.Maybe                     (maybeToList, catMaybes)
+import           Data.Maybe                     (maybeToList, catMaybes, fromMaybe)
 import           Data.Monoid                    ((<>))
 import           Data.Set                       (Set)
 import qualified Data.Set                       as Set
 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
@@ -78,6 +83,8 @@ import           System.IO                      (IOMode (ReadMode),
                                                  withBinaryFile)
 import           System.PosixCompat             (setFileMode)
 import           Text.EditDistance              as ED
+import           Distribution.Version           (anyVersion)
+import           Distribution.Text              (simpleParse)
 
 type PackageCaches = Map PackageIdentifier (PackageIndex, PackageCache)
 
@@ -130,18 +137,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 +269,11 @@ 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
+    (caches, pvcaches) <- getPackageCaches menv
+    let preferredVersions = fmap toVersionRange pvcaches
+        versions = Map.mapWithKey (filterBy' preferredVersions) $ groupByPackageName caches
         (missingNames, idents1) = partitionEithers $ map
-            (\name -> maybe (Left name ) (Right . PackageIdentifier name)
+            (\name -> maybe (Left name) (Right . PackageIdentifier name)
                 (Map.lookup name versions))
             (Set.toList names0)
         (missingIdents, resolved) = partitionEithers $ map (goIdent caches)
@@ -228,6 +289,18 @@ resolvePackagesAllowMissing menv idents0 names0 = do
                 , rpIndex = index
                 })
 
+    toTuple' (PackageIdentifier name version) = (name, [version])
+
+    groupByPackageName = fmap Set.fromList . Map.fromListWith mappend . map toTuple' . Map.keys
+
+    filterBy' pvs name vs =
+        fromMaybe (Set.findMax vs) $
+            flip latestApplicableVersion vs $ fromMaybe anyVersion $ Map.lookup name pvs
+
+    toVersionRange (_, PreferredVersionsCache raw) = fromMaybe anyVersion $ parse raw
+      where parse = simpleParse . T.unpack . T.dropWhile (/= ' ')
+
+
 data ToFetch = ToFetch
     { tfTarball :: !(Path Abs File)
     , tfDestDir :: !(Maybe (Path Abs Dir))
@@ -268,7 +341,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 +381,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

@@ -47,6 +47,7 @@ import qualified Data.Map.Strict as Map
 import           Data.Monoid
 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)
@@ -72,7 +73,12 @@ populateCache
     :: (MonadIO m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
     => EnvOverride
     -> PackageIndex
-    -> m (Map PackageIdentifier PackageCache)
+    -- Option 1
+    -- -> m (Map PackageName (Map Version PackageCache, Maybe PreferredVersionsCache))
+    -- Option 2
+    -> m (Map PackageIdentifier PackageCache, Map PackageName PreferredVersionsCache)
+    -- Original Option
+    -- -> m (Map PackageIdentifier PackageCache)
 populateCache menv index = do
     requireIndex menv index
     -- This uses full on lazy I/O instead of ResourceT to provide some
@@ -81,8 +87,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 +102,42 @@ 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
+                    Just (ident, ".cabal") -> (addCabal ident size, mpvc)
+                    Just (ident, ".json") -> (addJSON ident lbs, mpvc)
+                    _ -> case parsePreferredVersions $ Tar.entryPath e of
+                             Just !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,14 +146,23 @@ 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
 
+    parsePreferredVersions t1 = do
+        (p', t3) <- breakSlash
+                  $ T.map (\c -> if c == '\\' then '/' else c)
+                  $ T.pack t1
+        p <- parsePackageName p'
+        if t3 == "preferred-versions"
+            then return p
+            else Nothing
+
     parseNameVersion t1 = do
         (p', t3) <- breakSlash
                   $ T.map (\c -> if c == '\\' then '/' else c)
@@ -332,17 +353,22 @@ 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 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

src/Stack/Upgrade.hs

@@ -65,11 +65,11 @@ upgrade gitRepo mresolver builtHash =
                 return $ Just $ tmp </> $(mkRelDir "stack")
       Nothing -> do
         updateAllIndices menv
-        caches <- getPackageCaches menv
+        -- TODO(luigy) use same logic as in Stack.Fetch
+        (caches,_pv) <- getPackageCaches menv
         let latest = Map.fromListWith max
                    $ map toTuple
                    $ Map.keys
-
                    -- Mistaken upload to Hackage, just ignore it
                    $ Map.delete (PackageIdentifier
                         $(mkPackageName "stack")