Merge pull request #6666 from phadej/fix-sdist-permissions

Fix sdist permissions

Author: phadej

Cabal/Distribution/Simple.hs

@@ -413,31 +413,12 @@ installAction hooks flags args = do
                  (getBuildConfig hooks verbosity distPref)
                  hooks flags' args
 
+-- Since Cabal-3.4 UserHooks are completely ignored
 sdistAction :: UserHooks -> SDistFlags -> Args -> IO ()
-sdistAction hooks flags _args = do
-    distPref <- findDistPrefOrDefault (sDistDistPref flags)
-    let pbi   = emptyHookedBuildInfo
-
-    mlbi <- maybeGetPersistBuildConfig distPref
-
-    -- NB: It would be TOTALLY WRONG to use the 'PackageDescription'
-    -- store in the 'LocalBuildInfo' for the rest of @sdist@, because
-    -- that would result in only the files that would be built
-    -- according to the user's configure being packaged up.
-    -- In fact, it is not obvious why we need to read the
-    -- 'LocalBuildInfo' in the first place, except that we want
-    -- to do some architecture-independent preprocessing which
-    -- needs to be configured.  This is totally awful, see
-    -- GH#130.
-
-    (_, ppd) <- confPkgDescr hooks verbosity Nothing
-
-    let pkg_descr0 = flattenPackageDescription ppd
-    sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi
-    let pkg_descr = updatePackageDescription pbi pkg_descr0
-        mlbi' = fmap (\lbi -> lbi { localPkgDescr = pkg_descr }) mlbi
-
-    sdist pkg_descr mlbi' flags srcPref (allSuffixHandlers hooks)
+sdistAction _hooks flags _args = do
+    (_, ppd) <- confPkgDescr emptyUserHooks verbosity Nothing
+    let pkg_descr = flattenPackageDescription ppd
+    sdist pkg_descr flags srcPref knownSuffixHandlers
   where
     verbosity = fromFlag (sDistVerbosity flags)
 

Cabal/Distribution/Simple/SrcDist.hs

@@ -93,10 +93,13 @@ module Distribution.Simple.Utils (
 
         -- * finding files
         findFileEx,
+        findFileCwd,
         findFirstFile,
         findFileWithExtension,
+        findFileCwdWithExtension,
         findFileWithExtension',
         findAllFilesWithExtension,
+        findAllFilesCwdWithExtension,
         findModuleFileEx,
         findModuleFilesEx,
         getDirectoryContentsRecursive,
@@ -118,7 +121,9 @@ module Distribution.Simple.Utils (
         -- * .cabal and .buildinfo files
         defaultPackageDesc,
         findPackageDesc,
+        findPackageDescCwd,
         tryFindPackageDesc,
+        tryFindPackageDescCwd,
         findHookedPackageDesc,
 
         -- * reading and writing files safely
@@ -942,6 +947,21 @@ findFile :: [FilePath]    -- ^search locations
          -> IO FilePath
 findFile = findFileEx normal
 
+-- | Find a file by looking in a search path. The file path must match exactly.
+--
+-- @since 3.4.0.0
+findFileCwd
+    :: Verbosity
+    -> FilePath      -- ^ cwd
+    -> [FilePath]    -- ^ relative search location
+    -> FilePath      -- ^ File Name
+    -> IO FilePath
+findFileCwd verbosity cwd searchPath fileName =
+  findFirstFile (cwd </>)
+    [ path </> fileName
+    | path <- nub searchPath]
+  >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return
+
 -- | Find a file by looking in a search path. The file path must match exactly.
 --
 findFileEx :: Verbosity
@@ -968,6 +988,32 @@ findFileWithExtension extensions searchPath baseName =
     | path <- nub searchPath
     , ext <- nub extensions ]
 
+-- | @since 3.4.0.0
+findFileCwdWithExtension
+    :: FilePath
+    -> [String]
+    -> [FilePath]
+    -> FilePath
+    -> IO (Maybe FilePath)
+findFileCwdWithExtension cwd extensions searchPath baseName =
+  findFirstFile (cwd </>)
+    [ path </> baseName <.> ext
+    | path <- nub searchPath
+    , ext <- nub extensions ]
+
+-- | @since 3.4.0.0
+findAllFilesCwdWithExtension
+    :: FilePath       -- ^ cwd
+    -> [String]       -- ^ extensions
+    -> [FilePath]     -- ^ relative search locations
+    -> FilePath       -- ^ basename
+    -> IO [FilePath]
+findAllFilesCwdWithExtension cwd extensions searchPath basename =
+  findAllFiles (cwd </>)
+    [ path </> basename <.> ext
+    | path <- nub searchPath
+    , ext <- nub extensions ]
+
 findAllFilesWithExtension :: [String]
                           -> [FilePath]
                           -> FilePath
@@ -1460,16 +1506,23 @@ defaultPackageDesc verbosity = tryFindPackageDesc verbosity currentDir
 -- @.cabal@ files.
 findPackageDesc :: FilePath                    -- ^Where to look
                 -> IO (Either String FilePath) -- ^<pkgname>.cabal
-findPackageDesc dir
- = do files <- getDirectoryContents dir
+findPackageDesc = findPackageDescCwd "."
+
+-- | @since 3.4.0.0
+findPackageDescCwd
+    :: FilePath                    -- ^ project root
+    -> FilePath                    -- ^ relative directory
+    -> IO (Either String FilePath) -- ^ <pkgname>.cabal relative to the project root
+findPackageDescCwd cwd dir
+ = do files <- getDirectoryContents (cwd </> dir)
       -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
       -- file we filter to exclude dirs and null base file names:
-      cabalFiles <- filterM doesFileExist
-                       [ dir </> file
+      cabalFiles <- filterM (doesFileExist . snd)
+                       [ (dir </> file, cwd </> dir </> file)
                        | file <- files
                        , let (name, ext) = splitExtension file
                        , not (null name) && ext == ".cabal" ]
-      case cabalFiles of
+      case map fst cabalFiles of
         []          -> return (Left  noDesc)
         [cabalFile] -> return (Right cabalFile)
         multiple    -> return (Left  $ multiDesc multiple)
@@ -1489,6 +1542,13 @@ tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath
 tryFindPackageDesc verbosity dir =
   either (die' verbosity) return =<< findPackageDesc dir
 
+-- | Like 'findPackageDescCwd', but calls 'die' in case of error.
+--
+-- @since 3.4.0.0
+tryFindPackageDescCwd :: Verbosity -> FilePath -> FilePath -> IO FilePath
+tryFindPackageDescCwd verbosity cwd dir =
+  either (die' verbosity) return =<< findPackageDescCwd cwd dir
+
 -- |Find auxiliary package information in the given directory.
 -- Looks for @.buildinfo@ files.
 findHookedPackageDesc

Cabal/Distribution/Simple/Utils.hs

@@ -133,6 +133,12 @@ cabal-install-test:
 	rm -rf .ghc.environment.*
 	cd cabal-testsuite && `cabal-plan list-bin cabal-tests` --with-cabal=`cabal-plan list-bin cabal` --hide-successes -j3 ${TEST}
 
+# This doesn't run build, as you first need to test with cabal-install-test :)
+cabal-install-test-accept:
+	@which cabal-plan
+	rm -rf .ghc.environment.*
+	cd cabal-testsuite && `cabal-plan list-bin cabal-tests` --with-cabal=`cabal-plan list-bin cabal` --hide-successes -j3 --accept ${TEST}
+
 # Docker validation
 
 # Use this carefully, on big machine you can say
@@ -178,3 +184,8 @@ validate-via-docker-8.10.1:
 
 validate-via-docker-old:
 	docker build -t cabal-validate -f .docker/validate-old.dockerfile .
+
+# tags
+.PHONY : tags
+tags :
+	hasktags -c Cabal/Distribution Cabal/Language cabal-install/Distribution

Makefile

@@ -70,12 +70,11 @@ import qualified Data.ByteString.Char8      as BS
 import qualified Data.ByteString.Lazy.Char8 as BSL
 import Data.Either
     ( partitionEithers )
-import Data.List
-    ( sortOn )
 import qualified Data.Set as Set
 import System.Directory
-    ( getCurrentDirectory, setCurrentDirectory
-    , createDirectoryIfMissing, makeAbsolute )
+    ( getCurrentDirectory
+    , createDirectoryIfMissing, makeAbsolute
+    )
 import System.FilePath
     ( (</>), (<.>), makeRelative, normalise, takeDirectory )
 
@@ -218,9 +217,6 @@ sdistAction SdistFlags{..} targetStrings globalFlags = do
         baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand
         return (baseCtx, distDirLayout baseCtx)
 
-data IsExec = Exec | NoExec
-            deriving (Show, Eq)
-
 data OutputFormat = SourceList Char
                   | TarGzArchive
                   deriving (Show, Eq)
@@ -256,19 +252,13 @@ packageToSdist verbosity projectRootDir format outputFile pkg = do
           _ -> die' verbosity ("cannot convert tarball package to " ++ show format)
 
       Right dir -> do
-        oldPwd <- getCurrentDirectory
-        setCurrentDirectory dir
-
-        let norm flag = fmap ((flag, ) . normalise)
-        (norm NoExec -> nonexec, norm Exec -> exec) <-
-           listPackageSources verbosity (flattenPackageDescription $ packageDescription pkg) knownSuffixHandlers
-
-        let files =  nub . sortOn snd $ nonexec ++ exec
+        files' <- listPackageSources verbosity dir (flattenPackageDescription $ packageDescription pkg) knownSuffixHandlers
+        let files = nub $ sort $ map normalise files'
 
         case format of
             SourceList nulSep -> do
                 let prefix = makeRelative projectRootDir dir
-                write $ concat [prefix </> i ++ [nulSep] | (_, i) <- files]
+                write $ concat [prefix </> i ++ [nulSep] | i <- files]
                 when (outputFile /= "-") $
                     notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"
             TarGzArchive -> do
@@ -280,11 +270,8 @@ packageToSdist verbosity projectRootDir format outputFile pkg = do
                             Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
                             Right path -> tell [Tar.directoryEntry path]
 
-                        for_ files $ \(perm, file) -> do
+                        for_ files $ \file -> do
                             let fileDir = takeDirectory (prefix </> file)
-                                perm' = case perm of
-                                    Exec -> Tar.executableFilePermissions
-                                    NoExec -> Tar.ordinaryFilePermissions
                             needsEntry <- gets (Set.notMember fileDir)
 
                             when needsEntry $ do
@@ -293,10 +280,10 @@ packageToSdist verbosity projectRootDir format outputFile pkg = do
                                     Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
                                     Right path -> tell [Tar.directoryEntry path]
 
-                            contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ file
+                            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 = perm' }]
+                                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.
@@ -314,8 +301,6 @@ packageToSdist verbosity projectRootDir format outputFile pkg = do
                 when (outputFile /= "-") $
                     notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"
 
-        setCurrentDirectory oldPwd
-
 --
 
 reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage]

cabal-install/Distribution/Client/CmdSdist.hs

@@ -1226,7 +1226,7 @@ buildInplaceUnpackedPackage verbosity
                 execRebuild srcdir (needElaboratedConfiguredPackage pkg)
               listSdist =
                 fmap (map monitorFileHashed) $
-                    allPackageSourceFiles verbosity scriptOptions srcdir
+                    allPackageSourceFiles verbosity srcdir
               ifNullThen m m' = do xs <- m
                                    if null xs then m' else return xs
           monitors <- case PD.buildType (elabPkgDescription pkg) of

cabal-install/Distribution/Client/ProjectBuilding.hs

@@ -453,7 +453,7 @@ sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv = do
       when dirExists $
         removeDirectoryRecursive targetDir
       createDirectory targetTmpDir
-      prepareTree verbosity pkg Nothing targetTmpDir knownSuffixHandlers
+      prepareTree verbosity pkg targetTmpDir knownSuffixHandlers
       return (targetTmpDir, targetDir)
 
   -- Now rename the "snapshots/$PKGNAME-$VERSION-tmp" dirs to

cabal-install/Distribution/Client/Sandbox.hs

@@ -38,7 +38,6 @@ import Distribution.Client.SrcDist (allPackageSourceFiles)
 import Distribution.Client.Sandbox.Index
   (ListIgnoredBuildTreeRefs (ListIgnored), RefTypesToList(OnlyLinks)
   ,listBuildTreeRefs)
-import Distribution.Client.SetupWrapper
 
 import Distribution.Compat.Exception                 (catchIO)
 import Distribution.Compat.Time               (ModTime, getCurTime,
@@ -232,7 +231,7 @@ isDepModified verbosity now (packageDir, timestamp) = do
   debug verbosity ("Checking whether the dependency is modified: " ++ packageDir)
   -- TODO: we should properly plumb the correct options through
   -- instead of using defaultSetupScriptOptions
-  depSources <- allPackageSourceFiles verbosity defaultSetupScriptOptions packageDir
+  depSources <- allPackageSourceFiles verbosity packageDir
   go depSources
 
   where

cabal-install/Distribution/Client/Sandbox/Timestamp.hs

@@ -3,66 +3,26 @@ module Distribution.Client.SrcDist (
     allPackageSourceFiles,
 )  where
 
-
-import Control.Exception (IOException, evaluate)
-import System.Directory  (getTemporaryDirectory)
-import System.FilePath   ((</>))
-
-import Distribution.Compat.Exception                 (catchIO)
-import Distribution.Package                          (packageName)
 import Distribution.PackageDescription.Configuration (flattenPackageDescription)
 import Distribution.PackageDescription.Parsec        (readGenericPackageDescription)
-import Distribution.Pretty                           (prettyShow)
-import Distribution.Simple.Setup                     (Flag (..), defaultSDistFlags, sdistCommand)
-import Distribution.Simple.Utils                     (warn, withTempDirectory)
-import Distribution.Verbosity                        (Verbosity, lessVerbose, normal)
-import Distribution.Version                          (intersectVersionRanges, mkVersion, orLaterVersion)
+import Distribution.Simple.PreProcess                (knownSuffixHandlers)
+import Distribution.Simple.SrcDist                   (listPackageSourcesWithDie)
+import Distribution.Verbosity                        (Verbosity)
 
-import Distribution.Client.Setup        (SDistFlags (..))
-import Distribution.Client.SetupWrapper (SetupScriptOptions (..), setupWrapper)
-import Distribution.Client.Utils        (tryFindAddSourcePackageDesc)
+import Distribution.Client.Utils (tryFindAddSourcePackageDesc)
 
 -- | 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).
-allPackageSourceFiles :: Verbosity -> SetupScriptOptions -> FilePath
-                         -> IO [FilePath]
-allPackageSourceFiles verbosity setupOpts0 packageDir = do
-  pkg <- do
+--
+-- Used in sandbox and projectbuilding.
+-- TODO: when sandboxes are removed, move to ProjectBuilding.
+--
+allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]
+allPackageSourceFiles verbosity packageDir = do
+  pd <- do
     let err = "Error reading source files of package."
     desc <- tryFindAddSourcePackageDesc verbosity packageDir err
     flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc
-  globalTmp <- getTemporaryDirectory
-  withTempDirectory verbosity globalTmp "cabal-list-sources." $ \tempDir -> do
-    let file      = tempDir </> "cabal-sdist-list-sources"
-        flags     = defaultSDistFlags {
-          sDistVerbosity   = Flag $ if verbosity == normal
-                                    then lessVerbose verbosity else verbosity,
-          sDistListSources = Flag file
-          }
-        setupOpts = setupOpts0 {
-          -- 'sdist --list-sources' was introduced in Cabal 1.18.
-          useCabalVersion = intersectVersionRanges
-                              (orLaterVersion $ mkVersion [1,18,0])
-                              (useCabalVersion setupOpts0),
-          useWorkingDir = Just packageDir
-          }
-
-        doListSources :: IO [FilePath]
-        doListSources = do
-          setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags) (const [])
-          fmap lines . readFile $ file
 
-        onFailedListSources :: IOException -> IO ()
-        onFailedListSources e = do
-          warn verbosity $
-            "Could not list sources of the package '"
-            ++ prettyShow (packageName pkg) ++ "'."
-          warn verbosity $
-            "Exception was: " ++ show e
+  listPackageSourcesWithDie verbosity (\_ _ -> return []) packageDir pd knownSuffixHandlers
 
-    -- Run setup sdist --list-sources=TMPFILE
-    r <- doListSources `catchIO` (\e -> onFailedListSources e >> return [])
-    -- Ensure that we've closed the 'readFile' handle before we exit the
-    -- temporary directory.
-    _ <- evaluate (length r)
-    return r

cabal-install/Distribution/Client/SrcDist.hs

@@ -16,6 +16,5 @@ On benchmark 'Bench' an 'autogen-module' is not on 'other-modules'
 Packages using 'cabal-version: 2.0' and the autogenerated module Paths_* must include it also on the 'autogen-modules' field besides 'exposed-modules' and 'other-modules'. This specifies that the module does not come with the package and is generated on setup. Modules built with a custom Setup.hs script also go here to ensure that commands like sdist don't fail.
 The filename ./my.cabal does not match package name (expected: AutogenModules.cabal)
 Note: the public hackage server would reject this package.
-Warning: Cannot run preprocessors. Run 'configure' command first.
 Building source dist for AutogenModules-0.1...
 cabal: Error: Could not find module: MyLibHelperModule with any suffix: ["gc","chs","hsc","x","y","ly","cpphs","hs","lhs","hsig","lhsig"]. If the module is autogenerated it should be added to 'autogen-modules'.

cabal-testsuite/PackageTests/AutogenModules/Package/setup.cabal.out

@@ -16,6 +16,5 @@ On benchmark 'Bench' an 'autogen-module' is not on 'other-modules'
 Packages using 'cabal-version: 2.0' and the autogenerated module Paths_* must include it also on the 'autogen-modules' field besides 'exposed-modules' and 'other-modules'. This specifies that the module does not come with the package and is generated on setup. Modules built with a custom Setup.hs script also go here to ensure that commands like sdist don't fail.
 The filename ./my.cabal does not match package name (expected: AutogenModules.cabal)
 Note: the public hackage server would reject this package.
-Warning: Cannot run preprocessors. Run 'configure' command first.
 Building source dist for AutogenModules-0.1...
 setup: Error: Could not find module: MyLibHelperModule with any suffix: ["gc","chs","hsc","x","y","ly","cpphs","hs","lhs","hsig","lhsig"]. If the module is autogenerated it should be added to 'autogen-modules'.