SrcDist.hs

{-# OPTIONS -cpp #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.SrcDist
-- Copyright   :  Simon Marlow 2004
-- 
-- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>
-- Stability   :  alpha
-- Portability :  portable
--
-- Implements the \"@.\/setup sdist@\" command, which creates a source
-- distribution for this package.  That is, packs up the source code
-- into a tarball.

{- Copyright (c) 2003-2004, Simon Marlow
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Isaac Jones nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

-- 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 (
	 sdist
        ,createArchive
        ,prepareTree
        ,tarBallName
        ,copyFileTo
#ifdef DEBUG        
        ,hunitTests
#endif
  )  where

import Distribution.PackageDescription
	(PackageDescription(..), BuildInfo(..), Executable(..), Library(..),
         withLib, withExe, setupMessage)
import Distribution.Package (showPackageId, PackageIdentifier(pkgVersion))
import Distribution.Version (Version(versionBranch), VersionRange(AnyVersion))
import Distribution.Simple.Utils (createDirectoryIfMissingVerbose,
                                  smartCopySources, die, warn, notice,
                                  findPackageDesc, findFile, copyFileVerbose)
import Distribution.Simple.Setup (SDistFlags(..))
import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessSources)
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram,
                              rawSystemProgram, tarProgram )

#ifndef __NHC__
import Control.Exception (finally)
#endif
import Control.Monad(when)
import Data.Char (isSpace, toLower)
import Data.List (isPrefixOf)
import System.Time (getClockTime, toCalendarTime, CalendarTime(..))
import Distribution.Compat.Directory (doesFileExist, doesDirectoryExist,
         getCurrentDirectory, removeDirectoryRecursive)
import Distribution.Verbosity
import System.FilePath ((</>), takeDirectory, isAbsolute)

#ifdef DEBUG
import Test.HUnit (Test)
#endif

#ifdef __NHC__
finally :: IO a -> IO b -> IO a
x `finally` y = do { a <- x; y; return a }
#endif

-- |Create a source distribution.
sdist :: PackageDescription -- ^information from the tarball
      -> Maybe LocalBuildInfo -- ^Information from configure
      -> SDistFlags -- ^verbosity & snapshot
      -> FilePath -- ^build prefix (temp dir)
      -> FilePath -- ^TargetPrefix
      -> [PPSuffixHandler]  -- ^ extra preprocessors (includes suffixes)
      -> IO ()
sdist pkg_descr_orig mb_lbi (SDistFlags snapshot verbosity) tmpDir targetPref pps = do
    time <- getClockTime
    ct <- toCalendarTime time
    let date = ctYear ct*10000 + (fromEnum (ctMonth ct) + 1)*100 + ctDay ct
    let pkg_descr
          | snapshot  = updatePackage (updatePkgVersion
                          (updateVersionBranch (++ [date]))) pkg_descr_orig
          | otherwise = pkg_descr_orig
    prepareTree pkg_descr verbosity mb_lbi snapshot tmpDir pps date
    createArchive pkg_descr verbosity mb_lbi tmpDir targetPref
    return ()
  where
    updatePackage f pd = pd { package = f (package pd) }
    updatePkgVersion f pkg = pkg { pkgVersion = f (pkgVersion pkg) }
    updateVersionBranch f v = v { versionBranch = f (versionBranch v) }

-- |Prepare a directory tree of source files.
prepareTree :: PackageDescription -- ^info from the cabal file
            -> Verbosity          -- ^verbosity
            -> Maybe LocalBuildInfo
            -> Bool               -- ^snapshot
            -> FilePath           -- ^source tree to populate
            -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)
            -> Int                -- ^date
            -> IO FilePath

prepareTree pkg_descr verbosity mb_lbi snapshot tmpDir pps date = do
  setupMessage verbosity "Building source dist for" pkg_descr
  ex <- doesDirectoryExist tmpDir
  when ex (die $ "Source distribution already in place. please move: " ++ tmpDir)
  let targetDir = tmpDir </> (nameVersion pkg_descr)
  createDirectoryIfMissingVerbose verbosity True targetDir
  -- maybe move the library files into place
  withLib pkg_descr () $ \ l ->
    prepareDir verbosity targetDir pps (exposedModules l) (libBuildInfo l)
  -- move the executables into place
  withExe pkg_descr $ \ (Executable _ mainPath exeBi) -> do
    prepareDir verbosity targetDir pps [] exeBi
    srcMainFile <- findFile (hsSourceDirs exeBi) mainPath
    copyFileTo verbosity targetDir srcMainFile
  flip mapM_ (dataFiles pkg_descr) $ \ file -> do
    let 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

  -- copy the install-include files
  withLib pkg_descr () $ \ 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

  -- we have some preprocessors specified, try to generate those files
  when (not (null pps)) $
    case mb_lbi of
      Just lbi -> preprocessSources pkg_descr (lbi { buildDir = targetDir }) 
                                    True verbosity pps
      Nothing -> warn verbosity
          "Cannot run preprocessors.  Run 'configure' command first."

  -- setup isn't listed in the description file.
  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 writeFile (targetDir </> "Setup.hs") $ unlines [
                "import Distribution.Simple",
                "main = defaultMainWithHooks defaultUserHooks"]
  -- the description file itself
  descFile <- getCurrentDirectory >>= findPackageDesc verbosity
  let targetDescFile = targetDir </> descFile
  -- We could just writePackageDescription targetDescFile pkg_descr,
  -- but that would lose comments and formatting.
  if snapshot then do
      contents <- readFile descFile
      writeFile targetDescFile $
          unlines $ map (appendVersion date) $ lines $ contents
    else copyFileVerbose verbosity descFile targetDescFile
  return targetDir

  where

    appendVersion :: Int -> String -> String
    appendVersion n line
      | "version:" `isPrefixOf` map toLower line =
            trimTrailingSpace line ++ "." ++ show n
      | otherwise = line

    trimTrailingSpace :: String -> String
    trimTrailingSpace = reverse . dropWhile isSpace . reverse

    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

-- |Create an archive from a tree of source files, and clean up the tree.
createArchive :: PackageDescription   -- ^info from cabal file
              -> Verbosity            -- ^verbosity
              -> Maybe LocalBuildInfo -- ^info from configure
              -> FilePath             -- ^source tree to archive
              -> FilePath             -- ^name of archive to create
              -> IO FilePath

createArchive pkg_descr verbosity mb_lbi tmpDir targetPref = do
  let tarBallFilePath = targetPref </> tarBallName pkg_descr

  (tarProg, _) <- requireProgram verbosity tarProgram AnyVersion
                    (maybe defaultProgramConfiguration withPrograms mb_lbi)

   -- Hmm: I could well be skating on thinner ice here by using the -C option (=> GNU tar-specific?)
   -- [The prev. solution used pipes and sub-command sequences to set up the paths correctly,
   -- which is problematic in a Windows setting.]
  rawSystemProgram verbosity tarProg
           ["-C", tmpDir, "-czf", tarBallFilePath, nameVersion pkg_descr]
      -- XXX this should be done back where tmpDir is made, not here
      `finally` removeDirectoryRecursive tmpDir
  notice verbosity $ "Source tarball created: " ++ tarBallFilePath
  return tarBallFilePath

-- |Move the sources into place based on buildInfo
prepareDir :: Verbosity -- ^verbosity
           -> FilePath  -- ^TargetPrefix
           -> [PPSuffixHandler]  -- ^ extra preprocessors (includes suffixes)
           -> [String]  -- ^Exposed modules
           -> BuildInfo
           -> IO ()
prepareDir verbosity inPref pps mods BuildInfo{hsSourceDirs=srcDirs, otherModules=mods', cSources=cfiles}
    = do let suff = ppSuffixes pps  ++ ["hs", "lhs"]
         smartCopySources verbosity srcDirs inPref (mods++mods') suff True True
         mapM_ (copyFileTo verbosity inPref) cfiles

copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()
copyFileTo verbosity dir file = do
  let targetFile = dir </> file
  createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)
  copyFileVerbose verbosity file targetFile

------------------------------------------------------------

-- |The file name of the tarball
tarBallName :: PackageDescription -> FilePath
tarBallName p = (nameVersion p) ++ ".tar.gz"

nameVersion :: PackageDescription -> String
nameVersion = showPackageId . package

-- ------------------------------------------------------------
-- * Testing
-- ------------------------------------------------------------

#ifdef DEBUG
hunitTests :: [Test]
hunitTests = []
#endif