1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
-- Implements the \"@.\/cabal sdist@\" command, which creates a source
-- distribution for this package. That is, packs up the source code
-- into a tarball, making use of the corresponding Cabal module.
module Distribution.Client.SrcDist (
sdist
) where
import Distribution.Client.SetupWrapper
( SetupScriptOptions(..), defaultSetupScriptOptions, setupWrapper )
import Distribution.Client.Tar (createTarGzFile)
import Distribution.Package
( Package(..) )
import Distribution.PackageDescription
( PackageDescription )
import Distribution.PackageDescription.Configuration
( flattenPackageDescription )
import Distribution.PackageDescription.Parse
( readPackageDescription )
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose, defaultPackageDesc
, die, notice, withTempDirectory )
import Distribution.Client.Setup
( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) )
import Distribution.Simple.Setup
( Flag(..), sdistCommand, flagToList, fromFlag, fromFlagOrDefault )
import Distribution.Simple.BuildPaths ( srcPref)
import Distribution.Simple.Program (requireProgram, simpleProgram, programPath)
import Distribution.Simple.Program.Db (emptyProgramDb)
import Distribution.Text ( display )
import Distribution.Verbosity (Verbosity, lessVerbose, normal)
import Distribution.Version (Version(..), orLaterVersion)
import System.FilePath ((</>), (<.>))
import Control.Monad (when, unless)
import System.Directory (doesFileExist, removeFile, canonicalizePath)
import System.Process (runProcess, waitForProcess)
import System.Exit (ExitCode(..))
-- |Create a source distribution.
sdist :: SDistFlags -> SDistExFlags -> IO ()
sdist flags exflags = do
pkg <- return . flattenPackageDescription
=<< readPackageDescription verbosity
=<< defaultPackageDesc verbosity
let withDir = if not needMakeArchive then (\f -> f tmpTargetDir)
else withTempDirectory verbosity tmpTargetDir "sdist."
-- 'withTempDir' fails if we don't create 'tmpTargetDir'...
when needMakeArchive $
createDirectoryIfMissingVerbose verbosity True tmpTargetDir
withDir $ \tmpDir -> do
let outDir = if isOutDirectory then tmpDir else tmpDir </> tarBallName pkg
flags' = (if not needMakeArchive then flags
else flags { sDistDirectory = Flag outDir })
{ sDistVerbosity = Flag $ if verbosity == normal
then lessVerbose verbosity
else verbosity }
unless isListSources $
createDirectoryIfMissingVerbose verbosity True outDir
-- Run 'setup sdist --output-directory=tmpDir' (or
-- '--list-source'/'--output-directory=someOtherDir') in case we were passed
-- those options.
setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags') []
-- Unless we were given --list-sources or --output-directory ourselves,
-- create an archive.
when needMakeArchive $
createArchive verbosity pkg tmpDir distPref
when isOutDirectory $
notice verbosity $ "Source directory created: " ++ tmpTargetDir
when isListSources $
notice verbosity $ "List of package sources written to file '"
++ (fromFlag . sDistListSources $ flags) ++ "'"
where
flagEnabled f = not . null . flagToList . f $ flags
isListSources = flagEnabled sDistListSources
isOutDirectory = flagEnabled sDistDirectory
needMakeArchive = not (isListSources || isOutDirectory)
verbosity = fromFlag (sDistVerbosity flags)
distPref = fromFlag (sDistDistPref flags)
tmpTargetDir = fromFlagOrDefault (srcPref distPref) (sDistDirectory flags)
setupOpts = defaultSetupScriptOptions {
-- The '--output-directory' sdist flag was introduced in Cabal 1.12, and
-- '--list-sources' in 1.17.
useCabalVersion = if isListSources
then orLaterVersion $ Version [1,17,0] []
else orLaterVersion $ Version [1,12,0] []
}
format = fromFlag (sDistFormat exflags)
createArchive = case format of
TargzFormat -> createTarGzArchive
ZipFormat -> createZipArchive
tarBallName :: PackageDescription -> String
tarBallName = display . packageId
-- | Create a tar.gz archive from a tree of source files.
createTarGzArchive :: Verbosity -> PackageDescription -> FilePath -> FilePath
-> IO ()
createTarGzArchive verbosity pkg tmpDir targetPref = do
createTarGzFile tarBallFilePath tmpDir (tarBallName pkg)
notice verbosity $ "Source tarball created: " ++ tarBallFilePath
where
tarBallFilePath = targetPref </> tarBallName pkg <.> "tar.gz"
-- | Create a zip archive from a tree of source files.
createZipArchive :: Verbosity -> PackageDescription -> FilePath -> FilePath
-> IO ()
createZipArchive verbosity pkg tmpDir targetPref = do
let dir = tarBallName pkg
zipfile = targetPref </> dir <.> "zip"
(zipProg, _) <- requireProgram verbosity zipProgram emptyProgramDb
-- zip has an annoying habit 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. Can't just use 'canonicalizePath zipfile' since this function
-- requires its argument to refer to an existing file.
zipfileAbs <- fmap (</> dir <.> "zip") . canonicalizePath $ targetPref
--TODO: use runProgramInvocation, but has to be able to set CWD
hnd <- runProcess (programPath zipProg) ["-q", "-r", zipfileAbs, dir]
(Just tmpDir)
Nothing Nothing Nothing Nothing
exitCode <- waitForProcess hnd
unless (exitCode == ExitSuccess) $
die $ "Generating the zip file failed "
++ "(zip returned exit code " ++ show exitCode ++ ")"
notice verbosity $ "Source zip archive created: " ++ zipfile
where
zipProgram = simpleProgram "zip"
|
