{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors      #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeFamilies          #-}

{-|
Module      : Stack.SDist
Description : Types and functions related to Stack's @sdist@ command.
License     : BSD-3-Clause

Types and functions related to Stack's @sdist@ command.
-}

module Stack.SDist
  ( SDistOpts (..)
  , sdistCmd
  , getSDistTarball
  , checkSDistTarball
  , checkSDistTarball'
  , readLocalPackage
  ) where

import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import           Conduit ( runConduitRes, sourceLazy, sinkFileCautious )
import           Control.Concurrent.Execute
                   ( ActionContext (..), Concurrency (..) )
import           Control.Monad.Extra ( whenJust )
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import           Data.Char ( toLower )
import           Data.Data ( cast )
import qualified Data.Either.Extra as EE
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import           Data.Time.Clock.POSIX ( getPOSIXTime, utcTimeToPOSIXSeconds )
import           Distribution.Package ( Dependency (..) )
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription.Check as Check
import qualified Distribution.PackageDescription.Parsec as Cabal
import           Distribution.PackageDescription.PrettyPrint
                   ( showGenericPackageDescription )
import           Distribution.Simple.Utils ( cabalVersion )
import           Distribution.Version
                   ( earlierVersion, hasLowerBound, hasUpperBound, isAnyVersion
                   , orLaterVersion, simplifyVersionRange
                   )
import           Path ( (</>), parent, parseRelDir, parseRelFile )
import           Path.IO ( ensureDir, resolveDir' )
import           RIO.NonEmpty ( nonEmpty )
import qualified RIO.NonEmpty as NE
import           Stack.Build ( mkBaseConfigOpts, build, buildLocalTargets )
import           Stack.Build.Execute
                   ( ExcludeTHLoading (..), KeepOutputOpen (..) )
import           Stack.Build.ExecuteEnv ( withExecuteEnv, withSingleContext )
import           Stack.Build.Installed ( getInstalled, toInstallMap )
import           Stack.Build.Source ( projectLocalPackages )
import           Stack.BuildOpts ( defaultBuildOpts )
import           Stack.Constants ( stackProgName, stackProgName' )
import           Stack.Constants.Config ( distDirFromDir )
import           Stack.Package ( resolvePackage, resolvePackageDescription )
import           Stack.Prelude
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withDefaultEnvConfig )
import           Stack.SourceMap ( mkProjectPackage )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..), configFileL )
import           Stack.Types.BuildOpts ( BuildOpts (..) )
import           Stack.Types.BuildOptsCLI ( defaultBuildOptsCLI )
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.Installed
                   ( InstallMap, Installed (..), InstalledMap
                   , InstalledLibraryInfo (..), installedVersion
                   )
import           Stack.Types.Package
                   ( LocalPackage (..), Package (..), PackageConfig (..)
                   , packageIdentifier
                   )
import           Stack.Types.Plan ( TaskType (..) )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.PvpBounds ( PvpBounds (..), PvpBoundsType (..) )
import           Stack.Types.Runner ( HasRunner, Runner )
import           Stack.Types.SDistOpts ( SDistOpts (..) )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), ProjectPackage (..), SMWanted (..)
                   , SourceMap (..), ppRoot
                   )
import qualified Stack.Types.SourceMap as SourceMap ( SourceMap (..) )
import           Stack.Types.Version
                   ( intersectVersionRanges, nextMajorVersion )
import           System.Directory
                   ( copyFile, createDirectoryIfMissing, executable
                   , getModificationTime, getPermissions
                   )
import qualified System.FilePath as FP

-- | Type representing \'pretty\' exceptions thrown by functions exported by the

-- "Stack.SDist" module.

data SDistPrettyException
  = CheckException (NonEmpty Check.PackageCheck)
  | CabalFilePathsInconsistentBug (Path Abs File) (Path Abs File)
  | ToTarPathException String
  deriving Int -> SDistPrettyException -> ShowS
[SDistPrettyException] -> ShowS
SDistPrettyException -> FilePath
(Int -> SDistPrettyException -> ShowS)
-> (SDistPrettyException -> FilePath)
-> ([SDistPrettyException] -> ShowS)
-> Show SDistPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SDistPrettyException -> ShowS
showsPrec :: Int -> SDistPrettyException -> ShowS
$cshow :: SDistPrettyException -> FilePath
show :: SDistPrettyException -> FilePath
$cshowList :: [SDistPrettyException] -> ShowS
showList :: [SDistPrettyException] -> ShowS
Show

instance Pretty SDistPrettyException where
  pretty :: SDistPrettyException -> StyleDoc
pretty (CheckException NonEmpty PackageCheck
xs) =
    StyleDoc
"[S-6439]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"Package check reported the following errors:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList ((PackageCheck -> StyleDoc) -> [PackageCheck] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> StyleDoc
string (FilePath -> StyleDoc)
-> (PackageCheck -> FilePath) -> PackageCheck -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageCheck -> FilePath
forall a. Show a => a -> FilePath
show) (NonEmpty PackageCheck -> [PackageCheck]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty PackageCheck
xs) :: [StyleDoc])
  pretty (CabalFilePathsInconsistentBug Path Abs File
cabalFP Path Abs File
cabalFP') =
    StyleDoc
"[S-9595]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ FilePath -> StyleDoc
flow FilePath
"The impossible happened! Two Cabal file paths are \
                \inconsistent:"
         , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalFP
         , StyleDoc
"and"
         , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalFP' StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (ToTarPathException FilePath
e) =
    StyleDoc
"[S-7875]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
string FilePath
e

instance Exception SDistPrettyException

-- | Function underlying the @stack sdist@ command.

sdistCmd :: SDistOpts -> RIO Runner ()
sdistCmd :: SDistOpts -> RIO Runner ()
sdistCmd SDistOpts
sdistOpts =
  ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ RIO EnvConfig () -> RIO Config ()
forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig (RIO EnvConfig () -> RIO Config ())
-> RIO EnvConfig () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
    -- If no directories are specified, build all sdist tarballs.

    dirs' <- if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null SDistOpts
sdistOpts.dirsToWorkWith
      then do
        dirs <- Getting [Path Abs Dir] EnvConfig [Path Abs Dir]
-> RIO EnvConfig [Path Abs Dir]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting [Path Abs Dir] EnvConfig [Path Abs Dir]
 -> RIO EnvConfig [Path Abs Dir])
-> Getting [Path Abs Dir] EnvConfig [Path Abs Dir]
-> RIO EnvConfig [Path Abs Dir]
forall a b. (a -> b) -> a -> b
$
          (BuildConfig -> Const [Path Abs Dir] BuildConfig)
-> EnvConfig -> Const [Path Abs Dir] EnvConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' EnvConfig BuildConfig
buildConfigL ((BuildConfig -> Const [Path Abs Dir] BuildConfig)
 -> EnvConfig -> Const [Path Abs Dir] EnvConfig)
-> (([Path Abs Dir] -> Const [Path Abs Dir] [Path Abs Dir])
    -> BuildConfig -> Const [Path Abs Dir] BuildConfig)
-> Getting [Path Abs Dir] EnvConfig [Path Abs Dir]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> [Path Abs Dir])
-> SimpleGetter BuildConfig [Path Abs Dir]
forall s a. (s -> a) -> SimpleGetter s a
to ((ProjectPackage -> Path Abs Dir)
-> [ProjectPackage] -> [Path Abs Dir]
forall a b. (a -> b) -> [a] -> [b]
map ProjectPackage -> Path Abs Dir
ppRoot ([ProjectPackage] -> [Path Abs Dir])
-> (BuildConfig -> [ProjectPackage])
-> BuildConfig
-> [Path Abs Dir]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PackageName ProjectPackage -> [ProjectPackage]
forall k a. Map k a -> [a]
Map.elems (Map PackageName ProjectPackage -> [ProjectPackage])
-> (BuildConfig -> Map PackageName ProjectPackage)
-> BuildConfig
-> [ProjectPackage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.smWanted.project))
        when (null dirs) $ do
          configFile <- view configFileL
          -- We are indifferent as to whether the configuration file is a

          -- user-specific global or a project-level one.

          let eitherConfigFile = Either (Path Abs File) (Path Abs File) -> Path Abs File
forall a. Either a a -> a
EE.fromEither Either (Path Abs File) (Path Abs File)
configFile
          prettyErrorL
            [ style Shell "stack sdist"
            , flow "expects a list of targets, and otherwise defaults to all \
                   \of the project's packages. However, the configuration at"
            , pretty eitherConfigFile
            , flow "contains no packages, so no sdist tarballs will be \
                   \generated."
            ]
          exitFailure
        pure dirs
      else (FilePath -> RIO EnvConfig (Path Abs Dir))
-> [FilePath] -> RIO EnvConfig [Path Abs Dir]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM FilePath -> RIO EnvConfig (Path Abs Dir)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs Dir)
resolveDir' SDistOpts
sdistOpts.dirsToWorkWith
    forM_ dirs' $ \Path Abs Dir
dir -> do
      (tarName, tarBytes, _mcabalRevision) <-
        Maybe PvpBounds
-> Path Abs Dir
-> RIO
     EnvConfig
     (FilePath, ByteString, Maybe (PackageIdentifier, ByteString))
forall env.
HasEnvConfig env =>
Maybe PvpBounds
-> Path Abs Dir
-> RIO
     env (FilePath, ByteString, Maybe (PackageIdentifier, ByteString))
getSDistTarball SDistOpts
sdistOpts.pvpBounds Path Abs Dir
dir
      distDir <- distDirFromDir dir
      tarPath <- (distDir </>) <$> parseRelFile tarName
      ensureDir (parent tarPath)
      runConduitRes $
        sourceLazy tarBytes .|
        sinkFileCautious (toFilePath tarPath)
      prettyInfoL
        [flow "Wrote sdist-format compressed archive to"
        , pretty tarPath <> "."
        ]
      checkSDistTarball sdistOpts tarPath
      forM_ sdistOpts.tarPath $ copyTarToTarPath tarPath tarName
 where
  copyTarToTarPath :: Path b t -> FilePath -> FilePath -> m ()
copyTarToTarPath Path b t
tarPath FilePath
tarName FilePath
targetDir = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    let targetTarPath :: FilePath
targetTarPath = FilePath
targetDir FilePath -> ShowS
FP.</> FilePath
tarName
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
FP.takeDirectory FilePath
targetTarPath
    FilePath -> FilePath -> IO ()
copyFile (Path b t -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b t
tarPath) FilePath
targetTarPath

-- | Given the path to a package directory, creates a source distribution

-- tarball for the package.

--

-- While this yields a 'FilePath', the name of the tarball, this tarball is not

-- written to the disk and instead yielded as a lazy bytestring.

getSDistTarball ::
     HasEnvConfig env
  => Maybe PvpBounds
     -- ^ Override Config value

  -> Path Abs Dir
     -- ^ Path to package directory

  -> RIO
       env
       ( FilePath
       , L.ByteString
       , Maybe (PackageIdentifier, L.ByteString)
       )
     -- ^ Filename, tarball contents, and option Cabal file revision to upload

getSDistTarball :: forall env.
HasEnvConfig env =>
Maybe PvpBounds
-> Path Abs Dir
-> RIO
     env (FilePath, ByteString, Maybe (PackageIdentifier, ByteString))
getSDistTarball Maybe PvpBounds
mpvpBounds Path Abs Dir
pkgDir = do
  config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
  let PvpBounds pvpBounds asRevision =
        fromMaybe config.pvpBounds mpvpBounds
      tweakCabal = PvpBoundsType
pvpBounds PvpBoundsType -> PvpBoundsType -> Bool
forall a. Eq a => a -> a -> Bool
/= PvpBoundsType
PvpBoundsNone
      pkgFp = Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir
  lp <- readLocalPackage pkgDir
  forM_ lp.package.setupDeps $ \Map PackageName DepValue
customSetupDeps ->
    case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ((PackageName -> Text) -> [PackageName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
T.pack (FilePath -> Text)
-> (PackageName -> FilePath) -> PackageName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
packageNameString) (Map PackageName DepValue -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName DepValue
customSetupDeps)) of
      Just NonEmpty Text
nonEmptyDepTargets ->
        NonEmpty Text -> RIO env (Either SomeException ())
forall env.
HasEnvConfig env =>
NonEmpty Text -> RIO env (Either SomeException ())
buildLocalTargets NonEmpty Text
nonEmptyDepTargets RIO env (Either SomeException ())
-> (Either SomeException () -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left SomeException
err ->
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
              Utf8Builder
"Error: [S-8399]\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
              Utf8Builder
"Error building custom-setup dependencies: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
              SomeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SomeException
err
          Right ()
_ ->
            () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Maybe (NonEmpty Text)
Nothing ->
        FilePath -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
FilePath -> m ()
prettyWarnS FilePath
"unexpected empty custom-setup dependencies."
  sourceMap <- view $ envConfigL . to (.sourceMap)
  installMap <- toInstallMap sourceMap
  (installedMap, _globalDumpPkgs, _snapshotDumpPkgs, _localDumpPkgs) <-
    getInstalled installMap
  let deps = [(PackageIdentifier, GhcPkgId)] -> Map PackageIdentifier GhcPkgId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (PackageIdentifier
pid, InstalledLibraryInfo
libInfo.ghcPkgId)
        | (InstallLocation
_, Library PackageIdentifier
pid InstalledLibraryInfo
libInfo) <- InstalledMap -> [(InstallLocation, Installed)]
forall k a. Map k a -> [a]
Map.elems InstalledMap
installedMap]
  prettyInfoL
    [ flow "Getting the file list for"
    , style File (fromString  pkgFp) <> "."
    ]
  (fileList, cabalFP) <- getSDistFileList lp deps
  prettyInfoL
    [ flow "Building a compressed archive file in the sdist format for"
    , style File (fromString pkgFp) <> "."
    ]
  files <-
    normalizeTarballPaths (map (T.unpack . stripCR . T.pack) (lines fileList))
  -- We're going to loop below and eventually find the Cabal file. When we do,

  -- we'll upload this reference, if the mpvpBounds value indicates that we

  -- should be uploading a Cabal file revision.

  cabalFileRevisionRef <- liftIO (newIORef Nothing)
  -- NOTE: Could make this use lazy I/O to only read files as needed for upload

  -- (both GZip.compress and Tar.write are lazy). However, it seems less error

  -- prone and more predictable to read everything in at once, so that's what

  -- we're doing for now:

  let tarPath Bool
isDir FilePath
fp =
        case Bool -> FilePath -> Either FilePath TarPath
Tar.toTarPath Bool
isDir (FilePath
pkgIdName FilePath -> ShowS
FP.</> FilePath
fp) of
          Left FilePath
e -> SDistPrettyException -> IO TarPath
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SDistPrettyException -> IO TarPath)
-> SDistPrettyException -> IO TarPath
forall a b. (a -> b) -> a -> b
$ FilePath -> SDistPrettyException
ToTarPathException FilePath
e
          Right TarPath
tp -> TarPath -> IO TarPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TarPath
tp
      packWith FilePath -> TarPath -> IO (GenEntry TarPath LinkTarget)
f Bool
isDir FilePath
fp = IO (GenEntry TarPath LinkTarget)
-> RIO env (GenEntry TarPath LinkTarget)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (GenEntry TarPath LinkTarget)
 -> RIO env (GenEntry TarPath LinkTarget))
-> IO (GenEntry TarPath LinkTarget)
-> RIO env (GenEntry TarPath LinkTarget)
forall a b. (a -> b) -> a -> b
$ FilePath -> TarPath -> IO (GenEntry TarPath LinkTarget)
f (FilePath
pkgFp FilePath -> ShowS
FP.</> FilePath
fp) (TarPath -> IO (GenEntry TarPath LinkTarget))
-> IO TarPath -> IO (GenEntry TarPath LinkTarget)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> FilePath -> IO TarPath
tarPath Bool
isDir FilePath
fp
      packDir = (FilePath -> TarPath -> IO (GenEntry TarPath LinkTarget))
-> Bool -> FilePath -> RIO env (GenEntry TarPath LinkTarget)
packWith FilePath -> TarPath -> IO (GenEntry TarPath LinkTarget)
forall tarPath linkTarget.
FilePath -> tarPath -> IO (GenEntry tarPath linkTarget)
Tar.packDirectoryEntry Bool
True
      packFile FilePath
fp
        -- This is a Cabal file, we're going to tweak it, but only tweak it as a

        -- revision.

        | Bool
tweakCabal Bool -> Bool -> Bool
&& FilePath -> Bool
isCabalFp FilePath
fp Bool -> Bool -> Bool
&& Bool
asRevision = do
            lbsIdent <- PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
forall env.
HasEnvConfig env =>
PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
getCabalLbs PvpBoundsType
pvpBounds (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) Path Abs File
cabalFP SourceMap
sourceMap
            liftIO (writeIORef cabalFileRevisionRef (Just lbsIdent))
            packWith packFileEntry False fp
        -- Same, except we'll include the Cabal file in the original tarball

        -- upload.

        | Bool
tweakCabal Bool -> Bool -> Bool
&& FilePath -> Bool
isCabalFp FilePath
fp = do
            (_ident, lbs) <- PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
forall env.
HasEnvConfig env =>
PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
getCabalLbs PvpBoundsType
pvpBounds Maybe Int
forall a. Maybe a
Nothing Path Abs File
cabalFP SourceMap
sourceMap
            currTime <- liftIO getPOSIXTime -- Seconds from UNIX epoch

            tp <- liftIO $ tarPath False fp
            pure $ (Tar.fileEntry tp lbs) { Tar.entryTime = floor currTime }
        | Bool
otherwise = (FilePath -> TarPath -> IO (GenEntry TarPath LinkTarget))
-> Bool -> FilePath -> RIO env (GenEntry TarPath LinkTarget)
packWith FilePath -> TarPath -> IO (GenEntry TarPath LinkTarget)
packFileEntry Bool
False FilePath
fp
      isCabalFp FilePath
fp = Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir FilePath -> ShowS
FP.</> FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
cabalFP
      tarName = FilePath
pkgIdName FilePath -> ShowS
FP.<.> FilePath
"tar.gz"
      pkgIdName = PackageIdentifier -> FilePath
packageIdentifierString PackageIdentifier
pkgId
      pkgId = Package -> PackageIdentifier
packageIdentifier LocalPackage
lp.package
  dirEntries <- mapM packDir (dirsFromFiles files)
  fileEntries <- mapM packFile files
  mcabalFileRevision <- liftIO (readIORef cabalFileRevisionRef)
  pure
    ( tarName
    , GZip.compress (Tar.write (dirEntries ++ fileEntries))
    , mcabalFileRevision
    )

-- | Get the PVP bounds-enabled version of the given Cabal file

getCabalLbs ::
     HasEnvConfig env
  => PvpBoundsType
  -> Maybe Int -- ^ optional revision

  -> Path Abs File -- ^ Cabal file

  -> SourceMap
  -> RIO env (PackageIdentifier, L.ByteString)
getCabalLbs :: forall env.
HasEnvConfig env =>
PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
getCabalLbs PvpBoundsType
pvpBounds Maybe Int
mrev Path Abs File
cabalFP SourceMap
sourceMap = do
  (gpdio, _name, cabalFP') <-
    Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stackProgName') (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalFP)
  gpd <- liftIO $ gpdio NoPrintWarnings
  unless (cabalFP == cabalFP') $
    prettyThrowIO $ CabalFilePathsInconsistentBug cabalFP cabalFP'
  installMap <- toInstallMap sourceMap
  (installedMap, _, _, _) <- getInstalled installMap
  let subLibPackages = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$
          GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd
        PackageName -> [PackageName] -> [PackageName]
forall a. a -> [a] -> [a]
: ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
 -> PackageName)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map
            (UnqualComponentName -> PackageName
Cabal.unqualComponentNameToPackageName (UnqualComponentName -> PackageName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
    -> UnqualComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> UnqualComponentName
forall a b. (a, b) -> a
fst)
            (GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
Cabal.condSubLibraries GenericPackageDescription
gpd)
      gpd' = (Typeable Dependency => Dependency -> Dependency)
-> GenericPackageDescription -> GenericPackageDescription
forall a b.
(Data a, Typeable b) =>
(Typeable b => b -> b) -> a -> a
gtraverseT (Set PackageName
-> InstallMap -> InstalledMap -> Dependency -> Dependency
addBounds Set PackageName
subLibPackages InstallMap
installMap InstalledMap
installedMap) GenericPackageDescription
gpd
      gpd'' =
        case Maybe Int
mrev of
          Maybe Int
Nothing -> GenericPackageDescription
gpd'
          Just Int
rev -> GenericPackageDescription
gpd'
            { Cabal.packageDescription
             = (Cabal.packageDescription gpd')
                { Cabal.customFieldsPD
                = (("x-revision", show rev):)
                $ filter (\(FilePath
x, FilePath
_) -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"x-revision")
                $ Cabal.customFieldsPD
                $ Cabal.packageDescription gpd'
                }
            }
      ident = PackageDescription -> PackageIdentifier
Cabal.package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd''
  -- Sanity rendering and reparsing the input, to ensure there are no Cabal

  -- bugs, since there have been bugs here before, and currently are at the time

  -- of writing:

  --

  -- https://github.com/haskell/cabal/issues/1202

  -- https://github.com/haskell/cabal/issues/2353

  -- https://github.com/haskell/cabal/issues/4863 (current issue)

  let roundtripErrs =
           [StyleDoc] -> StyleDoc
fillSep
             [ FilePath -> StyleDoc
flow FilePath
"Bug detected in Cabal library. ((parse . render . parse) \
                    \=== id) does not hold for the Cabal file at"
             , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalFP
             ]
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
      (_warnings, eres) = Cabal.runParseResult
                        $ Cabal.parseGenericPackageDescription
                        $ T.encodeUtf8
                        $ T.pack
                        $ showGenericPackageDescription gpd
  case eres of
    Right GenericPackageDescription
roundtripped
      | GenericPackageDescription
roundtripped GenericPackageDescription -> GenericPackageDescription -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription
gpd -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
             StyleDoc
roundtripErrs
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"This seems to be fixed in development versions of Cabal, \
                  \but at time of writing, the fix is not in any released \
                  \versions."
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
               [ FilePath -> StyleDoc
flow FilePath
"Please see this GitHub issue for status:"
               , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/3549"
               ]
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
               [ FilePath -> StyleDoc
flow FilePath
"If the issue is closed as resolved, then you may be \
                      \able to fix this by upgrading to a newer version of \
                      \Stack via"
               , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack upgrade"
               , FilePath -> StyleDoc
flow FilePath
"for latest stable version or"
               , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack upgrade --git"
               , FilePath -> StyleDoc
flow FilePath
"for the latest development version."
               ]
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
               [ FilePath -> StyleDoc
flow FilePath
"If the issue is fixed, but updating doesn't solve the \
                      \problem, please check if there are similar open \
                      \issues, and if not, report a new issue to the Stack \
                      \issue tracker, at"
               , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/new"
               ]
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"If the issue is not fixed, feel free to leave a comment \
                  \on it indicating that you would like it to be fixed."
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    Left (Maybe Version
_version, NonEmpty PError
errs) -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         StyleDoc
roundtripErrs
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"In particular, parsing the rendered Cabal file is yielding a \
              \parse error. Please check if there are already issues \
              \tracking this, and if not, please report new issues to the \
              \Stack and Cabal issue trackers, via"
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
           [ Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/new"
           , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/haskell/cabal/issues/new"
           ]
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow (FilePath
"The parse error is: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unlines ((PError -> FilePath) -> [PError] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PError -> FilePath
forall a. Show a => a -> FilePath
show (NonEmpty PError -> [PError]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty PError
errs)))
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
  pure
    ( ident
    , TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd''
    )
 where
  addBounds ::
       Set PackageName
    -> InstallMap
    -> InstalledMap
    -> Dependency
    -> Dependency
  addBounds :: Set PackageName
-> InstallMap -> InstalledMap -> Dependency -> Dependency
addBounds Set PackageName
subLibPackages InstallMap
installMap InstalledMap
installedMap Dependency
dep =
    if PackageName
name PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
subLibPackages
      then Dependency
dep
      else case Maybe Version
foundVersion of
        Maybe Version
Nothing -> Dependency
dep
        Just Version
version -> PackageName
-> VersionRange -> NonEmptySet LibraryName -> Dependency
Dependency
          PackageName
name
          ( VersionRange -> VersionRange
simplifyVersionRange
          (VersionRange -> VersionRange) -> VersionRange -> VersionRange
forall a b. (a -> b) -> a -> b
$ ( if Bool
toAddUpper Bool -> Bool -> Bool
&& Bool -> Bool
not (VersionRange -> Bool
hasUpperBound VersionRange
range)
                then Version -> VersionRange -> VersionRange
addUpper Version
version
                else VersionRange -> VersionRange
forall a. a -> a
id
            )
            -- From Cabal-3.4.0.0, 'hasLowerBound isAnyVersion' is 'True'.

          (VersionRange -> VersionRange) -> VersionRange -> VersionRange
forall a b. (a -> b) -> a -> b
$ ( if    Bool
toAddLower
                 Bool -> Bool -> Bool
&& (VersionRange -> Bool
isAnyVersion VersionRange
range Bool -> Bool -> Bool
|| Bool -> Bool
not (VersionRange -> Bool
hasLowerBound VersionRange
range))
                then Version -> VersionRange -> VersionRange
addLower Version
version
                else VersionRange -> VersionRange
forall a. a -> a
id
            )
            VersionRange
range
          )
          NonEmptySet LibraryName
s
   where
    Dependency PackageName
name VersionRange
range NonEmptySet LibraryName
s = Dependency
dep
    foundVersion :: Maybe Version
foundVersion =
      case PackageName -> InstallMap -> Maybe (InstallLocation, Version)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstallMap
installMap of
        Just (InstallLocation
_, Version
version) -> Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version
        Maybe (InstallLocation, Version)
Nothing ->
          case PackageName -> InstalledMap -> Maybe (InstallLocation, Installed)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstalledMap
installedMap of
            Just (InstallLocation
_, Installed
installed) -> Version -> Maybe Version
forall a. a -> Maybe a
Just (Installed -> Version
installedVersion Installed
installed)
            Maybe (InstallLocation, Installed)
Nothing -> Maybe Version
forall a. Maybe a
Nothing

  addUpper :: Version -> VersionRange -> VersionRange
addUpper Version
version = VersionRange -> VersionRange -> VersionRange
intersectVersionRanges
      (Version -> VersionRange
earlierVersion (Version -> VersionRange) -> Version -> VersionRange
forall a b. (a -> b) -> a -> b
$ Version -> Version
nextMajorVersion Version
version)
  addLower :: Version -> VersionRange -> VersionRange
addLower Version
version = VersionRange -> VersionRange -> VersionRange
intersectVersionRanges (Version -> VersionRange
orLaterVersion Version
version)

  (Bool
toAddLower, Bool
toAddUpper) =
    case PvpBoundsType
pvpBounds of
      PvpBoundsType
PvpBoundsNone  -> (Bool
False, Bool
False)
      PvpBoundsType
PvpBoundsUpper -> (Bool
False, Bool
True)
      PvpBoundsType
PvpBoundsLower -> (Bool
True,  Bool
False)
      PvpBoundsType
PvpBoundsBoth  -> (Bool
True,  Bool
True)

-- | Traverse a data type.

gtraverseT :: (Data a,Typeable b) => (Typeable b => b -> b) -> a -> a
gtraverseT :: forall a b.
(Data a, Typeable b) =>
(Typeable b => b -> b) -> a -> a
gtraverseT Typeable b => b -> b
f =
  (forall b. Data b => b -> b) -> a -> a
forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT (\b
x -> case b -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
x of
                 Maybe b
Nothing -> (Typeable b => b -> b) -> b -> b
forall a b.
(Data a, Typeable b) =>
(Typeable b => b -> b) -> a -> a
gtraverseT b -> b
Typeable b => b -> b
f b
x
                 Just b
b  -> b -> Maybe b -> b
forall a. a -> Maybe a -> a
fromMaybe b
x (b -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (b -> b
Typeable b => b -> b
f b
b)))

-- | Read in a t'LocalPackage' config.  This makes some default decisions

-- about v'LocalPackage' fields that might not be appropriate for other

-- use-cases.

readLocalPackage :: HasEnvConfig env => Path Abs Dir -> RIO env LocalPackage
readLocalPackage :: forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
pkgDir = do
  config  <- RIO env PackageConfig
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasEnvConfig env) =>
m PackageConfig
getDefaultPackageConfig
  (gpdio, _, cabalFP) <- loadCabalFilePath (Just stackProgName') pkgDir
  gpd <- liftIO $ gpdio YesPrintWarnings
  let package = PackageConfig -> GenericPackageDescription -> Package
resolvePackage PackageConfig
config GenericPackageDescription
gpd
  pure LocalPackage
    { package
    , wanted = False -- HACK: makes it so that sdist output goes to a log

                       -- instead of a file.

    , cabalFP
    -- NOTE: these aren't the 'correct' values, but aren't used in the usage of

    -- this function in this module.

    , testBench = Nothing
    , buildHaddocks = False
    , forceDirty = False
    , dirtyFiles = pure Nothing
    , newBuildCaches = pure Map.empty
    , componentFiles = pure Map.empty
    , components = Set.empty
    , unbuildable = Set.empty
    }

-- | Returns a newline-separate list of paths, and the absolute path to the

-- Cabal file.

getSDistFileList ::
     HasEnvConfig env
  => LocalPackage
  -> Map PackageIdentifier GhcPkgId
  -> RIO env (String, Path Abs File)
getSDistFileList :: forall env.
HasEnvConfig env =>
LocalPackage
-> Map PackageIdentifier GhcPkgId
-> RIO env (FilePath, Path Abs File)
getSDistFileList LocalPackage
lp Map PackageIdentifier GhcPkgId
deps =
  FilePath
-> (Path Abs Dir -> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File)
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (Path Abs Dir -> m a) -> m a
withSystemTempDir (FilePath
stackProgName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"-sdist") ((Path Abs Dir -> RIO env (FilePath, Path Abs File))
 -> RIO env (FilePath, Path Abs File))
-> (Path Abs Dir -> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File)
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tmpdir -> do
    let bopts :: BuildOpts
bopts = BuildOpts
defaultBuildOpts
    let boptsCli :: BuildOptsCLI
boptsCli = BuildOptsCLI
defaultBuildOptsCLI
    baseConfigOpts <- BuildOptsCLI -> RIO env BaseConfigOpts
forall env.
HasEnvConfig env =>
BuildOptsCLI -> RIO env BaseConfigOpts
mkBaseConfigOpts BuildOptsCLI
boptsCli
    locals <- projectLocalPackages
    withExecuteEnv bopts boptsCli baseConfigOpts locals
      [] [] [] Nothing -- provide empty list of globals. This is a hack around

                       -- custom Setup.hs files

      $ \ExecuteEnv
ee ->
      ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe FilePath
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File)
forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe FilePath
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee TaskType
taskType Map PackageIdentifier GhcPkgId
deps (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"sdist") ((Package
  -> Path Abs File
  -> Path Abs Dir
  -> (KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ())
  -> (Utf8Builder -> RIO env ())
  -> OutputType
  -> RIO env (FilePath, Path Abs File))
 -> RIO env (FilePath, Path Abs File))
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File)
forall a b. (a -> b) -> a -> b
$
        \Package
_package Path Abs File
cabalFP Path Abs Dir
_pkgDir KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ()
cabal Utf8Builder -> RIO env ()
_announce OutputType
_outputType -> do
          let outFile :: FilePath
outFile = Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
tmpdir FilePath -> ShowS
FP.</> FilePath
"source-files-list"
          KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ()
cabal
            KeepOutputOpen
CloseOnException
            ExcludeTHLoading
KeepTHLoading
            [FilePath
"sdist", FilePath
"--list-sources", FilePath
outFile]
          contents <- IO ByteString -> RIO env ByteString
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ByteString
S.readFile FilePath
outFile)
          pure (T.unpack $ T.decodeUtf8With T.lenientDecode contents, cabalFP)
 where
  ac :: ActionContext
ac = Set ActionId -> [Action] -> Concurrency -> ActionContext
ActionContext Set ActionId
forall a. Set a
Set.empty [] Concurrency
ConcurrencyAllowed
  taskType :: TaskType
taskType = LocalPackage -> TaskType
TTLocalMutable LocalPackage
lp

normalizeTarballPaths ::
     (HasRunner env, HasTerm env)
  => [FilePath]
  -> RIO env [FilePath]
normalizeTarballPaths :: forall env.
(HasRunner env, HasTerm env) =>
[FilePath] -> RIO env [FilePath]
normalizeTarballPaths [FilePath]
fps = do
  -- TODO: consider whether erroring out is better - otherwise the user might

  -- upload an incomplete tar?

  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
outsideDir) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         FilePath -> StyleDoc
flow FilePath
"These files are outside of the package directory, and will be \
              \omitted from the tarball:"
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList ((FilePath -> StyleDoc) -> [FilePath] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File (StyleDoc -> StyleDoc)
-> (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString) [FilePath]
outsideDir)
  [FilePath] -> RIO env [FilePath]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
nubOrd [FilePath]
files)
 where
  ([FilePath]
outsideDir, [FilePath]
files) = [Either FilePath FilePath] -> ([FilePath], [FilePath])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((FilePath -> Either FilePath FilePath)
-> [FilePath] -> [Either FilePath FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Either FilePath FilePath
pathToEither [FilePath]
fps)
  pathToEither :: FilePath -> Either FilePath FilePath
pathToEither FilePath
fp = Either FilePath FilePath
-> (FilePath -> Either FilePath FilePath)
-> Maybe FilePath
-> Either FilePath FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left FilePath
fp) FilePath -> Either FilePath FilePath
forall a b. b -> Either a b
Right (FilePath -> Maybe FilePath
normalizePath FilePath
fp)

normalizePath :: FilePath -> Maybe FilePath
normalizePath :: FilePath -> Maybe FilePath
normalizePath = ([FilePath] -> FilePath) -> Maybe [FilePath] -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FilePath] -> FilePath
FP.joinPath (Maybe [FilePath] -> Maybe FilePath)
-> (FilePath -> Maybe [FilePath]) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> Maybe [FilePath]
forall {a}. (Eq a, IsString a) => [a] -> Maybe [a]
go ([FilePath] -> Maybe [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> Maybe [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
FP.splitDirectories (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.normalise
 where
  go :: [a] -> Maybe [a]
go [] = [a] -> Maybe [a]
forall a. a -> Maybe a
Just []
  go (a
"..":[a]
_) = Maybe [a]
forall a. Maybe a
Nothing
  go (a
_:a
"..":[a]
xs) = [a] -> Maybe [a]
go [a]
xs
  go (a
x:[a]
xs) = (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Maybe [a]
go [a]
xs

dirsFromFiles :: [FilePath] -> [FilePath]
dirsFromFiles :: [FilePath] -> [FilePath]
dirsFromFiles [FilePath]
dirs = Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toAscList (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.delete FilePath
"." Set FilePath
results)
 where
  results :: Set FilePath
results = (Set FilePath -> FilePath -> Set FilePath)
-> Set FilePath -> [FilePath] -> Set FilePath
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Set FilePath
s -> Set FilePath -> FilePath -> Set FilePath
go Set FilePath
s (FilePath -> Set FilePath) -> ShowS -> FilePath -> Set FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeDirectory) Set FilePath
forall a. Set a
Set.empty [FilePath]
dirs
  go :: Set FilePath -> FilePath -> Set FilePath
go Set FilePath
s FilePath
x
    | FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FilePath
x Set FilePath
s = Set FilePath
s
    | Bool
otherwise = Set FilePath -> FilePath -> Set FilePath
go (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.insert FilePath
x Set FilePath
s) (ShowS
FP.takeDirectory FilePath
x)

-- | Check package in given tarball. This will log all warnings and will throw

-- an exception in case of critical errors.

--

-- Note that we temporarily decompress the archive to analyze it.

checkSDistTarball ::
     HasEnvConfig env
  => SDistOpts -- ^ The configuration of what to check

  -> Path Abs File -- ^ Absolute path to tarball

  -> RIO env ()
checkSDistTarball :: forall env.
HasEnvConfig env =>
SDistOpts -> Path Abs File -> RIO env ()
checkSDistTarball SDistOpts
opts Path Abs File
tarball = Path Abs File -> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall env a.
Path Abs File -> (Path Abs Dir -> RIO env a) -> RIO env a
withTempTarGzContents Path Abs File
tarball ((Path Abs Dir -> RIO env ()) -> RIO env ())
-> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
pkgDir' -> do
  pkgDir <- (Path Abs Dir
pkgDir' Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</>) (Path Rel Dir -> Path Abs Dir)
-> RIO env (Path Rel Dir) -> RIO env (Path Abs Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (FilePath -> RIO env (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir (FilePath -> RIO env (Path Rel Dir))
-> (Path Abs File -> FilePath)
-> Path Abs File
-> RIO env (Path Rel Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeBaseName ShowS -> (Path Abs File -> FilePath) -> Path Abs File -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeBaseName ShowS -> (Path Abs File -> FilePath) -> Path Abs File -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> RIO env (Path Rel Dir))
-> Path Abs File -> RIO env (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs File
tarball)
  --               ^ drop ".tar"     ^ drop ".gz"

  when opts.buildTarball
    ( buildExtractedTarball ResolvedPath
        { resolvedRelative = RelFilePath "this-is-not-used" -- ugly hack

        , resolvedAbsolute = pkgDir
        }
    )
  unless opts.ignoreCheck (checkPackageInExtractedTarball pkgDir)

checkPackageInExtractedTarball ::
     HasEnvConfig env
  => Path Abs Dir -- ^ Absolute path to tarball

  -> RIO env ()
checkPackageInExtractedTarball :: forall env. HasEnvConfig env => Path Abs Dir -> RIO env ()
checkPackageInExtractedTarball Path Abs Dir
pkgDir = do
  (gpdio, name, _cabalfp) <- Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stackProgName') Path Abs Dir
pkgDir
  gpd <- liftIO $ gpdio YesPrintWarnings
  config <- getDefaultPackageConfig
  let pkgDesc = PackageConfig -> GenericPackageDescription -> PackageDescription
resolvePackageDescription PackageConfig
config GenericPackageDescription
gpd
  prettyInfoL
    [ flow "Checking package"
    , style Current (fromPackageName name)
    , flow "for common mistakes using Cabal version"
    , fromString $ versionString cabalVersion <> "."
    ]
  let pkgChecks = GenericPackageDescription -> [PackageCheck]
Check.checkPackage GenericPackageDescription
gpd
  fileChecks <-
    liftIO $ Check.checkPackageFiles minBound pkgDesc (toFilePath pkgDir)
  let checks = [PackageCheck]
pkgChecks [PackageCheck] -> [PackageCheck] -> [PackageCheck]
forall a. [a] -> [a] -> [a]
++ [PackageCheck]
fileChecks
      (errors, warnings) =
        let criticalIssue (Check.PackageBuildImpossible CheckExplanation
_) = Bool
True
            criticalIssue (Check.PackageDistInexcusable CheckExplanation
_) = Bool
True
            criticalIssue PackageCheck
_ = Bool
False
        in  List.partition criticalIssue checks
  unless (null warnings) $
    prettyWarn $
         flow "Package check reported the following warnings:"
      <> line
      <> bulletedList (map (fromString . show) warnings)
  whenJust (nonEmpty errors) $ \NonEmpty PackageCheck
ne -> SDistPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (SDistPrettyException -> RIO env ())
-> SDistPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ NonEmpty PackageCheck -> SDistPrettyException
CheckException NonEmpty PackageCheck
ne

buildExtractedTarball :: HasEnvConfig env => ResolvedPath Dir -> RIO env ()
buildExtractedTarball :: forall env. HasEnvConfig env => ResolvedPath Dir -> RIO env ()
buildExtractedTarball ResolvedPath Dir
pkgDir = do
  envConfig <- Getting EnvConfig env EnvConfig -> RIO env EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig env EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL
  localPackageToBuild <- readLocalPackage $ resolvedAbsolute pkgDir
  -- We remove the path based on the name of the package

  let isPathToRemove Path Abs Dir
path = do
        localPackage <- Path Abs Dir -> RIO env LocalPackage
forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
path
        pure
          $  localPackage.package.name
          == localPackageToBuild.package.name
  pathsToKeep <- Map.fromList <$> filterM
    (fmap not . isPathToRemove . resolvedAbsolute . (.resolvedDir) . snd)
    (Map.toList envConfig.buildConfig.smWanted.project)
  pp <- mkProjectPackage YesPrintWarnings pkgDir False
  let adjustEnvForBuild env
env =
        let updatedEnvConfig :: EnvConfig
updatedEnvConfig = EnvConfig
envConfig
              { sourceMap = updatePackagesInSourceMap envConfig.sourceMap
              , buildConfig = updateBuildConfig envConfig.buildConfig
              }
            updateBuildConfig :: BuildConfig -> BuildConfig
updateBuildConfig BuildConfig
bc = BuildConfig
bc
              { config = bc.config { build = defaultBuildOpts { tests = True } }
              }
        in  ASetter env env EnvConfig EnvConfig -> EnvConfig -> env -> env
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter env env EnvConfig EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL EnvConfig
updatedEnvConfig env
env
      updatePackagesInSourceMap SourceMap
sm =
        SourceMap
sm { SourceMap.project = Map.insert pp.projectCommon.name pp pathsToKeep }
  local adjustEnvForBuild $ build Nothing

-- | Version of 'checkSDistTarball' that first saves lazy bytestring to

-- temporary directory and then calls 'checkSDistTarball' on it.

checkSDistTarball' ::
     HasEnvConfig env
  => SDistOpts
  -> String       -- ^ Tarball name

  -> L.ByteString -- ^ Tarball contents as a byte string

  -> RIO env ()
checkSDistTarball' :: forall env.
HasEnvConfig env =>
SDistOpts -> FilePath -> ByteString -> RIO env ()
checkSDistTarball' SDistOpts
opts FilePath
name ByteString
bytes = FilePath -> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (Path Abs Dir -> m a) -> m a
withSystemTempDir FilePath
"stack" ((Path Abs Dir -> RIO env ()) -> RIO env ())
-> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tpath -> do
  npath <- (Path Abs Dir
tpath Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</>) (Path Rel File -> Path Abs File)
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
name
  liftIO $ L.writeFile (toFilePath npath) bytes
  checkSDistTarball opts npath

withTempTarGzContents ::
     Path Abs File
     -- ^ Location of tarball

  -> (Path Abs Dir -> RIO env a)
     -- ^ Perform actions given dir with tarball contents

  -> RIO env a
withTempTarGzContents :: forall env a.
Path Abs File -> (Path Abs Dir -> RIO env a) -> RIO env a
withTempTarGzContents Path Abs File
apath Path Abs Dir -> RIO env a
f = FilePath -> (Path Abs Dir -> RIO env a) -> RIO env a
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (Path Abs Dir -> m a) -> m a
withSystemTempDir FilePath
"stack" ((Path Abs Dir -> RIO env a) -> RIO env a)
-> (Path Abs Dir -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tpath -> do
  archive <- IO ByteString -> RIO env ByteString
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> RIO env ByteString)
-> IO ByteString -> RIO env ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
L.readFile (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
apath)
  liftIO . Tar.unpack (toFilePath tpath) . Tar.read . GZip.decompress $ archive
  f tpath

--------------------------------------------------------------------------------


-- Copy+modified from the tar package to avoid issues with lazy IO ( see

-- https://github.com/commercialhaskell/stack/issues/1344 )


packFileEntry ::
     FilePath -- ^ Full path to find the file on the local disk

  -> Tar.TarPath -- ^ Path to use for the tar Entry in the archive

  -> IO Tar.Entry
packFileEntry :: FilePath -> TarPath -> IO (GenEntry TarPath LinkTarget)
packFileEntry FilePath
filepath TarPath
tarpath = do
  mtime <- FilePath -> IO EpochTime
getModTime FilePath
filepath
  perms <- getPermissions filepath
  content <- S.readFile filepath
  let size = Int -> EpochTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
content)
      entryContent = ByteString -> EpochTime -> GenEntryContent LinkTarget
forall linkTarget.
ByteString -> EpochTime -> GenEntryContent linkTarget
Tar.NormalFile (ByteString -> ByteString
L.fromStrict ByteString
content) EpochTime
size
      entry = TarPath
-> GenEntryContent LinkTarget -> GenEntry TarPath LinkTarget
forall tarPath linkTarget.
tarPath
-> GenEntryContent linkTarget -> GenEntry tarPath linkTarget
Tar.simpleEntry TarPath
tarpath GenEntryContent LinkTarget
entryContent
  pure entry
    { Tar.entryPermissions = if executable perms
                               then Tar.executableFilePermissions
                               else Tar.ordinaryFilePermissions
    , Tar.entryTime = mtime
    }

getModTime :: FilePath -> IO Tar.EpochTime
getModTime :: FilePath -> IO EpochTime
getModTime FilePath
path = do
  t <- FilePath -> IO UTCTime
getModificationTime FilePath
path
  pure $ floor . utcTimeToPOSIXSeconds $ t

getDefaultPackageConfig ::
     (MonadIO m, MonadReader env m, HasEnvConfig env)
  => m PackageConfig
getDefaultPackageConfig :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasEnvConfig env) =>
m PackageConfig
getDefaultPackageConfig = do
  platform <- Getting Platform env Platform -> m Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
Lens' env Platform
platformL
  compilerVersion <- view actualCompilerVersionL
  pure PackageConfig
    { enableTests = False
    , enableBenchmarks = False
    , flags = mempty
    , ghcOptions = []
    , cabalConfigOpts = []
    , compilerVersion
    , platform
    }