{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [SDistException] -> ShowS
$cshowList :: [SDistException] -> ShowS
show :: SDistException -> FilePath
$cshow :: SDistException -> FilePath
showsPrec :: Int -> SDistException -> ShowS
$cshowsPrec :: Int -> SDistException -> ShowS
Show, Typeable)

instance Exception SDistException where
  displayException :: SDistException -> FilePath
displayException (CheckException NonEmpty PackageCheck
xs) = [FilePath] -> FilePath
unlines forall a b. (a -> b) -> a -> b
$
    [ FilePath
"Error: [S-6439]"
    , FilePath
"Package check reported the following errors:"
    ] forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> FilePath
show (forall a. NonEmpty a -> [a]
NE.toList NonEmpty PackageCheck
xs)
  displayException (CabalFilePathsInconsistentBug Path Abs File
cabalfp Path Abs File
cabalfp') = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ FilePath
"Error: [S-9595]\n"
    , FilePath
"The impossible happened! Two Cabal file paths are inconsistent: "
    , forall a. Show a => a -> FilePath
show (Path Abs File
cabalfp, Path Abs File
cabalfp')
    ]
  displayException (ToTarPathException FilePath
e) =
    FilePath
"Error: [S-7875\n"
    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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    let PvpBounds PvpBoundsType
pvpBounds Bool
asRevision = forall a. a -> Maybe a -> a
fromMaybe (Config -> PvpBounds
configPvpBounds Config
config) Maybe PvpBounds
mpvpBounds
        tweakCabal :: Bool
tweakCabal = PvpBoundsType
pvpBounds forall a. Eq a => a -> a -> Bool
/= PvpBoundsType
PvpBoundsNone
        pkgFp :: FilePath
pkgFp = forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir
    LocalPackage
lp <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
pkgDir
    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)) forall a b. (a -> b) -> a -> b
$ \Map PackageName VersionRange
customSetupDeps ->
        case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
packageNameString) (forall k a. Map k a -> [k]
Map.keys Map PackageName VersionRange
customSetupDeps)) of
          Just NonEmpty Text
nonEmptyDepTargets -> do
            Either SomeException ()
eres <- forall env.
HasEnvConfig env =>
NonEmpty Text -> RIO env (Either SomeException ())
buildLocalTargets NonEmpty Text
nonEmptyDepTargets
            case Either SomeException ()
eres of
              Left SomeException
err ->
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$
                  Utf8Builder
"Error: [S-8399]\n" forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
"Error building custom-setup dependencies: " forall a. Semigroup a => a -> a -> a
<>
                  forall a. Show a => a -> Utf8Builder
displayShow SomeException
err
              Right ()
_ ->
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Maybe (NonEmpty Text)
Nothing ->
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"unexpected empty custom-setup dependencies"
    SourceMap
sourceMap <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMap

    InstallMap
installMap <- forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
    (InstalledMap
installedMap, [DumpPackage]
_globalDumpPkgs, [DumpPackage]
_snapshotDumpPkgs, [DumpPackage]
_localDumpPkgs) <-
        forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
    let deps :: Map PackageIdentifier GhcPkgId
deps = 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)
_) <- forall k a. Map k a -> [a]
Map.elems InstalledMap
installedMap]

    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Getting file list for " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString FilePath
pkgFp
    (FilePath
fileList, Path Abs File
cabalfp) <- forall env.
HasEnvConfig env =>
LocalPackage
-> Map PackageIdentifier GhcPkgId
-> RIO env (FilePath, Path Abs File)
getSDistFileList LocalPackage
lp Map PackageIdentifier GhcPkgId
deps
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Building sdist tarball for " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString FilePath
pkgFp
    [FilePath]
files <- forall env. HasRunner env => [FilePath] -> RIO env [FilePath]
normalizeTarballPaths (forall a b. (a -> b) -> [a] -> [b]
map (Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
stripCR 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef 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 -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> SDistException
ToTarPathException FilePath
e
                Right TarPath
tp -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> TarPath -> IO Entry
f (FilePath
pkgFp FilePath -> ShowS
FP.</> FilePath
fp) 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 <- forall env.
HasEnvConfig env =>
PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
getCabalLbs PvpBoundsType
pvpBounds (forall a. a -> Maybe a
Just Int
1) Path Abs File
cabalfp SourceMap
sourceMap
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Maybe (PackageIdentifier, ByteString))
cabalFileRevisionRef (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) <- forall env.
HasEnvConfig env =>
PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
getCabalLbs PvpBoundsType
pvpBounds forall a. Maybe a
Nothing Path Abs File
cabalfp SourceMap
sourceMap
                POSIXTime
currTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime -- Seconds from UNIX epoch

                TarPath
tp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO TarPath
tarPath Bool
False FilePath
fp
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (TarPath -> ByteString -> Entry
Tar.fileEntry TarPath
tp ByteString
lbs) { entryTime :: EpochTime
Tar.entryTime = 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 = forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir FilePath -> ShowS
FP.</> FilePath
fp forall a. Eq a => a -> a -> Bool
== 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> RIO env Entry
packDir ([FilePath] -> [FilePath]
dirsFromFiles [FilePath]
files)
    [Entry]
fileEntries <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> RIO env Entry
packFile [FilePath]
files
    Maybe (PackageIdentifier, ByteString)
mcabalFileRevision <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe (PackageIdentifier, ByteString))
cabalFileRevisionRef)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
tarName, ByteString -> ByteString
GZip.compress ([Entry] -> ByteString
Tar.write ([Entry]
dirEntries 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') <-
      forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (forall a. a -> Maybe a
Just Text
stackProgName') (forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp)
    GenericPackageDescription
gpd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
NoPrintWarnings
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Path Abs File
cabalfp forall a. Eq a => a -> a -> Bool
== Path Abs File
cabalfp') forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO 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 <- forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
    (InstalledMap
installedMap, [DumpPackage]
_, [DumpPackage]
_, [DumpPackage]
_) <- forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
    let internalPackages :: Set PackageName
internalPackages = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$
          GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd forall a. a -> [a] -> [a]
:
          forall a b. (a -> b) -> [a] -> [b]
map (UnqualComponentName -> PackageName
Cabal.unqualComponentNameToPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
Cabal.condSubLibraries GenericPackageDescription
gpd)
        gpd' :: GenericPackageDescription
gpd' = 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", forall a. Show a => a -> FilePath
show Int
rev)forall a. a -> [a] -> [a]
:)
                  forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\(FilePath
x, FilePath
_) -> forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower FilePath
x forall a. Eq a => a -> a -> Bool
/= FilePath
"x-revision")
                  forall a b. (a -> b) -> a -> b
$ PackageDescription -> [(FilePath, FilePath)]
Cabal.customFieldsPD
                  forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd'
                  }
              }
        ident :: PackageIdentifier
ident = PackageDescription -> PackageIdentifier
Cabal.package 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
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalfp
          , StyleDoc
""
          ]
        ([PWarning]
_warnings, Either (Maybe Version, NonEmpty PError) GenericPackageDescription
eres) = forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
Cabal.runParseResult
                          forall a b. (a -> b) -> a -> b
$ ByteString -> ParseResult GenericPackageDescription
Cabal.parseGenericPackageDescription
                          forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8
                          forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack
                          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 forall a. Eq a => a -> a -> Bool
== GenericPackageDescription
gpd -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise -> do
            forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vsep forall a b. (a -> b) -> a -> b
$ [StyleDoc]
roundtripErrs 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
        forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vsep forall a b. (a -> b) -> a -> b
$ [StyleDoc]
roundtripErrs 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 forall a b. (a -> b) -> a -> b
$ FilePath
"The parse error is: " forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> FilePath
show (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty PError
errs))
          , StyleDoc
""
          ]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( PackageIdentifier
ident
      , Text -> ByteString
TLE.encodeUtf8 forall a b. (a -> b) -> a -> b
$ FilePath -> Text
TL.pack 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 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
            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 forall a. a -> a
id)
            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 forall a. a -> a
id)
              VersionRange
range) NonEmptySet LibraryName
s
      where
        foundVersion :: Maybe Version
foundVersion =
          case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstallMap
installMap of
              Just (InstallLocation
_, Version
version) -> forall a. a -> Maybe a
Just Version
version
              Maybe (InstallLocation, Version)
Nothing ->
                  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstalledMap
installedMap of
                      Just (InstallLocation
_, Installed
installed) -> forall a. a -> Maybe a
Just (Installed -> Version
installedVersion Installed
installed)
                      Maybe (InstallLocation, Installed)
Nothing -> forall a. Maybe a
Nothing

    addUpper :: Version -> VersionRange -> VersionRange
addUpper Version
version = VersionRange -> VersionRange -> VersionRange
intersectVersionRanges
        (Version -> VersionRange
earlierVersion 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 a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT (\b
x -> case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
x of
                 Maybe b
Nothing -> forall a b.
(Data a, Typeable b) =>
(Typeable b => b -> b) -> a -> a
gtraverseT Typeable b => b -> b
f b
x
                 Just b
b  -> forall a. a -> Maybe a -> a
fromMaybe b
x (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (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  <- forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasEnvConfig env) =>
m PackageConfig
getDefaultPackageConfig
    (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
cabalfp) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (forall a. a -> Maybe a
Just Text
stackProgName') Path Abs Dir
pkgDir
    GenericPackageDescription
gpd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
    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 = forall a. Maybe a
Nothing
        , lpBuildHaddocks :: Bool
lpBuildHaddocks = Bool
False
        , lpForceDirty :: Bool
lpForceDirty = Bool
False
        , lpDirtyFiles :: MemoizedWith EnvConfig (Maybe (Set FilePath))
lpDirtyFiles = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        , lpNewBuildCaches :: MemoizedWith
  EnvConfig (Map NamedComponent (Map FilePath FileCacheInfo))
lpNewBuildCaches = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
        , lpComponentFiles :: MemoizedWith EnvConfig (Map NamedComponent (Set (Path Abs File)))
lpComponentFiles = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
        , lpComponents :: Set NamedComponent
lpComponents = forall a. Set a
Set.empty
        , lpUnbuildable :: Set NamedComponent
lpUnbuildable = 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 =
    forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (Path Abs Dir -> m a) -> m a
withSystemTempDir (FilePath
stackProgName forall a. Semigroup a => a -> a -> a
<> FilePath
"-sdist") 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 <- forall env.
HasEnvConfig env =>
BuildOptsCLI -> RIO env BaseConfigOpts
mkBaseConfigOpts BuildOptsCLI
boptsCli
        [LocalPackage]
locals <- forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
        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
            [] [] [] forall a. Maybe a
Nothing -- provide empty list of globals. This is a hack around custom Setup.hs files

            forall a b. (a -> b) -> a -> b
$ \ExecuteEnv
ee ->
            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 (forall a. a -> Maybe a
Just FilePath
"sdist") 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 = 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ByteString
S.readFile FilePath
outFile)
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> FilePath
T.unpack 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 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 = 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 = forall k a. Map k a
Map.empty
        , taskAllInOne :: Bool
taskAllInOne = Bool
True
        , taskCachePkgSrc :: CachePkgSrc
taskCachePkgSrc = FilePath -> CachePkgSrc
CacheSrcLocal (forall b t. Path b t -> FilePath
toFilePath (forall b t. Path b t -> Path b Dir
parent 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?

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
outsideDir) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
            Utf8Builder
"Warning: These files are outside of the package directory, and will be omitted from the tarball: " forall a. Semigroup a => a -> a -> a
<>
            forall a. Show a => a -> Utf8Builder
displayShow [FilePath]
outsideDir
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Ord a => [a] -> [a]
nubOrd [FilePath]
files)
  where
    ([FilePath]
outsideDir, [FilePath]
files) = forall a b. [Either a b] -> ([a], [b])
partitionEithers (forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Either FilePath FilePath
pathToEither [FilePath]
fps)
    pathToEither :: FilePath -> Either FilePath FilePath
pathToEither FilePath
fp = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left FilePath
fp) forall a b. b -> Either a b
Right (FilePath -> Maybe FilePath
normalizePath FilePath
fp)

normalizePath :: FilePath -> Maybe FilePath
normalizePath :: FilePath -> Maybe FilePath
normalizePath = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FilePath] -> FilePath
FP.joinPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Eq a, IsString a) => [a] -> Maybe [a]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
FP.splitDirectories forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.normalise
  where
    go :: [a] -> Maybe [a]
go [] = forall a. a -> Maybe a
Just []
    go (a
"..":[a]
_) = forall a. Maybe a
Nothing
    go (a
_:a
"..":[a]
xs) = [a] -> Maybe [a]
go [a]
xs
    go (a
x:[a]
xs) = (a
x forall a. a -> [a] -> [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 = forall a. Set a -> [a]
Set.toAscList (forall a. Ord a => a -> Set a -> Set a
Set.delete FilePath
"." Set FilePath
results)
  where
    results :: Set FilePath
results = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeDirectory) forall a. Set a
Set.empty [FilePath]
dirs
    go :: Set FilePath -> FilePath -> Set FilePath
go Set FilePath
s FilePath
x
      | 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 (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 = forall env a.
Path Abs File -> (Path Abs Dir -> RIO env a) -> RIO env a
withTempTarGzContents Path Abs File
tarball forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
pkgDir' -> do
    Path Abs Dir
pkgDir  <- (Path Abs Dir
pkgDir' forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`
        (forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeBaseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeBaseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> FilePath
toFilePath forall a b. (a -> b) -> a -> b
$ Path Abs File
tarball)
    --               ^ drop ".tar"     ^ drop ".gz"

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SDistOpts -> Bool
sdoptsBuildTarball SDistOpts
opts) (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
                                      })
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SDistOpts -> Bool
sdoptsIgnoreCheck SDistOpts
opts) (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) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (forall a. a -> Maybe a
Just Text
stackProgName') Path Abs Dir
pkgDir
    GenericPackageDescription
gpd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings
    PackageConfig
config  <- 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
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
        Utf8Builder
"Checking package '" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
packageNameString PackageName
name) 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 forall a. Maybe a
Nothing of
            [] -> GenericPackageDescription
-> Maybe PackageDescription -> [PackageCheck]
Check.checkPackage GenericPackageDescription
gpd (forall a. a -> Maybe a
Just PackageDescription
pkgDesc)
            [PackageCheck]
x -> [PackageCheck]
x
    [PackageCheck]
fileChecks <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck]
Check.checkPackageFiles forall a. Bounded a => a
minBound PackageDescription
pkgDesc (forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir)
    let checks :: [PackageCheck]
checks = [PackageCheck]
pkgChecks 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 forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition PackageCheck -> Bool
criticalIssue [PackageCheck]
checks
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageCheck]
warnings) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Package check reported the following warnings:\n" forall a. Semigroup a => a -> a -> a
<>
                   forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
List.intersperse Utf8Builder
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> Utf8Builder
displayShow forall a b. (a -> b) -> a -> b
$ [PackageCheck]
warnings)
    case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [PackageCheck]
errors of
        Maybe (NonEmpty PackageCheck)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just NonEmpty PackageCheck
ne -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM 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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL
  LocalPackage
localPackageToBuild <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage forall a b. (a -> b) -> a -> b
$ 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 <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
path
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
localPackage) forall a. Eq a => a -> a -> Bool
== Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
localPackageToBuild)
  Map PackageName ProjectPackage
pathsToKeep
    <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
     forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall k a. Map k a -> [(k, a)]
Map.toList (SMWanted -> Map PackageName ProjectPackage
smwProject (BuildConfig -> SMWanted
bcSMWanted (EnvConfig -> BuildConfig
envConfigBuildConfig EnvConfig
envConfig))))
     forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> RIO env Bool
isPathToRemove forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> ResolvedPath Dir
ppResolvedDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
  ProjectPackage
pp <- 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 forall s t a b. ASetter s t a b -> b -> s -> t
set forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL EnvConfig
updatedEnvConfig env
env
      updatePackagesInSourceMap :: SourceMap -> SourceMap
updatePackagesInSourceMap SourceMap
sm =
        SourceMap
sm {smProject :: Map PackageName ProjectPackage
smProject = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (CommonPackage -> PackageName
cpName forall a b. (a -> b) -> a -> b
$ ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp) ProjectPackage
pp Map PackageName ProjectPackage
pathsToKeep}
  forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local env -> env
adjustEnvForBuild forall a b. (a -> b) -> a -> b
$ forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
build 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 = forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (Path Abs Dir -> m a) -> m a
withSystemTempDir FilePath
"stack" forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tpath -> do
    Path Abs File
npath   <- (Path Abs Dir
tpath forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
name
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
L.writeFile (forall b t. Path b t -> FilePath
toFilePath Path Abs File
npath) ByteString
bytes
    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 = forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (Path Abs Dir -> m a) -> m a
withSystemTempDir FilePath
"stack" forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tpath -> do
    ByteString
archive <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
L.readFile (forall b t. Path b t -> FilePath
toFilePath Path Abs File
apath)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => FilePath -> Entries e -> IO ()
Tar.unpack (forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
tpath) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.decompress 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
content)
  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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds 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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
  ActualCompiler
compilerVersion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
  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 = forall a. Monoid a => a
mempty
    , packageConfigGhcOptions :: [Text]
packageConfigGhcOptions = []
    , packageConfigCabalConfigOpts :: [Text]
packageConfigCabalConfigOpts = []
    , packageConfigCompilerVersion :: ActualCompiler
packageConfigCompilerVersion = ActualCompiler
compilerVersion
    , packageConfigPlatform :: Platform
packageConfigPlatform = Platform
platform
    }