{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TypeFamilies       #-}

-- 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 qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import           Data.Char ( toLower )
import           Data.Data ( cast )
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
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.Version
                   ( earlierVersion, hasLowerBound, hasUpperBound, isAnyVersion
                   , orLaterVersion, simplifyVersionRange
                   )
import           Path ( (</>), parent, parseRelDir, parseRelFile )
import           Path.IO ( ensureDir, resolveDir' )
import           Stack.Build ( mkBaseConfigOpts, build, buildLocalTargets )
import           Stack.Build.Execute
                   ( ExcludeTHLoading (..), KeepOutputOpen (..), withExecuteEnv
                   , withSingleContext
                   )
import           Stack.Build.Installed ( getInstalled, toInstallMap )
import           Stack.Build.Source ( projectLocalPackages )
import           Stack.Constants ( stackProgName, stackProgName' )
import           Stack.Constants.Config ( distDirFromDir )
import           Stack.Package
                   ( PackageDescriptionPair (..), resolvePackage
                   , resolvePackageDescription
                   )
import           Stack.Prelude
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withDefaultEnvConfig )
import           Stack.SourceMap ( mkProjectPackage )
import           Stack.Types.Build
                   ( CachePkgSrc (..), Task (..), TaskConfigOpts (..)
                   , TaskType (..)
                   )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..), stackYamlL )
import           Stack.Types.BuildOpts
                   ( BuildOpts (..), defaultBuildOpts, defaultBuildOptsCLI )
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.ConfigureOpts ( ConfigureOpts (..) )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.Package
                   ( InstallMap, Installed (..), InstalledMap, LocalPackage (..)
                   , Package (..), PackageConfig (..), installedVersion
                   , packageIdentifier
                   )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.PvpBounds ( PvpBounds (..), PvpBoundsType (..) )
import           Stack.Types.Runner ( HasRunner, Runner )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), ProjectPackage (..), SMWanted (..)
                   , SourceMap (..), ppRoot
                   )
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, Typeable)

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

-- | Type representing command line options for @stack sdist@ command.

data SDistOpts = SDistOpts
  { SDistOpts -> [FilePath]
sdoptsDirsToWorkWith :: [String]
    -- ^ Directories to package

  , SDistOpts -> Maybe PvpBounds
sdoptsPvpBounds :: Maybe PvpBounds
    -- ^ PVP Bounds overrides

  , SDistOpts -> Bool
sdoptsIgnoreCheck :: Bool
    -- ^ Whether to ignore check of the package for common errors

  , SDistOpts -> Bool
sdoptsBuildTarball :: Bool
    -- ^ Whether to build the tarball

  , SDistOpts -> Maybe FilePath
sdoptsTarPath :: Maybe FilePath
    -- ^ Where to copy the tarball

  }

-- | 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.

    [Path Abs Dir]
dirs' <- if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (SDistOpts -> [FilePath]
sdoptsDirsToWorkWith SDistOpts
sdistOpts)
      then do
        [Path Abs Dir]
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 -> Map PackageName ProjectPackage
smwProject (SMWanted -> Map PackageName ProjectPackage)
-> (BuildConfig -> SMWanted)
-> BuildConfig
-> Map PackageName ProjectPackage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
        Bool -> RIO EnvConfig () -> RIO EnvConfig ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Path Abs Dir] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs Dir]
dirs) (RIO EnvConfig () -> RIO EnvConfig ())
-> RIO EnvConfig () -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ do
          Path Abs File
stackYaml <- Getting (Path Abs File) EnvConfig (Path Abs File)
-> RIO EnvConfig (Path Abs File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs File) EnvConfig (Path Abs File)
forall env. HasBuildConfig env => Lens' env (Path Abs File)
Lens' EnvConfig (Path Abs File)
stackYamlL
          [StyleDoc] -> RIO EnvConfig ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyErrorL
            [ Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack sdist"
            , FilePath -> StyleDoc
flow FilePath
"expects a list of targets, and otherwise defaults to all \
                   \of the project's packages. However, the configuration at"
            , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml
            , FilePath -> StyleDoc
flow FilePath
"contains no packages, so no sdist tarballs will be \
                   \generated."
            ]
          RIO EnvConfig ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
        [Path Abs Dir] -> RIO EnvConfig [Path Abs Dir]
forall a. a -> RIO EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Path Abs Dir]
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 -> [FilePath]
sdoptsDirsToWorkWith SDistOpts
sdistOpts)
    [Path Abs Dir]
-> (Path Abs Dir -> RIO EnvConfig ()) -> RIO EnvConfig ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs Dir]
dirs' ((Path Abs Dir -> RIO EnvConfig ()) -> RIO EnvConfig ())
-> (Path Abs Dir -> RIO EnvConfig ()) -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
      (FilePath
tarName, ByteString
tarBytes, Maybe (PackageIdentifier, ByteString)
_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 -> Maybe PvpBounds
sdoptsPvpBounds SDistOpts
sdistOpts) Path Abs Dir
dir
      Path Abs Dir
distDir <- Path Abs Dir -> RIO EnvConfig (Path Abs Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
dir
      Path Abs File
tarPath <- (Path Abs Dir
distDir </>) (Path Rel File -> Path Abs File)
-> RIO EnvConfig (Path Rel File) -> RIO EnvConfig (Path Abs File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> RIO EnvConfig (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
tarName
      Path Abs Dir -> RIO EnvConfig ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
tarPath)
      ConduitT () Void (ResourceT (RIO EnvConfig)) () -> RIO EnvConfig ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (ConduitT () Void (ResourceT (RIO EnvConfig)) ()
 -> RIO EnvConfig ())
-> ConduitT () Void (ResourceT (RIO EnvConfig)) ()
-> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$
        ByteString -> ConduitT () ByteString (ResourceT (RIO EnvConfig)) ()
forall (m :: * -> *) lazy strict i.
(Monad m, LazySequence lazy strict) =>
lazy -> ConduitT i strict m ()
sourceLazy ByteString
tarBytes ConduitT () ByteString (ResourceT (RIO EnvConfig)) ()
-> ConduitT ByteString Void (ResourceT (RIO EnvConfig)) ()
-> ConduitT () Void (ResourceT (RIO EnvConfig)) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
        FilePath -> ConduitT ByteString Void (ResourceT (RIO EnvConfig)) ()
forall (m :: * -> *) o.
MonadResource m =>
FilePath -> ConduitM ByteString o m ()
sinkFileCautious (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
tarPath)
      [StyleDoc] -> RIO EnvConfig ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
        [FilePath -> StyleDoc
flow FilePath
"Wrote sdist-format compressed archive to"
        , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
tarPath StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
        ]
      SDistOpts -> Path Abs File -> RIO EnvConfig ()
forall env.
HasEnvConfig env =>
SDistOpts -> Path Abs File -> RIO env ()
checkSDistTarball SDistOpts
sdistOpts Path Abs File
tarPath
      Maybe FilePath
-> (FilePath -> RIO EnvConfig ()) -> RIO EnvConfig ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (SDistOpts -> Maybe FilePath
sdoptsTarPath SDistOpts
sdistOpts) ((FilePath -> RIO EnvConfig ()) -> RIO EnvConfig ())
-> (FilePath -> RIO EnvConfig ()) -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath -> FilePath -> RIO EnvConfig ()
forall {m :: * -> *} {b} {t}.
MonadIO m =>
Path b t -> FilePath -> FilePath -> m ()
copyTarToTarPath Path Abs File
tarPath FilePath
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 local package, creates its source distribution tarball.

--

-- 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 local package

  -> 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
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 PvpBoundsType
pvpBounds Bool
asRevision =
        PvpBounds -> Maybe PvpBounds -> PvpBounds
forall a. a -> Maybe a -> a
fromMaybe (Config -> PvpBounds
configPvpBounds Config
config) Maybe PvpBounds
mpvpBounds
      tweakCabal :: Bool
tweakCabal = PvpBoundsType
pvpBounds PvpBoundsType -> PvpBoundsType -> Bool
forall a. Eq a => a -> a -> Bool
/= PvpBoundsType
PvpBoundsNone
      pkgFp :: FilePath
pkgFp = Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir
  LocalPackage
lp <- Path Abs Dir -> RIO env LocalPackage
forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
pkgDir
  Maybe (Map PackageName VersionRange)
-> (Map PackageName VersionRange -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Package -> Maybe (Map PackageName VersionRange)
packageSetupDeps (LocalPackage -> Package
lpPackage LocalPackage
lp)) ((Map PackageName VersionRange -> RIO env ()) -> RIO env ())
-> (Map PackageName VersionRange -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Map PackageName VersionRange
customSetupDeps ->
    case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NE.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 VersionRange -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName VersionRange
customSetupDeps)) of
      Just NonEmpty Text
nonEmptyDepTargets -> do
        Either SomeException ()
eres <- NonEmpty Text -> RIO env (Either SomeException ())
forall env.
HasEnvConfig env =>
NonEmpty Text -> RIO env (Either SomeException ())
buildLocalTargets NonEmpty Text
nonEmptyDepTargets
        case Either SomeException ()
eres of
          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
sourceMap <- Getting SourceMap env SourceMap -> RIO env SourceMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting SourceMap env SourceMap -> RIO env SourceMap)
-> Getting SourceMap env SourceMap -> RIO env SourceMap
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const SourceMap EnvConfig)
-> env -> Const SourceMap env
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL((EnvConfig -> Const SourceMap EnvConfig)
 -> env -> Const SourceMap env)
-> ((SourceMap -> Const SourceMap SourceMap)
    -> EnvConfig -> Const SourceMap EnvConfig)
-> Getting SourceMap env SourceMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EnvConfig -> SourceMap) -> SimpleGetter EnvConfig SourceMap
forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMap
  InstallMap
installMap <- SourceMap -> RIO env InstallMap
forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
  (InstalledMap
installedMap, [DumpPackage]
_globalDumpPkgs, [DumpPackage]
_snapshotDumpPkgs, [DumpPackage]
_localDumpPkgs) <-
    InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
  let deps :: Map PackageIdentifier GhcPkgId
deps = [(PackageIdentifier, GhcPkgId)] -> Map PackageIdentifier GhcPkgId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (PackageIdentifier
pid, GhcPkgId
ghcPkgId)
        | (InstallLocation
_, Library PackageIdentifier
pid GhcPkgId
ghcPkgId Maybe (Either License License)
_) <- InstalledMap -> [(InstallLocation, Installed)]
forall k a. Map k a -> [a]
Map.elems InstalledMap
installedMap]
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ FilePath -> StyleDoc
flow FilePath
"Getting the file list for"
    , Style -> StyleDoc -> StyleDoc
style Style
File (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString  FilePath
pkgFp) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]
  (FilePath
fileList, Path Abs File
cabalfp) <- LocalPackage
-> Map PackageIdentifier GhcPkgId
-> RIO env (FilePath, Path Abs File)
forall env.
HasEnvConfig env =>
LocalPackage
-> Map PackageIdentifier GhcPkgId
-> RIO env (FilePath, Path Abs File)
getSDistFileList LocalPackage
lp Map PackageIdentifier GhcPkgId
deps
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ FilePath -> StyleDoc
flow FilePath
"Building a compressed archive file in the sdist format for"
    , Style -> StyleDoc -> StyleDoc
style Style
File (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString FilePath
pkgFp) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]
  [FilePath]
files <-
    [FilePath] -> RIO env [FilePath]
forall env.
(HasRunner env, HasTerm env) =>
[FilePath] -> RIO env [FilePath]
normalizeTarballPaths (ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> FilePath
T.unpack (Text -> FilePath) -> (FilePath -> Text) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
stripCR (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack) (FilePath -> [FilePath]
lines FilePath
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.

  IORef (Maybe (PackageIdentifier, ByteString))
cabalFileRevisionRef <- IO (IORef (Maybe (PackageIdentifier, ByteString)))
-> RIO env (IORef (Maybe (PackageIdentifier, ByteString)))
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe (PackageIdentifier, ByteString)
-> IO (IORef (Maybe (PackageIdentifier, ByteString)))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe (PackageIdentifier, ByteString)
forall a. Maybe a
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 -> FilePath -> IO TarPath
tarPath Bool
isDir FilePath
fp =
        case Bool -> FilePath -> Either FilePath TarPath
Tar.toTarPath Bool
isDir (ShowS
forceUtf8Enc (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
      -- convert a String of proper characters to a String of bytes in UTF8

      -- encoding masquerading as characters. This is necessary for tricking the

      -- tar package into proper character encoding.

      forceUtf8Enc :: ShowS
forceUtf8Enc = ByteString -> FilePath
S8.unpack (ByteString -> FilePath) -> (FilePath -> ByteString) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString)
-> (FilePath -> Text) -> FilePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
      packWith :: (FilePath -> TarPath -> IO Entry)
-> Bool -> FilePath -> RIO env Entry
packWith FilePath -> TarPath -> IO Entry
f Bool
isDir FilePath
fp = IO Entry -> RIO env Entry
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Entry -> RIO env Entry) -> IO Entry -> RIO env Entry
forall a b. (a -> b) -> a -> b
$ FilePath -> TarPath -> IO Entry
f (FilePath
pkgFp FilePath -> ShowS
FP.</> FilePath
fp) (TarPath -> IO Entry) -> IO TarPath -> IO Entry
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> FilePath -> IO TarPath
tarPath Bool
isDir FilePath
fp
      packDir :: FilePath -> RIO env Entry
packDir = (FilePath -> TarPath -> IO Entry)
-> Bool -> FilePath -> RIO env Entry
packWith FilePath -> TarPath -> IO Entry
Tar.packDirectoryEntry Bool
True
      packFile :: FilePath -> RIO env Entry
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
            (PackageIdentifier, ByteString)
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
            IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe (PackageIdentifier, ByteString))
-> Maybe (PackageIdentifier, ByteString) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Maybe (PackageIdentifier, ByteString))
cabalFileRevisionRef ((PackageIdentifier, ByteString)
-> Maybe (PackageIdentifier, ByteString)
forall a. a -> Maybe a
Just (PackageIdentifier, ByteString)
lbsIdent))
            (FilePath -> TarPath -> IO Entry)
-> Bool -> FilePath -> RIO env Entry
packWith FilePath -> TarPath -> IO Entry
packFileEntry Bool
False FilePath
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
            (PackageIdentifier
_ident, ByteString
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
            POSIXTime
currTime <- IO POSIXTime -> RIO env POSIXTime
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime -- Seconds from UNIX epoch

            TarPath
tp <- IO TarPath -> RIO env TarPath
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TarPath -> RIO env TarPath) -> IO TarPath -> RIO env TarPath
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO TarPath
tarPath Bool
False FilePath
fp
            Entry -> RIO env Entry
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Entry -> RIO env Entry) -> Entry -> RIO env Entry
forall a b. (a -> b) -> a -> b
$ (TarPath -> ByteString -> Entry
Tar.fileEntry TarPath
tp ByteString
lbs) { entryTime :: EpochTime
Tar.entryTime = POSIXTime -> EpochTime
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor POSIXTime
currTime }
        | Bool
otherwise = (FilePath -> TarPath -> IO Entry)
-> Bool -> FilePath -> RIO env Entry
packWith FilePath -> TarPath -> IO Entry
packFileEntry Bool
False FilePath
fp
      isCabalFp :: FilePath -> Bool
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
tarName = FilePath
pkgIdName FilePath -> ShowS
FP.<.> FilePath
"tar.gz"
      pkgIdName :: FilePath
pkgIdName = PackageIdentifier -> FilePath
packageIdentifierString PackageIdentifier
pkgId
      pkgId :: PackageIdentifier
pkgId = Package -> PackageIdentifier
packageIdentifier (LocalPackage -> Package
lpPackage LocalPackage
lp)
  [Entry]
dirEntries <- (FilePath -> RIO env Entry) -> [FilePath] -> RIO env [Entry]
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 env Entry
packDir ([FilePath] -> [FilePath]
dirsFromFiles [FilePath]
files)
  [Entry]
fileEntries <- (FilePath -> RIO env Entry) -> [FilePath] -> RIO env [Entry]
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 env Entry
packFile [FilePath]
files
  Maybe (PackageIdentifier, ByteString)
mcabalFileRevision <- IO (Maybe (PackageIdentifier, ByteString))
-> RIO env (Maybe (PackageIdentifier, ByteString))
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe (PackageIdentifier, ByteString))
-> IO (Maybe (PackageIdentifier, ByteString))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe (PackageIdentifier, ByteString))
cabalFileRevisionRef)
  (FilePath, ByteString, Maybe (PackageIdentifier, ByteString))
-> RIO
     env (FilePath, ByteString, Maybe (PackageIdentifier, ByteString))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( FilePath
tarName
    , ByteString -> ByteString
GZip.compress ([Entry] -> ByteString
Tar.write ([Entry]
dirEntries [Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++ [Entry]
fileEntries))
    , Maybe (PackageIdentifier, ByteString)
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
  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_name, Path Abs File
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)
  GenericPackageDescription
gpd <- IO GenericPackageDescription -> RIO env GenericPackageDescription
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
NoPrintWarnings
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Path Abs File
cabalfp Path Abs File -> Path Abs File -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs File
cabalfp') (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    SDistPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (SDistPrettyException -> RIO env ())
-> SDistPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs File -> SDistPrettyException
CabalFilePathsInconsistentBug Path Abs File
cabalfp Path Abs File
cabalfp'
  InstallMap
installMap <- SourceMap -> RIO env InstallMap
forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
  (InstalledMap
installedMap, [DumpPackage]
_, [DumpPackage]
_, [DumpPackage]
_) <- InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
  let internalPackages :: Set PackageName
internalPackages = [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' :: GenericPackageDescription
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
internalPackages InstallMap
installMap InstalledMap
installedMap) GenericPackageDescription
gpd
      gpd'' :: GenericPackageDescription
gpd'' =
        case Maybe Int
mrev of
          Maybe Int
Nothing -> GenericPackageDescription
gpd'
          Just Int
rev -> GenericPackageDescription
gpd'
            { packageDescription :: PackageDescription
Cabal.packageDescription
             = (GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd')
                { customFieldsPD :: [(FilePath, FilePath)]
Cabal.customFieldsPD
                = ((FilePath
"x-revision", Int -> FilePath
forall a. Show a => a -> FilePath
show Int
rev):)
                ([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ ((FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
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")
                ([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ PackageDescription -> [(FilePath, FilePath)]
Cabal.customFieldsPD
                (PackageDescription -> [(FilePath, FilePath)])
-> PackageDescription -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd'
                }
            }
      ident :: PackageIdentifier
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
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
      ([PWarning]
_warnings, Either (Maybe Version, NonEmpty PError) GenericPackageDescription
eres) = ParseResult GenericPackageDescription
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
Cabal.runParseResult
                        (ParseResult GenericPackageDescription
 -> ([PWarning],
     Either (Maybe Version, NonEmpty PError) GenericPackageDescription))
-> ParseResult GenericPackageDescription
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ ByteString -> ParseResult GenericPackageDescription
Cabal.parseGenericPackageDescription
                        (ByteString -> ParseResult GenericPackageDescription)
-> ByteString -> ParseResult GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8
                        (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack
                        (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> FilePath
showGenericPackageDescription GenericPackageDescription
gpd
  case Either (Maybe Version, NonEmpty PError) GenericPackageDescription
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
  (PackageIdentifier, ByteString)
-> RIO env (PackageIdentifier, ByteString)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( PackageIdentifier
ident
    , Text -> ByteString
TLE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
TL.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> FilePath
showGenericPackageDescription GenericPackageDescription
gpd''
    )
 where
  addBounds ::
       Set PackageName
    -> InstallMap
    -> InstalledMap
    -> Dependency
    -> Dependency
  addBounds :: Set PackageName
-> InstallMap -> InstalledMap -> Dependency -> Dependency
addBounds Set PackageName
internalPackages 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
internalPackages
      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 'LocalPackage' config.  This makes some default decisions about

-- '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
  PackageConfig
config  <- RIO env PackageConfig
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasEnvConfig env) =>
m PackageConfig
getDefaultPackageConfig
  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
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
  GenericPackageDescription
gpd <- IO GenericPackageDescription -> RIO env GenericPackageDescription
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings
  let package :: Package
package = PackageConfig -> GenericPackageDescription -> Package
resolvePackage PackageConfig
config GenericPackageDescription
gpd
  LocalPackage -> RIO env LocalPackage
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalPackage
    { lpPackage :: Package
lpPackage = Package
package
    , lpWanted :: Bool
lpWanted = Bool
False -- HACK: makes it so that sdist output goes to a log

                       -- instead of a file.

    , lpCabalFile :: Path Abs File
lpCabalFile = Path Abs File
cabalfp
    -- NOTE: these aren't the 'correct' values, but aren't used in the usage of

    -- this function in this module.

    , lpTestBench :: Maybe Package
lpTestBench = Maybe Package
forall a. Maybe a
Nothing
    , lpBuildHaddocks :: Bool
lpBuildHaddocks = Bool
False
    , lpForceDirty :: Bool
lpForceDirty = Bool
False
    , lpDirtyFiles :: MemoizedWith EnvConfig (Maybe (Set FilePath))
lpDirtyFiles = Maybe (Set FilePath)
-> MemoizedWith EnvConfig (Maybe (Set FilePath))
forall a. a -> MemoizedWith EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Set FilePath)
forall a. Maybe a
Nothing
    , lpNewBuildCaches :: MemoizedWith
  EnvConfig (Map NamedComponent (Map FilePath FileCacheInfo))
lpNewBuildCaches = Map NamedComponent (Map FilePath FileCacheInfo)
-> MemoizedWith
     EnvConfig (Map NamedComponent (Map FilePath FileCacheInfo))
forall a. a -> MemoizedWith EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map NamedComponent (Map FilePath FileCacheInfo)
forall k a. Map k a
Map.empty
    , lpComponentFiles :: MemoizedWith EnvConfig (Map NamedComponent (Set (Path Abs File)))
lpComponentFiles = Map NamedComponent (Set (Path Abs File))
-> MemoizedWith
     EnvConfig (Map NamedComponent (Set (Path Abs File)))
forall a. a -> MemoizedWith EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map NamedComponent (Set (Path Abs File))
forall k a. Map k a
Map.empty
    , lpComponents :: Set NamedComponent
lpComponents = Set NamedComponent
forall a. Set a
Set.empty
    , lpUnbuildable :: Set NamedComponent
lpUnbuildable = Set NamedComponent
forall a. Set a
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
baseConfigOpts <- BuildOptsCLI -> RIO env BaseConfigOpts
forall env.
HasEnvConfig env =>
BuildOptsCLI -> RIO env BaseConfigOpts
mkBaseConfigOpts BuildOptsCLI
boptsCli
    [LocalPackage]
locals <- RIO env [LocalPackage]
forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
    BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> Maybe Int
-> (ExecuteEnv -> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File)
forall env a.
HasEnvConfig env =>
BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> Maybe Int
-> (ExecuteEnv -> RIO env a)
-> RIO env a
withExecuteEnv BuildOpts
bopts BuildOptsCLI
boptsCli BaseConfigOpts
baseConfigOpts [LocalPackage]
locals
      [] [] [] Maybe Int
forall a. Maybe a
Nothing -- provide empty list of globals. This is a hack around

                       -- custom Setup.hs files

      ((ExecuteEnv -> RIO env (FilePath, Path Abs File))
 -> RIO env (FilePath, Path Abs File))
-> (ExecuteEnv -> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File)
forall a b. (a -> b) -> a -> b
$ \ExecuteEnv
ee ->
      ActionContext
-> ExecuteEnv
-> Task
-> 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
-> Task
-> 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 Task
task 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]
          ByteString
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)
          (FilePath, Path Abs File) -> RIO env (FilePath, Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode ByteString
contents, Path Abs File
cabalfp)
 where
  package :: Package
package = LocalPackage -> Package
lpPackage LocalPackage
lp
  ac :: ActionContext
ac = Set ActionId -> [Action] -> Concurrency -> ActionContext
ActionContext Set ActionId
forall a. Set a
Set.empty [] Concurrency
ConcurrencyAllowed
  task :: Task
task = Task
    { taskProvides :: PackageIdentifier
taskProvides =
        PackageName -> Version -> PackageIdentifier
PackageIdentifier (Package -> PackageName
packageName Package
package) (Package -> Version
packageVersion Package
package)
    , taskType :: TaskType
taskType = LocalPackage -> TaskType
TTLocalMutable LocalPackage
lp
    , taskConfigOpts :: TaskConfigOpts
taskConfigOpts = TaskConfigOpts
        { tcoMissing :: Set PackageIdentifier
tcoMissing = Set PackageIdentifier
forall a. Set a
Set.empty
        , tcoOpts :: Map PackageIdentifier GhcPkgId -> ConfigureOpts
tcoOpts = \Map PackageIdentifier GhcPkgId
_ -> [FilePath] -> [FilePath] -> ConfigureOpts
ConfigureOpts [] []
        }
    , taskBuildHaddock :: Bool
taskBuildHaddock = Bool
False
    , taskPresent :: Map PackageIdentifier GhcPkgId
taskPresent = Map PackageIdentifier GhcPkgId
forall k a. Map k a
Map.empty
    , taskAllInOne :: Bool
taskAllInOne = Bool
True
    , taskCachePkgSrc :: CachePkgSrc
taskCachePkgSrc = FilePath -> CachePkgSrc
CacheSrcLocal (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (Path Abs File -> Path Abs Dir) -> Path Abs File -> Path Abs Dir
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp))
    , taskAnyMissing :: Bool
taskAnyMissing = Bool
True
    , taskBuildTypeConfig :: Bool
taskBuildTypeConfig = Bool
False
    }

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]) -> 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
  Path Abs Dir
pkgDir <- (Path Abs Dir
pkgDir' </>) (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"

  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SDistOpts -> Bool
sdoptsBuildTarball SDistOpts
opts)
    ( ResolvedPath Dir -> RIO env ()
forall env. HasEnvConfig env => ResolvedPath Dir -> RIO env ()
buildExtractedTarball ResolvedPath
        { resolvedRelative :: RelFilePath
resolvedRelative = Text -> RelFilePath
RelFilePath Text
"this-is-not-used" -- ugly hack

        , resolvedAbsolute :: Path Abs Dir
resolvedAbsolute = Path Abs Dir
pkgDir
        }
    )
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SDistOpts -> Bool
sdoptsIgnoreCheck SDistOpts
opts) (Path Abs Dir -> RIO env ()
forall env. HasEnvConfig env => Path Abs Dir -> RIO env ()
checkPackageInExtractedTarball Path Abs Dir
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
  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
name, Path Abs File
_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
  GenericPackageDescription
gpd <- IO GenericPackageDescription -> RIO env GenericPackageDescription
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings
  PackageConfig
config <- RIO env PackageConfig
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasEnvConfig env) =>
m PackageConfig
getDefaultPackageConfig
  let PackageDescriptionPair PackageDescription
pkgDesc PackageDescription
_ = PackageConfig
-> GenericPackageDescription -> PackageDescriptionPair
resolvePackageDescription PackageConfig
config GenericPackageDescription
gpd
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ FilePath -> StyleDoc
flow FilePath
"Checking package"
    , Style -> StyleDoc -> StyleDoc
style Style
Current (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> FilePath
packageNameString PackageName
name)
    , FilePath -> StyleDoc
flow FilePath
"for common mistakes."
    ]
  let pkgChecks :: [PackageCheck]
pkgChecks =
        -- MSS 2017-12-12: Try out a few different variants of pkgDesc to try

        -- and provoke an error or warning. I don't know why, but when using

        -- `Just pkgDesc`, it appears that Cabal does not detect that `^>=` is

        -- used with `cabal-version: 1.24` or earlier. It seems like pkgDesc

        -- (the one we create) does not populate the `buildDepends` field,

        -- whereas flattenPackageDescription from Cabal does. In any event,

        -- using `Nothing` seems more logical for this check anyway, and the

        -- fallback to `Just pkgDesc` is just a crazy sanity check.

        case GenericPackageDescription
-> Maybe PackageDescription -> [PackageCheck]
Check.checkPackage GenericPackageDescription
gpd Maybe PackageDescription
forall a. Maybe a
Nothing of
          [] -> GenericPackageDescription
-> Maybe PackageDescription -> [PackageCheck]
Check.checkPackage GenericPackageDescription
gpd (PackageDescription -> Maybe PackageDescription
forall a. a -> Maybe a
Just PackageDescription
pkgDesc)
          [PackageCheck]
x -> [PackageCheck]
x
  [PackageCheck]
fileChecks <-
    IO [PackageCheck] -> RIO env [PackageCheck]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [PackageCheck] -> RIO env [PackageCheck])
-> IO [PackageCheck] -> RIO env [PackageCheck]
forall a b. (a -> b) -> a -> b
$ Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck]
Check.checkPackageFiles Verbosity
forall a. Bounded a => a
minBound PackageDescription
pkgDesc (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir)
  let checks :: [PackageCheck]
checks = [PackageCheck]
pkgChecks [PackageCheck] -> [PackageCheck] -> [PackageCheck]
forall a. [a] -> [a] -> [a]
++ [PackageCheck]
fileChecks
      ([PackageCheck]
errors, [PackageCheck]
warnings) =
        let criticalIssue :: PackageCheck -> Bool
criticalIssue (Check.PackageBuildImpossible FilePath
_) = Bool
True
            criticalIssue (Check.PackageDistInexcusable FilePath
_) = Bool
True
            criticalIssue PackageCheck
_ = Bool
False
        in  (PackageCheck -> Bool)
-> [PackageCheck] -> ([PackageCheck], [PackageCheck])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition PackageCheck -> Bool
criticalIssue [PackageCheck]
checks
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageCheck] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageCheck]
warnings) (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
"Package check reported the following warnings:"
      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
forall a. IsString a => FilePath -> a
fromString (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) [PackageCheck]
warnings)
  case [PackageCheck] -> Maybe (NonEmpty PackageCheck)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [PackageCheck]
errors of
    Maybe (NonEmpty PackageCheck)
Nothing -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just 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
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
  LocalPackage
localPackageToBuild <- Path Abs Dir -> RIO env LocalPackage
forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage (Path Abs Dir -> RIO env LocalPackage)
-> Path Abs Dir -> RIO env LocalPackage
forall a b. (a -> b) -> a -> b
$ ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
pkgDir
  -- We remove the path based on the name of the package

  let isPathToRemove :: Path Abs Dir -> RIO env Bool
isPathToRemove Path Abs Dir
path = do
        LocalPackage
localPackage <- Path Abs Dir -> RIO env LocalPackage
forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
path
        Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (Bool -> RIO env Bool) -> Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$  Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
localPackage)
          PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
localPackageToBuild)
  Map PackageName ProjectPackage
pathsToKeep <- [(PackageName, ProjectPackage)] -> Map PackageName ProjectPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, ProjectPackage)] -> Map PackageName ProjectPackage)
-> RIO env [(PackageName, ProjectPackage)]
-> RIO env (Map PackageName ProjectPackage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PackageName, ProjectPackage) -> RIO env Bool)
-> [(PackageName, ProjectPackage)]
-> RIO env [(PackageName, ProjectPackage)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM
    ((Bool -> Bool) -> RIO env Bool -> RIO env Bool
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (RIO env Bool -> RIO env Bool)
-> ((PackageName, ProjectPackage) -> RIO env Bool)
-> (PackageName, ProjectPackage)
-> RIO env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> RIO env Bool
isPathToRemove (Path Abs Dir -> RIO env Bool)
-> ((PackageName, ProjectPackage) -> Path Abs Dir)
-> (PackageName, ProjectPackage)
-> RIO env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute (ResolvedPath Dir -> Path Abs Dir)
-> ((PackageName, ProjectPackage) -> ResolvedPath Dir)
-> (PackageName, ProjectPackage)
-> Path Abs Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> ResolvedPath Dir
ppResolvedDir (ProjectPackage -> ResolvedPath Dir)
-> ((PackageName, ProjectPackage) -> ProjectPackage)
-> (PackageName, ProjectPackage)
-> ResolvedPath Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, ProjectPackage) -> ProjectPackage
forall a b. (a, b) -> b
snd)
    (Map PackageName ProjectPackage -> [(PackageName, ProjectPackage)]
forall k a. Map k a -> [(k, a)]
Map.toList (SMWanted -> Map PackageName ProjectPackage
smwProject (BuildConfig -> SMWanted
bcSMWanted (EnvConfig -> BuildConfig
envConfigBuildConfig EnvConfig
envConfig))))
  ProjectPackage
pp <- PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
YesPrintWarnings ResolvedPath Dir
pkgDir Bool
False
  let adjustEnvForBuild :: env -> env
adjustEnvForBuild env
env =
        let updatedEnvConfig :: EnvConfig
updatedEnvConfig = EnvConfig
envConfig
              { envConfigSourceMap :: SourceMap
envConfigSourceMap =
                  SourceMap -> SourceMap
updatePackagesInSourceMap (EnvConfig -> SourceMap
envConfigSourceMap EnvConfig
envConfig)
              , envConfigBuildConfig :: BuildConfig
envConfigBuildConfig =
                  BuildConfig -> BuildConfig
updateBuildConfig (EnvConfig -> BuildConfig
envConfigBuildConfig EnvConfig
envConfig)
              }
            updateBuildConfig :: BuildConfig -> BuildConfig
updateBuildConfig BuildConfig
bc = BuildConfig
bc
              { bcConfig :: Config
bcConfig = (BuildConfig -> Config
bcConfig BuildConfig
bc)
                 { configBuild :: BuildOpts
configBuild = BuildOpts
defaultBuildOpts { boptsTests :: Bool
boptsTests = Bool
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 -> SourceMap
updatePackagesInSourceMap SourceMap
sm =
        SourceMap
sm {smProject :: Map PackageName ProjectPackage
smProject = PackageName
-> ProjectPackage
-> Map PackageName ProjectPackage
-> Map PackageName ProjectPackage
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (CommonPackage -> PackageName
cpName (CommonPackage -> PackageName) -> CommonPackage -> PackageName
forall a b. (a -> b) -> a -> b
$ ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp) ProjectPackage
pp Map PackageName ProjectPackage
pathsToKeep}
  (env -> env) -> RIO env () -> RIO env ()
forall a. (env -> env) -> RIO env a -> RIO env a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local env -> env
adjustEnvForBuild (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
build Maybe (Set (Path Abs File) -> IO ())
forall a. Maybe a
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
  Path Abs File
npath <- (Path Abs Dir
tpath </>) (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
  IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
L.writeFile (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
npath) ByteString
bytes
  SDistOpts -> Path Abs File -> RIO env ()
forall env.
HasEnvConfig env =>
SDistOpts -> Path Abs File -> RIO env ()
checkSDistTarball SDistOpts
opts Path Abs File
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
  ByteString
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)
  IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ())
-> (ByteString -> IO ()) -> ByteString -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Entries FormatError -> IO ()
forall e. Exception e => FilePath -> Entries e -> IO ()
Tar.unpack (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
tpath) (Entries FormatError -> IO ())
-> (ByteString -> Entries FormatError) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read (ByteString -> Entries FormatError)
-> (ByteString -> ByteString) -> ByteString -> Entries FormatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.decompress (ByteString -> RIO env ()) -> ByteString -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ByteString
archive
  Path Abs Dir -> RIO env a
f Path Abs Dir
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 Entry
packFileEntry FilePath
filepath TarPath
tarpath = do
  EpochTime
mtime <- FilePath -> IO EpochTime
getModTime FilePath
filepath
  Permissions
perms <- FilePath -> IO Permissions
getPermissions FilePath
filepath
  ByteString
content <- FilePath -> IO ByteString
S.readFile FilePath
filepath
  let size :: EpochTime
size = Int -> EpochTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
content)
      entryContent :: EntryContent
entryContent = ByteString -> EpochTime -> EntryContent
Tar.NormalFile (ByteString -> ByteString
L.fromStrict ByteString
content) EpochTime
size
      entry :: Entry
entry = TarPath -> EntryContent -> Entry
Tar.simpleEntry TarPath
tarpath EntryContent
entryContent
  Entry -> IO Entry
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Entry
entry
    { entryPermissions :: Permissions
Tar.entryPermissions = if Permissions -> Bool
executable Permissions
perms
                               then Permissions
Tar.executableFilePermissions
                               else Permissions
Tar.ordinaryFilePermissions
    , entryTime :: EpochTime
Tar.entryTime = EpochTime
mtime
    }

getModTime :: FilePath -> IO Tar.EpochTime
getModTime :: FilePath -> IO EpochTime
getModTime FilePath
path = do
  UTCTime
t <- FilePath -> IO UTCTime
getModificationTime FilePath
path
  EpochTime -> IO EpochTime
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EpochTime -> IO EpochTime) -> EpochTime -> IO EpochTime
forall a b. (a -> b) -> a -> b
$ POSIXTime -> EpochTime
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> EpochTime)
-> (UTCTime -> POSIXTime) -> UTCTime -> EpochTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime -> EpochTime) -> UTCTime -> EpochTime
forall a b. (a -> b) -> a -> b
$ UTCTime
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
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
  ActualCompiler
compilerVersion <- Getting ActualCompiler env ActualCompiler -> m ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL
  PackageConfig -> m PackageConfig
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageConfig
    { packageConfigEnableTests :: Bool
packageConfigEnableTests = Bool
False
    , packageConfigEnableBenchmarks :: Bool
packageConfigEnableBenchmarks = Bool
False
    , packageConfigFlags :: Map FlagName Bool
packageConfigFlags = Map FlagName Bool
forall a. Monoid a => a
mempty
    , packageConfigGhcOptions :: [Text]
packageConfigGhcOptions = []
    , packageConfigCabalConfigOpts :: [Text]
packageConfigCabalConfigOpts = []
    , packageConfigCompilerVersion :: ActualCompiler
packageConfigCompilerVersion = ActualCompiler
compilerVersion
    , packageConfigPlatform :: Platform
packageConfigPlatform = Platform
platform
    }