{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE ConstraintKinds    #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RankNTypes         #-}
{-# LANGUAGE TypeFamilies       #-}

-- Create a source distribution tarball

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

import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import           Control.Applicative
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
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
                   ( simplifyVersionRange, orLaterVersion, earlierVersion
                   , hasUpperBound, hasLowerBound
                   )
import           Path
import           Path.IO
                   hiding
                     ( getModificationTime, getPermissions, withSystemTempDir )
import           Stack.Build ( mkBaseConfigOpts, build, buildLocalTargets )
import           Stack.Build.Execute
import           Stack.Build.Installed
import           Stack.Build.Source ( projectLocalPackages )
import           Stack.Package
import           Stack.Prelude hiding ( Display (..) )
import           Stack.SourceMap
import           Stack.Types.Build
import           Stack.Types.Config
import           Stack.Types.GhcPkgId
import           Stack.Types.Package
import           Stack.Types.SourceMap
import           Stack.Types.Version
import           System.Directory ( getModificationTime, getPermissions )
import qualified System.FilePath as FP

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.SDist" module.

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

instance Exception SDistException where
  displayException :: SDistException -> FilePath
displayException (CheckException NonEmpty PackageCheck
xs) = [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
    [ FilePath
"Error: [S-6439]"
    , FilePath
"Package check reported the following errors:"
    ] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> (PackageCheck -> FilePath) -> [PackageCheck] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageCheck -> FilePath
forall a. Show a => a -> FilePath
show (NonEmpty PackageCheck -> [PackageCheck]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty PackageCheck
xs)
  displayException (CabalFilePathsInconsistentBug Path Abs File
cabalfp Path Abs File
cabalfp') = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ FilePath
"Error: [S-9595]\n"
    , FilePath
"The impossible happened! Two Cabal file paths are inconsistent: "
    , (Path Abs File, Path Abs File) -> FilePath
forall a. Show a => a -> FilePath
show (Path Abs File
cabalfp, Path Abs File
cabalfp')
    ]
  displayException (ToTarPathException FilePath
e) =
    FilePath
"Error: [S-7875\n"
    FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
e

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

  }

-- | 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 ->
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"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]

    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Getting file list for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
pkgFp
    (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
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Building sdist tarball for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
pkgFp
    [FilePath]
files <- [FilePath] -> RIO env [FilePath]
forall env. HasRunner 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
pkgId FilePath -> ShowS
FP.</> FilePath
fp)) of
                Left FilePath
e -> SDistException -> IO TarPath
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (SDistException -> IO TarPath) -> SDistException -> IO TarPath
forall a b. (a -> b) -> a -> b
$ FilePath -> SDistException
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
pkgId FilePath -> ShowS
FP.<.> FilePath
"tar.gz"
        pkgId :: FilePath
pkgId = PackageIdentifier -> FilePath
packageIdentifierString (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
$
      SDistException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (SDistException -> RIO env ()) -> SDistException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs File -> SDistException
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)]
forall a. a -> [a] -> [a]
:)
                  ([(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 =
          [ FilePath -> StyleDoc
flow FilePath
"Bug detected in Cabal library. ((parse . render . parse) === \
                 \id) does not hold for the Cabal file at"
          StyleDoc -> StyleDoc -> StyleDoc
<+> Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalfp
          , StyleDoc
""
          ]
        ([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 -> do
            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] -> StyleDoc
vsep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc]
roundtripErrs [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. [a] -> [a] -> [a]
++
              [ StyleDoc
"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
"Please see this GitHub issue for status:" StyleDoc -> StyleDoc -> StyleDoc
<+> Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/3549"
              , StyleDoc
""
              , [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
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
""
              , 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
""
              ]
      Left (Maybe Version
_version, NonEmpty PError
errs) -> do
        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] -> StyleDoc
vsep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc]
roundtripErrs [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall 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
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"
            ]
          , FilePath -> StyleDoc
flow (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall a b. (a -> b) -> a -> b
$ FilePath
"The parse error is: " FilePath -> ShowS
forall 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
""
          ]
    (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 dep :: Dependency
dep@(Dependency PackageName
name VersionRange
range NonEmptySet LibraryName
s) =
      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)
            (VersionRange -> VersionRange) -> VersionRange -> VersionRange
forall a b. (a -> b) -> a -> b
$ (if Bool
toAddLower 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
        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 => [FilePath] -> RIO env [FilePath]
normalizeTarballPaths :: forall env. HasRunner 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
$
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
            Utf8Builder
"Warning: These files are outside of the package directory, and will be omitted from the tarball: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
            [FilePath] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow [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
    Path Abs Dir
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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`
        (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
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        Utf8Builder
"Checking package '" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
packageNameString PackageName
name) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"' 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
$
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Package check reported the following warnings:\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                   [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat (Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
List.intersperse Utf8Builder
"\n" ([Utf8Builder] -> [Utf8Builder])
-> ([PackageCheck] -> [Utf8Builder])
-> [PackageCheck]
-> [Utf8Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageCheck -> Utf8Builder) -> [PackageCheck] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageCheck -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow ([PackageCheck] -> [Utf8Builder])
-> [PackageCheck] -> [Utf8Builder]
forall a b. (a -> b) -> a -> b
$ [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 -> SDistException -> RIO env ()
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (SDistException -> RIO env ()) -> SDistException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ NonEmpty PackageCheck -> SDistException
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)
-> RIO env [(PackageName, ProjectPackage)]
-> RIO env (Map PackageName ProjectPackage)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(PackageName, ProjectPackage)] -> Map PackageName ProjectPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
     (RIO env [(PackageName, ProjectPackage)]
 -> RIO env (Map PackageName ProjectPackage))
-> RIO env [(PackageName, ProjectPackage)]
-> RIO env (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (((PackageName, ProjectPackage) -> RIO env Bool)
 -> [(PackageName, ProjectPackage)]
 -> RIO env [(PackageName, ProjectPackage)])
-> [(PackageName, ProjectPackage)]
-> ((PackageName, ProjectPackage) -> RIO env Bool)
-> RIO env [(PackageName, ProjectPackage)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((PackageName, ProjectPackage) -> RIO env Bool)
-> [(PackageName, ProjectPackage)]
-> RIO env [(PackageName, ProjectPackage)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (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))))
     (((PackageName, ProjectPackage) -> RIO env Bool)
 -> RIO env [(PackageName, ProjectPackage)])
-> ((PackageName, ProjectPackage) -> RIO env Bool)
-> RIO env [(PackageName, ProjectPackage)]
forall a b. (a -> b) -> a -> b
$ (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
  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 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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` 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)
  Entry -> IO Entry
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TarPath -> EntryContent -> Entry
Tar.simpleEntry TarPath
tarpath (ByteString -> EpochTime -> EntryContent
Tar.NormalFile (ByteString -> ByteString
L.fromStrict ByteString
content) EpochTime
size)) {
    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)
-> (UTCTime -> EpochTime) -> UTCTime -> IO EpochTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> IO EpochTime) -> UTCTime -> IO 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
    }