From 7bd59c852e88998f1705634ae06e2ac60a2fae82 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Wed, 24 Feb 2016 23:43:42 -0500 Subject: [PATCH 1/7] [rfc] first pass at #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 | 2 +- src/Stack/Fetch.hs | 93 +++++++++++++++++++++++++++++---- src/Stack/PackageIndex.hs | 64 ++++++++++++++++------- src/Stack/Types/Config.hs | 5 ++ src/Stack/Types/PackageIndex.hs | 16 ++++++ src/Stack/Upgrade.hs | 4 +- src/main/Main.hs | 11 ++-- 7 files changed, 159 insertions(+), 36 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 6c8994ba33..5352c53562 100644 --- a/src/Stack/Config.hs +++ b/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 diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index b8ae815f84..6ea186b6c1 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -55,7 +55,7 @@ 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 @@ -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 @@ -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, diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index cab5824567..4f1d3c42fc 100644 --- a/src/Stack/PackageIndex.hs +++ b/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,7 +146,7 @@ populateCache menv index = do , pcSize = 0 , pcDownload = Just pd } - m + mpc breakSlash x | T.null z = Nothing @@ -142,6 +154,15 @@ populateCache menv index = do 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. diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 8c41b1bc57..1362daec3f 100644 --- a/src/Stack/Types/Config.hs +++ b/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 diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs index 0aff54b86e..6d97f5c30f 100644 --- a/src/Stack/Types/PackageIndex.hs +++ b/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 diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 11f2d68648..b8cee6d13b 100644 --- a/src/Stack/Upgrade.hs +++ b/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") diff --git a/src/main/Main.hs b/src/main/Main.hs index 2fc6d2f015..3a24f0c99b 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -260,7 +260,10 @@ commandLineHandler progName isInterpreter = complicatedOptions addCommand' "unpack" "Unpack one or more packages locally" unpackCmd - (some $ strArgument $ metavar "PACKAGE") + ((,) <$> switch + ( long "latest" + <> help "fetch latest version from hackage") + <*> some (strArgument $ metavar "PACKAGE")) addCommand' "update" "Update the package index" updateCmd @@ -900,10 +903,10 @@ uninstallCmd _ go = withConfigAndLock go $ do $logError "For the default executable destination, please run 'stack path --local-bin-path'" -- | Unpack packages to the filesystem -unpackCmd :: [String] -> GlobalOpts -> IO () -unpackCmd names go = withConfigAndLock go $ do +unpackCmd :: (Bool,[String]) -> GlobalOpts -> IO () +unpackCmd (useLatest, names) go = withBuildConfig go $ do menv <- getMinimalEnvOverride - Stack.Fetch.unpackPackages menv "." names + Stack.Fetch.unpackPackages menv "." names useLatest -- | Update the package index updateCmd :: () -> GlobalOpts -> IO () From d16441607cf9fc7ce8e6c5513f255e08d7502d5d Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Thu, 25 Feb 2016 14:01:45 -0500 Subject: [PATCH 2/7] integration tests for stack unpack --- .../Main.hs | 30 +++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 test/integration/tests/1391-unpack-within-preferred-version/Main.hs diff --git a/test/integration/tests/1391-unpack-within-preferred-version/Main.hs b/test/integration/tests/1391-unpack-within-preferred-version/Main.hs new file mode 100644 index 0000000000..4860793768 --- /dev/null +++ b/test/integration/tests/1391-unpack-within-preferred-version/Main.hs @@ -0,0 +1,30 @@ +import Control.Monad (when) +import StackTest +import System.Exit + + +main :: IO () +main = do + -- get version from snapshot + stack ["--resolver=lts-4.0", "unpack", "stack"] + doesExist "stack-1.0.0" + + -- check latest download querying hackage + -- stack ["unpack", "--latest", "stack"] + -- let latestCmd = unwords + -- ["curl -H 'Accept: application/json'" + -- ,"http://hackage.haskell.org/package/stack/preferred" + -- ,"| sed -n 's/.*\"normal-version\":\\[\\([0-9,\"\\.]*\\)\\].*/\\1/p'" + -- ,"| tr ',' '\n' | tr -d '\"'" + -- ,"| sort" + -- ,"| tail -1" + -- ] + -- ec <- run' "bash" ["-c", "ls stack-$("++ latestCmd ++")"] + -- when (ec /= ExitSuccess) $ fail "didn't match latest on hackage." + + -- download deprecated version when asked explicitly + stack ["unpack", "stack-9.9.9"] + doesExist "stack-9.9.9" + + -- should fail when a package does not exist + stackErr ["unpack", "i-dont-exists-0"] From c5d354ad1271af90249e18896793e2d3e0a515b7 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Fri, 26 Feb 2016 00:29:39 -0500 Subject: [PATCH 3/7] simplify cache population --- src/Stack/PackageIndex.hs | 45 +++++++++++++++------------------------ 1 file changed, 17 insertions(+), 28 deletions(-) diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index 4f1d3c42fc..36aff90393 100644 --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -73,12 +73,7 @@ populateCache :: (MonadIO m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> PackageIndex - -- 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 @@ -112,12 +107,11 @@ populateCache menv index = do 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, mpvc) - Just (ident, ".json") -> (addJSON ident lbs, mpvc) - _ -> case parsePreferredVersions $ Tar.entryPath e of - Just !pkg -> (mpc, addPreferredVersion pkg lbs) - _ -> ms + 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 = @@ -154,26 +148,21 @@ populateCache menv index = do where (y, z) = T.break (== '/') x - parsePreferredVersions 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' if t3 == "preferred-versions" - then return p - else Nothing + 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 - parseNameVersion t1 = do - (p', t3) <- breakSlash - $ T.map (\c -> if c == '\\' then '/' else c) - $ T.pack t1 - 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 data PackageIndexException = GitNotAvailable IndexName From db9bf44cbe99c6132988daf76762c248ef90cd95 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Fri, 26 Feb 2016 01:29:06 -0500 Subject: [PATCH 4/7] minor naming refactor --- src/Stack/Fetch.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index 6ea186b6c1..4f211b78e3 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -64,6 +64,8 @@ import Data.Text.Encoding (decodeUtf8) import Data.Typeable (Typeable) import Data.Word (Word64) import qualified Data.Yaml as Yaml +import Distribution.Text (simpleParse) +import Distribution.Version (anyVersion) import Network.HTTP.Client (checkStatus) import Network.HTTP.Download import Network.HTTP.Types.Status @@ -83,8 +85,6 @@ 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) @@ -269,9 +269,11 @@ resolvePackagesAllowMissing -> Set PackageName -> m (Set PackageName, Set PackageIdentifier, Map PackageIdentifier ResolvedPackage) resolvePackagesAllowMissing menv idents0 names0 = do - (caches, pvcaches) <- getPackageCaches menv - let preferredVersions = fmap toVersionRange pvcaches - versions = Map.mapWithKey (filterBy' preferredVersions) $ groupByPackageName caches + (caches, preferred) <- getPackageCaches menv + let preferredVersion = maybe anyVersion toVersionRange . flip Map.lookup preferred + latestApplicable name vs = + fromMaybe (Set.findMax vs) $ latestApplicableVersion (preferredVersion name) vs + versions = Map.mapWithKey latestApplicable $ groupByPackageName caches (missingNames, idents1) = partitionEithers $ map (\name -> maybe (Left name) (Right . PackageIdentifier name) (Map.lookup name versions)) @@ -293,10 +295,6 @@ resolvePackagesAllowMissing menv idents0 names0 = do 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 (/= ' ') From e6910870a68deb277136adb55b0d1e6f266cd75a Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Fri, 26 Feb 2016 01:29:33 -0500 Subject: [PATCH 5/7] fix for 7.8.4 --- src/Stack/PackageIndex.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index 36aff90393..7c901f9112 100644 --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -22,6 +22,7 @@ module Stack.PackageIndex ) 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) From 1acf1dafb904ba698790038fcb3e2c4c03e17f23 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Fri, 26 Feb 2016 01:39:07 -0500 Subject: [PATCH 6/7] more 7.8.4 fixes --- src/Stack/Fetch.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index 4f211b78e3..df1be590da 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -293,7 +293,7 @@ resolvePackagesAllowMissing menv idents0 names0 = do toTuple' (PackageIdentifier name version) = (name, [version]) - groupByPackageName = fmap Set.fromList . Map.fromListWith mappend . map toTuple' . Map.keys + groupByPackageName = fmap Set.fromList . Map.fromListWith (<>) . map toTuple' . Map.keys toVersionRange (_, PreferredVersionsCache raw) = fromMaybe anyVersion $ parse raw where parse = simpleParse . T.unpack . T.dropWhile (/= ' ') From 5572bfff199eec0d030af50f4d8a983a1eb8b73e Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Fri, 26 Feb 2016 09:48:33 -0500 Subject: [PATCH 7/7] update 'stack upgrade' to only consider non-deprecated versions --- src/Stack/Fetch.hs | 20 ++++---------------- src/Stack/PackageIndex.hs | 25 +++++++++++++++++++++++++ src/Stack/Upgrade.hs | 11 +---------- 3 files changed, 30 insertions(+), 26 deletions(-) diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index df1be590da..6a82f0c43b 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -55,7 +55,7 @@ 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, fromMaybe) +import Data.Maybe (maybeToList, catMaybes) import Data.Monoid ((<>)) import Data.Set (Set) import qualified Data.Set as Set @@ -64,8 +64,6 @@ import Data.Text.Encoding (decodeUtf8) import Data.Typeable (Typeable) import Data.Word (Word64) import qualified Data.Yaml as Yaml -import Distribution.Text (simpleParse) -import Distribution.Version (anyVersion) import Network.HTTP.Client (checkStatus) import Network.HTTP.Download import Network.HTTP.Types.Status @@ -269,12 +267,9 @@ resolvePackagesAllowMissing -> Set PackageName -> m (Set PackageName, Set PackageIdentifier, Map PackageIdentifier ResolvedPackage) resolvePackagesAllowMissing menv idents0 names0 = 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 - versions = Map.mapWithKey latestApplicable $ groupByPackageName caches - (missingNames, idents1) = partitionEithers $ map + (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) @@ -291,13 +286,6 @@ resolvePackagesAllowMissing menv idents0 names0 = do , rpIndex = index }) - 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 (/= ' ') - data ToFetch = ToFetch { tfTarball :: !(Path Abs File) diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index 7c901f9112..8b50e67a5f 100644 --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -19,6 +19,7 @@ module Stack.PackageIndex ( updateAllIndices , getPackageCaches + , getLatestApplicablePackageCache ) where import qualified Codec.Archive.Tar as Tar @@ -45,7 +46,9 @@ 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 @@ -55,6 +58,9 @@ 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, @@ -343,6 +349,25 @@ 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 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 diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index b8cee6d13b..2742053cf7 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -65,17 +65,8 @@ upgrade gitRepo mresolver builtHash = return $ Just $ tmp $(mkRelDir "stack") Nothing -> do updateAllIndices 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") - $(mkVersion "9.9.9")) + latest <- getLatestApplicablePackageCache menv - caches case Map.lookup $(mkPackageName "stack") latest of Nothing -> error "No stack found in package indices" Just version | version <= fromCabalVersion Paths.version -> do