Unverified Commit c5d4b7ce authored by Oleg Grenrus's avatar Oleg Grenrus Committed by GitHub
Browse files

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

Fix sdist permissions
parents 95a6ee3b b2ee5e6f
...@@ -413,31 +413,12 @@ installAction hooks flags args = do ...@@ -413,31 +413,12 @@ installAction hooks flags args = do
(getBuildConfig hooks verbosity distPref) (getBuildConfig hooks verbosity distPref)
hooks flags' args hooks flags' args
-- Since Cabal-3.4 UserHooks are completely ignored
sdistAction :: UserHooks -> SDistFlags -> Args -> IO () sdistAction :: UserHooks -> SDistFlags -> Args -> IO ()
sdistAction hooks flags _args = do sdistAction _hooks flags _args = do
distPref <- findDistPrefOrDefault (sDistDistPref flags) (_, ppd) <- confPkgDescr emptyUserHooks verbosity Nothing
let pbi = emptyHookedBuildInfo let pkg_descr = flattenPackageDescription ppd
sdist pkg_descr flags srcPref knownSuffixHandlers
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)
where where
verbosity = fromFlag (sDistVerbosity flags) verbosity = fromFlag (sDistVerbosity flags)
......
...@@ -39,7 +39,8 @@ module Distribution.Simple.SrcDist ( ...@@ -39,7 +39,8 @@ module Distribution.Simple.SrcDist (
dateToSnapshotNumber, dateToSnapshotNumber,
-- * Extracting the source files -- * Extracting the source files
listPackageSources listPackageSources,
listPackageSourcesWithDie,
) where ) where
...@@ -57,7 +58,6 @@ import Distribution.Simple.Glob ...@@ -57,7 +58,6 @@ import Distribution.Simple.Glob
import Distribution.Simple.Utils import Distribution.Simple.Utils
import Distribution.Simple.Setup import Distribution.Simple.Setup
import Distribution.Simple.PreProcess import Distribution.Simple.PreProcess
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.BuildPaths import Distribution.Simple.BuildPaths
import Distribution.Simple.Program import Distribution.Simple.Program
import Distribution.Pretty import Distribution.Pretty
...@@ -73,33 +73,28 @@ import System.FilePath ((</>), (<.>), dropExtension, isRelative) ...@@ -73,33 +73,28 @@ import System.FilePath ((</>), (<.>), dropExtension, isRelative)
import Control.Monad import Control.Monad
-- |Create a source distribution. -- |Create a source distribution.
sdist :: PackageDescription -- ^information from the tarball sdist :: PackageDescription -- ^ information from the tarball
-> Maybe LocalBuildInfo -- ^Information from configure -> SDistFlags -- ^ verbosity & snapshot
-> SDistFlags -- ^verbosity & snapshot -> (FilePath -> FilePath) -- ^ build prefix (temp dir)
-> (FilePath -> FilePath) -- ^build prefix (temp dir)
-> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes)
-> IO () -> IO ()
sdist pkg mb_lbi flags mkTmpDir pps = do sdist pkg flags mkTmpDir pps = do
distPref <- findDistPrefOrDefault $ sDistDistPref flags distPref <- findDistPrefOrDefault $ sDistDistPref flags
let targetPref = distPref let targetPref = distPref
tmpTargetDir = mkTmpDir distPref tmpTargetDir = mkTmpDir distPref
-- When given --list-sources, just output the list of sources to a file. -- When given --list-sources, just output the list of sources to a file.
case (sDistListSources flags) of case sDistListSources flags of
Flag path -> withFile path WriteMode $ \outHandle -> do Flag path -> withFile path WriteMode $ \outHandle -> do
(ordinary, maybeExecutable) <- listPackageSources verbosity pkg pps ordinary <- listPackageSources verbosity "." pkg pps
traverse_ (hPutStrLn outHandle) ordinary traverse_ (hPutStrLn outHandle) ordinary
traverse_ (hPutStrLn outHandle) maybeExecutable notice verbosity $ "List of package sources written to file '" ++ path ++ "'"
notice verbosity $ "List of package sources written to file '"
++ path ++ "'"
NoFlag -> do NoFlag -> do
-- do some QA -- do some QA
printPackageProblems verbosity pkg printPackageProblems verbosity pkg
when (isNothing mb_lbi) $
warn verbosity "Cannot run preprocessors. Run 'configure' command first."
date <- getCurrentTime date <- getCurrentTime
let pkg' | snapshot = snapshotPackage date pkg let pkg' | snapshot = snapshotPackage date pkg
| otherwise = pkg | otherwise = pkg
...@@ -114,49 +109,64 @@ sdist pkg mb_lbi flags mkTmpDir pps = do ...@@ -114,49 +109,64 @@ sdist pkg mb_lbi flags mkTmpDir pps = do
withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
let targetDir = tmpDir </> tarBallName pkg' let targetDir = tmpDir </> tarBallName pkg'
generateSourceDir targetDir pkg' generateSourceDir targetDir pkg'
targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref targzFile <- createArchive verbosity pkg' tmpDir targetPref
notice verbosity $ "Source tarball created: " ++ targzFile notice verbosity $ "Source tarball created: " ++ targzFile
where where
generateSourceDir :: FilePath -> PackageDescription -> IO ()
generateSourceDir targetDir pkg' = do generateSourceDir targetDir pkg' = do
setupMessage verbosity "Building source dist for" (packageId pkg') setupMessage verbosity "Building source dist for" (packageId pkg')
prepareTree verbosity pkg' mb_lbi targetDir pps prepareTree verbosity pkg' targetDir pps
when snapshot $ when snapshot $
overwriteSnapshotPackageDesc verbosity pkg' targetDir overwriteSnapshotPackageDesc verbosity pkg' targetDir
verbosity = fromFlag (sDistVerbosity flags) verbosity = fromFlag (sDistVerbosity flags)
snapshot = fromFlag (sDistSnapshot flags) snapshot = fromFlag (sDistSnapshot flags)
-- | List all source files of a package. Returns a tuple of lists: first -- | List all source files of a package.
-- component is a list of ordinary files, second one is a list of those files --
-- that may be executable. -- Since @Cabal-3.4@ returns a single list. There shouldn't be any
listPackageSources :: Verbosity -- ^ verbosity -- executable files, they are hardly portable.
-> PackageDescription -- ^ info from the cabal file --
-> [PPSuffixHandler] -- ^ extra preprocessors (include listPackageSources
-- suffixes) :: Verbosity -- ^ verbosity
-> IO ([FilePath], [FilePath]) -> FilePath -- ^ directory with cabal file
listPackageSources verbosity pkg_descr0 pps = do -> PackageDescription -- ^ info from the cabal file
-- Call helpers that actually do all work. -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes)
ordinary <- listPackageSourcesOrdinary verbosity pkg_descr pps -> IO [FilePath] -- ^ relative paths
maybeExecutable <- listPackageSourcesMaybeExecutable verbosity pkg_descr listPackageSources verbosity cwd pkg_descr0 pps = do
return (ordinary, maybeExecutable) -- Call helpers that actually do all work.
listPackageSources' verbosity die' cwd pkg_descr pps
where where
pkg_descr = filterAutogenModules pkg_descr0 pkg_descr = filterAutogenModules pkg_descr0
-- | List those source files that may be executable (e.g. the configure script). -- | A variant of 'listPackageSources' with configurable 'die'.
listPackageSourcesMaybeExecutable :: Verbosity -> PackageDescription -> IO [FilePath] --
listPackageSourcesMaybeExecutable verbosity pkg_descr = -- /Note:/ may still 'die' directly. For example on missing include file.
-- Extra source files. --
fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> -- Since @3.4.0.0
matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath listPackageSourcesWithDie
:: Verbosity -- ^ verbosity
-- | List those source files that should be copied with ordinary permissions. -> (Verbosity -> String -> IO [FilePath]) -- ^ 'die'' alternative
listPackageSourcesOrdinary :: Verbosity -> FilePath -- ^ directory with cabal file
-> PackageDescription -> PackageDescription -- ^ info from the cabal file
-> [PPSuffixHandler] -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes)
-> IO [FilePath] -> IO [FilePath] -- ^ relative paths
listPackageSourcesOrdinary verbosity pkg_descr pps = listPackageSourcesWithDie verbosity rip cwd pkg_descr0 pps = do
-- Call helpers that actually do all work.
listPackageSources' verbosity rip cwd pkg_descr pps
where
pkg_descr = filterAutogenModules pkg_descr0
listPackageSources'
:: Verbosity
-> (Verbosity -> String -> IO [FilePath])
-> FilePath
-> PackageDescription
-> [PPSuffixHandler]
-> IO [FilePath]
listPackageSources' verbosity rip cwd pkg_descr pps =
fmap concat . sequenceA $ fmap concat . sequenceA $
[ [
-- Library sources. -- Library sources.
...@@ -166,20 +176,20 @@ listPackageSourcesOrdinary verbosity pkg_descr pps = ...@@ -166,20 +176,20 @@ listPackageSourcesOrdinary verbosity pkg_descr pps =
signatures = sigs, signatures = sigs,
libBuildInfo = libBi libBuildInfo = libBi
} -> } ->
allSourcesBuildInfo verbosity libBi pps (modules ++ sigs) allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs)
-- Executables sources. -- Executables sources.
, fmap concat , fmap concat
. withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do . withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do
biSrcs <- allSourcesBuildInfo verbosity exeBi pps [] biSrcs <- allSourcesBuildInfo verbosity rip cwd exeBi pps []
mainSrc <- findMainExeFile verbosity exeBi pps mainPath mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath
return (mainSrc:biSrcs) return (mainSrc:biSrcs)
-- Foreign library sources -- Foreign library sources
, fmap concat , fmap concat
. withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do . withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do
biSrcs <- allSourcesBuildInfo verbosity flibBi pps [] biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps []
defFiles <- mapM (findModDefFile verbosity flibBi pps) defFiles <- mapM (findModDefFile verbosity cwd flibBi pps)
(foreignLibModDefFile flib) (foreignLibModDefFile flib)
return (defFiles ++ biSrcs) return (defFiles ++ biSrcs)
...@@ -189,13 +199,13 @@ listPackageSourcesOrdinary verbosity pkg_descr pps = ...@@ -189,13 +199,13 @@ listPackageSourcesOrdinary verbosity pkg_descr pps =
let bi = testBuildInfo t let bi = testBuildInfo t
case testInterface t of case testInterface t of
TestSuiteExeV10 _ mainPath -> do TestSuiteExeV10 _ mainPath -> do
biSrcs <- allSourcesBuildInfo verbosity bi pps [] biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []
srcMainFile <- findMainExeFile verbosity bi pps mainPath srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath
return (srcMainFile:biSrcs) return (srcMainFile:biSrcs)
TestSuiteLibV09 _ m -> TestSuiteLibV09 _ m ->
allSourcesBuildInfo verbosity bi pps [m] allSourcesBuildInfo verbosity rip cwd bi pps [m]
TestSuiteUnsupported tp -> TestSuiteUnsupported tp ->
die' verbosity $ "Unsupported test suite type: " ++ show tp rip verbosity $ "Unsupported test suite type: " ++ show tp
-- Benchmarks sources. -- Benchmarks sources.
, fmap concat , fmap concat
...@@ -203,11 +213,11 @@ listPackageSourcesOrdinary verbosity pkg_descr pps = ...@@ -203,11 +213,11 @@ listPackageSourcesOrdinary verbosity pkg_descr pps =
let bi = benchmarkBuildInfo bm let bi = benchmarkBuildInfo bm
case benchmarkInterface bm of case benchmarkInterface bm of
BenchmarkExeV10 _ mainPath -> do BenchmarkExeV10 _ mainPath -> do
biSrcs <- allSourcesBuildInfo verbosity bi pps [] biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []
srcMainFile <- findMainExeFile verbosity bi pps mainPath srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath
return (srcMainFile:biSrcs) return (srcMainFile:biSrcs)
BenchmarkUnsupported tp -> die' verbosity $ "Unsupported benchmark type: " BenchmarkUnsupported tp ->
++ show tp rip verbosity $ "Unsupported benchmark type: " ++ show tp
-- Data files. -- Data files.
, fmap concat , fmap concat
...@@ -216,13 +226,17 @@ listPackageSourcesOrdinary verbosity pkg_descr pps = ...@@ -216,13 +226,17 @@ listPackageSourcesOrdinary verbosity pkg_descr pps =
srcDataDir = if null srcDataDirRaw srcDataDir = if null srcDataDirRaw
then "." then "."
else srcDataDirRaw else srcDataDirRaw
in fmap (fmap (srcDataDir </>)) $ in fmap (fmap (\p -> cwd </> srcDataDir </> p)) $
matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir filename matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir filename
-- Extra source files.
, fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->
matchDirFileGlob verbosity (specVersion pkg_descr) cwd fpath
-- Extra doc files. -- Extra doc files.
, fmap concat , fmap concat
. for (extraDocFiles pkg_descr) $ \ filename -> . for (extraDocFiles pkg_descr) $ \ filename ->
matchDirFileGlob verbosity (specVersion pkg_descr) "." filename matchDirFileGlob verbosity (specVersion pkg_descr) cwd filename
-- License file(s). -- License file(s).
, return (licenseFiles pkg_descr) , return (licenseFiles pkg_descr)
...@@ -233,13 +247,13 @@ listPackageSourcesOrdinary verbosity pkg_descr pps = ...@@ -233,13 +247,13 @@ listPackageSourcesOrdinary verbosity pkg_descr pps =
let lbi = libBuildInfo l let lbi = libBuildInfo l
incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi) incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi)
relincdirs = "." : filter isRelative (includeDirs lbi) relincdirs = "." : filter isRelative (includeDirs lbi)
traverse (fmap snd . findIncludeFile verbosity relincdirs) incls traverse (fmap snd . findIncludeFile verbosity cwd relincdirs) incls
-- Setup script, if it exists. -- Setup script, if it exists.
, fmap (maybe [] (\f -> [f])) $ findSetupFile "" , fmap (maybe [] (\f -> [f])) $ findSetupFile cwd
-- The .cabal file itself. -- The .cabal file itself.
, fmap (\d -> [d]) (defaultPackageDesc verbosity) , fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".")
] ]
where where
...@@ -255,41 +269,29 @@ listPackageSourcesOrdinary verbosity pkg_descr pps = ...@@ -255,41 +269,29 @@ listPackageSourcesOrdinary verbosity pkg_descr pps =
-- |Prepare a directory tree of source files. -- |Prepare a directory tree of source files.
prepareTree :: Verbosity -- ^verbosity prepareTree :: Verbosity -- ^verbosity
-> PackageDescription -- ^info from the cabal file -> PackageDescription -- ^info from the cabal file
-> Maybe LocalBuildInfo
-> FilePath -- ^source tree to populate -> FilePath -- ^source tree to populate
-> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes)
-> IO () -> IO ()
prepareTree verbosity pkg_descr0 mb_lbi targetDir pps = do prepareTree verbosity pkg_descr0 targetDir pps = do
-- If the package was configured then we can run platform-independent ordinary <- listPackageSources verbosity "." pkg_descr pps
-- pre-processors and include those generated files. installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary)
case mb_lbi of maybeCreateDefaultSetupScript targetDir
Just lbi | not (null pps) -> do
let lbi' = lbi{ buildDir = targetDir </> buildDir lbi }
withAllComponentsInBuildOrder pkg_descr lbi' $ \c clbi ->
preprocessComponent pkg_descr c lbi' clbi True verbosity pps
_ -> return ()
(ordinary, mExecutable) <- listPackageSources verbosity pkg_descr0 pps
installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary)
installMaybeExecutableFiles verbosity targetDir (zip (repeat []) mExecutable)
maybeCreateDefaultSetupScript targetDir
where where
pkg_descr = filterAutogenModules pkg_descr0 pkg_descr = filterAutogenModules pkg_descr0
-- | Find the setup script file, if it exists. -- | Find the setup script file, if it exists.
findSetupFile :: FilePath -> IO (Maybe FilePath) findSetupFile :: FilePath -> IO (Maybe FilePath)
findSetupFile targetDir = do findSetupFile targetDir = do
hsExists <- doesFileExist setupHs hsExists <- doesFileExist (targetDir </> setupHs)
lhsExists <- doesFileExist setupLhs lhsExists <- doesFileExist (targetDir </> setupLhs)
if hsExists if hsExists
then return (Just setupHs) then return (Just setupHs)
else if lhsExists else if lhsExists
then return (Just setupLhs) then return (Just setupLhs)
else return Nothing else return Nothing
where where
setupHs = targetDir </> "Setup.hs" setupHs = "Setup.hs"
setupLhs = targetDir </> "Setup.lhs" setupLhs = "Setup.lhs"
-- | Create a default setup script in the target directory, if it doesn't exist. -- | Create a default setup script in the target directory, if it doesn't exist.
maybeCreateDefaultSetupScript :: FilePath -> IO () maybeCreateDefaultSetupScript :: FilePath -> IO ()
...@@ -304,31 +306,36 @@ maybeCreateDefaultSetupScript targetDir = do ...@@ -304,31 +306,36 @@ maybeCreateDefaultSetupScript targetDir = do
-- | Find the main executable file. -- | Find the main executable file.
findMainExeFile findMainExeFile
:: Verbosity -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath :: Verbosity
findMainExeFile verbosity exeBi pps mainPath = do -> FilePath -- ^ cwd
ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) -> BuildInfo
-> [PPSuffixHandler]
-> FilePath -- ^ main-is
-> IO FilePath
findMainExeFile verbosity cwd exeBi pps mainPath = do
ppFile <- findFileCwdWithExtension cwd (ppSuffixes pps) (hsSourceDirs exeBi)
(dropExtension mainPath) (dropExtension mainPath)
case ppFile of case ppFile of
Nothing -> findFileEx verbosity (hsSourceDirs exeBi) mainPath Nothing -> findFileCwd verbosity cwd (hsSourceDirs exeBi) mainPath
Just pp -> return pp Just pp -> return pp
-- | Find a module definition file -- | Find a module definition file
-- --
-- TODO: I don't know if this is right -- TODO: I don't know if this is right
findModDefFile findModDefFile
:: Verbosity -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath :: Verbosity -> FilePath -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath
findModDefFile verbosity flibBi _pps modDefPath = findModDefFile verbosity cwd flibBi _pps modDefPath =
findFileEx verbosity (".":hsSourceDirs flibBi) modDefPath findFileCwd verbosity cwd (".":hsSourceDirs flibBi) modDefPath
-- | Given a list of include paths, try to find the include file named -- | Given a list of include paths, try to find the include file named
-- @f@. Return the name of the file and the full path, or exit with error if -- @f@. Return the name of the file and the full path, or exit with error if
-- there's no such file. -- there's no such file.
findIncludeFile :: Verbosity -> [FilePath] -> String -> IO (String, FilePath) findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath)
findIncludeFile verbosity [] f = die' verbosity ("can't find include file " ++ f) findIncludeFile verbosity _ [] f = die' verbosity ("can't find include file " ++ f)
findIncludeFile verbosity (d:ds) f = do findIncludeFile verbosity cwd (d:ds) f = do
let path = (d </> f) let path = (d </> f)
b <- doesFileExist path b <- doesFileExist (cwd </> path)
if b then return (f,path) else findIncludeFile verbosity ds f if b then return (f,path) else findIncludeFile verbosity cwd ds f
-- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' -- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules'
-- and 'other-modules'. -- and 'other-modules'.
...@@ -353,15 +360,14 @@ filterAutogenModules pkg_descr0 = mapLib filterAutogenModuleLib $ ...@@ -353,15 +360,14 @@ filterAutogenModules pkg_descr0 = mapLib filterAutogenModuleLib $
-- It is expected that the appropriate snapshot version has already been set -- It is expected that the appropriate snapshot version has already been set
-- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. -- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'.
-- --
prepareSnapshotTree :: Verbosity -- ^verbosity prepareSnapshotTree
-> PackageDescription -- ^info from the cabal file :: Verbosity -- ^verbosity
-> Maybe LocalBuildInfo -> PackageDescription -- ^info from the cabal file
-> FilePath -- ^source tree to populate -> FilePath -- ^source tree to populate
-> [PPSuffixHandler] -- ^extra preprocessors (includes -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes)
-- suffixes) -> IO ()
-> IO () prepareSnapshotTree verbosity pkg targetDir pps = do
prepareSnapshotTree verbosity pkg mb_lbi targetDir pps = do prepareTree verbosity pkg targetDir pps
prepareTree verbosity pkg mb_lbi targetDir pps
overwriteSnapshotPackageDesc verbosity pkg targetDir overwriteSnapshotPackageDesc verbosity pkg targetDir
overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity
...@@ -409,21 +415,16 @@ dateToSnapshotNumber date = case toGregorian (utctDay date) of ...@@ -409,21 +415,16 @@ dateToSnapshotNumber date = case toGregorian (utctDay date) of
+ month * 100 + month * 100
+ day + day
-- | Callback type for use by sdistWith.
type CreateArchiveFun = Verbosity -- ^verbosity
-> PackageDescription -- ^info from cabal file
-> Maybe LocalBuildInfo -- ^info from configure
-> FilePath -- ^source tree to archive
-> FilePath -- ^name of archive to create
-> IO FilePath
-- | Create an archive from a tree of source files, and clean up the tree. -- | Create an archive from a tree of source files, and clean up the tree.
createArchive :: CreateArchiveFun createArchive
createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do :: Verbosity -- ^ verbosity
-> PackageDescription -- ^ info from cabal file
-> FilePath -- ^ source tree to archive
-> FilePath -- ^ name of archive to create
-> IO FilePath
createArchive verbosity pkg_descr tmpDir targetPref = do
let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz" let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz"
(tarProg, _) <- requireProgram verbosity tarProgram defaultProgramDb
(tarProg, _) <- requireProgram verbosity tarProgram
(maybe defaultProgramDb withPrograms mb_lbi)
let formatOptSupported = maybe False (== "YES") $ let formatOptSupported = maybe False (== "YES") $
Map.lookup "Supports --format" Map.lookup "Supports --format"
(programProperties tarProg) (programProperties tarProg)
...@@ -438,25 +439,28 @@ createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do ...@@ -438,25 +439,28 @@ createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do
return tarBallFilePath return tarBallFilePath
-- | Given a buildinfo, return the names of all source files. -- | Given a buildinfo, return the names of all source files.
allSourcesBuildInfo :: Verbosity allSourcesBuildInfo
-> BuildInfo :: Verbosity
-> [PPSuffixHandler] -- ^ Extra preprocessors -> (Verbosity -> String -> IO [FilePath])
-> [ModuleName] -- ^ Exposed modules -> FilePath -- ^ cwd
-> IO [FilePath] -> BuildInfo
allSourcesBuildInfo verbosity bi pps modules = do -> [PPSuffixHandler] -- ^ Extra preprocessors
-> [ModuleName] -- ^ Exposed modules
-> IO [FilePath]
allSourcesBuildInfo verbosity rip cwd bi pps modules = do
let searchDirs = hsSourceDirs bi let searchDirs = hsSourceDirs bi
sources <- fmap concat $ sequenceA $ sources <- fmap concat $ sequenceA $
[ let file = ModuleName.toFilePath module_ [ let file = ModuleName.toFilePath module_
-- NB: *Not* findFileWithExtension, because the same source -- NB: *Not* findFileWithExtension, because the same source
-- file may show up in multiple paths due to a conditional; -- file may show up in multiple paths due to a conditional;
-- we need to package all of them. See #367. -- we need to package all of them. See #367.
in findAllFilesWithExtension suffixes searchDirs file in findAllFilesCwdWithExtension cwd suffixes searchDirs file
>>= nonEmpty (notFound module_) return >>= nonEmpty (notFound module_) return
| module_ <- modules ++ otherModules bi ] | module_ <- modules ++ otherModules bi ]
bootFiles <- sequenceA bootFiles <- sequenceA
[ let file = ModuleName.toFilePath module_ [ let file = ModuleName.toFilePath module_
fileExts = ["hs-boot", "lhs-boot"] fileExts = ["hs-boot", "lhs-boot"]
in findFileWithExtension fileExts (hsSourceDirs bi) file in findFileCwdWithExtension cwd fileExts (hsSourceDirs bi) file
| module_ <- modules ++ otherModules bi ]<