CmdSdist.hs 14.3 KB
Newer Older
Alexis Williams's avatar
Alexis Williams committed
1
2
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
3
{-# LANGUAGE OverloadedStrings #-}
Alexis Williams's avatar
Alexis Williams committed
4
5
6
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
Alexis Williams's avatar
Alexis Williams committed
7
8
module Distribution.Client.CmdSdist 
    ( sdistCommand, sdistAction, packageToSdist
Alexis Williams's avatar
Alexis Williams committed
9
    , SdistFlags(..), defaultSdistFlags
Alexis Williams's avatar
Alexis Williams committed
10
    , OutputFormat(..), ArchiveFormat(..) ) where
Alexis Williams's avatar
Alexis Williams committed
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

import Distribution.Client.CmdErrorMessages
    ( Plural(..), renderComponentKind )
import Distribution.Client.ProjectOrchestration
    ( ProjectBaseContext(..), establishProjectBaseContext )
import Distribution.Client.TargetSelector
    ( TargetSelector(..), ComponentKind
    , readTargetSelectors, reportTargetSelectorProblems )
import Distribution.Client.RebuildMonad
    ( runRebuild )
import Distribution.Client.Setup
    ( ArchiveFormat(..), GlobalFlags(..) )
import Distribution.Solver.Types.SourcePackage
    ( SourcePackage(..) )
import Distribution.Client.Types
    ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage )
import Distribution.Client.DistDirLayout
    ( DistDirLayout(..), defaultDistDirLayout )
import Distribution.Client.ProjectConfig
    ( findProjectRoot, readProjectConfig )

import Distribution.Package
    ( Package(packageId) )
import Distribution.PackageDescription.Configuration
    ( flattenPackageDescription )
import Distribution.Pretty
    ( prettyShow )
import Distribution.ReadE
    ( succeedReadE )
import Distribution.Simple.Command
    ( CommandUI(..), option, choiceOpt, reqArg )
import Distribution.Simple.PreProcess
    ( knownSuffixHandlers )
import Distribution.Simple.Setup
    ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe
    , optionVerbosity, optionDistPref, trueArg
    )
import Distribution.Simple.SrcDist
    ( listPackageSources )
import Distribution.Simple.Utils
quasicomputational's avatar
quasicomputational committed
51
    ( die', notice, withOutputMarker )
Alexis Williams's avatar
Alexis Williams committed
52
53
54
55
56
57
58
59
60
import Distribution.Types.ComponentName
    ( ComponentName, showComponentName )
import Distribution.Types.PackageName
    ( PackageName, unPackageName )
import Distribution.Verbosity
    ( Verbosity, normal )

import qualified Codec.Archive.Tar       as Tar
import qualified Codec.Archive.Tar.Entry as Tar
Alexis Williams's avatar
Alexis Williams committed
61
import qualified Codec.Archive.Zip       as Zip
Alexis Williams's avatar
Alexis Williams committed
62
63
64
65
import qualified Codec.Compression.GZip  as GZip
import Control.Exception
    ( throwIO )
import Control.Monad
Alexis Williams's avatar
Alexis Williams committed
66
    ( when, forM, forM_ )
Alexis Williams's avatar
Alexis Williams committed
67
import Control.Monad.Trans
Alexis Williams's avatar
Alexis Williams committed
68
69
70
71
72
    ( liftIO )
import Control.Monad.State.Lazy
    ( StateT, modify, gets, evalStateT )
import Control.Monad.Writer.Lazy
    ( WriterT, tell, execWriterT )
Alexis Williams's avatar
Alexis Williams committed
73
74
import Data.Bits
    ( shiftL )
Alexis Williams's avatar
Alexis Williams committed
75
76
77
78
import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.Either
    ( partitionEithers )
import Data.List
79
    ( find, sortOn, nub, intercalate )
Alexis Williams's avatar
Alexis Williams committed
80
import qualified Data.Set as Set
Alexis Williams's avatar
Alexis Williams committed
81
82
import System.Directory
    ( getCurrentDirectory, setCurrentDirectory
Alexis Williams's avatar
Alexis Williams committed
83
    , createDirectoryIfMissing, makeAbsolute )
Alexis Williams's avatar
Alexis Williams committed
84
import System.FilePath
85
    ( (</>), (<.>), makeRelative, normalise, takeDirectory )
Alexis Williams's avatar
Alexis Williams committed
86
87
88
89
90
91

sdistCommand :: CommandUI SdistFlags
sdistCommand = CommandUI
    { commandName = "new-sdist"
    , commandSynopsis = "Generate a source distribution file (.tar.gz)."
    , commandUsage = \pname ->
Alexis Williams's avatar
Alexis Williams committed
92
        "Usage: " ++ pname ++ " new-sdist [FLAGS] [PACKAGES]\n"
Alexis Williams's avatar
Alexis Williams committed
93
    , commandDescription  = Just $ \_ ->
Alexis Williams's avatar
Alexis Williams committed
94
        "Generates tarballs of project packages suitable for upload to Hackage."
Alexis Williams's avatar
Alexis Williams committed
95
96
97
98
99
100
101
102
103
104
105
106
    , commandNotes = Nothing
    , commandDefaultFlags = defaultSdistFlags
    , commandOptions = \showOrParseArgs ->
        [ optionVerbosity
            sdistVerbosity (\v flags -> flags { sdistVerbosity = v })
        , optionDistPref
            sdistDistDir (\dd flags -> flags { sdistDistDir = dd })
            showOrParseArgs
        , option [] ["project-file"]
            "Set the name of the cabal.project file to search for in parent directories"
            sdistProjectFile (\pf flags -> flags { sdistProjectFile = pf })
            (reqArg "FILE" (succeedReadE Flag) flagToList)
107
        , option ['l'] ["list-only"]
Alexis Williams's avatar
Alexis Williams committed
108
109
110
            "Just list the sources, do not make a tarball"
            sdistListSources (\v flags -> flags { sdistListSources = v })
            trueArg
111
112
113
114
        , option ['z'] ["null-sep"]
            "Separate the source files with NUL bytes rather than newlines."
            sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v })
            trueArg
Alexis Williams's avatar
Alexis Williams committed
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
        , option [] ["archive-format"] 
            "Choose what type of archive to create. No effect if given with '--list-only'"
                sdistArchiveFormat (\v flags -> flags { sdistArchiveFormat = 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")
                ]
            )
        , option ['o'] ["output-dir"]
            "Choose the output directory of this command. '-' sends all output to stdout"
            sdistOutputPath (\o flags -> flags { sdistOutputPath = o })
            (reqArg "PATH" (succeedReadE Flag) flagToList)
        ]
    }

data SdistFlags = SdistFlags
    { sdistVerbosity     :: Flag Verbosity
    , sdistDistDir       :: Flag FilePath
    , sdistProjectFile   :: Flag FilePath
    , sdistListSources   :: Flag Bool
137
    , sdistNulSeparated  :: Flag Bool
Alexis Williams's avatar
Alexis Williams committed
138
139
140
141
142
143
144
145
146
147
    , sdistArchiveFormat :: Flag ArchiveFormat
    , sdistOutputPath    :: Flag FilePath
    }

defaultSdistFlags :: SdistFlags
defaultSdistFlags = SdistFlags
    { sdistVerbosity     = toFlag normal
    , sdistDistDir       = mempty
    , sdistProjectFile   = mempty
    , sdistListSources   = toFlag False
148
    , sdistNulSeparated  = toFlag False
Alexis Williams's avatar
Alexis Williams committed
149
150
151
152
153
154
155
156
157
158
159
160
161
    , sdistArchiveFormat = toFlag TargzFormat
    , sdistOutputPath    = mempty
    }

--

sdistAction :: SdistFlags -> [String] -> GlobalFlags -> IO ()
sdistAction SdistFlags{..} targetStrings globalFlags = do
    let verbosity = fromFlagOrDefault normal sdistVerbosity
        mDistDirectory = flagToMaybe sdistDistDir
        mProjectFile = flagToMaybe sdistProjectFile
        globalConfig = globalConfigFile globalFlags
        listSources = fromFlagOrDefault False sdistListSources
162
        nulSeparated = fromFlagOrDefault False sdistNulSeparated
Alexis Williams's avatar
Alexis Williams committed
163
164
165
166
167
168
169
170
171
172
173
174
175
        archiveFormat = fromFlagOrDefault TargzFormat sdistArchiveFormat
        mOutputPath = flagToMaybe sdistOutputPath
  
    projectRoot <- either throwIO return =<< findProjectRoot Nothing mProjectFile
    let distLayout = defaultDistDirLayout projectRoot mDistDirectory
    dir <- getCurrentDirectory
    projectConfig <- runRebuild dir $ readProjectConfig verbosity globalConfig distLayout
    baseCtx <- establishProjectBaseContext verbosity projectConfig
    let localPkgs = localPackages baseCtx

    targetSelectors <- either (reportTargetSelectorProblems verbosity) return
        =<< readTargetSelectors localPkgs targetStrings
    
Alexis Williams's avatar
Alexis Williams committed
176
177
178
179
180
    mOutputPath' <- case mOutputPath of
        Just "-"  -> return (Just "-")
        Just path -> Just <$> makeAbsolute path
        Nothing   -> return Nothing
    
Alexis Williams's avatar
Alexis Williams committed
181
    let 
182
        format =
quasicomputational's avatar
quasicomputational committed
183
184
            if | listSources, nulSeparated -> SourceList '\0'
               | listSources               -> SourceList '\n'
185
186
187
188
189
190
191
               | otherwise                 -> Archive archiveFormat

        ext = case format of
                SourceList _        -> "list"
                Archive TargzFormat -> "tar.gz"
                Archive ZipFormat   -> "zip"
    
Alexis Williams's avatar
Alexis Williams committed
192
        outputPath pkg = case mOutputPath' of
193
            Just path
Alexis Williams's avatar
Alexis Williams committed
194
                | path == "-" -> "-"
195
                | otherwise   -> path </> prettyShow (packageId pkg) <.> ext
Alexis Williams's avatar
Alexis Williams committed
196
197
198
199
200
201
202
203
            Nothing
                | listSources -> "-"
                | otherwise   -> distSdistFile distLayout (packageId pkg) archiveFormat

    createDirectoryIfMissing True (distSdistDirectory distLayout)
    
    case reifyTargetSelectors localPkgs targetSelectors of
        Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs
Alexis Williams's avatar
Alexis Williams committed
204
        Right pkgs 
205
            | length pkgs > 1, not listSources, Just "-" <- mOutputPath' -> 
Alexis Williams's avatar
Alexis Williams committed
206
                die' verbosity "Can't write multiple tarballs to standard output!"
207
            | otherwise ->
208
                mapM_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distLayout) format (outputPath pkg) pkg) pkgs
Alexis Williams's avatar
Alexis Williams committed
209

Alexis Williams's avatar
Alexis Williams committed
210
211
212
data IsExec = Exec | NoExec
            deriving (Show, Eq)

213
214
215
216
data OutputFormat = SourceList Char
                  | Archive ArchiveFormat
                  deriving (Show, Eq)

217
218
packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO ()
packageToSdist verbosity projectRootDir format outputFile pkg = do
Alexis Williams's avatar
Alexis Williams committed
219
220
221
222
223
    dir <- case packageSource pkg of
        LocalUnpackedPackage path -> return path
        _ -> die' verbosity "The impossible happened: a local package isn't local"
    setCurrentDirectory dir

Alexis Williams's avatar
Alexis Williams committed
224
225
    let norm flag = fmap ((flag, ) . normalise)
    (norm NoExec -> nonexec, norm Exec -> exec) <- 
Alexis Williams's avatar
Alexis Williams committed
226
227
        listPackageSources verbosity (flattenPackageDescription $ packageDescription pkg) knownSuffixHandlers

quasicomputational's avatar
quasicomputational committed
228
229
230
    let write = if outputFile == "-"
          then putStr . withOutputMarker verbosity . BSL.unpack
          else BSL.writeFile outputFile
Alexis Williams's avatar
Alexis Williams committed
231
        files =  nub . sortOn snd $ nonexec ++ exec
Alexis Williams's avatar
Alexis Williams committed
232

233
    case format of
234
        SourceList nulSep -> do
Alexis Williams's avatar
Alexis Williams committed
235
            let prefix = makeRelative projectRootDir dir
236
237
238
            write (BSL.pack . (++ [nulSep]) . intercalate [nulSep] . fmap ((prefix </>) . snd) $ files)
            when (outputFile /= "-") $
                notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"
239
        Archive TargzFormat -> do
Alexis Williams's avatar
Alexis Williams committed
240
            let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()
Alexis Williams's avatar
Alexis Williams committed
241
242
243
244
245
246
247
248
249
250
251
252
253
                entriesM = do
                    let prefix = prettyShow (packageId pkg)
                    modify (Set.insert prefix)
                    case Tar.toTarPath True prefix of
                        Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
                        Right path -> tell [Tar.directoryEntry path]

                    forM_ files $ \(perm, file) -> do
                        let fileDir = takeDirectory (prefix </> file)
                            perm' = case perm of
                                Exec -> Tar.executableFilePermissions
                                NoExec -> Tar.ordinaryFilePermissions
                        needsEntry <- gets (Set.notMember fileDir)
Alexis Williams's avatar
Alexis Williams committed
254

Alexis Williams's avatar
Alexis Williams committed
255
256
257
258
259
260
261
262
                        when needsEntry $ do
                            modify (Set.insert fileDir)
                            case Tar.toTarPath True fileDir of
                                Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
                                Right path -> tell [Tar.directoryEntry path]
                            
                        contents <- liftIO $ BSL.readFile file
                        case Tar.toTarPath False (prefix </> file) of
Alexis Williams's avatar
Alexis Williams committed
263
                            Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
Alexis Williams's avatar
Alexis Williams committed
264
                            Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = perm' }]
Alexis Williams's avatar
Alexis Williams committed
265
            
Alexis Williams's avatar
Alexis Williams committed
266
267
            entries <- execWriterT (evalStateT entriesM mempty)
            let -- Pretend our GZip file is made on Unix.
268
269
270
271
272
                normalize bs = BSL.concat [first, "\x03", rest']
                    where
                        (first, rest) = BSL.splitAt 9 bs
                        rest' = BSL.tail rest
            write . normalize . GZip.compress . Tar.write $ entries
273
274
            when (outputFile /= "-") $
                notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"
275
        Archive ZipFormat -> do
Alexis Williams's avatar
Alexis Williams committed
276
            let prefix = prettyShow (packageId pkg)
Alexis Williams's avatar
Alexis Williams committed
277
278
279
280
281
282
283
            entries <- forM files $ \(perm, file) -> do
                let perm' = case perm of
                        -- -rwxr-xr-x
                        Exec   -> 0o010755 `shiftL` 16
                        -- -rw-r--r--
                        NoExec -> 0o010644 `shiftL` 16
                contents <- BSL.readFile file
Alexis Williams's avatar
Alexis Williams committed
284
                return $ (Zip.toEntry (prefix </> file) 0 contents) { Zip.eExternalFileAttributes = perm' }
Alexis Williams's avatar
Alexis Williams committed
285
286
            let archive = foldr Zip.addEntryToArchive Zip.emptyArchive entries
            write (Zip.fromArchive archive)
Alexis Williams's avatar
Alexis Williams committed
287
288
            when (outputFile /= "-") $
                notice verbosity $ "Wrote zip sdist to " ++ outputFile ++ "\n"
Alexis Williams's avatar
Alexis Williams committed
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323

--

reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage]
reifyTargetSelectors pkgs sels = 
    case partitionEithers (foldMap go sels) of
        ([], sels') -> Right sels'
        (errs, _)   -> Left errs
    where
        flatten (SpecificSourcePackage pkg@SourcePackage{}) = pkg
        flatten _ = error "The impossible happened: how do we not know about a local package?"
        pkgs' = fmap flatten pkgs

        getPkg pid = case find ((== pid) . packageId) pkgs' of
            Just pkg -> Right pkg
            Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages."
        
        go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage]
        go (TargetPackage _ pids Nothing) = fmap getPkg pids
        go (TargetAllPackages Nothing) = Right <$> pkgs'

        go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)]
        go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)]

        go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)]
        go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)]

        go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)]

data TargetProblem = AllComponentsOnly ComponentKind
                   | NonlocalPackageNotAllowed PackageName
                   | ComponentsNotAllowed ComponentName

renderTargetProblem :: TargetProblem -> String
renderTargetProblem (AllComponentsOnly kind) =
quasicomputational's avatar
quasicomputational committed
324
    "It is not possible to package only the " ++ renderComponentKind Plural kind ++ " from a package "
Alexis Williams's avatar
Alexis Williams committed
325
326
327
328
329
330
331
332
    ++ "for distribution. Only entire packages may be packaged for distribution."
renderTargetProblem (ComponentsNotAllowed cname) =
    "The component " ++ showComponentName cname ++ " cannot be packaged for distribution on its own. "
    ++ "Only entire packages may be packaged for distribution."
renderTargetProblem (NonlocalPackageNotAllowed pname) =
    "The package " ++ unPackageName pname ++ " cannot be packaged for distribution, because it is not "
    ++ "local to this project."