content: -----------------------------------------------------------------------------
  -- |
  -- Module      :  Distribution.Simple.SrcDist
  -- Copyright   :  Simon Marlow 2004
  -- License     :  BSD3
  --
  -- Maintainer  :  cabal-devel@haskell.org
  -- Portability :  portable
  --
  -- This handles the @sdist@ command. The module exports an 'sdist' action but
  -- also some of the phases that make it up so that other tools can use just the
  -- bits they need. In particular the preparation of the tree of files to go
  -- into the source tarball is separated from actually building the source
  -- tarball.
  --
  -- The 'createArchive' action uses the external @tar@ program and assumes that
  -- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows.
  -- The 'sdist' action now also does some distribution QA checks.
  
  -- NOTE: FIX: we don't have a great way of testing this module, since
  -- we can't easily look inside a tarball once its created.
  
  module Distribution.Simple.SrcDist (
    -- * The top level action
    sdist,
  
    -- ** Parts of 'sdist'
    printPackageProblems,
    prepareTree,
    createArchive,
  
    -- ** Snapshots
    prepareSnapshotTree,
    snapshotPackage,
    snapshotVersion,
    dateToSnapshotNumber,
  
    -- * Extracting the source files
    listPackageSources
  
    )  where
  
  import Distribution.PackageDescription
           ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..)
           , TestSuite(..), TestSuiteInterface(..), Benchmark(..)
           , BenchmarkInterface(..) )
  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
           , installOrdinaryFiles, installMaybeExecutableFiles
           , findFile, findFileWithExtension, matchFileGlob
           , withTempDirectory, defaultPackageDesc
           , die, warn, notice, info, setupMessage )
  import Distribution.Simple.Setup ( Flag(..), SDistFlags(..)
                                   , fromFlag, flagToMaybe)
  import Distribution.Simple.PreProcess ( PPSuffixHandler, ppSuffixes
                                        , preprocessComponent )
  import Distribution.Simple.LocalBuildInfo
           ( LocalBuildInfo(..), withAllComponentsInBuildOrder )
  import Distribution.Simple.BuildPaths ( autogenModuleName )
  import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram,
                                       runProgram, programProperties, tarProgram )
  import Distribution.Text
           ( display )
  
  import Control.Monad(when, unless, forM)
  import Data.Char (toLower)
  import Data.List (partition, isPrefixOf)
  import qualified Data.Map as Map
  import Data.Maybe (isNothing, catMaybes)
  import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay)
  import System.Directory ( doesFileExist )
  import System.IO (IOMode(WriteMode), hPutStrLn, withFile)
  import Distribution.Verbosity (Verbosity)
  import System.FilePath
           ( (</>), (<.>), dropExtension, isAbsolute )
  
  -- |Create a source distribution.
  sdist :: PackageDescription     -- ^information from the tarball
        -> Maybe LocalBuildInfo   -- ^Information from configure
        -> SDistFlags             -- ^verbosity & snapshot
        -> (FilePath -> FilePath) -- ^build prefix (temp dir)
        -> [PPSuffixHandler]      -- ^ extra preprocessors (includes suffixes)
        -> IO ()
  sdist pkg mb_lbi flags mkTmpDir pps =
  
    -- When given --list-sources, just output the list of sources to a file.
    case (sDistListSources flags) of
      Flag path -> withFile path WriteMode $ \outHandle -> do
        (ordinary, maybeExecutable) <- listPackageSources verbosity pkg pps
        mapM_ (hPutStrLn outHandle) ordinary
        mapM_ (hPutStrLn outHandle) maybeExecutable
        notice verbosity $ "List of package sources written to file '"
                           ++ path ++ "'"
      NoFlag    -> do
        -- do some QA
        printPackageProblems verbosity pkg
  
        when (isNothing mb_lbi) $
          warn verbosity "Cannot run preprocessors. Run 'configure' command first."
  
        date <- getCurrentTime
        let pkg' | snapshot  = snapshotPackage date pkg
                 | otherwise = pkg
  
        case flagToMaybe (sDistDirectory flags) of
          Just targetDir -> do
            generateSourceDir targetDir pkg'
            info verbosity $ "Source directory created: " ++ targetDir
  
          Nothing -> do
            createDirectoryIfMissingVerbose verbosity True tmpTargetDir
            withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
              let targetDir = tmpDir </> tarBallName pkg'
              generateSourceDir targetDir pkg'
              targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref
              notice verbosity $ "Source tarball created: " ++ targzFile
  
    where
      generateSourceDir targetDir pkg' = do
  
        setupMessage verbosity "Building source dist for" (packageId pkg')
        prepareTree verbosity pkg' mb_lbi targetDir pps
        when snapshot $
          overwriteSnapshotPackageDesc verbosity pkg' targetDir
  
      verbosity = fromFlag (sDistVerbosity flags)
      snapshot  = fromFlag (sDistSnapshot flags)
  
      distPref     = fromFlag $ sDistDistPref flags
      targetPref   = distPref
      tmpTargetDir = mkTmpDir distPref
  
  -- | List all source files of a package. Returns a tuple of lists: first
  -- component is a list of ordinary files, second one is a list of those files
  -- that may be executable.
  listPackageSources :: Verbosity          -- ^ verbosity
                     -> PackageDescription -- ^ info from the cabal file
                     -> [PPSuffixHandler]  -- ^ extra preprocessors (include
                                           -- suffixes)
                     -> IO ([FilePath], [FilePath])
  listPackageSources verbosity pkg_descr0 pps = do
    -- Call helpers that actually do all work.
    ordinary        <- listPackageSourcesOrdinary        verbosity pkg_descr pps
    maybeExecutable <- listPackageSourcesMaybeExecutable pkg_descr
    return (ordinary, maybeExecutable)
    where
      pkg_descr = filterAutogenModule pkg_descr0
  
  -- | List those source files that may be executable (e.g. the configure script).
  listPackageSourcesMaybeExecutable :: PackageDescription -> IO [FilePath]
  listPackageSourcesMaybeExecutable pkg_descr =
    -- Extra source files.
    fmap concat . forM (extraSrcFiles pkg_descr) $ \fpath -> matchFileGlob fpath
  
  -- | List those source files that should be copied with ordinary permissions.
  listPackageSourcesOrdinary :: Verbosity
                             -> PackageDescription
                             -> [PPSuffixHandler]
                             -> IO [FilePath]
  listPackageSourcesOrdinary verbosity pkg_descr pps =
    fmap concat . sequence $
    [
      -- Library sources.
      withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->
       allSourcesBuildInfo libBi pps modules
  
      -- Executables sources.
    , fmap concat
      . withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do
         biSrcs  <- allSourcesBuildInfo exeBi pps []
         mainSrc <- findMainExeFile exeBi pps mainPath
         return (mainSrc:biSrcs)
  
      -- Test suites sources.
    , fmap concat
      . withTest $ \t -> do
         let bi  = testBuildInfo t
         case testInterface t of
           TestSuiteExeV10 _ mainPath -> do
             biSrcs <- allSourcesBuildInfo bi pps []
             srcMainFile <- do
               ppFile <- findFileWithExtension (ppSuffixes pps)
                         (hsSourceDirs bi) (dropExtension mainPath)
               case ppFile of
                 Nothing -> findFile (hsSourceDirs bi) mainPath
                 Just pp -> return pp
             return (srcMainFile:biSrcs)
           TestSuiteLibV09 _ m ->
             allSourcesBuildInfo bi pps [m]
           TestSuiteUnsupported tp -> die $ "Unsupported test suite type: "
                                     ++ show tp
  
      -- Benchmarks sources.
    , fmap concat
      . withBenchmark $ \bm -> do
         let  bi = benchmarkBuildInfo bm
         case benchmarkInterface bm of
           BenchmarkExeV10 _ mainPath -> do
             biSrcs <- allSourcesBuildInfo bi pps []
             srcMainFile <- do
               ppFile <- findFileWithExtension (ppSuffixes pps)
                         (hsSourceDirs bi) (dropExtension mainPath)
               case ppFile of
                 Nothing -> findFile (hsSourceDirs bi) mainPath
                 Just pp -> return pp
             return (srcMainFile:biSrcs)
           BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: "
                                      ++ show tp
  
      -- Data files.
    , fmap concat
      . forM (dataFiles pkg_descr) $ \filename ->
         matchFileGlob (dataDir pkg_descr </> filename)
  
      -- Extra doc files.
    , fmap concat
      . forM (extraDocFiles pkg_descr) $ \ filename ->
        matchFileGlob filename
  
      -- License file(s).
    , return (licenseFiles pkg_descr)
  
      -- Install-include files.
    , withLib $ \ l -> do
         let lbi = libBuildInfo l
             relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)
         mapM (fmap snd . findIncludeFile relincdirs) (installIncludes lbi)
  
      -- Setup script, if it exists.
    , fmap (maybe [] (\f -> [f])) $ findSetupFile ""
  
      -- The .cabal file itself.
    , fmap (\d -> [d]) (defaultPackageDesc verbosity)
  
    ]
    where
      -- We have to deal with all libs and executables, so we have local
      -- versions of these functions that ignore the 'buildable' attribute:
      withLib       action = maybe (return []) action (library pkg_descr)
      withExe       action = mapM action (executables pkg_descr)
      withTest      action = mapM action (testSuites pkg_descr)
      withBenchmark action = mapM action (benchmarks pkg_descr)
  
  
  -- |Prepare a directory tree of source files.
  prepareTree :: Verbosity          -- ^verbosity
              -> PackageDescription -- ^info from the cabal file
              -> Maybe LocalBuildInfo
              -> FilePath           -- ^source tree to populate
              -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)
              -> IO ()
  prepareTree verbosity pkg_descr0 mb_lbi targetDir pps = do
    -- If the package was configured then we can run platform-independent
    -- pre-processors and include those generated files.
    case mb_lbi of
      Just lbi | not (null pps) -> do
        let lbi' = lbi{ buildDir = targetDir </> buildDir lbi }
        withAllComponentsInBuildOrder pkg_descr lbi' $ \c _ ->
          preprocessComponent pkg_descr c lbi' 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
      pkg_descr = filterAutogenModule pkg_descr0
  
  -- | Find the setup script file, if it exists.
  findSetupFile :: FilePath -> IO (Maybe FilePath)
  findSetupFile targetDir = do
    hsExists  <- doesFileExist setupHs
    lhsExists <- doesFileExist setupLhs
    if hsExists
      then return (Just setupHs)
      else if lhsExists
           then return (Just setupLhs)
           else return Nothing
      where
        setupHs  = targetDir </> "Setup.hs"
        setupLhs = targetDir </> "Setup.lhs"
  
  -- | Create a default setup script in the target directory, if it doesn't exist.
  maybeCreateDefaultSetupScript :: FilePath -> IO ()
  maybeCreateDefaultSetupScript targetDir = do
    mSetupFile <- findSetupFile targetDir
    case mSetupFile of
      Just _setupFile -> return ()
      Nothing         -> do
        writeUTF8File (targetDir </> "Setup.hs") $ unlines [
          "import Distribution.Simple",
          "main = defaultMain"]
  
  -- | Find the main executable file.
  findMainExeFile :: BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath
  findMainExeFile exeBi pps mainPath = do
    ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi)
              (dropExtension mainPath)
    case ppFile of
      Nothing -> findFile (hsSourceDirs exeBi) mainPath
      Just pp -> return pp
  
  -- | 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
  -- there's no such file.
  findIncludeFile :: [FilePath] -> String -> IO (String, FilePath)
  findIncludeFile [] f = die ("can't find include file " ++ f)
  findIncludeFile (d:ds) f = do
    let path = (d </> f)
    b <- doesFileExist path
    if b then return (f,path) else findIncludeFile ds f
  
  -- | Remove the auto-generated module ('Paths_*') from 'exposed-modules' and
  -- 'other-modules'.
  filterAutogenModule :: PackageDescription -> PackageDescription
  filterAutogenModule pkg_descr0 = mapLib filterAutogenModuleLib $
                                   mapAllBuildInfo filterAutogenModuleBI pkg_descr0
    where
      mapLib f pkg = pkg { library = fmap f (library pkg) }
      filterAutogenModuleLib lib = lib {
        exposedModules = filter (/=autogenModule) (exposedModules lib)
      }
      filterAutogenModuleBI bi = bi {
        otherModules   = filter (/=autogenModule) (otherModules bi)
      }
      autogenModule = autogenModuleName pkg_descr0
  
  -- | Prepare a directory tree of source files for a snapshot version.
  -- It is expected that the appropriate snapshot version has already been set
  -- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'.
  --
  prepareSnapshotTree :: Verbosity          -- ^verbosity
                      -> PackageDescription -- ^info from the cabal file
                      -> Maybe LocalBuildInfo
                      -> FilePath           -- ^source tree to populate
                      -> [PPSuffixHandler]  -- ^extra preprocessors (includes
                                            -- suffixes)
                      -> IO ()
  prepareSnapshotTree verbosity pkg mb_lbi targetDir pps = do
    prepareTree verbosity pkg mb_lbi targetDir pps
    overwriteSnapshotPackageDesc verbosity pkg targetDir
  
  overwriteSnapshotPackageDesc :: Verbosity          -- ^verbosity
                               -> PackageDescription -- ^info from the cabal file
                               -> FilePath           -- ^source tree
                               -> IO ()
  overwriteSnapshotPackageDesc verbosity pkg targetDir = do
      -- We could just writePackageDescription targetDescFile pkg_descr,
      -- but that would lose comments and formatting.
      descFile <- defaultPackageDesc verbosity
      withUTF8FileContents descFile $
        writeUTF8File (targetDir </> descFile)
          . unlines . map (replaceVersion (packageVersion pkg)) . lines
  
    where
      replaceVersion :: Version -> String -> String
      replaceVersion version line
        | "version:" `isPrefixOf` map toLower line
                    = "version: " ++ display version
        | otherwise = line
  
  -- | Modifies a 'PackageDescription' by appending a snapshot number
  -- corresponding to the given date.
  --
  snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription
  snapshotPackage date pkg =
    pkg {
      package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) }
    }
    where pkgid = packageId pkg
  
  -- | Modifies a 'Version' by appending a snapshot number corresponding
  -- to the given date.
  --
  snapshotVersion :: UTCTime -> Version -> Version
  snapshotVersion date version = version {
      versionBranch = versionBranch version
                   ++ [dateToSnapshotNumber date]
    }
  
  -- | Given a date produce a corresponding integer representation.
  -- For example given a date @18/03/2008@ produce the number @20080318@.
  --
  dateToSnapshotNumber :: UTCTime -> Int
  dateToSnapshotNumber date = case toGregorian (utctDay date) of
                              (year, month, day) ->
                                  fromIntegral year * 10000
                                + month             * 100
                                + 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.
  createArchive :: CreateArchiveFun
  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)
    let formatOptSupported = maybe False (== "YES") $
                             Map.lookup "Supports --format"
                             (programProperties tarProg)
    runProgram verbosity tarProg $
      -- Hmm: I could well be skating on thinner ice here by using the -C option
      -- (=> seems to be supported at least by GNU and *BSD tar) [The
      -- prev. solution used pipes and sub-command sequences to set up the paths
      -- correctly, which is problematic in a Windows setting.]
      ["-czf", tarBallFilePath, "-C", tmpDir]
      ++ (if formatOptSupported then ["--format", "ustar"] else [])
      ++ [tarBallName pkg_descr]
    return tarBallFilePath
  
  -- | Given a buildinfo, return the names of all source files.
  allSourcesBuildInfo :: BuildInfo
                         -> [PPSuffixHandler] -- ^ Extra preprocessors
                         -> [ModuleName]      -- ^ Exposed modules
                         -> IO [FilePath]
  allSourcesBuildInfo bi pps modules = 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 ]
  
    return $ sources ++ catMaybes bootFiles ++ cSources bi ++ jsSources bi
  
    where
      suffixes = ppSuffixes pps ++ ["hs", "lhs"]
      notFound m = die $ "Error: Could not find module: " ++ display m
                   ++ " with any suffix: " ++ show suffixes
  
  
  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."
  
  ------------------------------------------------------------
  
  -- | The name of the tarball without extension
  --
  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),
      testSuites  = fmap mapTestBi (testSuites pkg),
      benchmarks  = fmap mapBenchBi (benchmarks pkg)
    }
    where
      mapLibBi lib  = lib { libBuildInfo       = f (libBuildInfo lib) }
      mapExeBi exe  = exe { buildInfo          = f (buildInfo exe) }
      mapTestBi t   = t   { testBuildInfo      = f (testBuildInfo t) }
      mapBenchBi bm = bm  { benchmarkBuildInfo = f (benchmarkBuildInfo bm) }
  