Commit ae0dee3e authored by Duncan Coutts's avatar Duncan Coutts

Add cabal sdist --zip flag for creating zip archives

Handy if you want to send sources to people who do not grok .tar.gz
Requires that the 'zip' program be installed (unlike for .tar.gz where
we do it internally so that it works on all systems).
parent c08ea407
......@@ -26,6 +26,7 @@ module Distribution.Client.Setup
, reportCommand, ReportFlags(..)
, unpackCommand, UnpackFlags(..)
, initCommand, IT.InitFlags(..)
, sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
, parsePackageArgs
--TODO: stop exporting these:
......@@ -47,9 +48,9 @@ import Distribution.Simple.Program
import Distribution.Simple.Command hiding (boolOpt)
import qualified Distribution.Simple.Command as Command
import qualified Distribution.Simple.Setup as Cabal
( configureCommand )
( configureCommand, sdistCommand )
import Distribution.Simple.Setup
( ConfigFlags(..) )
( ConfigFlags(..), SDistFlags(..) )
import Distribution.Simple.Setup
( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe
, optionVerbosity, trueArg, falseArg )
......@@ -959,6 +960,57 @@ initCommand = CommandUI {
[(x,"")] -> Just x
_ -> Nothing
-- ------------------------------------------------------------
-- * SDist flags
-- ------------------------------------------------------------
-- | Extra flags to @sdist@ beyond runghc Setup sdist
--
data SDistExFlags = SDistExFlags {
sDistFormat :: Flag ArchiveFormat
}
deriving Show
data ArchiveFormat = TargzFormat | ZipFormat -- | ...
deriving (Show, Eq)
defaultSDistExFlags :: SDistExFlags
defaultSDistExFlags = SDistExFlags {
sDistFormat = Flag TargzFormat
}
sdistCommand :: CommandUI (SDistFlags, SDistExFlags)
sdistCommand = Cabal.sdistCommand {
commandDefaultFlags = (commandDefaultFlags Cabal.sdistCommand, defaultSDistExFlags),
commandOptions = \showOrParseArgs ->
liftOptions fst setFst (commandOptions Cabal.sdistCommand showOrParseArgs)
++ liftOptions snd setSnd sdistExOptions
}
where
setFst a (_,b) = (a,b)
setSnd b (a,_) = (a,b)
sdistExOptions =
[option [] ["archive-format"] "archive-format"
sDistFormat (\v flags -> flags { sDistFormat = v })
(choiceOpt
[ (Flag TargzFormat, ([], ["targz"]),
"Produce a '.tar.gz' format archive (default and required for uploading to hackage)")
, (Flag ZipFormat, ([], ["zip"]),
"Produce a '.zip' format archive")
])
]
instance Monoid SDistExFlags where
mempty = SDistExFlags {
sDistFormat = mempty
}
mappend a b = SDistExFlags {
sDistFormat = combine sDistFormat
}
where
combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------
......
......@@ -4,6 +4,8 @@
module Distribution.Client.SrcDist (
sdist
) where
import Distribution.Simple.SrcDist
( printPackageProblems, prepareTree, snapshotPackage )
import Distribution.Client.Tar (createTarGzFile)
......@@ -15,16 +17,20 @@ import Distribution.PackageDescription
import Distribution.PackageDescription.Parse
( readPackageDescription )
import Distribution.Simple.Utils
( defaultPackageDesc, warn, notice, setupMessage
( defaultPackageDesc, die, warn, notice, setupMessage
, createDirectoryIfMissingVerbose, withTempDirectory
, withUTF8FileContents, writeUTF8File )
import Distribution.Client.Setup
( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) )
import Distribution.Simple.Setup
( SDistFlags(..), fromFlag, flagToMaybe )
( fromFlag, flagToMaybe )
import Distribution.Verbosity (Verbosity)
import Distribution.Simple.PreProcess (knownSuffixHandlers)
import Distribution.Simple.BuildPaths ( srcPref)
import Distribution.Simple.Configure(maybeGetPersistBuildConfig)
import Distribution.PackageDescription.Configuration ( flattenPackageDescription )
import Distribution.Simple.Program (requireProgram, simpleProgram, programPath)
import Distribution.Simple.Program.Db (emptyProgramDb)
import Distribution.Text
( display )
import Distribution.Version
......@@ -32,14 +38,17 @@ import Distribution.Version
import System.Time (getClockTime, toCalendarTime)
import System.FilePath ((</>), (<.>))
import Control.Monad (when)
import Control.Monad (when, unless)
import Data.Maybe (isNothing)
import Data.Char (toLower)
import Data.List (isPrefixOf)
import System.Directory (doesFileExist, removeFile, canonicalizePath)
import System.Process (runProcess, waitForProcess)
import System.Exit (ExitCode(..))
-- |Create a source distribution.
sdist :: SDistFlags -> IO ()
sdist flags = do
sdist :: SDistFlags -> SDistExFlags -> IO ()
sdist flags exflags = do
pkg <- return . flattenPackageDescription
=<< readPackageDescription verbosity
=<< defaultPackageDesc verbosity
......@@ -65,7 +74,7 @@ sdist flags = do
withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
let targetDir = tmpDir </> tarBallName pkg'
generateSourceDir targetDir pkg' mb_lbi
targzFile <- createArchive verbosity pkg' tmpDir targetPref
targzFile <- createArchive verbosity format pkg' tmpDir targetPref
notice verbosity $ "Source tarball created: " ++ targzFile
where
......@@ -78,6 +87,7 @@ sdist flags = do
verbosity = fromFlag (sDistVerbosity flags)
snapshot = fromFlag (sDistSnapshot flags)
format = fromFlag (sDistFormat exflags)
pps = knownSuffixHandlers
distPref = fromFlag $ sDistDistPref flags
targetPref = distPref
......@@ -105,14 +115,46 @@ overwriteSnapshotPackageDesc verbosity pkg targetDir = do
= "version: " ++ display version
| otherwise = line
-- |Create an archive from a tree of source files, and clean up the tree.
-- | Create an archive from a tree of source files.
--
createArchive :: Verbosity
-> ArchiveFormat
-> PackageDescription
-> FilePath
-> FilePath
-> IO FilePath
createArchive _verbosity pkg tmpDir targetPref = do
createArchive _verbosity TargzFormat pkg tmpDir targetPref = do
createTarGzFile tarBallFilePath tmpDir (tarBallName pkg)
return tarBallFilePath
where
tarBallFilePath = targetPref </> tarBallName pkg <.> "tar.gz"
createArchive verbosity ZipFormat pkg tmpDir targetPref = do
createZipFile verbosity zipFilePath tmpDir (tarBallName pkg)
return zipFilePath
where
zipFilePath = targetPref </> tarBallName pkg <.> "zip"
createZipFile :: Verbosity -> FilePath -> FilePath -> FilePath -> IO ()
createZipFile verbosity zipfile base dir = do
(zipProg, _) <- requireProgram verbosity zipProgram emptyProgramDb
-- zip has an annoying habbit of updating the target rather than creating
-- it from scratch. While that might sound like an optimisation, it doesn't
-- remove files already in the archive that are no longer present in the
-- uncompressed tree.
alreadyExists <- doesFileExist zipfile
when alreadyExists $ removeFile zipfile
-- we call zip with a different CWD, so have to make the path absolute
zipfileAbs <- canonicalizePath zipfile
--TODO: use runProgramInvocation, but has to be able to set CWD
hnd <- runProcess (programPath zipProg) ["-q", "-r", zipfileAbs, dir] (Just base)
Nothing Nothing Nothing Nothing
exitCode <- waitForProcess hnd
unless (exitCode == ExitSuccess) $
die $ "Generating the zip file failed "
++ "(zip returned exit code " ++ show exitCode ++ ")"
where
zipProgram = simpleProgram "zip"
......@@ -27,6 +27,7 @@ import Distribution.Client.Setup
, UploadFlags(..), uploadCommand
, ReportFlags(..), reportCommand
, InitFlags, initCommand
, SDistFlags(..), SDistExFlags(..), sdistCommand
, reportCommand
, unpackCommand, UnpackFlags(..) )
import Distribution.Simple.Setup
......@@ -36,7 +37,6 @@ import Distribution.Simple.Setup
, CopyFlags(..), copyCommand
, RegisterFlags(..), registerCommand
, CleanFlags(..), cleanCommand
, SDistFlags(..), sdistCommand
, TestFlags(..), testCommand
, Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
......@@ -322,11 +322,11 @@ checkAction verbosityFlag extraArgs _globalFlags = do
unless allOk exitFailure
sdistAction :: SDistFlags -> [String] -> GlobalFlags -> IO ()
sdistAction sflags extraArgs _globalFlags = do
sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> GlobalFlags -> IO ()
sdistAction (sdistFlags, sdistExFlags) extraArgs _globalFlags = do
unless (null extraArgs) $ do
die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs
sdist sflags
sdist sdistFlags sdistExFlags
reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO ()
reportAction reportFlags extraArgs globalFlags = do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment