-----------------------------------------------------------------------------
-- |
-- 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) }