diff --git a/epm/Distribution/Client/Config.hs b/epm/Distribution/Client/Config.hs index 14b3790de2a..752a0a00d1a 100644 --- a/epm/Distribution/Client/Config.hs +++ b/epm/Distribution/Client/Config.hs @@ -228,6 +228,7 @@ instance Monoid SavedConfig where installShadowPkgs = combine installShadowPkgs, installStrongFlags = combine installStrongFlags, installReinstall = combine installReinstall, + installEtaPatchesDirectory = combine installEtaPatchesDirectory, installAvoidReinstalls = combine installAvoidReinstalls, installOverrideReinstall = combine installOverrideReinstall, installUpgradeDeps = combine installUpgradeDeps, diff --git a/epm/Distribution/Client/Config.hs-boot b/epm/Distribution/Client/Config.hs-boot new file mode 100644 index 00000000000..6284b65938a --- /dev/null +++ b/epm/Distribution/Client/Config.hs-boot @@ -0,0 +1,4 @@ +module Distribution.Client.Config where + +defaultCabalDir :: IO FilePath +defaultPatchesDir :: IO FilePath diff --git a/epm/Distribution/Client/Get.hs b/epm/Distribution/Client/Get.hs index e7e7b7280b4..5010a52d31c 100644 --- a/epm/Distribution/Client/Get.hs +++ b/epm/Distribution/Client/Get.hs @@ -43,7 +43,7 @@ import Distribution.Client.Compat.Process ( readProcessWithExitCode ) import Distribution.Compat.Exception ( catchIO ) - +import Distribution.Client.Config ( defaultPatchesDir ) import Control.Exception ( finally ) import Control.Monad @@ -170,7 +170,7 @@ unpackPackage verbosity prefix pkgid descOverride pkgPath = do when existsFile $ die $ "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." notice verbosity $ "Unpacking to " ++ pkgdir' - patchedExtractTarGzFile verbosity prefix pkgdirname pkgPath + patchedExtractTarGzFile verbosity prefix pkgdirname pkgPath defaultPatchesDir case descOverride of Nothing -> return () diff --git a/epm/Distribution/Client/IndexUtils.hs b/epm/Distribution/Client/IndexUtils.hs index e4162116259..b26a158c210 100644 --- a/epm/Distribution/Client/IndexUtils.hs +++ b/epm/Distribution/Client/IndexUtils.hs @@ -51,6 +51,7 @@ import Distribution.Simple.Program ( ProgramConfiguration ) import qualified Distribution.Simple.Configure as Configure ( getInstalledPackages ) +import Distribution.Client.Config ( defaultPatchesDir ) import Distribution.ParseUtils ( ParseResult(..) ) import Distribution.Version @@ -450,7 +451,7 @@ packageIndexFromCache mkPkg hnd entrs mode = accum mempty [] entrs -- from the index tarball if it turns out that we need it. -- Most of the time we only need the package id. ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do - mPatch <- patchedPackageCabalFile pkgid + mPatch <- patchedPackageCabalFile pkgid defaultPatchesDir pkgtxt <- maybe (getEntryContent blockno) return mPatch pkg <- readPackageDescription pkgtxt return (pkg, pkgtxt) diff --git a/epm/Distribution/Client/Install.hs b/epm/Distribution/Client/Install.hs index 9488b7b273a..c3d0e2cf711 100644 --- a/epm/Distribution/Client/Install.hs +++ b/epm/Distribution/Client/Install.hs @@ -79,7 +79,7 @@ import Distribution.Client.Setup , ConfigFlags(..), configureCommand, filterConfigureFlags , ConfigExFlags(..), InstallFlags(..) ) import Distribution.Client.Config - ( defaultCabalDir, defaultUserInstall ) + ( defaultCabalDir, defaultUserInstall, defaultPatchesDir ) import Distribution.Client.Patch import Distribution.Client.Sandbox.Timestamp ( withUpdateTimestamps ) @@ -1009,7 +1009,7 @@ performInstallations verbosity rpkg $ \configFlags' src pkg pkgoverride -> fetchSourcePackage verbosity fetchLimit src $ \src' -> installLocalPackage verbosity buildLimit - (packageId pkg) src' distPref $ \mpath -> + (packageId pkg) src' distPref etaPatchesDir $ \mpath -> installUnpackedPackage verbosity buildLimit installLock numJobs pkg_key (setupScriptOptions installedPkgIndex cacheLock) miscOptions configFlags' installFlags haddockFlags @@ -1052,6 +1052,7 @@ performInstallations verbosity } reportingLevel = fromFlag (installBuildReports installFlags) logsDir = fromFlag (globalLogsDir globalFlags) + etaPatchesDir = fromFlagOrDefault defaultPatchesDir (toFlag $ return $ fromFlag $ installEtaPatchesDirectory installFlags) -- Should the build output be written to a log file instead of stdout? useLogFile :: UseLogFile @@ -1234,9 +1235,10 @@ installLocalPackage :: Verbosity -> JobLimit -> PackageIdentifier -> PackageLocation FilePath -> FilePath + -> IO FilePath -- ^ Patches directory option -> (Maybe FilePath -> IO BuildResult) -> IO BuildResult -installLocalPackage verbosity jobLimit pkgid location distPref installPkg = +installLocalPackage verbosity jobLimit pkgid location distPref patchDir installPkg = case location of @@ -1245,15 +1247,15 @@ installLocalPackage verbosity jobLimit pkgid location distPref installPkg = LocalTarballPackage tarballPath -> installLocalTarballPackage verbosity jobLimit - pkgid tarballPath distPref installPkg + pkgid tarballPath distPref installPkg patchDir RemoteTarballPackage _ tarballPath -> installLocalTarballPackage verbosity jobLimit - pkgid tarballPath distPref installPkg + pkgid tarballPath distPref installPkg patchDir RepoTarballPackage _ _ tarballPath -> installLocalTarballPackage verbosity jobLimit - pkgid tarballPath distPref installPkg + pkgid tarballPath distPref installPkg patchDir installLocalTarballPackage @@ -1261,9 +1263,10 @@ installLocalTarballPackage -> JobLimit -> PackageIdentifier -> FilePath -> FilePath -> (Maybe FilePath -> IO BuildResult) + -> IO FilePath -> IO BuildResult installLocalTarballPackage verbosity jobLimit pkgid - tarballPath distPref installPkg = do + tarballPath distPref installPkg patchDir = do tmp <- getTemporaryDirectory withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath -> onFailure UnpackFailed $ do @@ -1274,7 +1277,7 @@ installLocalTarballPackage verbosity jobLimit pkgid withJobLimit jobLimit $ do info verbosity $ "Extracting " ++ tarballPath ++ " to " ++ tmpDirPath ++ "..." - patchedExtractTarGzFile verbosity tmpDirPath relUnpackedPath tarballPath + patchedExtractTarGzFile verbosity tmpDirPath relUnpackedPath tarballPath patchDir exists <- doesFileExist descFilePath when (not exists) $ die $ "Package .cabal file not found: " ++ show descFilePath diff --git a/epm/Distribution/Client/Patch.hs b/epm/Distribution/Client/Patch.hs index 8aefd6d48c1..90ab6dd3538 100644 --- a/epm/Distribution/Client/Patch.hs +++ b/epm/Distribution/Client/Patch.hs @@ -24,25 +24,31 @@ import System.Directory ( doesFileExist ) import qualified Data.ByteString.Lazy as BS -patchedPackageCabalFile :: PackageIdentifier -> IO (Maybe BS.ByteString) +patchedPackageCabalFile :: PackageIdentifier + -> IO FilePath + -> IO (Maybe BS.ByteString) patchedPackageCabalFile (PackageIdentifier { pkgName = name - , pkgVersion = Version { versionBranch = versions } }) - = findCabalFilePatch $ unPackageName name + , pkgVersion = Version { versionBranch = versions } }) patchesDir + = findCabalFilePatch (unPackageName name ++ "-" ++ (intercalate "." $ map show versions) - <.> "cabal" + <.> "cabal") patchesDir -patchedTarPackageCabalFile :: FilePath -> IO (Maybe (FilePath, BS.ByteString)) -patchedTarPackageCabalFile tarFilePath = - fmap (fmap (\bs -> (cabalFile, bs))) $ findCabalFilePatch cabalFile +patchedTarPackageCabalFile :: FilePath + -> IO FilePath + -> IO (Maybe (FilePath, BS.ByteString)) +patchedTarPackageCabalFile tarFilePath patchesDir' = + fmap (fmap (\bs -> (cabalFile, bs))) $ findCabalFilePatch cabalFile patchesDir' where packageAndVersion = dropExtension . dropExtension $ tarFilePath cabalFile = packageAndVersion <.> "cabal" -findCabalFilePatch :: FilePath -> IO (Maybe BS.ByteString) -findCabalFilePatch cabalFile = do - patchesDir <- defaultPatchesDir +findCabalFilePatch :: FilePath + -> IO FilePath -- ^ Filepath of the patches directory + -> IO (Maybe BS.ByteString) +findCabalFilePatch cabalFile patchesDir' = do + patchesDir <- patchesDir' -- TODO: Speed this up with a cache? let cabalPatchLocation = patchesDir "patches" cabalFile exists <- doesFileExist cabalPatchLocation @@ -50,9 +56,14 @@ findCabalFilePatch cabalFile = do then fmap Just $ BS.readFile cabalPatchLocation else return Nothing -patchedExtractTarGzFile :: Verbosity -> FilePath -> FilePath -> FilePath -> IO () -patchedExtractTarGzFile verbosity dir expected tar = do - patchesDir <- defaultPatchesDir +patchedExtractTarGzFile :: Verbosity + -> FilePath -- ^ Destination directory of tar.gz file + -> FilePath -- ^ Expected subdir (to check for tarbombs) + -> FilePath -- ^ Tarball + -> IO FilePath -- ^ Filepath of the patches directory + -> IO () +patchedExtractTarGzFile verbosity dir expected tar patchesDir' = do + patchesDir <- patchesDir' -- TODO: Speed this up with a cache? let patchFileLocation = patchesDir "patches" patchFile exists <- doesFileExist patchFileLocation diff --git a/epm/Distribution/Client/Patch.hs-boot b/epm/Distribution/Client/Patch.hs-boot index b32d92de79a..722abf7de68 100644 --- a/epm/Distribution/Client/Patch.hs-boot +++ b/epm/Distribution/Client/Patch.hs-boot @@ -4,5 +4,9 @@ import Distribution.Package ( PackageIdentifier ) import System.FilePath ( FilePath ) import qualified Data.ByteString.Lazy as BS -patchedTarPackageCabalFile :: FilePath -> IO (Maybe (FilePath, BS.ByteString)) -patchedPackageCabalFile :: PackageIdentifier -> IO (Maybe BS.ByteString) \ No newline at end of file +patchedTarPackageCabalFile :: FilePath + -> IO FilePath + -> IO (Maybe (FilePath, BS.ByteString)) +patchedPackageCabalFile :: PackageIdentifier + -> IO FilePath + -> IO (Maybe BS.ByteString) diff --git a/epm/Distribution/Client/Setup.hs b/epm/Distribution/Client/Setup.hs index 8c006766b54..e9d3a884c74 100644 --- a/epm/Distribution/Client/Setup.hs +++ b/epm/Distribution/Client/Setup.hs @@ -1145,7 +1145,8 @@ data InstallFlags = InstallFlags { installSymlinkBinDir :: Flag FilePath, installOneShot :: Flag Bool, installNumJobs :: Flag (Maybe Int), - installRunTests :: Flag Bool + installRunTests :: Flag Bool, + installEtaPatchesDirectory :: Flag FilePath } defaultInstallFlags :: InstallFlags @@ -1172,7 +1173,8 @@ defaultInstallFlags = InstallFlags { installSymlinkBinDir = mempty, installOneShot = Flag False, installNumJobs = mempty, - installRunTests = mempty + installRunTests = mempty, + installEtaPatchesDirectory = mempty } where docIndexFile = toPathTemplate ("$datadir" "doc" @@ -1346,6 +1348,11 @@ installOptions showOrParseArgs = installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v }) (reqArgFlag "DIR") + , option [] ["patches-directory"] + "Specify explicit Eta patches directory" + installEtaPatchesDirectory (\v flags -> flags { installEtaPatchesDirectory = v }) + (reqArgFlag "DIR") + , option [] ["build-summary"] "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" installSummaryFile (\v flags -> flags { installSummaryFile = v }) @@ -1417,7 +1424,8 @@ instance Monoid InstallFlags where installSymlinkBinDir = mempty, installOneShot = mempty, installNumJobs = mempty, - installRunTests = mempty + installRunTests = mempty, + installEtaPatchesDirectory = mempty } mappend a b = InstallFlags { installDocumentation = combine installDocumentation, @@ -1442,7 +1450,8 @@ instance Monoid InstallFlags where installSymlinkBinDir = combine installSymlinkBinDir, installOneShot = combine installOneShot, installNumJobs = combine installNumJobs, - installRunTests = combine installRunTests + installRunTests = combine installRunTests, + installEtaPatchesDirectory = combine installEtaPatchesDirectory } where combine field = field a `mappend` field b diff --git a/epm/Distribution/Client/Targets.hs b/epm/Distribution/Client/Targets.hs index 18723b073f8..0d71f338a4d 100644 --- a/epm/Distribution/Client/Targets.hs +++ b/epm/Distribution/Client/Targets.hs @@ -45,6 +45,10 @@ module Distribution.Client.Targets ( ) where +import System.Directory + ( getAppUserDataDirectory) +import System.FilePath + ( ()) import Distribution.Package ( Package(..), PackageName(..) , PackageIdentifier(..), packageName, packageVersion @@ -53,7 +57,6 @@ import Distribution.Client.Types ( SourcePackage(..), PackageLocation(..), OptionalStanza(..) ) import Distribution.Client.Dependency.Types ( PackageConstraint(..) ) - import qualified Distribution.Client.World as World import Distribution.Client.PackageIndex (PackageIndex) import qualified Distribution.Client.PackageIndex as PackageIndex @@ -61,6 +64,7 @@ import qualified Distribution.Client.Tar as Tar import Distribution.Client.FetchUtils import Distribution.Client.Utils ( tryFindPackageDesc ) import {-# SOURCE #-} Distribution.Client.Patch ( patchedTarPackageCabalFile ) +import {-# SOURCE #-} Distribution.Client.Config (defaultCabalDir, defaultPatchesDir) import Distribution.PackageDescription ( GenericPackageDescription, FlagName(..), FlagAssignment ) @@ -462,6 +466,7 @@ fetchPackageTarget verbosity target = case target of -- -- This only affects targets given by location, named targets are unaffected. -- + readPackageTarget :: Verbosity -> PackageTarget (PackageLocation FilePath) -> IO (PackageTarget SourcePackage) @@ -515,7 +520,7 @@ readPackageTarget verbosity target = case target of extractTarballPackageCabalFile :: FilePath -> String -> IO (FilePath, BS.ByteString) extractTarballPackageCabalFile tarballFile tarballOriginalLoc = do - maybePatchedCabalFile <- patchedTarPackageCabalFile tarballFile + maybePatchedCabalFile <- patchedTarPackageCabalFile tarballFile defaultPatchesDir maybe ( either (die . formatErr) return . check