Merge pull request haskell#3 from psibi/eta-patch-directory

Add --eta-patches-directory option to epm install

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,

epm/Distribution/Client/Config.hs-boot

@@ -0,0 +1,4 @@
+module Distribution.Client.Config where
+
+defaultCabalDir :: IO FilePath
+defaultPatchesDir :: IO FilePath

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 ()

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)

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,25 +1247,26 @@ 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
   :: Verbosity
   -> 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

epm/Distribution/Client/Patch.hs

@@ -24,35 +24,46 @@ 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
   if exists
   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

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)
+patchedTarPackageCabalFile :: FilePath 
+                           -> IO FilePath
+                           -> IO (Maybe (FilePath, BS.ByteString))
+patchedPackageCabalFile :: PackageIdentifier 
+                        -> IO FilePath
+                        -> IO (Maybe BS.ByteString)

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
 

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,14 +57,14 @@ 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
 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