CmdSdist.hs 15 KB
Newer Older
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
1 2
{-# LANGUAGE MultiWayIf        #-}
{-# LANGUAGE NamedFieldPuns    #-}
3
{-# LANGUAGE OverloadedStrings #-}
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
4 5 6 7
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE ViewPatterns      #-}
module Distribution.Client.CmdSdist
Alexis Williams's avatar
Alexis Williams committed
8
    ( sdistCommand, sdistAction, packageToSdist
Alexis Williams's avatar
Alexis Williams committed
9
    , SdistFlags(..), defaultSdistFlags
10
    , OutputFormat(..)) where
Alexis Williams's avatar
Alexis Williams committed
11

Oleg Grenrus's avatar
Oleg Grenrus committed
12 13 14
import Prelude ()
import Distribution.Client.Compat.Prelude

Alexis Williams's avatar
Alexis Williams committed
15 16 17
import Distribution.Client.CmdErrorMessages
    ( Plural(..), renderComponentKind )
import Distribution.Client.ProjectOrchestration
18
    ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext, establishProjectBaseContextWithRoot)
Alexis Williams's avatar
Alexis Williams committed
19 20 21 22
import Distribution.Client.TargetSelector
    ( TargetSelector(..), ComponentKind
    , readTargetSelectors, reportTargetSelectorProblems )
import Distribution.Client.Setup
23
    ( GlobalFlags(..) )
Alexis Williams's avatar
Alexis Williams committed
24 25 26 27 28
import Distribution.Solver.Types.SourcePackage
    ( SourcePackage(..) )
import Distribution.Client.Types
    ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage )
import Distribution.Client.DistDirLayout
29
    ( DistDirLayout(..), ProjectRoot (..) )
Alexis Williams's avatar
Alexis Williams committed
30
import Distribution.Client.ProjectConfig
31
    ( ProjectConfig, withProjectOrGlobalConfigIgn, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared )
Alexis Williams's avatar
Alexis Williams committed
32 33 34 35 36 37 38 39 40 41

import Distribution.Package
    ( Package(packageId) )
import Distribution.PackageDescription.Configuration
    ( flattenPackageDescription )
import Distribution.Pretty
    ( prettyShow )
import Distribution.ReadE
    ( succeedReadE )
import Distribution.Simple.Command
42
    ( CommandUI(..), option, reqArg )
Alexis Williams's avatar
Alexis Williams committed
43 44 45 46
import Distribution.Simple.PreProcess
    ( knownSuffixHandlers )
import Distribution.Simple.Setup
    ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe
47
    , optionVerbosity, optionDistPref, trueArg, configVerbosity, configDistPref
Alexis Williams's avatar
Alexis Williams committed
48 49 50 51
    )
import Distribution.Simple.SrcDist
    ( listPackageSources )
import Distribution.Simple.Utils
52
    ( die', notice, withOutputMarker, wrapText )
Alexis Williams's avatar
Alexis Williams committed
53 54 55 56 57 58 59 60 61 62
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
import qualified Codec.Compression.GZip  as GZip
Alexis Williams's avatar
Alexis Williams committed
63
import Control.Monad.Trans
Alexis Williams's avatar
Alexis Williams committed
64 65 66 67 68
    ( liftIO )
import Control.Monad.State.Lazy
    ( StateT, modify, gets, evalStateT )
import Control.Monad.Writer.Lazy
    ( WriterT, tell, execWriterT )
69
import qualified Data.ByteString.Char8      as BS
Alexis Williams's avatar
Alexis Williams committed
70 71 72
import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.Either
    ( partitionEithers )
Alexis Williams's avatar
Alexis Williams committed
73
import qualified Data.Set as Set
Alexis Williams's avatar
Alexis Williams committed
74
import System.Directory
75
    ( getCurrentDirectory
Alexis Williams's avatar
Alexis Williams committed
76
    , createDirectoryIfMissing, makeAbsolute
77
    )
Alexis Williams's avatar
Alexis Williams committed
78
import System.FilePath
79
    ( (</>), (<.>), makeRelative, normalise, takeDirectory )
Alexis Williams's avatar
Alexis Williams committed
80 81 82

sdistCommand :: CommandUI SdistFlags
sdistCommand = CommandUI
83
    { commandName = "v2-sdist"
Alexis Williams's avatar
Alexis Williams committed
84 85
    , commandSynopsis = "Generate a source distribution file (.tar.gz)."
    , commandUsage = \pname ->
86
        "Usage: " ++ pname ++ " v2-sdist [FLAGS] [PACKAGES]\n"
87
    , commandDescription  = Just $ \_ -> wrapText
Alexis Williams's avatar
Alexis Williams committed
88
        "Generates tarballs of project packages suitable for upload to Hackage."
Alexis Williams's avatar
Alexis Williams committed
89 90 91 92 93 94 95 96 97 98 99 100
    , 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)
101 102 103 104
        , option ['z'] ["ignore-project"]
            "Ignore local project configuration"
            sdistIgnoreProject (\v flags -> flags { sdistIgnoreProject = v })
            trueArg
105
        , option ['l'] ["list-only"]
Alexis Williams's avatar
Alexis Williams committed
106 107 108
            "Just list the sources, do not make a tarball"
            sdistListSources (\v flags -> flags { sdistListSources = v })
            trueArg
109
        , option [] ["null-sep"]
110 111 112
            "Separate the source files with NUL bytes rather than newlines."
            sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v })
            trueArg
113
        , option ['o'] ["output-directory", "outputdir"]
Alexis Williams's avatar
Alexis Williams committed
114 115 116 117 118 119 120 121 122 123
            "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
124
    , sdistIgnoreProject :: Flag Bool
Alexis Williams's avatar
Alexis Williams committed
125
    , sdistListSources   :: Flag Bool
126
    , sdistNulSeparated  :: Flag Bool
Alexis Williams's avatar
Alexis Williams committed
127 128 129 130 131 132 133 134
    , sdistOutputPath    :: Flag FilePath
    }

defaultSdistFlags :: SdistFlags
defaultSdistFlags = SdistFlags
    { sdistVerbosity     = toFlag normal
    , sdistDistDir       = mempty
    , sdistProjectFile   = mempty
135
    , sdistIgnoreProject = toFlag False
Alexis Williams's avatar
Alexis Williams committed
136
    , sdistListSources   = toFlag False
137
    , sdistNulSeparated  = toFlag False
Alexis Williams's avatar
Alexis Williams committed
138 139 140 141 142 143 144
    , sdistOutputPath    = mempty
    }

--

sdistAction :: SdistFlags -> [String] -> GlobalFlags -> IO ()
sdistAction SdistFlags{..} targetStrings globalFlags = do
145 146
    (baseCtx, distDirLayout) <- withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag withProject withoutProject

Alexis Williams's avatar
Alexis Williams committed
147 148 149
    let localPkgs = localPackages baseCtx

    targetSelectors <- either (reportTargetSelectorProblems verbosity) return
150
        =<< readTargetSelectors localPkgs Nothing targetStrings
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
151

152
    -- elaborate path, create target directory
Alexis Williams's avatar
Alexis Williams committed
153 154
    mOutputPath' <- case mOutputPath of
        Just "-"  -> return (Just "-")
155 156 157 158 159 160 161
        Just path -> do
            abspath <- makeAbsolute path
            createDirectoryIfMissing True abspath
            return (Just abspath)
        Nothing   -> do
            createDirectoryIfMissing True (distSdistDirectory distDirLayout)
            return Nothing
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
162

163
    let format :: OutputFormat
164
        format =
quasicomputational's avatar
quasicomputational committed
165 166
            if | listSources, nulSeparated -> SourceList '\0'
               | listSources               -> SourceList '\n'
167
               | otherwise                 -> TarGzArchive
168 169

        ext = case format of
Emily Pillmore's avatar
Emily Pillmore committed
170 171
                SourceList _  -> "list"
                TarGzArchive  -> "tar.gz"
172

Alexis Williams's avatar
Alexis Williams committed
173
        outputPath pkg = case mOutputPath' of
174
            Just path
Alexis Williams's avatar
Alexis Williams committed
175
                | path == "-" -> "-"
176
                | otherwise   -> path </> prettyShow (packageId pkg) <.> ext
Alexis Williams's avatar
Alexis Williams committed
177 178
            Nothing
                | listSources -> "-"
179
                | otherwise   -> distSdistFile distDirLayout (packageId pkg)
Alexis Williams's avatar
Alexis Williams committed
180

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
181

Alexis Williams's avatar
Alexis Williams committed
182 183
    case reifyTargetSelectors localPkgs targetSelectors of
        Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
184 185
        Right pkgs
            | length pkgs > 1, not listSources, Just "-" <- mOutputPath' ->
Alexis Williams's avatar
Alexis Williams committed
186
                die' verbosity "Can't write multiple tarballs to standard output!"
187
            | otherwise ->
188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218
                traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs
  where
    verbosity      = fromFlagOrDefault normal sdistVerbosity
    listSources    = fromFlagOrDefault False sdistListSources
    nulSeparated   = fromFlagOrDefault False sdistNulSeparated
    mOutputPath    = flagToMaybe sdistOutputPath
    ignoreProject  = fromFlagOrDefault False sdistIgnoreProject

    prjConfig :: ProjectConfig
    prjConfig = commandLineFlagsToProjectConfig
        globalFlags
        mempty { configVerbosity = sdistVerbosity, configDistPref = sdistDistDir }
        mempty
        mempty
        mempty
        mempty
        mempty
        mempty

    globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig)

    withProject :: IO (ProjectBaseContext, DistDirLayout)
    withProject = do
        baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand
        return (baseCtx, distDirLayout baseCtx)

    withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout)
    withoutProject config = do
        cwd <- getCurrentDirectory
        baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand
        return (baseCtx, distDirLayout baseCtx)
Alexis Williams's avatar
Alexis Williams committed
219

220
data OutputFormat = SourceList Char
221
                  | TarGzArchive
222 223
                  deriving (Show, Eq)

224 225
packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO ()
packageToSdist verbosity projectRootDir format outputFile pkg = do
226
    let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg))
227 228 229
    dir0 <- case packageSource pkg of
             LocalUnpackedPackage path             -> pure (Right path)
             RemoteSourceRepoPackage _ (Just path) -> pure (Right path)
230
             RemoteSourceRepoPackage {}            -> death
231 232
             LocalTarballPackage tgz               -> pure (Left tgz)
             RemoteTarballPackage _ (Just tgz)     -> pure (Left tgz)
233 234
             RemoteTarballPackage {}               -> death
             RepoTarballPackage {}                 -> death
Alexis Williams's avatar
Alexis Williams committed
235

236 237 238 239 240 241 242 243
    let -- Write String to stdout or file, using the default TextEncoding.
        write
          | outputFile == "-" = putStr . withOutputMarker verbosity
          | otherwise = writeFile outputFile
        -- Write raw ByteString to stdout or file as it is, without encoding.
        writeLBS
          | outputFile == "-" = BSL.putStr
          | otherwise = BSL.writeFile outputFile
Alexis Williams's avatar
Alexis Williams committed
244

245 246 247
    case dir0 of
      Left tgz -> do
        case format of
248
          TarGzArchive -> do
249
            writeLBS =<< BSL.readFile tgz
250
            when (outputFile /= "-") $
251
              notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"
252 253 254
          _ -> die' verbosity ("cannot convert tarball package to " ++ show format)

      Right dir -> do
255 256
        files' <- listPackageSources verbosity dir (flattenPackageDescription $ packageDescription pkg) knownSuffixHandlers
        let files = nub $ sort $ map normalise files'
257 258 259 260

        case format of
            SourceList nulSep -> do
                let prefix = makeRelative projectRootDir dir
261
                write $ concat [prefix </> i ++ [nulSep] | i <- files]
262 263
                when (outputFile /= "-") $
                    notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"
264
            TarGzArchive -> do
265 266 267 268 269
                let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()
                    entriesM = do
                        let prefix = prettyShow (packageId pkg)
                        modify (Set.insert prefix)
                        case Tar.toTarPath True prefix of
Alexis Williams's avatar
Alexis Williams committed
270
                            Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
271 272
                            Right path -> tell [Tar.directoryEntry path]

273
                        for_ files $ \file -> do
274 275 276 277 278 279 280 281 282
                            let fileDir = takeDirectory (prefix </> file)
                            needsEntry <- gets (Set.notMember fileDir)

                            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]

283
                            contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir </> file
284 285
                            case Tar.toTarPath False (prefix </> file) of
                                Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
286
                                Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }]
287 288 289

                entries <- execWriterT (evalStateT entriesM mempty)
                let -- Pretend our GZip file is made on Unix.
Oleg Grenrus's avatar
Oleg Grenrus committed
290
                    normalize bs = BSL.concat [pfx, "\x03", rest']
291
                        where
Oleg Grenrus's avatar
Oleg Grenrus committed
292
                            (pfx, rest) = BSL.splitAt 9 bs
293 294 295 296 297 298 299
                            rest' = BSL.tail rest
                    -- The Unix epoch, which is the default value, is
                    -- unsuitable because it causes unpacking problems on
                    -- Windows; we need a post-1980 date. One gigasecond
                    -- after the epoch is during 2001-09-09, so that does
                    -- nicely. See #5596.
                    setModTime entry = entry { Tar.entryTime = 1000000000 }
300
                writeLBS . normalize . GZip.compress . Tar.write $ fmap setModTime entries
301 302
                when (outputFile /= "-") $
                    notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"
303

Alexis Williams's avatar
Alexis Williams committed
304 305 306
--

reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage]
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
307
reifyTargetSelectors pkgs sels =
Alexis Williams's avatar
Alexis Williams committed
308 309 310 311 312 313 314 315 316 317 318
    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."
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
319

Alexis Williams's avatar
Alexis Williams committed
320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337
        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
338
    "It is not possible to package only the " ++ renderComponentKind Plural kind ++ " from a package "
Alexis Williams's avatar
Alexis Williams committed
339 340 341 342 343 344 345
    ++ "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."