{-# 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           Stack.Prelude hiding (Display (..))
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           Data.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           RIO.PrettyPrint
import           Stack.Build (mkBaseConfigOpts, build, buildLocalTargets)
import           Stack.Build.Execute
import           Stack.Build.Installed
import           Stack.Build.Source (projectLocalPackages)
import           Stack.Types.GhcPkgId
import           Stack.Package
import           Stack.SourceMap
import           Stack.Types.Build
import           Stack.Types.Config
import           Stack.Types.Package
import           Stack.Types.SourceMap
import           Stack.Types.Version
import           System.Directory (getModificationTime, getPermissions)
import qualified System.FilePath as FP

-- | Special exception to throw when you want to fail because of bad results

-- of package check.


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

  }

newtype CheckException
  = CheckException (NonEmpty Check.PackageCheck)
  deriving (Typeable)

instance Exception CheckException

instance Show CheckException where
  show :: CheckException -> FilePath
show (CheckException NonEmpty PackageCheck
xs) =
    FilePath
"Package check reported the following errors:\n" forall a. [a] -> [a] -> [a]
++
    (forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\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 -> FilePath
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ NonEmpty PackageCheck
xs)

-- | 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 building custom-setup dependencies: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
err
              Right ()
_ ->
                forall (m :: * -> *) a. Monad m => a -> m a
return ()
          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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString forall (m :: * -> *) a. Monad m => a -> m a
return
            (Bool -> FilePath -> Either FilePath TarPath
Tar.toTarPath Bool
isDir (ShowS
forceUtf8Enc (FilePath
pkgId FilePath -> ShowS
FP.</> FilePath
fp)))
        -- 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return (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) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (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 a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"getCabalLbs: cabalfp /= cabalfp': " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (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 (m :: * -> *) a. Monad m => a -> m a
return ()
        | 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 (m :: * -> *) a. Monad m => a -> m a
return
      ( 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) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath 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 (m :: * -> *) a. Monad m => a -> m a
return 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.

        , lpTestDeps :: Map PackageName VersionRange
lpTestDeps = forall k a. Map k a
Map.empty
        , lpBenchDeps :: Map PackageName VersionRange
lpBenchDeps = forall k a. Map k a
Map.empty
        , 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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return (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) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath 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])
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]
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 (m :: * -> *) a. Monad m => a -> m a
return ()
        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 -> CheckException
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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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
    }