From 68e9e1aad202f260237e173365e81c3df1e74cfe Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 18 Jun 2020 11:34:34 +0300 Subject: [PATCH 1/2] Add packageDirToSdist to CmdSdist --- cabal-install/Distribution/Client/CmdSdist.hs | 89 +++++-------------- cabal-install/Distribution/Client/SrcDist.hs | 68 +++++++++++++- 2 files changed, 86 insertions(+), 71 deletions(-) diff --git a/cabal-install/Distribution/Client/CmdSdist.hs b/cabal-install/Distribution/Client/CmdSdist.hs index 5d88b2bf2c7..adbe04afd07 100644 --- a/cabal-install/Distribution/Client/CmdSdist.hs +++ b/cabal-install/Distribution/Client/CmdSdist.hs @@ -51,6 +51,8 @@ import Distribution.Simple.Setup ) import Distribution.Simple.SrcDist ( listPackageSources ) +import Distribution.Client.SrcDist + ( packageDirToSdist ) import Distribution.Simple.Utils ( die', notice, withOutputMarker, wrapText ) import Distribution.Types.ComponentName @@ -60,24 +62,13 @@ import Distribution.Types.PackageName import Distribution.Verbosity ( normal ) -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Codec.Compression.GZip as GZip -import Control.Monad.Trans - ( liftIO ) -import Control.Monad.State.Lazy - ( StateT, modify, gets, evalStateT ) -import Control.Monad.Writer.Lazy - ( WriterT, tell, execWriterT ) -import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.Set as Set import System.Directory ( getCurrentDirectory , createDirectoryIfMissing, makeAbsolute ) import System.FilePath - ( (), (<.>), makeRelative, normalise, takeDirectory ) + ( (), (<.>), makeRelative, normalise ) ------------------------------------------------------------------------------- -- Command @@ -238,72 +229,34 @@ packageToSdist verbosity projectRootDir format outputFile pkg = do RepoTarballPackage {} -> death let -- Write String to stdout or file, using the default TextEncoding. - write - | outputFile == "-" = putStr . withOutputMarker verbosity - | otherwise = writeFile outputFile + write str + | outputFile == "-" = putStr (withOutputMarker verbosity str) + | otherwise = do + writeFile outputFile str + notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" -- Write raw ByteString to stdout or file as it is, without encoding. - writeLBS - | outputFile == "-" = BSL.putStr - | otherwise = BSL.writeFile outputFile + writeLBS lbs + | outputFile == "-" = BSL.putStr lbs + | otherwise = do + BSL.writeFile outputFile lbs + notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" case dir0 of Left tgz -> do case format of TarGzArchive -> do writeLBS =<< BSL.readFile tgz - when (outputFile /= "-") $ - notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" _ -> die' verbosity ("cannot convert tarball package to " ++ show format) - Right dir -> do - files' <- listPackageSources verbosity dir (flattenPackageDescription $ srcpkgDescription pkg) knownSuffixHandlers - let files = nub $ sort $ map normalise files' + Right dir -> case format of + SourceList nulSep -> do + files' <- listPackageSources verbosity dir (flattenPackageDescription $ srcpkgDescription pkg) knownSuffixHandlers + let files = nub $ sort $ map normalise files' + let prefix = makeRelative projectRootDir dir + write $ concat [prefix i ++ [nulSep] | i <- files] - case format of - SourceList nulSep -> do - let prefix = makeRelative projectRootDir dir - write $ concat [prefix i ++ [nulSep] | i <- files] - when (outputFile /= "-") $ - notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" - TarGzArchive -> do - let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) () - entriesM = do - let prefix = prettyShow (packageId pkg) - modify (Set.insert prefix) - case Tar.toTarPath True prefix of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [Tar.directoryEntry path] - - for_ files $ \file -> do - let fileDir = takeDirectory (prefix file) - needsEntry <- gets (Set.notMember fileDir) - - when needsEntry $ do - modify (Set.insert fileDir) - case Tar.toTarPath True fileDir of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [Tar.directoryEntry path] - - contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir file - case Tar.toTarPath False (prefix file) of - Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) - Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }] - - entries <- execWriterT (evalStateT entriesM mempty) - let -- Pretend our GZip file is made on Unix. - normalize bs = BSL.concat [pfx, "\x03", rest'] - where - (pfx, rest) = BSL.splitAt 9 bs - rest' = BSL.tail rest - -- The Unix epoch, which is the default value, is - -- unsuitable because it causes unpacking problems on - -- Windows; we need a post-1980 date. One gigasecond - -- after the epoch is during 2001-09-09, so that does - -- nicely. See #5596. - setModTime entry = entry { Tar.entryTime = 1000000000 } - writeLBS . normalize . GZip.compress . Tar.write $ fmap setModTime entries - when (outputFile /= "-") $ - notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" + TarGzArchive -> do + packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS -- diff --git a/cabal-install/Distribution/Client/SrcDist.hs b/cabal-install/Distribution/Client/SrcDist.hs index 8498d7202fa..35654321e63 100644 --- a/cabal-install/Distribution/Client/SrcDist.hs +++ b/cabal-install/Distribution/Client/SrcDist.hs @@ -1,18 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} -- | Utilities to implemenet cabal @v2-sdist@. module Distribution.Client.SrcDist ( allPackageSourceFiles, + packageDirToSdist, ) where -import Distribution.Solver.Compat.Prelude +import Distribution.Client.Compat.Prelude import Prelude () +import Control.Monad.State.Lazy (StateT, evalStateT, gets, modify) +import Control.Monad.Trans (liftIO) +import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell) +import System.FilePath (normalise, takeDirectory, ()) + +import Distribution.Client.Utils (tryFindAddSourcePackageDesc) +import Distribution.Package (Package (packageId)) import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.PackageDescription.Parsec (readGenericPackageDescription) import Distribution.Simple.PreProcess (knownSuffixHandlers) +import Distribution.Simple.SrcDist (listPackageSources) import Distribution.Simple.SrcDist (listPackageSourcesWithDie) -import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils (die') +import Distribution.Types.GenericPackageDescription (GenericPackageDescription) -import Distribution.Client.Utils (tryFindAddSourcePackageDesc) +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Set as Set -- | List all source files of a given add-source dependency. Exits with error if -- something is wrong (e.g. there is no .cabal file in the given directory). @@ -29,3 +45,49 @@ allPackageSourceFiles verbosity packageDir = do listPackageSourcesWithDie verbosity (\_ _ -> return []) packageDir pd knownSuffixHandlers +-- | Create a tarball for a package in a directory +packageDirToSdist + :: Verbosity + -> GenericPackageDescription -- ^ read in GPD + -> FilePath -- ^ directory containing that GPD + -> IO BSL.ByteString -- ^ resulting sdist tarball +packageDirToSdist verbosity gpd dir = do + files' <- listPackageSources verbosity dir (flattenPackageDescription gpd) knownSuffixHandlers + let files = nub $ sort $ map normalise files' + + let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) () + entriesM = do + let prefix = prettyShow (packageId gpd) + modify (Set.insert prefix) + case Tar.toTarPath True prefix of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [Tar.directoryEntry path] + + for_ files $ \file -> do + let fileDir = takeDirectory (prefix file) + needsEntry <- gets (Set.notMember fileDir) + + when needsEntry $ do + modify (Set.insert fileDir) + case Tar.toTarPath True fileDir of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [Tar.directoryEntry path] + + contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir file + case Tar.toTarPath False (prefix file) of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }] + + entries <- execWriterT (evalStateT entriesM mempty) + let -- Pretend our GZip file is made on Unix. + normalize bs = BSL.concat [pfx, "\x03", rest'] + where + (pfx, rest) = BSL.splitAt 9 bs + rest' = BSL.tail rest + -- The Unix epoch, which is the default value, is + -- unsuitable because it causes unpacking problems on + -- Windows; we need a post-1980 date. One gigasecond + -- after the epoch is during 2001-09-09, so that does + -- nicely. See #5596. + setModTime entry = entry { Tar.entryTime = 1000000000 } + return . normalize . GZip.compress . Tar.write $ fmap setModTime entries From 2b6cd51a9638dec56cf8c70fafcdd20ab53d5714 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 18 Jun 2020 13:28:01 +0300 Subject: [PATCH 2/2] Resolve #5586. Treat all packages as remote except LocalUnpackedPackage Also calculate hashes for all locally available tarballs. --- .../Distribution/Client/FetchUtils.hs | 4 +- .../Distribution/Client/ProjectBuilding.hs | 13 +++--- .../Distribution/Client/ProjectConfig.hs | 31 ++++++++----- .../Distribution/Client/ProjectPlanning.hs | 44 +++++++++++-------- 4 files changed, 53 insertions(+), 39 deletions(-) diff --git a/cabal-install/Distribution/Client/FetchUtils.hs b/cabal-install/Distribution/Client/FetchUtils.hs index d857c53d1e5..b087867f5d0 100644 --- a/cabal-install/Distribution/Client/FetchUtils.hs +++ b/cabal-install/Distribution/Client/FetchUtils.hs @@ -99,8 +99,8 @@ checkFetched loc = case loc of return (Just $ RemoteTarballPackage uri file) RepoTarballPackage repo pkgid (Just file) -> return (Just $ RepoTarballPackage repo pkgid file) - RemoteSourceRepoPackage repo (Just dir) -> - return (Just $ RemoteSourceRepoPackage repo dir) + RemoteSourceRepoPackage repo (Just file) -> + return (Just $ RemoteSourceRepoPackage repo file) RemoteTarballPackage _uri Nothing -> return Nothing RemoteSourceRepoPackage _repo Nothing -> return Nothing diff --git a/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal-install/Distribution/Client/ProjectBuilding.hs index fa305edd51a..134e2249999 100644 --- a/cabal-install/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/Distribution/Client/ProjectBuilding.hs @@ -200,13 +200,8 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = -- artifacts under the shared dist directory. dryRunLocalPkg pkg depsBuildStatus srcdir - Just (RemoteSourceRepoPackage _repo srcdir) -> - -- At this point, source repos are essentially the same as local - -- dirs, since we've already download them. - dryRunLocalPkg pkg depsBuildStatus srcdir - - -- The three tarball cases are handled the same as each other, - -- though depending on the build style. + -- The rest cases are all tarball cases are, + -- and handled the same as each other though depending on the build style. Just (LocalTarballPackage tarball) -> dryRunTarballPkg pkg depsBuildStatus tarball @@ -216,6 +211,10 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = Just (RepoTarballPackage _ _ tarball) -> dryRunTarballPkg pkg depsBuildStatus tarball + Just (RemoteSourceRepoPackage _repo tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + + dryRunTarballPkg :: ElaboratedConfiguredPackage -> [BuildStatus] -> FilePath diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index c8042b56cb2..5c8cf444ca7 100644 --- a/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/Distribution/Client/ProjectConfig.hs @@ -127,6 +127,8 @@ import Distribution.Version ( Version ) import qualified Distribution.Deprecated.ParseUtils as OldParser ( ParseResult(..), locatedErrorMsg, showPWarning ) +import Distribution.Client.SrcDist + ( packageDirToSdist ) import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar @@ -1170,6 +1172,7 @@ syncAndReadSourcePackagesRemoteRepos verbosity syncSourceRepos verbosity vcs [ (repo, repoPath) | (repo, _, repoPath) <- repoGroupWithPaths ] + -- TODO phadej 2020-06-18 add post-sync script -- But for reading we go through each 'SourceRepo' including its subdir -- value and have to know which path each one ended up in. @@ -1199,24 +1202,30 @@ syncAndReadSourcePackagesRemoteRepos verbosity : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ] readPackageFromSourceRepo - :: SourceRepositoryPackage Maybe -> FilePath + :: SourceRepositoryPackage Maybe + -> FilePath -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) readPackageFromSourceRepo repo repoPath = do - let packageDir = maybe repoPath (repoPath ) (srpSubdir repo) + let packageDir :: FilePath + packageDir = maybe repoPath (repoPath ) (srpSubdir repo) + entries <- liftIO $ getDirectoryContents packageDir - --TODO: wrap exceptions + --TODO: dcoutts 2018-06-23: wrap exceptions case filter (\e -> takeExtension e == ".cabal") entries of [] -> liftIO $ throwIO $ NoCabalFileFound packageDir (_:_:_) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir [cabalFileName] -> do + let cabalFilePath = packageDir cabalFileName monitorFiles [monitorFileHashed cabalFilePath] - liftIO $ fmap (mkSpecificSourcePackage location) - . readSourcePackageCabalFile verbosity cabalFilePath - =<< BS.readFile cabalFilePath - where - cabalFilePath = packageDir cabalFileName - location = RemoteSourceRepoPackage repo packageDir + gpd <- liftIO $ readSourcePackageCabalFile verbosity cabalFilePath =<< BS.readFile cabalFilePath + + -- write sdist tarball, to repoPath-pgkid + tarball <- liftIO $ packageDirToSdist verbosity gpd packageDir + let tarballPath = repoPath ++ "-" ++ prettyShow (packageId gpd) ++ ".tar.gz" + liftIO $ LBS.writeFile tarballPath tarball + let location = RemoteSourceRepoPackage repo tarballPath + return $ mkSpecificSourcePackage location gpd reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems @@ -1231,13 +1240,11 @@ syncAndReadSourcePackagesRemoteRepos verbosity -- mkSpecificSourcePackage :: PackageLocation FilePath -> GenericPackageDescription - -> PackageSpecifier - (SourcePackage (PackageLocation (Maybe FilePath))) + -> PackageSpecifier (SourcePackage UnresolvedPkgLoc) mkSpecificSourcePackage location pkg = SpecificSourcePackage SourcePackage { srcpkgPackageId = packageId pkg , srcpkgDescription = pkg - --TODO: it is silly that we still have to use a Maybe FilePath here , srcpkgSource = fmap Just location , srcpkgDescrOverride = Nothing } diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 4bbc95848ac..ffbd3698cbb 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -593,6 +593,10 @@ rebuildInstallPlan verbosity Map.fromList [ (pkgname, stanzas) | pkg <- localPackages + -- TODO: misnormer: we should separate + -- builtin/global/inplace/local packages + -- and packages explicitly mentioned in the project + -- , let pkgname = pkgSpecifierTarget pkg testsEnabled = lookupLocalPackageConfig packageConfigTests @@ -600,12 +604,14 @@ rebuildInstallPlan verbosity benchmarksEnabled = lookupLocalPackageConfig packageConfigBenchmarks projectConfig pkgname - stanzas = - Map.fromList $ + isLocal = isJust (shouldBeLocal pkg) + stanzas + | isLocal = Map.fromList $ [ (TestStanzas, enabled) - | enabled <- flagToList testsEnabled ] - ++ [ (BenchStanzas , enabled) + | enabled <- flagToList testsEnabled ] ++ + [ (BenchStanzas , enabled) | enabled <- flagToList benchmarksEnabled ] + | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False) ] ] -- Elaborate the solver's install plan to get a fully detailed plan. This @@ -823,10 +829,14 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do -- Tarballs from remote URLs. We must have downloaded these already -- (since we extracted the .cabal file earlier) - --TODO: [required eventually] finish remote tarball functionality --- allRemoteTarballPkgs = --- [ (pkgid, ) --- | (pkgid, RemoteTarballPackage ) <- allPkgLocations ] + remoteTarballPkgs = + [ (pkgid, tarball) + | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ] + + -- tarballs from source-repository-package stanzas + sourceRepoTarballPkgs = + [ (pkgid, tarball) + | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ] -- Tarballs from repositories, either where the repository provides -- hashes as part of the repo metadata, or where we will have to @@ -906,6 +916,8 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do -- let allTarballFilePkgs :: [(PackageId, FilePath)] allTarballFilePkgs = localTarballPkgs + ++ remoteTarballPkgs + ++ sourceRepoTarballPkgs ++ repoTarballPkgsDownloaded ++ repoTarballPkgsNewlyDownloaded hashesFromTarballFiles <- liftIO $ @@ -1925,16 +1937,6 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB Set.fromList (catMaybes (map shouldBeLocal localPackages)) --TODO: localPackages is a misnomer, it's all project packages -- here is where we decide which ones will be local! - where - shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId - shouldBeLocal NamedPackage{} = Nothing - shouldBeLocal (SpecificSourcePackage pkg) - | LocalTarballPackage _ <- srcpkgSource pkg = Nothing - | otherwise = Just (packageId pkg) - -- TODO: Is it only LocalTarballPackages we can know about without - -- them being "local" in the sense meant here? - -- - -- Also, review use of SourcePackage's loc vs ProjectPackageLocation pkgsUseSharedLibrary :: Set PackageId pkgsUseSharedLibrary = @@ -1995,6 +1997,12 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB -- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping +shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId +shouldBeLocal NamedPackage{} = Nothing +shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of + LocalUnpackedPackage _ -> Just (packageId pkg) + _ -> Nothing + -- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p)