module Distribution.Simple.SrcDist (
sdist,
printPackageProblems,
prepareTree,
createArchive,
prepareSnapshotTree,
snapshotPackage,
snapshotVersion,
dateToSnapshotNumber,
) where
import Distribution.PackageDescription
( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) )
import Distribution.PackageDescription.Check
( PackageCheck(..), checkConfiguredPackage, checkPackageFiles )
import Distribution.Package
( PackageIdentifier(pkgVersion), Package(..), packageVersion )
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as ModuleName
import Distribution.Version
( Version(versionBranch) )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File
, installOrdinaryFile, installOrdinaryFiles
, findFile, findFileWithExtension, matchFileGlob
, withTempDirectory, 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, Permissions(executable), getPermissions )
import Distribution.Compat.CopyFile (setFileExecutable)
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
tmpTargetDir = mkTmpDir distPref
printPackageProblems verbosity pkg
when (isNothing mb_lbi) $
warn verbosity "Cannot run preprocessors. Run 'configure' command first."
createDirectoryIfMissingVerbose verbosity True tmpTargetDir
withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
date <- toCalendarTime =<< getClockTime
let pkg' | snapshot = snapshotPackage date pkg
| otherwise = pkg
setupMessage verbosity "Building source dist for" (packageId pkg')
_ <- if snapshot
then 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_descr0 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
files <- matchFileGlob (dataDir pkg_descr </> filename)
let dir = takeDirectory (dataDir pkg_descr </> filename)
createDirectoryIfMissingVerbose verbosity True (targetDir </> dir)
sequence_ [ installOrdinaryFile verbosity file (targetDir </> file)
| file <- files ]
when (not (null (licenseFile pkg_descr))) $
copyFileTo verbosity targetDir (licenseFile pkg_descr)
flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do
files <- matchFileGlob fpath
sequence_
[ do copyFileTo verbosity targetDir file
perms <- getPermissions file
when (executable perms)
(setFileExecutable (targetDir </> file))
| file <- files ]
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
installOrdinaryFile verbosity descFile (targetDir </> descFile)
return targetDir
where
pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0
filterAutogenModule bi = bi {
otherModules = filter (/=autogenModule) (otherModules bi)
}
autogenModule = autogenModuleName pkg_descr0
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]
-> IO FilePath
prepareSnapshotTree verbosity pkg mb_lbi distPref tmpDir pps = do
targetDir <- prepareTree verbosity pkg mb_lbi distPref tmpDir pps
overwriteSnapshotPackageDesc (packageVersion pkg) targetDir
return targetDir
where
overwriteSnapshotPackageDesc version targetDir = do
descFile <- defaultPackageDesc verbosity
withUTF8FileContents descFile $
writeUTF8File (targetDir </> descFile)
. unlines . map (replaceVersion version) . lines
replaceVersion :: Version -> String -> String
replaceVersion version line
| "version:" `isPrefixOf` map toLower line
= "version: " ++ display version
| otherwise = line
snapshotPackage :: CalendarTime -> PackageDescription -> PackageDescription
snapshotPackage date pkg =
pkg {
package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) }
}
where pkgid = packageId pkg
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
(maybe defaultProgramConfiguration withPrograms mb_lbi)
rawSystemProgram verbosity tarProg
["-C", tmpDir, "-czf", tarBallFilePath, tarBallName pkg_descr]
return tarBallFilePath
prepareDir :: Verbosity
-> PackageDescription
-> FilePath
-> FilePath
-> [PPSuffixHandler]
-> [ModuleName]
-> BuildInfo
-> IO ()
prepareDir verbosity _pkg _distPref inPref pps modules bi
= do let searchDirs = hsSourceDirs bi
sources <- sequence
[ let file = ModuleName.toFilePath module_
in findFileWithExtension suffixes searchDirs file
>>= maybe (notFound module_) return
| module_ <- modules ++ otherModules bi ]
bootFiles <- sequence
[ let file = ModuleName.toFilePath module_
fileExts = ["hs-boot", "lhs-boot"]
in findFileWithExtension fileExts (hsSourceDirs bi) file
| module_ <- modules ++ otherModules bi ]
let allSources = sources ++ catMaybes bootFiles ++ cSources bi
installOrdinaryFiles verbosity inPref (zip (repeat []) allSources)
where suffixes = ppSuffixes pps ++ ["hs", "lhs"]
notFound m = die $ "Error: Could not find module: " ++ display 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)
installOrdinaryFile 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
mapAllBuildInfo :: (BuildInfo -> BuildInfo)
-> (PackageDescription -> PackageDescription)
mapAllBuildInfo f pkg = pkg {
library = fmap mapLibBi (library pkg),
executables = fmap mapExeBi (executables pkg)
}
where
mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) }
mapExeBi exe = exe { buildInfo = f (buildInfo exe) }