cabal-install/src/Distribution/Client/CmdSdist.hs

   1 {-# LANGUAGE MultiWayIf #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE TupleSections #-}
   6 {-# LANGUAGE ViewPatterns #-}
   7
   8 module Distribution.Client.CmdSdist
   9   ( sdistCommand
  10   , sdistAction
  11   , packageToSdist
  12   , OutputFormat (..)
  13   ) where
  14
  15 import Distribution.Client.Compat.Prelude
  16 import Prelude ()
  17
  18 import Distribution.Client.CmdErrorMessages
  19   ( Plural (..)
  20   , renderComponentKind
  21   )
  22 import Distribution.Client.DistDirLayout
  23   ( DistDirLayout (..)
  24   , ProjectRoot (..)
  25   )
  26 import Distribution.Client.NixStyleOptions
  27   ( NixStyleFlags (..)
  28   , defaultNixStyleFlags
  29   )
  30 import Distribution.Client.ProjectConfig
  31   ( ProjectConfig
  32   , commandLineFlagsToProjectConfig
  33   , projectConfigConfigFile
  34   , projectConfigShared
  35   , withProjectOrGlobalConfig
  36   )
  37 import Distribution.Client.ProjectFlags
  38   ( ProjectFlags (..)
  39   , defaultProjectFlags
  40   , projectFlagsOptions
  41   )
  42 import Distribution.Client.ProjectOrchestration
  43   ( CurrentCommand (..)
  44   , ProjectBaseContext (..)
  45   , establishProjectBaseContext
  46   , establishProjectBaseContextWithRoot
  47   )
  48 import Distribution.Client.Setup
  49   ( GlobalFlags (..)
  50   )
  51 import Distribution.Client.TargetSelector
  52   ( ComponentKind
  53   , TargetSelector (..)
  54   , readTargetSelectors
  55   , reportTargetSelectorProblems
  56   )
  57 import Distribution.Client.Types
  58   ( PackageLocation (..)
  59   , PackageSpecifier (..)
  60   , UnresolvedSourcePackage
  61   )
  62 import Distribution.Solver.Types.SourcePackage
  63   ( SourcePackage (..)
  64   )
  65
  66 import Distribution.Client.Errors
  67 import Distribution.Client.SrcDist
  68   ( packageDirToSdist
  69   )
  70 import Distribution.Compat.Lens
  71   ( _1
  72   , _2
  73   )
  74 import Distribution.Package
  75   ( Package (packageId)
  76   )
  77 import Distribution.PackageDescription.Configuration
  78   ( flattenPackageDescription
  79   )
  80 import Distribution.ReadE
  81   ( succeedReadE
  82   )
  83 import Distribution.Simple.Command
  84   ( CommandUI (..)
  85   , OptionField
  86   , ShowOrParseArgs
  87   , liftOptionL
  88   , option
  89   , reqArg
  90   )
  91 import Distribution.Simple.PreProcess
  92   ( knownSuffixHandlers
  93   )
  94 import Distribution.Simple.Setup
  95   ( Flag (..)
  96   , configDistPref
  97   , configVerbosity
  98   , flagToList
  99   , flagToMaybe
 100   , fromFlagOrDefault
 101   , optionDistPref
 102   , optionVerbosity
 103   , toFlag
 104   , trueArg
 105   )
 106 import Distribution.Simple.SrcDist
 107   ( listPackageSourcesWithDie
 108   )
 109 import Distribution.Simple.Utils
 110   ( dieWithException
 111   , notice
 112   , withOutputMarker
 113   , wrapText
 114   )
 115 import Distribution.Types.ComponentName
 116   ( ComponentName
 117   , showComponentName
 118   )
 119 import Distribution.Types.GenericPackageDescription (GenericPackageDescription)
 120 import Distribution.Types.PackageName
 121   ( PackageName
 122   , unPackageName
 123   )
 124 import Distribution.Verbosity
 125   ( normal
 126   )
 127
 128 import qualified Data.ByteString.Lazy.Char8 as BSL
 129 import System.Directory
 130   ( createDirectoryIfMissing
 131   , getCurrentDirectory
 132   , makeAbsolute
 133   )
 134 import System.FilePath
 135   ( makeRelative
 136   , normalise
 137   , (<.>)
 138   , (</>)
 139   )
 140
 141 -------------------------------------------------------------------------------
 142 -- Command
 143 -------------------------------------------------------------------------------
 144
 145 sdistCommand :: CommandUI (ProjectFlags, SdistFlags)
 146 sdistCommand =
 147   CommandUI
 148     { commandName = "v2-sdist"
 149     , commandSynopsis = "Generate a source distribution file (.tar.gz)."
 150     , commandUsage = \pname ->
 151         "Usage: " ++ pname ++ " v2-sdist [FLAGS] [PACKAGES]\n"
 152     , commandDescription = Just $ \_ ->
 153         wrapText
 154           "Generates tarballs of project packages suitable for upload to Hackage."
 155     , commandNotes = Nothing
 156     , commandDefaultFlags = (defaultProjectFlags, defaultSdistFlags)
 157     , commandOptions = \showOrParseArgs ->
 158         map (liftOptionL _1) (projectFlagsOptions showOrParseArgs)
 159           ++ map (liftOptionL _2) (sdistOptions showOrParseArgs)
 160     }
 161
 162 -------------------------------------------------------------------------------
 163 -- Flags
 164 -------------------------------------------------------------------------------
 165
 166 data SdistFlags = SdistFlags
 167   { sdistVerbosity :: Flag Verbosity
 168   , sdistDistDir :: Flag FilePath
 169   , sdistListSources :: Flag Bool
 170   , sdistNulSeparated :: Flag Bool
 171   , sdistOutputPath :: Flag FilePath
 172   }
 173
 174 defaultSdistFlags :: SdistFlags
 175 defaultSdistFlags =
 176   SdistFlags
 177     { sdistVerbosity = toFlag normal
 178     , sdistDistDir = mempty
 179     , sdistListSources = toFlag False
 180     , sdistNulSeparated = toFlag False
 181     , sdistOutputPath = mempty
 182     }
 183
 184 sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags]
 185 sdistOptions showOrParseArgs =
 186   [ optionVerbosity
 187       sdistVerbosity
 188       (\v flags -> flags{sdistVerbosity = v})
 189   , optionDistPref
 190       sdistDistDir
 191       (\dd flags -> flags{sdistDistDir = dd})
 192       showOrParseArgs
 193   , option
 194       ['l']
 195       ["list-only"]
 196       "Just list the sources, do not make a tarball"
 197       sdistListSources
 198       (\v flags -> flags{sdistListSources = v})
 199       trueArg
 200   , option
 201       []
 202       ["null-sep"]
 203       "Separate the source files with NUL bytes rather than newlines."
 204       sdistNulSeparated
 205       (\v flags -> flags{sdistNulSeparated = v})
 206       trueArg
 207   , option
 208       ['o']
 209       ["output-directory", "outputdir"]
 210       "Choose the output directory of this command. '-' sends all output to stdout"
 211       sdistOutputPath
 212       (\o flags -> flags{sdistOutputPath = o})
 213       (reqArg "PATH" (succeedReadE Flag) flagToList)
 214   ]
 215
 216 -------------------------------------------------------------------------------
 217 -- Action
 218 -------------------------------------------------------------------------------
 219
 220 sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO ()
 221 sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do
 222   (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity flagIgnoreProject globalConfigFlag withProject withoutProject
 223
 224   let localPkgs = localPackages baseCtx
 225
 226   targetSelectors <-
 227     either (reportTargetSelectorProblems verbosity) return
 228       =<< readTargetSelectors localPkgs Nothing targetStrings
 229
 230   -- elaborate path, create target directory
 231   mOutputPath' <- case mOutputPath of
 232     Just "-" -> return (Just "-")
 233     Just path -> do
 234       abspath <- makeAbsolute path
 235       createDirectoryIfMissing True abspath
 236       return (Just abspath)
 237     Nothing -> do
 238       createDirectoryIfMissing True (distSdistDirectory distDirLayout)
 239       return Nothing
 240
 241   let format :: OutputFormat
 242       format =
 243         if
 244             | listSources, nulSeparated -> SourceList '\0'
 245             | listSources -> SourceList '\n'
 246             | otherwise -> TarGzArchive
 247
 248       ext = case format of
 249         SourceList _ -> "list"
 250         TarGzArchive -> "tar.gz"
 251
 252       outputPath pkg = case mOutputPath' of
 253         Just path
 254           | path == "-" -> "-"
 255           | otherwise -> path </> prettyShow (packageId pkg) <.> ext
 256         Nothing
 257           | listSources -> "-"
 258           | otherwise -> distSdistFile distDirLayout (packageId pkg)
 259
 260   case reifyTargetSelectors localPkgs targetSelectors of
 261     Left errs -> dieWithException verbosity $ SdistActionException . fmap renderTargetProblem $ errs
 262     Right pkgs
 263       | length pkgs > 1
 264       , not listSources
 265       , Just "-" <- mOutputPath' ->
 266           dieWithException verbosity Can'tWriteMultipleTarballs
 267       | otherwise ->
 268           traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs
 269   where
 270     verbosity = fromFlagOrDefault normal sdistVerbosity
 271     listSources = fromFlagOrDefault False sdistListSources
 272     nulSeparated = fromFlagOrDefault False sdistNulSeparated
 273     mOutputPath = flagToMaybe sdistOutputPath
 274
 275     prjConfig :: ProjectConfig
 276     prjConfig =
 277       commandLineFlagsToProjectConfig
 278         globalFlags
 279         (defaultNixStyleFlags ())
 280           { configFlags =
 281               (configFlags $ defaultNixStyleFlags ())
 282                 { configVerbosity = sdistVerbosity
 283                 , configDistPref = sdistDistDir
 284                 }
 285           , projectFlags = pf
 286           }
 287         mempty
 288
 289     globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig)
 290
 291     withProject :: IO (ProjectBaseContext, DistDirLayout)
 292     withProject = do
 293       baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand
 294       return (baseCtx, distDirLayout baseCtx)
 295
 296     withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout)
 297     withoutProject config = do
 298       cwd <- getCurrentDirectory
 299       baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand
 300       return (baseCtx, distDirLayout baseCtx)
 301
 302 data OutputFormat
 303   = SourceList Char
 304   | TarGzArchive
 305   deriving (Show, Eq)
 306
 307 packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO ()
 308 packageToSdist verbosity projectRootDir format outputFile pkg = do
 309   let death = dieWithException verbosity $ ImpossibleHappened (show pkg)
 310   dir0 <- case srcpkgSource pkg of
 311     LocalUnpackedPackage path -> pure (Right path)
 312     RemoteSourceRepoPackage _ (Just tgz) -> pure (Left tgz)
 313     RemoteSourceRepoPackage{} -> death
 314     LocalTarballPackage tgz -> pure (Left tgz)
 315     RemoteTarballPackage _ (Just tgz) -> pure (Left tgz)
 316     RemoteTarballPackage{} -> death
 317     RepoTarballPackage{} -> death
 318
 319   let
 320     -- Write String to stdout or file, using the default TextEncoding.
 321     write str
 322       | outputFile == "-" = putStr (withOutputMarker verbosity str)
 323       | otherwise = do
 324           writeFile outputFile str
 325           notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"
 326     -- Write raw ByteString to stdout or file as it is, without encoding.
 327     writeLBS lbs
 328       | outputFile == "-" = BSL.putStr lbs
 329       | otherwise = do
 330           BSL.writeFile outputFile lbs
 331           notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"
 332
 333   case dir0 of
 334     Left tgz -> do
 335       case format of
 336         TarGzArchive -> do
 337           writeLBS =<< BSL.readFile tgz
 338         _ -> dieWithException verbosity $ CannotConvertTarballPackage (show format)
 339     Right dir -> case format of
 340       SourceList nulSep -> do
 341         let gpd :: GenericPackageDescription
 342             gpd = srcpkgDescription pkg
 343
 344         files' <- listPackageSourcesWithDie verbosity dieWithException dir (flattenPackageDescription gpd) knownSuffixHandlers
 345         let files = nub $ sort $ map normalise files'
 346         let prefix = makeRelative projectRootDir dir
 347         write $ concat [prefix </> i ++ [nulSep] | i <- files]
 348       TarGzArchive -> do
 349         packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS
 350
 351 --
 352
 353 reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage]
 354 reifyTargetSelectors pkgs sels =
 355   case partitionEithers (foldMap go sels) of
 356     ([], sels') -> Right sels'
 357     (errs, _) -> Left errs
 358   where
 359     -- there can be pkgs which are in extra-packages:
 360     -- these are not SpecificSourcePackage
 361     --
 362     -- Why these packages are in localPkgs, it's confusing.
 363     -- Anyhow, better to be lenient here.
 364     --
 365     flatten (SpecificSourcePackage pkg@SourcePackage{}) = Just pkg
 366     flatten _ = Nothing
 367
 368     pkgs' = mapMaybe flatten pkgs
 369
 370     getPkg pid = case find ((== pid) . packageId) pkgs' of
 371       Just pkg -> Right pkg
 372       Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages."
 373
 374     go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage]
 375     go (TargetPackage _ pids Nothing) = fmap getPkg pids
 376     go (TargetAllPackages Nothing) = Right <$> pkgs'
 377     go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)]
 378     go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)]
 379     go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)]
 380     go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)]
 381     go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)]
 382
 383 data TargetProblem
 384   = AllComponentsOnly ComponentKind
 385   | NonlocalPackageNotAllowed PackageName
 386   | ComponentsNotAllowed ComponentName
 387
 388 renderTargetProblem :: TargetProblem -> String
 389 renderTargetProblem (AllComponentsOnly kind) =
 390   "It is not possible to package only the "
 391     ++ renderComponentKind Plural kind
 392     ++ " from a package "
 393     ++ "for distribution. Only entire packages may be packaged for distribution."
 394 renderTargetProblem (ComponentsNotAllowed cname) =
 395   "The component "
 396     ++ showComponentName cname
 397     ++ " cannot be packaged for distribution on its own. "
 398     ++ "Only entire packages may be packaged for distribution."
 399 renderTargetProblem (NonlocalPackageNotAllowed pname) =
 400   "The package "
 401     ++ unPackageName pname
 402     ++ " cannot be packaged for distribution, because it is not "
 403     ++ "local to this project."