Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

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

Closed
Show file tree
Hide file tree
Changes from 1 commit
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion src/Stack/Config.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
93 changes: 83 additions & 10 deletions src/Stack/Fetch.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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)

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand All @@ -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 =
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why not filterBy without the prime?

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))
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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,
Expand Down
64 changes: 45 additions & 19 deletions src/Stack/PackageIndex.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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
Expand All @@ -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"
Expand All @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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.
Expand Down
5 changes: 5 additions & 0 deletions src/Stack/Types/Config.hs
Original file line number Diff line number Diff line change
Expand Up @@ -72,6 +72,7 @@ module Stack.Types.Config
,configPackageIndexGz
,configPackageIndexRoot
,configPackageTarball
,configPreferredVersionsCache
,indexNameText
,IndexLocation(..)
-- ** Project & ProjectAndConfigMonoid
Expand Down Expand Up @@ -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
Expand Down
16 changes: 16 additions & 0 deletions src/Stack/Types/PackageIndex.hs
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,8 @@ module Stack.Types.PackageIndex
( PackageDownload (..)
, PackageCache (..)
, PackageCacheMap (..)
, PreferredVersionsCache (..)
, PreferredVersionsCacheMap (..)
) where

import Control.Monad (mzero)
Expand All @@ -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
Expand Down
4 changes: 2 additions & 2 deletions src/Stack/Upgrade.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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")
Expand Down
Loading