{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Stack.SDist
( SDistOpts (..)
, sdistCmd
, getSDistTarball
, checkSDistTarball
, checkSDistTarball'
) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import Conduit ( runConduitRes, sourceLazy, sinkFileCautious )
import Control.Concurrent.Execute
( ActionContext (..), Concurrency (..) )
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Char ( toLower )
import Data.Data ( cast )
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Time.Clock.POSIX ( getPOSIXTime, utcTimeToPOSIXSeconds )
import Distribution.Package ( Dependency (..) )
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription.Check as Check
import qualified Distribution.PackageDescription.Parsec as Cabal
import Distribution.PackageDescription.PrettyPrint
( showGenericPackageDescription )
import Distribution.Version
( simplifyVersionRange, orLaterVersion, earlierVersion
, hasUpperBound, hasLowerBound
)
import Path ( (</>), parent, parseRelDir, parseRelFile )
import Path.IO ( ensureDir, resolveDir' )
import Stack.Build ( mkBaseConfigOpts, build, buildLocalTargets )
import Stack.Build.Execute
( ExcludeTHLoading (..), KeepOutputOpen (..), withExecuteEnv
, withSingleContext
)
import Stack.Build.Installed ( getInstalled, toInstallMap )
import Stack.Build.Source ( projectLocalPackages )
import Stack.Constants ( stackProgName, stackProgName' )
import Stack.Constants.Config ( distDirFromDir )
import Stack.Package
( PackageDescriptionPair (..), resolvePackage
, resolvePackageDescription
)
import Stack.Prelude
import Stack.Runners
( ShouldReexec (..), withConfig, withDefaultEnvConfig )
import Stack.SourceMap ( mkProjectPackage )
import Stack.Types.Build
( CachePkgSrc (..), Task (..), TaskConfigOpts (..)
, TaskType (..)
)
import Stack.Types.BuildConfig
( BuildConfig (..), HasBuildConfig (..), stackYamlL )
import Stack.Types.BuildOpts
( BuildOpts (..), defaultBuildOpts, defaultBuildOptsCLI )
import Stack.Types.Config ( Config (..), HasConfig (..) )
import Stack.Types.ConfigureOpts ( ConfigureOpts (..) )
import Stack.Types.EnvConfig
( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL )
import Stack.Types.GhcPkgId ( GhcPkgId )
import Stack.Types.Package
( InstallMap, Installed (..), InstalledMap, LocalPackage (..)
, Package (..), PackageConfig (..), installedVersion
, packageIdentifier
)
import Stack.Types.Platform ( HasPlatform (..) )
import Stack.Types.PvpBounds ( PvpBounds (..), PvpBoundsType (..) )
import Stack.Types.Runner ( HasRunner, Runner )
import Stack.Types.SourceMap
( CommonPackage (..), ProjectPackage (..), SMWanted (..)
, SourceMap (..), ppRoot
)
import Stack.Types.Version
( intersectVersionRanges, nextMajorVersion )
import System.Directory
( copyFile, createDirectoryIfMissing, executable
, getModificationTime, getPermissions
)
import qualified System.FilePath as FP
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]
, SDistOpts -> Maybe PvpBounds
sdoptsPvpBounds :: Maybe PvpBounds
, SDistOpts -> Bool
sdoptsIgnoreCheck :: Bool
, SDistOpts -> Bool
sdoptsBuildTarball :: Bool
, SDistOpts -> Maybe FilePath
sdoptsTarPath :: Maybe FilePath
}
sdistCmd :: SDistOpts -> RIO Runner ()
sdistCmd :: SDistOpts -> RIO Runner ()
sdistCmd SDistOpts
sdistOpts =
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec forall a b. (a -> b) -> a -> b
$ forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig forall a b. (a -> b) -> a -> b
$ do
[Path Abs Dir]
dirs' <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (SDistOpts -> [FilePath]
sdoptsDirsToWorkWith SDistOpts
sdistOpts)
then do
[Path Abs Dir]
dirs <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (forall a b. (a -> b) -> [a] -> [b]
map ProjectPackage -> Path Abs Dir
ppRoot forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMWanted -> Map PackageName ProjectPackage
smwProject forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs Dir]
dirs) forall a b. (a -> b) -> a -> b
$ do
Path Abs File
stackYaml <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasBuildConfig env => Lens' env (Path Abs File)
stackYamlL
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyErrorL
[ Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack sdist"
, FilePath -> StyleDoc
flow FilePath
"expects a list of targets, and otherwise defaults to all of the project's packages."
, FilePath -> StyleDoc
flow FilePath
"However, the configuration at"
, forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml
, FilePath -> StyleDoc
flow FilePath
"contains no packages, so no sdist tarballs will be generated."
]
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Path Abs Dir]
dirs
else forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs Dir)
resolveDir' (SDistOpts -> [FilePath]
sdoptsDirsToWorkWith SDistOpts
sdistOpts)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs Dir]
dirs' forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
(FilePath
tarName, ByteString
tarBytes, Maybe (PackageIdentifier, ByteString)
_mcabalRevision) <-
forall env.
HasEnvConfig env =>
Maybe PvpBounds
-> Path Abs Dir
-> RIO
env (FilePath, ByteString, Maybe (PackageIdentifier, ByteString))
getSDistTarball (SDistOpts -> Maybe PvpBounds
sdoptsPvpBounds SDistOpts
sdistOpts) Path Abs Dir
dir
Path Abs Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
dir
Path Abs File
tarPath <- (Path Abs Dir
distDir </>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
tarName
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
tarPath)
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) lazy strict i.
(Monad m, LazySequence lazy strict) =>
lazy -> ConduitT i strict m ()
sourceLazy ByteString
tarBytes forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
forall (m :: * -> *) o.
MonadResource m =>
FilePath -> ConduitM ByteString o m ()
sinkFileCautious (forall b t. Path b t -> FilePath
toFilePath Path Abs File
tarPath)
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[FilePath -> StyleDoc
flow FilePath
"Wrote sdist-format compressed archive to"
, forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
tarPath forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
forall env.
HasEnvConfig env =>
SDistOpts -> Path Abs File -> RIO env ()
checkSDistTarball SDistOpts
sdistOpts Path Abs File
tarPath
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (SDistOpts -> Maybe FilePath
sdoptsTarPath SDistOpts
sdistOpts) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {b} {t}.
MonadIO m =>
Path b t -> FilePath -> FilePath -> m ()
copyTarToTarPath Path Abs File
tarPath FilePath
tarName
where
copyTarToTarPath :: Path b t -> FilePath -> FilePath -> m ()
copyTarToTarPath Path b t
tarPath FilePath
tarName FilePath
targetDir = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let targetTarPath :: FilePath
targetTarPath = FilePath
targetDir FilePath -> ShowS
FP.</> FilePath
tarName
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ ShowS
FP.takeDirectory FilePath
targetTarPath
FilePath -> FilePath -> IO ()
copyFile (forall b t. Path b t -> FilePath
toFilePath Path b t
tarPath) FilePath
targetTarPath
getSDistTarball ::
HasEnvConfig env
=> Maybe PvpBounds
-> Path Abs Dir
-> RIO env (FilePath, L.ByteString, Maybe (PackageIdentifier, L.ByteString))
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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
FilePath -> m ()
prettyWarnS FilePath
"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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ FilePath -> StyleDoc
flow FilePath
"Getting the file list for"
, Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => FilePath -> a
fromString FilePath
pkgFp) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
(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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ FilePath -> StyleDoc
flow FilePath
"Building a compressed archive file in the sdist format for"
, Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => FilePath -> a
fromString FilePath
pkgFp) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
[FilePath]
files <-
forall env.
(HasRunner env, HasTerm 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))
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)
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
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
| 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
| 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
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
)
getCabalLbs :: HasEnvConfig env
=> PvpBoundsType
-> Maybe Int
-> Path Abs 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 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''
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 ->
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) ->
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)
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)))
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
, lpCabalFile :: Path Abs File
lpCabalFile = Path Abs File
cabalfp
, 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
}
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
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, HasTerm env)
=> [FilePath]
-> RIO env [FilePath]
normalizeTarballPaths :: forall env.
(HasRunner env, HasTerm env) =>
[FilePath] -> RIO env [FilePath]
normalizeTarballPaths [FilePath]
fps = do
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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
FilePath -> StyleDoc
flow FilePath
"These files are outside of the package directory, and will be \
\omitted from the tarball:"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => FilePath -> a
fromString) [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 (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)
checkSDistTarball ::
HasEnvConfig env
=> SDistOpts
-> Path Abs File
-> 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(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)
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"
, 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
-> RIO env ()
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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ FilePath -> StyleDoc
flow FilePath
"Checking package"
, Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> FilePath
packageNameString PackageName
name)
, FilePath -> StyleDoc
flow FilePath
"for common mistakes."
]
let pkgChecks :: [PackageCheck]
pkgChecks =
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 CheckExplanation
_) = Bool
True
criticalIssue (Check.PackageDistInexcusable CheckExplanation
_) = 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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
FilePath -> StyleDoc
flow FilePath
"Package check reported the following warnings:"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => FilePath -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show) [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 ()
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
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
checkSDistTarball' ::
HasEnvConfig env
=> SDistOpts
-> String
-> L.ByteString
-> 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
-> (Path Abs Dir -> RIO env a)
-> 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
packFileEntry :: FilePath
-> Tar.TarPath
-> 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 a b. (a -> b) -> a -> b
$ 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
}