module Distribution.Simple.SrcDist (
sdist,
printPackageProblems,
prepareTree,
createArchive,
prepareSnapshotTree,
snapshotVersion,
dateToSnapshotNumber,
) where
import Distribution.PackageDescription
( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) )
import Distribution.PackageDescription.Check
import Distribution.Package
( PackageIdentifier(pkgVersion), Package(..) )
import Distribution.Version
( Version(versionBranch), VersionRange(AnyVersion) )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, readUTF8File, writeUTF8File
, copyFiles, copyFileVerbose, findFile, findFileWithExtension
, withTempDirectory, dotToSep, defaultPackageDesc
, die, warn, notice, setupMessage )
import Distribution.Simple.Setup (SDistFlags(..), fromFlag)
import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessSources)
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
import Distribution.Simple.BuildPaths ( autogenModuleName )
import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram,
rawSystemProgram, tarProgram )
import Distribution.Text
( display )
import Control.Monad(when, unless)
import Data.Char (toLower)
import Data.List (partition, isPrefixOf)
import Data.Maybe (isNothing, catMaybes)
import System.Time (getClockTime, toCalendarTime, CalendarTime(..))
import System.Directory (doesFileExist, doesDirectoryExist)
import Distribution.Verbosity (Verbosity)
import System.FilePath
( (</>), (<.>), takeDirectory, dropExtension, isAbsolute )
sdist :: PackageDescription
-> Maybe LocalBuildInfo
-> SDistFlags
-> (FilePath -> FilePath)
-> [PPSuffixHandler]
-> IO ()
sdist pkg mb_lbi flags mkTmpDir pps = do
let distPref = fromFlag $ sDistDistPref flags
targetPref = distPref
tmpDir = mkTmpDir distPref
printPackageProblems verbosity pkg
exists <- doesDirectoryExist tmpDir
when exists $
die $ "Source distribution already in place. please move or remove: "
++ tmpDir
when (isNothing mb_lbi) $
warn verbosity "Cannot run preprocessors. Run 'configure' command first."
withTempDirectory verbosity tmpDir $ do
setupMessage verbosity "Building source dist for" (packageId pkg)
if snapshot
then getClockTime >>= toCalendarTime
>>= prepareSnapshotTree verbosity pkg mb_lbi distPref tmpDir pps
else prepareTree verbosity pkg mb_lbi distPref tmpDir pps
targzFile <- createArchive verbosity pkg mb_lbi tmpDir targetPref
notice verbosity $ "Source tarball created: " ++ targzFile
where
verbosity = fromFlag (sDistVerbosity flags)
snapshot = fromFlag (sDistSnapshot flags)
prepareTree :: Verbosity
-> PackageDescription
-> Maybe LocalBuildInfo
-> FilePath
-> FilePath
-> [PPSuffixHandler]
-> IO FilePath
prepareTree verbosity pkg_descr mb_lbi distPref tmpDir pps = do
let targetDir = tmpDir </> tarBallName pkg_descr
createDirectoryIfMissingVerbose verbosity True targetDir
withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->
prepareDir verbosity pkg_descr distPref targetDir pps modules libBi
withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do
prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi
srcMainFile <- do
ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath)
case ppFile of
Nothing -> findFile (hsSourceDirs exeBi) mainPath
Just pp -> return pp
copyFileTo verbosity targetDir srcMainFile
flip mapM_ (dataFiles pkg_descr) $ \ filename -> do
let file = dataDir pkg_descr </> filename
dir = takeDirectory file
createDirectoryIfMissingVerbose verbosity True (targetDir </> dir)
copyFileVerbose verbosity file (targetDir </> file)
when (not (null (licenseFile pkg_descr))) $
copyFileTo verbosity targetDir (licenseFile pkg_descr)
flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do
copyFileTo verbosity targetDir fpath
withLib $ \ l -> do
let lbi = libBuildInfo l
relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)
incs <- mapM (findInc relincdirs) (installIncludes lbi)
flip mapM_ incs $ \(_,fpath) ->
copyFileTo verbosity targetDir fpath
case mb_lbi of
Just lbi | not (null pps)
-> preprocessSources pkg_descr (lbi { buildDir = targetDir </> buildDir lbi })
True verbosity pps
_ -> return ()
hsExists <- doesFileExist "Setup.hs"
lhsExists <- doesFileExist "Setup.lhs"
if hsExists then copyFileTo verbosity targetDir "Setup.hs"
else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs"
else writeUTF8File (targetDir </> "Setup.hs") $ unlines [
"import Distribution.Simple",
"main = defaultMain"]
descFile <- defaultPackageDesc verbosity
copyFileVerbose verbosity descFile (targetDir </> descFile)
return targetDir
where
findInc [] f = die ("can't find include file " ++ f)
findInc (d:ds) f = do
let path = (d </> f)
b <- doesFileExist path
if b then return (f,path) else findInc ds f
withLib action = maybe (return ()) action (library pkg_descr)
withExe action = mapM_ action (executables pkg_descr)
prepareSnapshotTree :: Verbosity
-> PackageDescription
-> Maybe LocalBuildInfo
-> FilePath
-> FilePath
-> [PPSuffixHandler]
-> CalendarTime
-> IO FilePath
prepareSnapshotTree verbosity pkg mb_lbi distPref tmpDir pps date = do
let pkgid = packageId pkg
pkgver' = snapshotVersion date (pkgVersion pkgid)
pkg' = pkg { package = pkgid { pkgVersion = pkgver' } }
targetDir <- prepareTree verbosity pkg' mb_lbi distPref tmpDir pps
overwriteSnapshotPackageDesc pkgver' targetDir
return targetDir
where
overwriteSnapshotPackageDesc version targetDir = do
descFile <- defaultPackageDesc verbosity
writeUTF8File (targetDir </> descFile)
. unlines . map (replaceVersion version) . lines
=<< readUTF8File descFile
replaceVersion :: Version -> String -> String
replaceVersion version line
| "version:" `isPrefixOf` map toLower line
= "version: " ++ display version
| otherwise = line
snapshotVersion :: CalendarTime -> Version -> Version
snapshotVersion date version = version {
versionBranch = versionBranch version
++ [dateToSnapshotNumber date]
}
dateToSnapshotNumber :: CalendarTime -> Int
dateToSnapshotNumber date = year * 10000
+ month * 100
+ day
where
year = ctYear date
month = fromEnum (ctMonth date) + 1
day = ctDay date
createArchive :: Verbosity
-> PackageDescription
-> Maybe LocalBuildInfo
-> FilePath
-> FilePath
-> IO FilePath
createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do
let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz"
(tarProg, _) <- requireProgram verbosity tarProgram AnyVersion
(maybe defaultProgramConfiguration withPrograms mb_lbi)
rawSystemProgram verbosity tarProg
["-C", tmpDir, "-czf", tarBallFilePath, tarBallName pkg_descr]
return tarBallFilePath
prepareDir :: Verbosity
-> PackageDescription
-> FilePath
-> FilePath
-> [PPSuffixHandler]
-> [String]
-> BuildInfo
-> IO ()
prepareDir verbosity pkg distPref inPref pps modules bi
= do let searchDirs = hsSourceDirs bi ++ [autogenModulesDir]
autogenModulesDir = distPref </> "build" </> "autogen"
autogenFile = autogenModulesDir </> autogenModuleName pkg <.> "hs"
sources <- filter (/=autogenFile) `fmap` sequence
[ let file = dotToSep module_
in findFileWithExtension suffixes searchDirs file
>>= maybe (notFound module_) return
| module_ <- modules ++ otherModules bi ]
bootFiles <- sequence
[ let file = dotToSep module_
in findFileWithExtension ["hs-boot"] (hsSourceDirs bi) file
| module_ <- modules ++ otherModules bi ]
let allSources = sources ++ catMaybes bootFiles ++ cSources bi
copyFiles verbosity inPref (zip (repeat []) allSources)
where suffixes = ppSuffixes pps ++ ["hs", "lhs"]
notFound m = die $ "Error: Could not find module: " ++ m
++ " with any suffix: " ++ show suffixes
copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()
copyFileTo verbosity dir file = do
let targetFile = dir </> file
createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)
copyFileVerbose verbosity file targetFile
printPackageProblems :: Verbosity -> PackageDescription -> IO ()
printPackageProblems verbosity pkg_descr = do
ioChecks <- checkPackageFiles pkg_descr "."
let pureChecks = checkConfiguredPackage pkg_descr
isDistError (PackageDistSuspicious _) = False
isDistError _ = True
(errors, warnings) = partition isDistError (pureChecks ++ ioChecks)
unless (null errors) $
notice verbosity $ "Distribution quality errors:\n"
++ unlines (map explanation errors)
unless (null warnings) $
notice verbosity $ "Distribution quality warnings:\n"
++ unlines (map explanation warnings)
unless (null errors) $
notice verbosity
"Note: the public hackage server would reject this package."
tarBallName :: PackageDescription -> String
tarBallName = display . packageId