cabal-install-3.0.0.0: Distribution/Client/CmdSdist.hs
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Distribution.Client.CmdSdist
( sdistCommand, sdistAction, packageToSdist
, SdistFlags(..), defaultSdistFlags
, OutputFormat(..)) where
import Distribution.Client.CmdErrorMessages
( Plural(..), renderComponentKind )
import Distribution.Client.ProjectOrchestration
( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext )
import Distribution.Client.TargetSelector
( TargetSelector(..), ComponentKind
, readTargetSelectors, reportTargetSelectorProblems )
import Distribution.Client.RebuildMonad
( runRebuild )
import Distribution.Client.Setup
( 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.Compat.Semigroup
((<>))
import Distribution.Package
( Package(packageId) )
import Distribution.PackageDescription.Configuration
( flattenPackageDescription )
import Distribution.Pretty
( prettyShow )
import Distribution.ReadE
( succeedReadE )
import Distribution.Simple.Command
( CommandUI(..), option, 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
( die', notice, withOutputMarker, wrapText )
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
import Control.Exception
( throwIO )
import Control.Monad
( when, forM_ )
import Control.Monad.Trans
( liftIO )
import Control.Monad.State.Lazy
( StateT, modify, gets, evalStateT )
import Control.Monad.Writer.Lazy
( WriterT, tell, execWriterT )
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.Either
( partitionEithers )
import Data.List
( find, sortOn, nub )
import qualified Data.Set as Set
import System.Directory
( getCurrentDirectory, setCurrentDirectory
, createDirectoryIfMissing, makeAbsolute )
import System.FilePath
( (</>), (<.>), makeRelative, normalise, takeDirectory )
sdistCommand :: CommandUI SdistFlags
sdistCommand = CommandUI
{ commandName = "v2-sdist"
, commandSynopsis = "Generate a source distribution file (.tar.gz)."
, commandUsage = \pname ->
"Usage: " ++ pname ++ " v2-sdist [FLAGS] [PACKAGES]\n"
, commandDescription = Just $ \_ -> wrapText
"Generates tarballs of project packages suitable for upload to Hackage."
, 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)
, option ['l'] ["list-only"]
"Just list the sources, do not make a tarball"
sdistListSources (\v flags -> flags { sdistListSources = v })
trueArg
, option ['z'] ["null-sep"]
"Separate the source files with NUL bytes rather than newlines."
sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v })
trueArg
, option ['o'] ["output-dir", "outputdir"]
"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
, sdistNulSeparated :: Flag Bool
, sdistOutputPath :: Flag FilePath
}
defaultSdistFlags :: SdistFlags
defaultSdistFlags = SdistFlags
{ sdistVerbosity = toFlag normal
, sdistDistDir = mempty
, sdistProjectFile = mempty
, sdistListSources = toFlag False
, sdistNulSeparated = toFlag False
, 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
nulSeparated = fromFlagOrDefault False sdistNulSeparated
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 OtherCommand
let localPkgs = localPackages baseCtx
targetSelectors <- either (reportTargetSelectorProblems verbosity) return
=<< readTargetSelectors localPkgs Nothing targetStrings
mOutputPath' <- case mOutputPath of
Just "-" -> return (Just "-")
Just path -> Just <$> makeAbsolute path
Nothing -> return Nothing
let
format =
if | listSources, nulSeparated -> SourceList '\0'
| listSources -> SourceList '\n'
| otherwise -> TarGzArchive
ext = case format of
SourceList _ -> "list"
TarGzArchive -> "tar.gz"
outputPath pkg = case mOutputPath' of
Just path
| path == "-" -> "-"
| otherwise -> path </> prettyShow (packageId pkg) <.> ext
Nothing
| listSources -> "-"
| otherwise -> distSdistFile distLayout (packageId pkg)
createDirectoryIfMissing True (distSdistDirectory distLayout)
case reifyTargetSelectors localPkgs targetSelectors of
Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs
Right pkgs
| length pkgs > 1, not listSources, Just "-" <- mOutputPath' ->
die' verbosity "Can't write multiple tarballs to standard output!"
| otherwise ->
mapM_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distLayout) format (outputPath pkg) pkg) pkgs
data IsExec = Exec | NoExec
deriving (Show, Eq)
data OutputFormat = SourceList Char
| TarGzArchive
deriving (Show, Eq)
packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO ()
packageToSdist verbosity projectRootDir format outputFile pkg = do
let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg))
dir0 <- case packageSource pkg of
LocalUnpackedPackage path -> pure (Right path)
RemoteSourceRepoPackage _ (Just path) -> pure (Right path)
RemoteSourceRepoPackage {} -> death
LocalTarballPackage tgz -> pure (Left tgz)
RemoteTarballPackage _ (Just tgz) -> pure (Left tgz)
RemoteTarballPackage {} -> death
RepoTarballPackage {} -> death
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
case dir0 of
Left tgz -> do
case format of
TarGzArchive -> do
writeLBS =<< BSL.readFile tgz
when (outputFile /= "-") $
notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"
_ -> die' verbosity ("cannot convert tarball package to " ++ show format)
Right dir -> do
oldPwd <- getCurrentDirectory
setCurrentDirectory dir
let norm flag = fmap ((flag, ) . normalise)
(norm NoExec -> nonexec, norm Exec -> exec) <-
listPackageSources verbosity (flattenPackageDescription $ packageDescription pkg) knownSuffixHandlers
let files = nub . sortOn snd $ nonexec ++ exec
case format of
SourceList nulSep -> do
let prefix = makeRelative projectRootDir dir
write $ concat [prefix </> i ++ [nulSep] | (_, i) <- files]
when (outputFile /= "-") $
notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"
TarGzArchive -> do
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
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)
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 . fmap BSL.fromStrict . BS.readFile $ file
case Tar.toTarPath False (prefix </> file) of
Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = perm' }]
entries <- execWriterT (evalStateT entriesM mempty)
let -- Pretend our GZip file is made on Unix.
normalize bs = BSL.concat [first, "\x03", rest']
where
(first, rest) = BSL.splitAt 9 bs
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 }
writeLBS . normalize . GZip.compress . Tar.write $ fmap setModTime entries
when (outputFile /= "-") $
notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"
setCurrentDirectory oldPwd
--
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) =
"It is not possible to package only the " ++ renderComponentKind Plural kind ++ " from a package "
++ "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."