Cabal/Distribution/Simple/SrcDist.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE RankNTypes #-}
   3
   4 -----------------------------------------------------------------------------
   5 -- |
   6 -- Module      :  Distribution.Simple.SrcDist
   7 -- Copyright   :  Simon Marlow 2004
   8 -- License     :  BSD3
   9 --
  10 -- Maintainer  :  cabal-devel@haskell.org
  11 -- Portability :  portable
  12 --
  13 -- This handles the @sdist@ command. The module exports an 'sdist' action but
  14 -- also some of the phases that make it up so that other tools can use just the
  15 -- bits they need. In particular the preparation of the tree of files to go
  16 -- into the source tarball is separated from actually building the source
  17 -- tarball.
  18 --
  19 -- The 'createArchive' action uses the external @tar@ program and assumes that
  20 -- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows.
  21 -- The 'sdist' action now also does some distribution QA checks.
  22
  23 -- NOTE: FIX: we don't have a great way of testing this module, since
  24 -- we can't easily look inside a tarball once its created.
  25
  26 module Distribution.Simple.SrcDist (
  27   -- * The top level action
  28   sdist,
  29
  30   -- ** Parts of 'sdist'
  31   printPackageProblems,
  32   prepareTree,
  33   createArchive,
  34
  35   -- ** Snapshots
  36   prepareSnapshotTree,
  37   snapshotPackage,
  38   snapshotVersion,
  39   dateToSnapshotNumber,
  40
  41   -- * Extracting the source files
  42   listPackageSources
  43
  44   )  where
  45
  46 import Prelude ()
  47 import Distribution.Compat.Prelude
  48
  49 import Distribution.PackageDescription hiding (Flag)
  50 import Distribution.PackageDescription.Check hiding (doesFileExist)
  51 import Distribution.Package
  52 import Distribution.ModuleName
  53 import qualified Distribution.ModuleName as ModuleName
  54 import Distribution.Version
  55 import Distribution.Simple.Glob
  56 import Distribution.Simple.Utils
  57 import Distribution.Simple.Setup
  58 import Distribution.Simple.PreProcess
  59 import Distribution.Simple.LocalBuildInfo
  60 import Distribution.Simple.BuildPaths
  61 import Distribution.Simple.Program
  62 import Distribution.Text
  63 import Distribution.Types.ForeignLib
  64 import Distribution.Verbosity
  65
  66 import Data.List (partition)
  67 import qualified Data.Map as Map
  68 import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay)
  69 import System.Directory ( doesFileExist )
  70 import System.IO (IOMode(WriteMode), hPutStrLn, withFile)
  71 import System.FilePath ((</>), (<.>), dropExtension, isRelative)
  72 import Control.Monad
  73
  74 -- |Create a source distribution.
  75 sdist :: PackageDescription     -- ^information from the tarball
  76       -> Maybe LocalBuildInfo   -- ^Information from configure
  77       -> SDistFlags             -- ^verbosity & snapshot
  78       -> (FilePath -> FilePath) -- ^build prefix (temp dir)
  79       -> [PPSuffixHandler]      -- ^ extra preprocessors (includes suffixes)
  80       -> IO ()
  81 sdist pkg mb_lbi flags mkTmpDir pps =
  82
  83   -- When given --list-sources, just output the list of sources to a file.
  84   case (sDistListSources flags) of
  85     Flag path -> withFile path WriteMode $ \outHandle -> do
  86       (ordinary, maybeExecutable) <- listPackageSources verbosity pkg pps
  87       traverse_ (hPutStrLn outHandle) ordinary
  88       traverse_ (hPutStrLn outHandle) maybeExecutable
  89       notice verbosity $ "List of package sources written to file '"
  90                          ++ path ++ "'"
  91     NoFlag    -> do
  92       -- do some QA
  93       printPackageProblems verbosity pkg
  94
  95       when (isNothing mb_lbi) $
  96         warn verbosity "Cannot run preprocessors. Run 'configure' command first."
  97
  98       date <- getCurrentTime
  99       let pkg' | snapshot  = snapshotPackage date pkg
 100                | otherwise = pkg
 101
 102       case flagToMaybe (sDistDirectory flags) of
 103         Just targetDir -> do
 104           generateSourceDir targetDir pkg'
 105           info verbosity $ "Source directory created: " ++ targetDir
 106
 107         Nothing -> do
 108           createDirectoryIfMissingVerbose verbosity True tmpTargetDir
 109           withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
 110             let targetDir = tmpDir </> tarBallName pkg'
 111             generateSourceDir targetDir pkg'
 112             targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref
 113             notice verbosity $ "Source tarball created: " ++ targzFile
 114
 115   where
 116     generateSourceDir targetDir pkg' = do
 117
 118       setupMessage verbosity "Building source dist for" (packageId pkg')
 119       prepareTree verbosity pkg' mb_lbi targetDir pps
 120       when snapshot $
 121         overwriteSnapshotPackageDesc verbosity pkg' targetDir
 122
 123     verbosity = fromFlag (sDistVerbosity flags)
 124     snapshot  = fromFlag (sDistSnapshot flags)
 125
 126     distPref     = fromFlag $ sDistDistPref flags
 127     targetPref   = distPref
 128     tmpTargetDir = mkTmpDir distPref
 129
 130 -- | List all source files of a package. Returns a tuple of lists: first
 131 -- component is a list of ordinary files, second one is a list of those files
 132 -- that may be executable.
 133 listPackageSources :: Verbosity          -- ^ verbosity
 134                    -> PackageDescription -- ^ info from the cabal file
 135                    -> [PPSuffixHandler]  -- ^ extra preprocessors (include
 136                                          -- suffixes)
 137                    -> IO ([FilePath], [FilePath])
 138 listPackageSources verbosity pkg_descr0 pps = do
 139   -- Call helpers that actually do all work.
 140   ordinary        <- listPackageSourcesOrdinary        verbosity pkg_descr pps
 141   maybeExecutable <- listPackageSourcesMaybeExecutable verbosity pkg_descr
 142   return (ordinary, maybeExecutable)
 143   where
 144     pkg_descr = filterAutogenModules pkg_descr0
 145
 146 -- | List those source files that may be executable (e.g. the configure script).
 147 listPackageSourcesMaybeExecutable :: Verbosity -> PackageDescription -> IO [FilePath]
 148 listPackageSourcesMaybeExecutable verbosity pkg_descr =
 149   -- Extra source files.
 150   fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->
 151     matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath
 152
 153 -- | List those source files that should be copied with ordinary permissions.
 154 listPackageSourcesOrdinary :: Verbosity
 155                            -> PackageDescription
 156                            -> [PPSuffixHandler]
 157                            -> IO [FilePath]
 158 listPackageSourcesOrdinary verbosity pkg_descr pps =
 159   fmap concat . sequenceA $
 160   [
 161     -- Library sources.
 162     fmap concat
 163     . withAllLib $ \Library {
 164                       exposedModules = modules,
 165                       signatures     = sigs,
 166                       libBuildInfo   = libBi
 167                     } ->
 168      allSourcesBuildInfo verbosity libBi pps (modules ++ sigs)
 169
 170     -- Executables sources.
 171   , fmap concat
 172     . withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do
 173        biSrcs  <- allSourcesBuildInfo verbosity exeBi pps []
 174        mainSrc <- findMainExeFile exeBi pps mainPath
 175        return (mainSrc:biSrcs)
 176
 177     -- Foreign library sources
 178   , fmap concat
 179     . withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do
 180        biSrcs   <- allSourcesBuildInfo verbosity flibBi pps []
 181        defFiles <- mapM (findModDefFile flibBi pps) (foreignLibModDefFile flib)
 182        return (defFiles ++ biSrcs)
 183
 184     -- Test suites sources.
 185   , fmap concat
 186     . withAllTest $ \t -> do
 187        let bi  = testBuildInfo t
 188        case testInterface t of
 189          TestSuiteExeV10 _ mainPath -> do
 190            biSrcs <- allSourcesBuildInfo verbosity bi pps []
 191            srcMainFile <- findMainExeFile bi pps mainPath
 192            return (srcMainFile:biSrcs)
 193          TestSuiteLibV09 _ m ->
 194            allSourcesBuildInfo verbosity bi pps [m]
 195          TestSuiteUnsupported tp -> die' verbosity $ "Unsupported test suite type: "
 196                                    ++ show tp
 197
 198     -- Benchmarks sources.
 199   , fmap concat
 200     . withAllBenchmark $ \bm -> do
 201        let  bi = benchmarkBuildInfo bm
 202        case benchmarkInterface bm of
 203          BenchmarkExeV10 _ mainPath -> do
 204            biSrcs <- allSourcesBuildInfo verbosity bi pps []
 205            srcMainFile <- findMainExeFile bi pps mainPath
 206            return (srcMainFile:biSrcs)
 207          BenchmarkUnsupported tp -> die' verbosity $ "Unsupported benchmark type: "
 208                                     ++ show tp
 209
 210     -- Data files.
 211   , fmap concat
 212     . for (dataFiles pkg_descr) $ \filename ->
 213         let srcDataDirRaw = dataDir pkg_descr
 214             srcDataDir = if null srcDataDirRaw
 215               then "."
 216               else srcDataDirRaw
 217         in fmap (fmap (srcDataDir </>)) $
 218              matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir filename
 219
 220     -- Extra doc files.
 221   , fmap concat
 222     . for (extraDocFiles pkg_descr) $ \ filename ->
 223         matchDirFileGlob verbosity (specVersion pkg_descr) "." filename
 224
 225     -- License file(s).
 226   , return (licenseFiles pkg_descr)
 227
 228     -- Install-include files.
 229   , fmap concat
 230     . withAllLib $ \ l -> do
 231        let lbi = libBuildInfo l
 232            relincdirs = "." : filter isRelative (includeDirs lbi)
 233        traverse (fmap snd . findIncludeFile verbosity relincdirs) (installIncludes lbi)
 234
 235     -- Setup script, if it exists.
 236   , fmap (maybe [] (\f -> [f])) $ findSetupFile ""
 237
 238     -- The .cabal file itself.
 239   , fmap (\d -> [d]) (defaultPackageDesc verbosity)
 240
 241   ]
 242   where
 243     -- We have to deal with all libs and executables, so we have local
 244     -- versions of these functions that ignore the 'buildable' attribute:
 245     withAllLib       action = traverse action (allLibraries pkg_descr)
 246     withAllFLib      action = traverse action (foreignLibs pkg_descr)
 247     withAllExe       action = traverse action (executables pkg_descr)
 248     withAllTest      action = traverse action (testSuites pkg_descr)
 249     withAllBenchmark action = traverse action (benchmarks pkg_descr)
 250
 251
 252 -- |Prepare a directory tree of source files.
 253 prepareTree :: Verbosity          -- ^verbosity
 254             -> PackageDescription -- ^info from the cabal file
 255             -> Maybe LocalBuildInfo
 256             -> FilePath           -- ^source tree to populate
 257             -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)
 258             -> IO ()
 259 prepareTree verbosity pkg_descr0 mb_lbi targetDir pps = do
 260   -- If the package was configured then we can run platform-independent
 261   -- pre-processors and include those generated files.
 262   case mb_lbi of
 263     Just lbi | not (null pps) -> do
 264       let lbi' = lbi{ buildDir = targetDir </> buildDir lbi }
 265       withAllComponentsInBuildOrder pkg_descr lbi' $ \c clbi ->
 266         preprocessComponent pkg_descr c lbi' clbi True verbosity pps
 267     _ -> return ()
 268
 269   (ordinary, mExecutable)  <- listPackageSources verbosity pkg_descr0 pps
 270   installOrdinaryFiles        verbosity targetDir (zip (repeat []) ordinary)
 271   installMaybeExecutableFiles verbosity targetDir (zip (repeat []) mExecutable)
 272   maybeCreateDefaultSetupScript targetDir
 273
 274   where
 275     pkg_descr = filterAutogenModules pkg_descr0
 276
 277 -- | Find the setup script file, if it exists.
 278 findSetupFile :: FilePath -> NoCallStackIO (Maybe FilePath)
 279 findSetupFile targetDir = do
 280   hsExists  <- doesFileExist setupHs
 281   lhsExists <- doesFileExist setupLhs
 282   if hsExists
 283     then return (Just setupHs)
 284     else if lhsExists
 285          then return (Just setupLhs)
 286          else return Nothing
 287     where
 288       setupHs  = targetDir </> "Setup.hs"
 289       setupLhs = targetDir </> "Setup.lhs"
 290
 291 -- | Create a default setup script in the target directory, if it doesn't exist.
 292 maybeCreateDefaultSetupScript :: FilePath -> NoCallStackIO ()
 293 maybeCreateDefaultSetupScript targetDir = do
 294   mSetupFile <- findSetupFile targetDir
 295   case mSetupFile of
 296     Just _setupFile -> return ()
 297     Nothing         -> do
 298       writeUTF8File (targetDir </> "Setup.hs") $ unlines [
 299         "import Distribution.Simple",
 300         "main = defaultMain"]
 301
 302 -- | Find the main executable file.
 303 findMainExeFile :: BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath
 304 findMainExeFile exeBi pps mainPath = do
 305   ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi)
 306             (dropExtension mainPath)
 307   case ppFile of
 308     Nothing -> findFile (hsSourceDirs exeBi) mainPath
 309     Just pp -> return pp
 310
 311 -- | Find a module definition file
 312 --
 313 -- TODO: I don't know if this is right
 314 findModDefFile :: BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath
 315 findModDefFile flibBi _pps modDefPath =
 316     findFile (".":hsSourceDirs flibBi) modDefPath
 317
 318 -- | Given a list of include paths, try to find the include file named
 319 -- @f@. Return the name of the file and the full path, or exit with error if
 320 -- there's no such file.
 321 findIncludeFile :: Verbosity -> [FilePath] -> String -> IO (String, FilePath)
 322 findIncludeFile verbosity [] f = die' verbosity ("can't find include file " ++ f)
 323 findIncludeFile verbosity (d:ds) f = do
 324   let path = (d </> f)
 325   b <- doesFileExist path
 326   if b then return (f,path) else findIncludeFile verbosity ds f
 327
 328 -- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules'
 329 -- and 'other-modules'.
 330 filterAutogenModules :: PackageDescription -> PackageDescription
 331 filterAutogenModules pkg_descr0 = mapLib filterAutogenModuleLib $
 332                                  mapAllBuildInfo filterAutogenModuleBI pkg_descr0
 333   where
 334     mapLib f pkg = pkg { library      = fmap f (library pkg)
 335                        , subLibraries = map f (subLibraries pkg) }
 336     filterAutogenModuleLib lib = lib {
 337       exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib)
 338     }
 339     filterAutogenModuleBI bi = bi {
 340       otherModules   = filter (filterFunction bi) (otherModules bi)
 341     }
 342     pathsModule = autogenPathsModuleName pkg_descr0
 343     filterFunction bi = \mn ->
 344                                    mn /= pathsModule
 345                                 && not (mn `elem` autogenModules bi)
 346
 347 -- | Prepare a directory tree of source files for a snapshot version.
 348 -- It is expected that the appropriate snapshot version has already been set
 349 -- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'.
 350 --
 351 prepareSnapshotTree :: Verbosity          -- ^verbosity
 352                     -> PackageDescription -- ^info from the cabal file
 353                     -> Maybe LocalBuildInfo
 354                     -> FilePath           -- ^source tree to populate
 355                     -> [PPSuffixHandler]  -- ^extra preprocessors (includes
 356                                           -- suffixes)
 357                     -> IO ()
 358 prepareSnapshotTree verbosity pkg mb_lbi targetDir pps = do
 359   prepareTree verbosity pkg mb_lbi targetDir pps
 360   overwriteSnapshotPackageDesc verbosity pkg targetDir
 361
 362 overwriteSnapshotPackageDesc :: Verbosity          -- ^verbosity
 363                              -> PackageDescription -- ^info from the cabal file
 364                              -> FilePath           -- ^source tree
 365                              -> IO ()
 366 overwriteSnapshotPackageDesc verbosity pkg targetDir = do
 367     -- We could just writePackageDescription targetDescFile pkg_descr,
 368     -- but that would lose comments and formatting.
 369     descFile <- defaultPackageDesc verbosity
 370     withUTF8FileContents descFile $
 371       writeUTF8File (targetDir </> descFile)
 372         . unlines . map (replaceVersion (packageVersion pkg)) . lines
 373
 374   where
 375     replaceVersion :: Version -> String -> String
 376     replaceVersion version line
 377       | "version:" `isPrefixOf` map toLower line
 378                   = "version: " ++ display version
 379       | otherwise = line
 380
 381 -- | Modifies a 'PackageDescription' by appending a snapshot number
 382 -- corresponding to the given date.
 383 --
 384 snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription
 385 snapshotPackage date pkg =
 386   pkg {
 387     package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) }
 388   }
 389   where pkgid = packageId pkg
 390
 391 -- | Modifies a 'Version' by appending a snapshot number corresponding
 392 -- to the given date.
 393 --
 394 snapshotVersion :: UTCTime -> Version -> Version
 395 snapshotVersion date = alterVersion (++ [dateToSnapshotNumber date])
 396
 397 -- | Given a date produce a corresponding integer representation.
 398 -- For example given a date @18/03/2008@ produce the number @20080318@.
 399 --
 400 dateToSnapshotNumber :: UTCTime -> Int
 401 dateToSnapshotNumber date = case toGregorian (utctDay date) of
 402                             (year, month, day) ->
 403                                 fromIntegral year * 10000
 404                               + month             * 100
 405                               + day
 406
 407 -- | Callback type for use by sdistWith.
 408 type CreateArchiveFun = Verbosity               -- ^verbosity
 409                         -> PackageDescription   -- ^info from cabal file
 410                         -> Maybe LocalBuildInfo -- ^info from configure
 411                         -> FilePath             -- ^source tree to archive
 412                         -> FilePath             -- ^name of archive to create
 413                         -> IO FilePath
 414
 415 -- | Create an archive from a tree of source files, and clean up the tree.
 416 createArchive :: CreateArchiveFun
 417 createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do
 418   let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz"
 419
 420   (tarProg, _) <- requireProgram verbosity tarProgram
 421                     (maybe defaultProgramDb withPrograms mb_lbi)
 422   let formatOptSupported = maybe False (== "YES") $
 423                            Map.lookup "Supports --format"
 424                            (programProperties tarProg)
 425   runProgram verbosity tarProg $
 426     -- Hmm: I could well be skating on thinner ice here by using the -C option
 427     -- (=> seems to be supported at least by GNU and *BSD tar) [The
 428     -- prev. solution used pipes and sub-command sequences to set up the paths
 429     -- correctly, which is problematic in a Windows setting.]
 430     ["-czf", tarBallFilePath, "-C", tmpDir]
 431     ++ (if formatOptSupported then ["--format", "ustar"] else [])
 432     ++ [tarBallName pkg_descr]
 433   return tarBallFilePath
 434
 435 -- | Given a buildinfo, return the names of all source files.
 436 allSourcesBuildInfo :: Verbosity
 437                        -> BuildInfo
 438                        -> [PPSuffixHandler] -- ^ Extra preprocessors
 439                        -> [ModuleName]      -- ^ Exposed modules
 440                        -> IO [FilePath]
 441 allSourcesBuildInfo verbosity bi pps modules = do
 442   let searchDirs = hsSourceDirs bi
 443   sources <- fmap concat $ sequenceA $
 444     [ let file = ModuleName.toFilePath module_
 445       -- NB: *Not* findFileWithExtension, because the same source
 446       -- file may show up in multiple paths due to a conditional;
 447       -- we need to package all of them.  See #367.
 448       in findAllFilesWithExtension suffixes searchDirs file
 449          >>= nonEmpty (notFound module_) return
 450     | module_ <- modules ++ otherModules bi ]
 451   bootFiles <- sequenceA
 452     [ let file = ModuleName.toFilePath module_
 453           fileExts = ["hs-boot", "lhs-boot"]
 454       in findFileWithExtension fileExts (hsSourceDirs bi) file
 455     | module_ <- modules ++ otherModules bi ]
 456
 457   return $ sources ++ catMaybes bootFiles ++ cSources bi ++ cxxSources bi ++ jsSources bi
 458
 459   where
 460     nonEmpty x _ [] = x
 461     nonEmpty _ f xs = f xs
 462     suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"]
 463     notFound m = die' verbosity $ "Error: Could not find module: " ++ display m
 464                  ++ " with any suffix: " ++ show suffixes ++ ". If the module "
 465                  ++ "is autogenerated it should be added to 'autogen-modules'."
 466
 467
 468 -- | Note: must be called with the CWD set to the directory containing
 469 -- the '.cabal' file.
 470 printPackageProblems :: Verbosity -> PackageDescription -> IO ()
 471 printPackageProblems verbosity pkg_descr = do
 472   ioChecks      <- checkPackageFiles verbosity pkg_descr "."
 473   let pureChecks = checkConfiguredPackage pkg_descr
 474       isDistError (PackageDistSuspicious     _) = False
 475       isDistError (PackageDistSuspiciousWarn _) = False
 476       isDistError _                             = True
 477       (errors, warnings) = partition isDistError (pureChecks ++ ioChecks)
 478   unless (null errors) $
 479       notice verbosity $ "Distribution quality errors:\n"
 480                       ++ unlines (map explanation errors)
 481   unless (null warnings) $
 482       notice verbosity $ "Distribution quality warnings:\n"
 483                       ++ unlines (map explanation warnings)
 484   unless (null errors) $
 485       notice verbosity
 486         "Note: the public hackage server would reject this package."
 487
 488 ------------------------------------------------------------
 489
 490 -- | The name of the tarball without extension
 491 --
 492 tarBallName :: PackageDescription -> String
 493 tarBallName = display . packageId
 494
 495 mapAllBuildInfo :: (BuildInfo -> BuildInfo)
 496                 -> (PackageDescription -> PackageDescription)
 497 mapAllBuildInfo f pkg = pkg {
 498     library     = fmap mapLibBi (library pkg),
 499     subLibraries = fmap mapLibBi (subLibraries pkg),
 500     foreignLibs = fmap mapFLibBi (foreignLibs pkg),
 501     executables = fmap mapExeBi (executables pkg),
 502     testSuites  = fmap mapTestBi (testSuites pkg),
 503     benchmarks  = fmap mapBenchBi (benchmarks pkg)
 504   }
 505   where
 506     mapLibBi   lib  = lib  { libBuildInfo        = f (libBuildInfo lib) }
 507     mapFLibBi  flib = flib { foreignLibBuildInfo = f (foreignLibBuildInfo flib) }
 508     mapExeBi   exe  = exe  { buildInfo           = f (buildInfo exe) }
 509     mapTestBi  tst  = tst  { testBuildInfo       = f (testBuildInfo tst) }
 510     mapBenchBi bm   = bm   { benchmarkBuildInfo  = f (benchmarkBuildInfo bm) }