{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module Stack.SDist
( getSDistTarball
, checkSDistTarball
, checkSDistTarball'
, SDistOpts (..)
) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import Control.Applicative
import Control.Concurrent.Execute
( ActionContext (..), Concurrency (..) )
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Char ( toLower )
import Data.Data ( cast )
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Time.Clock.POSIX
import Distribution.Package ( Dependency (..) )
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription.Check as Check
import qualified Distribution.PackageDescription.Parsec as Cabal
import Distribution.PackageDescription.PrettyPrint
( showGenericPackageDescription )
import Distribution.Version
( simplifyVersionRange, orLaterVersion, earlierVersion
, hasUpperBound, hasLowerBound
)
import Path
import Path.IO
hiding
( getModificationTime, getPermissions, withSystemTempDir )
import Stack.Build ( mkBaseConfigOpts, build, buildLocalTargets )
import Stack.Build.Execute
import Stack.Build.Installed
import Stack.Build.Source ( projectLocalPackages )
import Stack.Package
import Stack.Prelude hiding ( Display (..) )
import Stack.SourceMap
import Stack.Types.Build
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.Package
import Stack.Types.SourceMap
import Stack.Types.Version
import System.Directory ( getModificationTime, getPermissions )
import qualified System.FilePath as FP
data SDistException
= CheckException (NonEmpty Check.PackageCheck)
| CabalFilePathsInconsistentBug (Path Abs File) (Path Abs File)
| ToTarPathException String
deriving (Int -> SDistException -> ShowS
[SDistException] -> ShowS
SDistException -> FilePath
(Int -> SDistException -> ShowS)
-> (SDistException -> FilePath)
-> ([SDistException] -> ShowS)
-> Show SDistException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SDistException -> ShowS
showsPrec :: Int -> SDistException -> ShowS
$cshow :: SDistException -> FilePath
show :: SDistException -> FilePath
$cshowList :: [SDistException] -> ShowS
showList :: [SDistException] -> ShowS
Show, Typeable)
instance Exception SDistException where
displayException :: SDistException -> FilePath
displayException (CheckException NonEmpty PackageCheck
xs) = [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
[ FilePath
"Error: [S-6439]"
, FilePath
"Package check reported the following errors:"
] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> (PackageCheck -> FilePath) -> [PackageCheck] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageCheck -> FilePath
forall a. Show a => a -> FilePath
show (NonEmpty PackageCheck -> [PackageCheck]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty PackageCheck
xs)
displayException (CabalFilePathsInconsistentBug Path Abs File
cabalfp Path Abs File
cabalfp') = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ FilePath
"Error: [S-9595]\n"
, FilePath
"The impossible happened! Two Cabal file paths are inconsistent: "
, (Path Abs File, Path Abs File) -> FilePath
forall a. Show a => a -> FilePath
show (Path Abs File
cabalfp, Path Abs File
cabalfp')
]
displayException (ToTarPathException FilePath
e) =
FilePath
"Error: [S-7875\n"
FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
e
data SDistOpts = SDistOpts
{ SDistOpts -> [FilePath]
sdoptsDirsToWorkWith :: [String]
, SDistOpts -> Maybe PvpBounds
sdoptsPvpBounds :: Maybe PvpBounds
, SDistOpts -> Bool
sdoptsIgnoreCheck :: Bool
, SDistOpts -> Bool
sdoptsBuildTarball :: Bool
, SDistOpts -> Maybe FilePath
sdoptsTarPath :: Maybe FilePath
}
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 <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
let PvpBounds PvpBoundsType
pvpBounds Bool
asRevision = PvpBounds -> Maybe PvpBounds -> PvpBounds
forall a. a -> Maybe a -> a
fromMaybe (Config -> PvpBounds
configPvpBounds Config
config) Maybe PvpBounds
mpvpBounds
tweakCabal :: Bool
tweakCabal = PvpBoundsType
pvpBounds PvpBoundsType -> PvpBoundsType -> Bool
forall a. Eq a => a -> a -> Bool
/= PvpBoundsType
PvpBoundsNone
pkgFp :: FilePath
pkgFp = Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir
LocalPackage
lp <- Path Abs Dir -> RIO env LocalPackage
forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
pkgDir
Maybe (Map PackageName VersionRange)
-> (Map PackageName VersionRange -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Package -> Maybe (Map PackageName VersionRange)
packageSetupDeps (LocalPackage -> Package
lpPackage LocalPackage
lp)) ((Map PackageName VersionRange -> RIO env ()) -> RIO env ())
-> (Map PackageName VersionRange -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Map PackageName VersionRange
customSetupDeps ->
case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ((PackageName -> Text) -> [PackageName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
T.pack (FilePath -> Text)
-> (PackageName -> FilePath) -> PackageName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
packageNameString) (Map PackageName VersionRange -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName VersionRange
customSetupDeps)) of
Just NonEmpty Text
nonEmptyDepTargets -> do
Either SomeException ()
eres <- NonEmpty Text -> RIO env (Either SomeException ())
forall env.
HasEnvConfig env =>
NonEmpty Text -> RIO env (Either SomeException ())
buildLocalTargets NonEmpty Text
nonEmptyDepTargets
case Either SomeException ()
eres of
Left SomeException
err ->
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Error: [S-8399]\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"Error building custom-setup dependencies: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
SomeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SomeException
err
Right ()
_ ->
() -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe (NonEmpty Text)
Nothing ->
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"unexpected empty custom-setup dependencies"
SourceMap
sourceMap <- Getting SourceMap env SourceMap -> RIO env SourceMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting SourceMap env SourceMap -> RIO env SourceMap)
-> Getting SourceMap env SourceMap -> RIO env SourceMap
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const SourceMap EnvConfig)
-> env -> Const SourceMap env
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL((EnvConfig -> Const SourceMap EnvConfig)
-> env -> Const SourceMap env)
-> ((SourceMap -> Const SourceMap SourceMap)
-> EnvConfig -> Const SourceMap EnvConfig)
-> Getting SourceMap env SourceMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EnvConfig -> SourceMap) -> SimpleGetter EnvConfig SourceMap
forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMap
InstallMap
installMap <- SourceMap -> RIO env InstallMap
forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
(InstalledMap
installedMap, [DumpPackage]
_globalDumpPkgs, [DumpPackage]
_snapshotDumpPkgs, [DumpPackage]
_localDumpPkgs) <-
InstallMap
-> RIO
env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> RIO
env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
let deps :: Map PackageIdentifier GhcPkgId
deps = [(PackageIdentifier, GhcPkgId)] -> Map PackageIdentifier GhcPkgId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (PackageIdentifier
pid, GhcPkgId
ghcPkgId)
| (InstallLocation
_, Library PackageIdentifier
pid GhcPkgId
ghcPkgId Maybe (Either License License)
_) <- InstalledMap -> [(InstallLocation, Installed)]
forall k a. Map k a -> [a]
Map.elems InstalledMap
installedMap]
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Getting file list for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
pkgFp
(FilePath
fileList, Path Abs File
cabalfp) <- LocalPackage
-> Map PackageIdentifier GhcPkgId
-> RIO env (FilePath, Path Abs File)
forall env.
HasEnvConfig env =>
LocalPackage
-> Map PackageIdentifier GhcPkgId
-> RIO env (FilePath, Path Abs File)
getSDistFileList LocalPackage
lp Map PackageIdentifier GhcPkgId
deps
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Building sdist tarball for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
pkgFp
[FilePath]
files <- [FilePath] -> RIO env [FilePath]
forall env. HasRunner env => [FilePath] -> RIO env [FilePath]
normalizeTarballPaths (ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> FilePath
T.unpack (Text -> FilePath) -> (FilePath -> Text) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
stripCR (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack) (FilePath -> [FilePath]
lines FilePath
fileList))
IORef (Maybe (PackageIdentifier, ByteString))
cabalFileRevisionRef <- IO (IORef (Maybe (PackageIdentifier, ByteString)))
-> RIO env (IORef (Maybe (PackageIdentifier, ByteString)))
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe (PackageIdentifier, ByteString)
-> IO (IORef (Maybe (PackageIdentifier, ByteString)))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe (PackageIdentifier, ByteString)
forall a. Maybe a
Nothing)
let tarPath :: Bool -> FilePath -> IO TarPath
tarPath Bool
isDir FilePath
fp =
case Bool -> FilePath -> Either FilePath TarPath
Tar.toTarPath Bool
isDir (ShowS
forceUtf8Enc (FilePath
pkgId FilePath -> ShowS
FP.</> FilePath
fp)) of
Left FilePath
e -> SDistException -> IO TarPath
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (SDistException -> IO TarPath) -> SDistException -> IO TarPath
forall a b. (a -> b) -> a -> b
$ FilePath -> SDistException
ToTarPathException FilePath
e
Right TarPath
tp -> TarPath -> IO TarPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TarPath
tp
forceUtf8Enc :: ShowS
forceUtf8Enc = ByteString -> FilePath
S8.unpack (ByteString -> FilePath) -> (FilePath -> ByteString) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString)
-> (FilePath -> Text) -> FilePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
packWith :: (FilePath -> TarPath -> IO Entry)
-> Bool -> FilePath -> RIO env Entry
packWith FilePath -> TarPath -> IO Entry
f Bool
isDir FilePath
fp = IO Entry -> RIO env Entry
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Entry -> RIO env Entry) -> IO Entry -> RIO env Entry
forall a b. (a -> b) -> a -> b
$ FilePath -> TarPath -> IO Entry
f (FilePath
pkgFp FilePath -> ShowS
FP.</> FilePath
fp) (TarPath -> IO Entry) -> IO TarPath -> IO Entry
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> FilePath -> IO TarPath
tarPath Bool
isDir FilePath
fp
packDir :: FilePath -> RIO env Entry
packDir = (FilePath -> TarPath -> IO Entry)
-> Bool -> FilePath -> RIO env Entry
packWith FilePath -> TarPath -> IO Entry
Tar.packDirectoryEntry Bool
True
packFile :: FilePath -> RIO env Entry
packFile FilePath
fp
| Bool
tweakCabal Bool -> Bool -> Bool
&& FilePath -> Bool
isCabalFp FilePath
fp Bool -> Bool -> Bool
&& Bool
asRevision = do
(PackageIdentifier, ByteString)
lbsIdent <- PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
forall env.
HasEnvConfig env =>
PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
getCabalLbs PvpBoundsType
pvpBounds (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) Path Abs File
cabalfp SourceMap
sourceMap
IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe (PackageIdentifier, ByteString))
-> Maybe (PackageIdentifier, ByteString) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Maybe (PackageIdentifier, ByteString))
cabalFileRevisionRef ((PackageIdentifier, ByteString)
-> Maybe (PackageIdentifier, ByteString)
forall a. a -> Maybe a
Just (PackageIdentifier, ByteString)
lbsIdent))
(FilePath -> TarPath -> IO Entry)
-> Bool -> FilePath -> RIO env Entry
packWith FilePath -> TarPath -> IO Entry
packFileEntry Bool
False FilePath
fp
| Bool
tweakCabal Bool -> Bool -> Bool
&& FilePath -> Bool
isCabalFp FilePath
fp = do
(PackageIdentifier
_ident, ByteString
lbs) <- PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
forall env.
HasEnvConfig env =>
PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
getCabalLbs PvpBoundsType
pvpBounds Maybe Int
forall a. Maybe a
Nothing Path Abs File
cabalfp SourceMap
sourceMap
POSIXTime
currTime <- IO POSIXTime -> RIO env POSIXTime
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
TarPath
tp <- IO TarPath -> RIO env TarPath
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TarPath -> RIO env TarPath) -> IO TarPath -> RIO env TarPath
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO TarPath
tarPath Bool
False FilePath
fp
Entry -> RIO env Entry
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Entry -> RIO env Entry) -> Entry -> RIO env Entry
forall a b. (a -> b) -> a -> b
$ (TarPath -> ByteString -> Entry
Tar.fileEntry TarPath
tp ByteString
lbs) { entryTime :: EpochTime
Tar.entryTime = POSIXTime -> EpochTime
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor POSIXTime
currTime }
| Bool
otherwise = (FilePath -> TarPath -> IO Entry)
-> Bool -> FilePath -> RIO env Entry
packWith FilePath -> TarPath -> IO Entry
packFileEntry Bool
False FilePath
fp
isCabalFp :: FilePath -> Bool
isCabalFp FilePath
fp = Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir FilePath -> ShowS
FP.</> FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
cabalfp
tarName :: FilePath
tarName = FilePath
pkgId FilePath -> ShowS
FP.<.> FilePath
"tar.gz"
pkgId :: FilePath
pkgId = PackageIdentifier -> FilePath
packageIdentifierString (Package -> PackageIdentifier
packageIdentifier (LocalPackage -> Package
lpPackage LocalPackage
lp))
[Entry]
dirEntries <- (FilePath -> RIO env Entry) -> [FilePath] -> RIO env [Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM FilePath -> RIO env Entry
packDir ([FilePath] -> [FilePath]
dirsFromFiles [FilePath]
files)
[Entry]
fileEntries <- (FilePath -> RIO env Entry) -> [FilePath] -> RIO env [Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM FilePath -> RIO env Entry
packFile [FilePath]
files
Maybe (PackageIdentifier, ByteString)
mcabalFileRevision <- IO (Maybe (PackageIdentifier, ByteString))
-> RIO env (Maybe (PackageIdentifier, ByteString))
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe (PackageIdentifier, ByteString))
-> IO (Maybe (PackageIdentifier, ByteString))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe (PackageIdentifier, ByteString))
cabalFileRevisionRef)
(FilePath, ByteString, Maybe (PackageIdentifier, ByteString))
-> RIO
env (FilePath, ByteString, Maybe (PackageIdentifier, ByteString))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
tarName, ByteString -> ByteString
GZip.compress ([Entry] -> ByteString
Tar.write ([Entry]
dirEntries [Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++ [Entry]
fileEntries)), Maybe (PackageIdentifier, ByteString)
mcabalFileRevision)
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') <-
Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stackProgName') (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp)
GenericPackageDescription
gpd <- IO GenericPackageDescription -> RIO env GenericPackageDescription
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
NoPrintWarnings
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Path Abs File
cabalfp Path Abs File -> Path Abs File -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs File
cabalfp') (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
SDistException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (SDistException -> RIO env ()) -> SDistException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs File -> SDistException
CabalFilePathsInconsistentBug Path Abs File
cabalfp Path Abs File
cabalfp'
InstallMap
installMap <- SourceMap -> RIO env InstallMap
forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
(InstalledMap
installedMap, [DumpPackage]
_, [DumpPackage]
_, [DumpPackage]
_) <- InstallMap
-> RIO
env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> RIO
env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
let internalPackages :: Set PackageName
internalPackages = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$
GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd PackageName -> [PackageName] -> [PackageName]
forall a. a -> [a] -> [a]
:
((UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> PackageName)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (UnqualComponentName -> PackageName
Cabal.unqualComponentNameToPackageName (UnqualComponentName -> PackageName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> UnqualComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> UnqualComponentName
forall a b. (a, b) -> a
fst) (GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
Cabal.condSubLibraries GenericPackageDescription
gpd)
gpd' :: GenericPackageDescription
gpd' = (Typeable Dependency => Dependency -> Dependency)
-> GenericPackageDescription -> GenericPackageDescription
forall a b.
(Data a, Typeable b) =>
(Typeable b => b -> b) -> a -> a
gtraverseT (Set PackageName
-> InstallMap -> InstalledMap -> Dependency -> Dependency
addBounds Set PackageName
internalPackages InstallMap
installMap InstalledMap
installedMap) GenericPackageDescription
gpd
gpd'' :: GenericPackageDescription
gpd'' =
case Maybe Int
mrev of
Maybe Int
Nothing -> GenericPackageDescription
gpd'
Just Int
rev -> GenericPackageDescription
gpd'
{ packageDescription :: PackageDescription
Cabal.packageDescription
= (GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd')
{ customFieldsPD :: [(FilePath, FilePath)]
Cabal.customFieldsPD
= ((FilePath
"x-revision", Int -> FilePath
forall a. Show a => a -> FilePath
show Int
rev)(FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
:)
([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ ((FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(FilePath
x, FilePath
_) -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"x-revision")
([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ PackageDescription -> [(FilePath, FilePath)]
Cabal.customFieldsPD
(PackageDescription -> [(FilePath, FilePath)])
-> PackageDescription -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd'
}
}
ident :: PackageIdentifier
ident = PackageDescription -> PackageIdentifier
Cabal.package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd''
let roundtripErrs :: [StyleDoc]
roundtripErrs =
[ FilePath -> StyleDoc
flow FilePath
"Bug detected in Cabal library. ((parse . render . parse) === \
\id) does not hold for the Cabal file at"
StyleDoc -> StyleDoc -> StyleDoc
<+> Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalfp
, StyleDoc
""
]
([PWarning]
_warnings, Either (Maybe Version, NonEmpty PError) GenericPackageDescription
eres) = ParseResult GenericPackageDescription
-> ([PWarning],
Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
Cabal.runParseResult
(ParseResult GenericPackageDescription
-> ([PWarning],
Either (Maybe Version, NonEmpty PError) GenericPackageDescription))
-> ParseResult GenericPackageDescription
-> ([PWarning],
Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ ByteString -> ParseResult GenericPackageDescription
Cabal.parseGenericPackageDescription
(ByteString -> ParseResult GenericPackageDescription)
-> ByteString -> ParseResult GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8
(Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack
(FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> FilePath
showGenericPackageDescription GenericPackageDescription
gpd
case Either (Maybe Version, NonEmpty PError) GenericPackageDescription
eres of
Right GenericPackageDescription
roundtripped
| GenericPackageDescription
roundtripped GenericPackageDescription -> GenericPackageDescription -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription
gpd -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise -> do
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vsep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc]
roundtripErrs [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. [a] -> [a] -> [a]
++
[ StyleDoc
"This seems to be fixed in development versions of Cabal, but \
\at time of writing, the fix is not in any released versions."
, StyleDoc
""
, StyleDoc
"Please see this GitHub issue for status:" StyleDoc -> StyleDoc -> StyleDoc
<+> Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/3549"
, StyleDoc
""
, [StyleDoc] -> StyleDoc
fillSep
[ FilePath -> StyleDoc
flow FilePath
"If the issue is closed as resolved, then you may be \
\able to fix this by upgrading to a newer version of \
\Stack via"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack upgrade"
, FilePath -> StyleDoc
flow FilePath
"for latest stable version or"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack upgrade --git"
, FilePath -> StyleDoc
flow FilePath
"for the latest development version."
]
, StyleDoc
""
, [StyleDoc] -> StyleDoc
fillSep
[ FilePath -> StyleDoc
flow FilePath
"If the issue is fixed, but updating doesn't solve the \
\problem, please check if there are similar open \
\issues, and if not, report a new issue to the Stack \
\issue tracker, at"
, Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/new"
]
, StyleDoc
""
, FilePath -> StyleDoc
flow FilePath
"If the issue is not fixed, feel free to leave a comment \
\on it indicating that you would like it to be fixed."
, StyleDoc
""
]
Left (Maybe Version
_version, NonEmpty PError
errs) -> do
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vsep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [StyleDoc]
roundtripErrs [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. [a] -> [a] -> [a]
++
[ FilePath -> StyleDoc
flow FilePath
"In particular, parsing the rendered Cabal file is yielding a \
\parse error. Please check if there are already issues \
\tracking this, and if not, please report new issues to the \
\Stack and Cabal issue trackers, via"
, [StyleDoc] -> StyleDoc
bulletedList
[ Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/new"
, Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/haskell/cabal/issues/new"
]
, FilePath -> StyleDoc
flow (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall a b. (a -> b) -> a -> b
$ FilePath
"The parse error is: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unlines ((PError -> FilePath) -> [PError] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PError -> FilePath
forall a. Show a => a -> FilePath
show (NonEmpty PError -> [PError]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty PError
errs))
, StyleDoc
""
]
(PackageIdentifier, ByteString)
-> RIO env (PackageIdentifier, ByteString)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( PackageIdentifier
ident
, Text -> ByteString
TLE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
TL.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> FilePath
showGenericPackageDescription GenericPackageDescription
gpd''
)
where
addBounds :: Set PackageName -> InstallMap -> InstalledMap -> Dependency -> Dependency
addBounds :: Set PackageName
-> InstallMap -> InstalledMap -> Dependency -> Dependency
addBounds Set PackageName
internalPackages InstallMap
installMap InstalledMap
installedMap dep :: Dependency
dep@(Dependency PackageName
name VersionRange
range NonEmptySet LibraryName
s) =
if PackageName
name PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
internalPackages
then Dependency
dep
else case Maybe Version
foundVersion of
Maybe Version
Nothing -> Dependency
dep
Just Version
version -> PackageName
-> VersionRange -> NonEmptySet LibraryName -> Dependency
Dependency PackageName
name (VersionRange -> VersionRange
simplifyVersionRange
(VersionRange -> VersionRange) -> VersionRange -> VersionRange
forall a b. (a -> b) -> a -> b
$ (if Bool
toAddUpper Bool -> Bool -> Bool
&& Bool -> Bool
not (VersionRange -> Bool
hasUpperBound VersionRange
range) then Version -> VersionRange -> VersionRange
addUpper Version
version else VersionRange -> VersionRange
forall a. a -> a
id)
(VersionRange -> VersionRange) -> VersionRange -> VersionRange
forall a b. (a -> b) -> a -> b
$ (if Bool
toAddLower Bool -> Bool -> Bool
&& Bool -> Bool
not (VersionRange -> Bool
hasLowerBound VersionRange
range) then Version -> VersionRange -> VersionRange
addLower Version
version else VersionRange -> VersionRange
forall a. a -> a
id)
VersionRange
range) NonEmptySet LibraryName
s
where
foundVersion :: Maybe Version
foundVersion =
case PackageName -> InstallMap -> Maybe (InstallLocation, Version)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstallMap
installMap of
Just (InstallLocation
_, Version
version) -> Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version
Maybe (InstallLocation, Version)
Nothing ->
case PackageName -> InstalledMap -> Maybe (InstallLocation, Installed)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstalledMap
installedMap of
Just (InstallLocation
_, Installed
installed) -> Version -> Maybe Version
forall a. a -> Maybe a
Just (Installed -> Version
installedVersion Installed
installed)
Maybe (InstallLocation, Installed)
Nothing -> Maybe Version
forall a. Maybe a
Nothing
addUpper :: Version -> VersionRange -> VersionRange
addUpper Version
version = VersionRange -> VersionRange -> VersionRange
intersectVersionRanges
(Version -> VersionRange
earlierVersion (Version -> VersionRange) -> Version -> VersionRange
forall a b. (a -> b) -> a -> b
$ Version -> Version
nextMajorVersion Version
version)
addLower :: Version -> VersionRange -> VersionRange
addLower Version
version = VersionRange -> VersionRange -> VersionRange
intersectVersionRanges (Version -> VersionRange
orLaterVersion Version
version)
(Bool
toAddLower, Bool
toAddUpper) =
case PvpBoundsType
pvpBounds of
PvpBoundsType
PvpBoundsNone -> (Bool
False, Bool
False)
PvpBoundsType
PvpBoundsUpper -> (Bool
False, Bool
True)
PvpBoundsType
PvpBoundsLower -> (Bool
True, Bool
False)
PvpBoundsType
PvpBoundsBoth -> (Bool
True, Bool
True)
gtraverseT :: (Data a,Typeable b) => (Typeable b => b -> b) -> a -> a
gtraverseT :: forall a b.
(Data a, Typeable b) =>
(Typeable b => b -> b) -> a -> a
gtraverseT Typeable b => b -> b
f =
(forall b. Data b => b -> b) -> a -> a
forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT (\b
x -> case b -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
x of
Maybe b
Nothing -> (Typeable b => b -> b) -> b -> b
forall a b.
(Data a, Typeable b) =>
(Typeable b => b -> b) -> a -> a
gtraverseT b -> b
Typeable b => b -> b
f b
x
Just b
b -> b -> Maybe b -> b
forall a. a -> Maybe a -> a
fromMaybe b
x (b -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (b -> b
Typeable b => b -> b
f b
b)))
readLocalPackage :: HasEnvConfig env => Path Abs Dir -> RIO env LocalPackage
readLocalPackage :: forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
pkgDir = do
PackageConfig
config <- RIO env PackageConfig
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasEnvConfig env) =>
m PackageConfig
getDefaultPackageConfig
(PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
cabalfp) <- Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stackProgName') Path Abs Dir
pkgDir
GenericPackageDescription
gpd <- IO GenericPackageDescription -> RIO env GenericPackageDescription
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings
let package :: Package
package = PackageConfig -> GenericPackageDescription -> Package
resolvePackage PackageConfig
config GenericPackageDescription
gpd
LocalPackage -> RIO env LocalPackage
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalPackage
{ lpPackage :: Package
lpPackage = Package
package
, lpWanted :: Bool
lpWanted = Bool
False
, lpCabalFile :: Path Abs File
lpCabalFile = Path Abs File
cabalfp
, lpTestBench :: Maybe Package
lpTestBench = Maybe Package
forall a. Maybe a
Nothing
, lpBuildHaddocks :: Bool
lpBuildHaddocks = Bool
False
, lpForceDirty :: Bool
lpForceDirty = Bool
False
, lpDirtyFiles :: MemoizedWith EnvConfig (Maybe (Set FilePath))
lpDirtyFiles = Maybe (Set FilePath)
-> MemoizedWith EnvConfig (Maybe (Set FilePath))
forall a. a -> MemoizedWith EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Set FilePath)
forall a. Maybe a
Nothing
, lpNewBuildCaches :: MemoizedWith
EnvConfig (Map NamedComponent (Map FilePath FileCacheInfo))
lpNewBuildCaches = Map NamedComponent (Map FilePath FileCacheInfo)
-> MemoizedWith
EnvConfig (Map NamedComponent (Map FilePath FileCacheInfo))
forall a. a -> MemoizedWith EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map NamedComponent (Map FilePath FileCacheInfo)
forall k a. Map k a
Map.empty
, lpComponentFiles :: MemoizedWith EnvConfig (Map NamedComponent (Set (Path Abs File)))
lpComponentFiles = Map NamedComponent (Set (Path Abs File))
-> MemoizedWith
EnvConfig (Map NamedComponent (Set (Path Abs File)))
forall a. a -> MemoizedWith EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map NamedComponent (Set (Path Abs File))
forall k a. Map k a
Map.empty
, lpComponents :: Set NamedComponent
lpComponents = Set NamedComponent
forall a. Set a
Set.empty
, lpUnbuildable :: Set NamedComponent
lpUnbuildable = Set NamedComponent
forall a. Set a
Set.empty
}
getSDistFileList :: HasEnvConfig env => LocalPackage -> Map PackageIdentifier GhcPkgId -> RIO env (String, Path Abs File)
getSDistFileList :: forall env.
HasEnvConfig env =>
LocalPackage
-> Map PackageIdentifier GhcPkgId
-> RIO env (FilePath, Path Abs File)
getSDistFileList LocalPackage
lp Map PackageIdentifier GhcPkgId
deps =
FilePath
-> (Path Abs Dir -> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File)
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (Path Abs Dir -> m a) -> m a
withSystemTempDir (FilePath
stackProgName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"-sdist") ((Path Abs Dir -> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File))
-> (Path Abs Dir -> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File)
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tmpdir -> do
let bopts :: BuildOpts
bopts = BuildOpts
defaultBuildOpts
let boptsCli :: BuildOptsCLI
boptsCli = BuildOptsCLI
defaultBuildOptsCLI
BaseConfigOpts
baseConfigOpts <- BuildOptsCLI -> RIO env BaseConfigOpts
forall env.
HasEnvConfig env =>
BuildOptsCLI -> RIO env BaseConfigOpts
mkBaseConfigOpts BuildOptsCLI
boptsCli
[LocalPackage]
locals <- RIO env [LocalPackage]
forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> Maybe Int
-> (ExecuteEnv -> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File)
forall env a.
HasEnvConfig env =>
BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> Maybe Int
-> (ExecuteEnv -> RIO env a)
-> RIO env a
withExecuteEnv BuildOpts
bopts BuildOptsCLI
boptsCli BaseConfigOpts
baseConfigOpts [LocalPackage]
locals
[] [] [] Maybe Int
forall a. Maybe a
Nothing
((ExecuteEnv -> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File))
-> (ExecuteEnv -> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File)
forall a b. (a -> b) -> a -> b
$ \ExecuteEnv
ee ->
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageIdentifier GhcPkgId
-> Maybe FilePath
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File)
forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageIdentifier GhcPkgId
-> Maybe FilePath
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task Map PackageIdentifier GhcPkgId
deps (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"sdist") ((Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File))
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env (FilePath, Path Abs File))
-> RIO env (FilePath, Path Abs File)
forall a b. (a -> b) -> a -> b
$ \Package
_package Path Abs File
cabalfp Path Abs Dir
_pkgDir KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ()
cabal Utf8Builder -> RIO env ()
_announce OutputType
_outputType -> do
let outFile :: FilePath
outFile = Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
tmpdir FilePath -> ShowS
FP.</> FilePath
"source-files-list"
KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ()
cabal KeepOutputOpen
CloseOnException ExcludeTHLoading
KeepTHLoading [FilePath
"sdist", FilePath
"--list-sources", FilePath
outFile]
ByteString
contents <- IO ByteString -> RIO env ByteString
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ByteString
S.readFile FilePath
outFile)
(FilePath, Path Abs File) -> RIO env (FilePath, Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode ByteString
contents, Path Abs File
cabalfp)
where
package :: Package
package = LocalPackage -> Package
lpPackage LocalPackage
lp
ac :: ActionContext
ac = Set ActionId -> [Action] -> Concurrency -> ActionContext
ActionContext Set ActionId
forall a. Set a
Set.empty [] Concurrency
ConcurrencyAllowed
task :: Task
task = Task
{ taskProvides :: PackageIdentifier
taskProvides = PackageName -> Version -> PackageIdentifier
PackageIdentifier (Package -> PackageName
packageName Package
package) (Package -> Version
packageVersion Package
package)
, taskType :: TaskType
taskType = LocalPackage -> TaskType
TTLocalMutable LocalPackage
lp
, taskConfigOpts :: TaskConfigOpts
taskConfigOpts = TaskConfigOpts
{ tcoMissing :: Set PackageIdentifier
tcoMissing = Set PackageIdentifier
forall a. Set a
Set.empty
, tcoOpts :: Map PackageIdentifier GhcPkgId -> ConfigureOpts
tcoOpts = \Map PackageIdentifier GhcPkgId
_ -> [FilePath] -> [FilePath] -> ConfigureOpts
ConfigureOpts [] []
}
, taskBuildHaddock :: Bool
taskBuildHaddock = Bool
False
, taskPresent :: Map PackageIdentifier GhcPkgId
taskPresent = Map PackageIdentifier GhcPkgId
forall k a. Map k a
Map.empty
, taskAllInOne :: Bool
taskAllInOne = Bool
True
, taskCachePkgSrc :: CachePkgSrc
taskCachePkgSrc = FilePath -> CachePkgSrc
CacheSrcLocal (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (Path Abs File -> Path Abs Dir) -> Path Abs File -> Path Abs Dir
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp))
, taskAnyMissing :: Bool
taskAnyMissing = Bool
True
, taskBuildTypeConfig :: Bool
taskBuildTypeConfig = Bool
False
}
normalizeTarballPaths :: HasRunner env => [FilePath] -> RIO env [FilePath]
normalizeTarballPaths :: forall env. HasRunner env => [FilePath] -> RIO env [FilePath]
normalizeTarballPaths [FilePath]
fps = do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
outsideDir) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Warning: These files are outside of the package directory, and will be omitted from the tarball: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
[FilePath] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow [FilePath]
outsideDir
[FilePath] -> RIO env [FilePath]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
nubOrd [FilePath]
files)
where
([FilePath]
outsideDir, [FilePath]
files) = [Either FilePath FilePath] -> ([FilePath], [FilePath])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((FilePath -> Either FilePath FilePath)
-> [FilePath] -> [Either FilePath FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Either FilePath FilePath
pathToEither [FilePath]
fps)
pathToEither :: FilePath -> Either FilePath FilePath
pathToEither FilePath
fp = Either FilePath FilePath
-> (FilePath -> Either FilePath FilePath)
-> Maybe FilePath
-> Either FilePath FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left FilePath
fp) FilePath -> Either FilePath FilePath
forall a b. b -> Either a b
Right (FilePath -> Maybe FilePath
normalizePath FilePath
fp)
normalizePath :: FilePath -> Maybe FilePath
normalizePath :: FilePath -> Maybe FilePath
normalizePath = ([FilePath] -> FilePath) -> Maybe [FilePath] -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FilePath] -> FilePath
FP.joinPath (Maybe [FilePath] -> Maybe FilePath)
-> (FilePath -> Maybe [FilePath]) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> Maybe [FilePath]
forall {a}. (Eq a, IsString a) => [a] -> Maybe [a]
go ([FilePath] -> Maybe [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> Maybe [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
FP.splitDirectories (FilePath -> [FilePath]) -> ShowS -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.normalise
where
go :: [a] -> Maybe [a]
go [] = [a] -> Maybe [a]
forall a. a -> Maybe a
Just []
go (a
"..":[a]
_) = Maybe [a]
forall a. Maybe a
Nothing
go (a
_:a
"..":[a]
xs) = [a] -> Maybe [a]
go [a]
xs
go (a
x:[a]
xs) = (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Maybe [a]
go [a]
xs
dirsFromFiles :: [FilePath] -> [FilePath]
dirsFromFiles :: [FilePath] -> [FilePath]
dirsFromFiles [FilePath]
dirs = Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toAscList (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.delete FilePath
"." Set FilePath
results)
where
results :: Set FilePath
results = (Set FilePath -> FilePath -> Set FilePath)
-> Set FilePath -> [FilePath] -> Set FilePath
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Set FilePath
s -> Set FilePath -> FilePath -> Set FilePath
go Set FilePath
s (FilePath -> Set FilePath) -> ShowS -> FilePath -> Set FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeDirectory) Set FilePath
forall a. Set a
Set.empty [FilePath]
dirs
go :: Set FilePath -> FilePath -> Set FilePath
go Set FilePath
s FilePath
x
| FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FilePath
x Set FilePath
s = Set FilePath
s
| Bool
otherwise = Set FilePath -> FilePath -> Set FilePath
go (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.insert FilePath
x Set FilePath
s) (ShowS
FP.takeDirectory FilePath
x)
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 = Path Abs File -> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall env a.
Path Abs File -> (Path Abs Dir -> RIO env a) -> RIO env a
withTempTarGzContents Path Abs File
tarball ((Path Abs Dir -> RIO env ()) -> RIO env ())
-> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
pkgDir' -> do
Path Abs Dir
pkgDir <- (Path Abs Dir
pkgDir' Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</>) (Path Rel Dir -> Path Abs Dir)
-> RIO env (Path Rel Dir) -> RIO env (Path Abs Dir)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`
(FilePath -> RIO env (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir (FilePath -> RIO env (Path Rel Dir))
-> (Path Abs File -> FilePath)
-> Path Abs File
-> RIO env (Path Rel Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeBaseName ShowS -> (Path Abs File -> FilePath) -> Path Abs File -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeBaseName ShowS -> (Path Abs File -> FilePath) -> Path Abs File -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> RIO env (Path Rel Dir))
-> Path Abs File -> RIO env (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs File
tarball)
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SDistOpts -> Bool
sdoptsBuildTarball SDistOpts
opts) (ResolvedPath Dir -> RIO env ()
forall env. HasEnvConfig env => ResolvedPath Dir -> RIO env ()
buildExtractedTarball ResolvedPath
{ resolvedRelative :: RelFilePath
resolvedRelative = Text -> RelFilePath
RelFilePath Text
"this-is-not-used"
, resolvedAbsolute :: Path Abs Dir
resolvedAbsolute = Path Abs Dir
pkgDir
})
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SDistOpts -> Bool
sdoptsIgnoreCheck SDistOpts
opts) (Path Abs Dir -> RIO env ()
forall env. HasEnvConfig env => Path Abs Dir -> RIO env ()
checkPackageInExtractedTarball Path Abs Dir
pkgDir)
checkPackageInExtractedTarball
:: HasEnvConfig env
=> Path Abs Dir
-> RIO env ()
Path Abs Dir
pkgDir = do
(PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
name, Path Abs File
_cabalfp) <- Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stackProgName') Path Abs Dir
pkgDir
GenericPackageDescription
gpd <- IO GenericPackageDescription -> RIO env GenericPackageDescription
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings
PackageConfig
config <- RIO env PackageConfig
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasEnvConfig env) =>
m PackageConfig
getDefaultPackageConfig
let PackageDescriptionPair PackageDescription
pkgDesc PackageDescription
_ = PackageConfig
-> GenericPackageDescription -> PackageDescriptionPair
resolvePackageDescription PackageConfig
config GenericPackageDescription
gpd
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Checking package '" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
packageNameString PackageName
name) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"' for common mistakes"
let pkgChecks :: [PackageCheck]
pkgChecks =
case GenericPackageDescription
-> Maybe PackageDescription -> [PackageCheck]
Check.checkPackage GenericPackageDescription
gpd Maybe PackageDescription
forall a. Maybe a
Nothing of
[] -> GenericPackageDescription
-> Maybe PackageDescription -> [PackageCheck]
Check.checkPackage GenericPackageDescription
gpd (PackageDescription -> Maybe PackageDescription
forall a. a -> Maybe a
Just PackageDescription
pkgDesc)
[PackageCheck]
x -> [PackageCheck]
x
[PackageCheck]
fileChecks <- IO [PackageCheck] -> RIO env [PackageCheck]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [PackageCheck] -> RIO env [PackageCheck])
-> IO [PackageCheck] -> RIO env [PackageCheck]
forall a b. (a -> b) -> a -> b
$ Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck]
Check.checkPackageFiles Verbosity
forall a. Bounded a => a
minBound PackageDescription
pkgDesc (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir)
let checks :: [PackageCheck]
checks = [PackageCheck]
pkgChecks [PackageCheck] -> [PackageCheck] -> [PackageCheck]
forall a. [a] -> [a] -> [a]
++ [PackageCheck]
fileChecks
([PackageCheck]
errors, [PackageCheck]
warnings) =
let criticalIssue :: PackageCheck -> Bool
criticalIssue (Check.PackageBuildImpossible FilePath
_) = Bool
True
criticalIssue (Check.PackageDistInexcusable FilePath
_) = Bool
True
criticalIssue PackageCheck
_ = Bool
False
in (PackageCheck -> Bool)
-> [PackageCheck] -> ([PackageCheck], [PackageCheck])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition PackageCheck -> Bool
criticalIssue [PackageCheck]
checks
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageCheck] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageCheck]
warnings) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Package check reported the following warnings:\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
[Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat (Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
List.intersperse Utf8Builder
"\n" ([Utf8Builder] -> [Utf8Builder])
-> ([PackageCheck] -> [Utf8Builder])
-> [PackageCheck]
-> [Utf8Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageCheck -> Utf8Builder) -> [PackageCheck] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageCheck -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow ([PackageCheck] -> [Utf8Builder])
-> [PackageCheck] -> [Utf8Builder]
forall a b. (a -> b) -> a -> b
$ [PackageCheck]
warnings)
case [PackageCheck] -> Maybe (NonEmpty PackageCheck)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [PackageCheck]
errors of
Maybe (NonEmpty PackageCheck)
Nothing -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just NonEmpty PackageCheck
ne -> SDistException -> RIO env ()
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (SDistException -> RIO env ()) -> SDistException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ NonEmpty PackageCheck -> SDistException
CheckException NonEmpty PackageCheck
ne
buildExtractedTarball :: HasEnvConfig env => ResolvedPath Dir -> RIO env ()
ResolvedPath Dir
pkgDir = do
EnvConfig
envConfig <- Getting EnvConfig env EnvConfig -> RIO env EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig env EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL
LocalPackage
localPackageToBuild <- Path Abs Dir -> RIO env LocalPackage
forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage (Path Abs Dir -> RIO env LocalPackage)
-> Path Abs Dir -> RIO env LocalPackage
forall a b. (a -> b) -> a -> b
$ ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
pkgDir
let isPathToRemove :: Path Abs Dir -> RIO env Bool
isPathToRemove Path Abs Dir
path = do
LocalPackage
localPackage <- Path Abs Dir -> RIO env LocalPackage
forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
path
Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> RIO env Bool) -> Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
localPackage) PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
localPackageToBuild)
Map PackageName ProjectPackage
pathsToKeep
<- ([(PackageName, ProjectPackage)] -> Map PackageName ProjectPackage)
-> RIO env [(PackageName, ProjectPackage)]
-> RIO env (Map PackageName ProjectPackage)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(PackageName, ProjectPackage)] -> Map PackageName ProjectPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
(RIO env [(PackageName, ProjectPackage)]
-> RIO env (Map PackageName ProjectPackage))
-> RIO env [(PackageName, ProjectPackage)]
-> RIO env (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (((PackageName, ProjectPackage) -> RIO env Bool)
-> [(PackageName, ProjectPackage)]
-> RIO env [(PackageName, ProjectPackage)])
-> [(PackageName, ProjectPackage)]
-> ((PackageName, ProjectPackage) -> RIO env Bool)
-> RIO env [(PackageName, ProjectPackage)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((PackageName, ProjectPackage) -> RIO env Bool)
-> [(PackageName, ProjectPackage)]
-> RIO env [(PackageName, ProjectPackage)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Map PackageName ProjectPackage -> [(PackageName, ProjectPackage)]
forall k a. Map k a -> [(k, a)]
Map.toList (SMWanted -> Map PackageName ProjectPackage
smwProject (BuildConfig -> SMWanted
bcSMWanted (EnvConfig -> BuildConfig
envConfigBuildConfig EnvConfig
envConfig))))
(((PackageName, ProjectPackage) -> RIO env Bool)
-> RIO env [(PackageName, ProjectPackage)])
-> ((PackageName, ProjectPackage) -> RIO env Bool)
-> RIO env [(PackageName, ProjectPackage)]
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool) -> RIO env Bool -> RIO env Bool
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (RIO env Bool -> RIO env Bool)
-> ((PackageName, ProjectPackage) -> RIO env Bool)
-> (PackageName, ProjectPackage)
-> RIO env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> RIO env Bool
isPathToRemove (Path Abs Dir -> RIO env Bool)
-> ((PackageName, ProjectPackage) -> Path Abs Dir)
-> (PackageName, ProjectPackage)
-> RIO env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute (ResolvedPath Dir -> Path Abs Dir)
-> ((PackageName, ProjectPackage) -> ResolvedPath Dir)
-> (PackageName, ProjectPackage)
-> Path Abs Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> ResolvedPath Dir
ppResolvedDir (ProjectPackage -> ResolvedPath Dir)
-> ((PackageName, ProjectPackage) -> ProjectPackage)
-> (PackageName, ProjectPackage)
-> ResolvedPath Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, ProjectPackage) -> ProjectPackage
forall a b. (a, b) -> b
snd
ProjectPackage
pp <- PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
YesPrintWarnings ResolvedPath Dir
pkgDir Bool
False
let adjustEnvForBuild :: env -> env
adjustEnvForBuild env
env =
let updatedEnvConfig :: EnvConfig
updatedEnvConfig = EnvConfig
envConfig
{ envConfigSourceMap :: SourceMap
envConfigSourceMap = SourceMap -> SourceMap
updatePackagesInSourceMap (EnvConfig -> SourceMap
envConfigSourceMap EnvConfig
envConfig)
, envConfigBuildConfig :: BuildConfig
envConfigBuildConfig = BuildConfig -> BuildConfig
updateBuildConfig (EnvConfig -> BuildConfig
envConfigBuildConfig EnvConfig
envConfig)
}
updateBuildConfig :: BuildConfig -> BuildConfig
updateBuildConfig BuildConfig
bc = BuildConfig
bc
{ bcConfig :: Config
bcConfig = (BuildConfig -> Config
bcConfig BuildConfig
bc)
{ configBuild :: BuildOpts
configBuild = BuildOpts
defaultBuildOpts { boptsTests :: Bool
boptsTests = Bool
True } }
}
in ASetter env env EnvConfig EnvConfig -> EnvConfig -> env -> env
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter env env EnvConfig EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL EnvConfig
updatedEnvConfig env
env
updatePackagesInSourceMap :: SourceMap -> SourceMap
updatePackagesInSourceMap SourceMap
sm =
SourceMap
sm {smProject :: Map PackageName ProjectPackage
smProject = PackageName
-> ProjectPackage
-> Map PackageName ProjectPackage
-> Map PackageName ProjectPackage
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (CommonPackage -> PackageName
cpName (CommonPackage -> PackageName) -> CommonPackage -> PackageName
forall a b. (a -> b) -> a -> b
$ ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp) ProjectPackage
pp Map PackageName ProjectPackage
pathsToKeep}
(env -> env) -> RIO env () -> RIO env ()
forall a. (env -> env) -> RIO env a -> RIO env a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local env -> env
adjustEnvForBuild (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
build Maybe (Set (Path Abs File) -> IO ())
forall a. Maybe a
Nothing
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 = FilePath -> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (Path Abs Dir -> m a) -> m a
withSystemTempDir FilePath
"stack" ((Path Abs Dir -> RIO env ()) -> RIO env ())
-> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tpath -> do
Path Abs File
npath <- (Path Abs Dir
tpath Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</>) (Path Rel File -> Path Abs File)
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` FilePath -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
name
IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
L.writeFile (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
npath) ByteString
bytes
SDistOpts -> Path Abs File -> RIO env ()
forall env.
HasEnvConfig env =>
SDistOpts -> Path Abs File -> RIO env ()
checkSDistTarball SDistOpts
opts Path Abs File
npath
withTempTarGzContents
:: Path Abs File
-> (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 = FilePath -> (Path Abs Dir -> RIO env a) -> RIO env a
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (Path Abs Dir -> m a) -> m a
withSystemTempDir FilePath
"stack" ((Path Abs Dir -> RIO env a) -> RIO env a)
-> (Path Abs Dir -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tpath -> do
ByteString
archive <- IO ByteString -> RIO env ByteString
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> RIO env ByteString)
-> IO ByteString -> RIO env ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
L.readFile (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
apath)
IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ())
-> (ByteString -> IO ()) -> ByteString -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Entries FormatError -> IO ()
forall e. Exception e => FilePath -> Entries e -> IO ()
Tar.unpack (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
tpath) (Entries FormatError -> IO ())
-> (ByteString -> Entries FormatError) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read (ByteString -> Entries FormatError)
-> (ByteString -> ByteString) -> ByteString -> Entries FormatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.decompress (ByteString -> RIO env ()) -> ByteString -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ByteString
archive
Path Abs Dir -> RIO env a
f Path Abs Dir
tpath
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 = Int -> EpochTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
content)
Entry -> IO Entry
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TarPath -> EntryContent -> Entry
Tar.simpleEntry TarPath
tarpath (ByteString -> EpochTime -> EntryContent
Tar.NormalFile (ByteString -> ByteString
L.fromStrict ByteString
content) EpochTime
size)) {
entryPermissions :: Permissions
Tar.entryPermissions = if Permissions -> Bool
executable Permissions
perms then Permissions
Tar.executableFilePermissions
else Permissions
Tar.ordinaryFilePermissions,
entryTime :: EpochTime
Tar.entryTime = EpochTime
mtime
}
getModTime :: FilePath -> IO Tar.EpochTime
getModTime :: FilePath -> IO EpochTime
getModTime FilePath
path = do
UTCTime
t <- FilePath -> IO UTCTime
getModificationTime FilePath
path
EpochTime -> IO EpochTime
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EpochTime -> IO EpochTime)
-> (UTCTime -> EpochTime) -> UTCTime -> IO EpochTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> EpochTime
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> EpochTime)
-> (UTCTime -> POSIXTime) -> UTCTime -> EpochTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime -> IO EpochTime) -> UTCTime -> IO EpochTime
forall a b. (a -> b) -> a -> b
$ UTCTime
t
getDefaultPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env)
=> m PackageConfig
getDefaultPackageConfig :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasEnvConfig env) =>
m PackageConfig
getDefaultPackageConfig = do
Platform
platform <- Getting Platform env Platform -> m Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
Lens' env Platform
platformL
ActualCompiler
compilerVersion <- Getting ActualCompiler env ActualCompiler -> m ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL
PackageConfig -> m PackageConfig
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageConfig
{ packageConfigEnableTests :: Bool
packageConfigEnableTests = Bool
False
, packageConfigEnableBenchmarks :: Bool
packageConfigEnableBenchmarks = Bool
False
, packageConfigFlags :: Map FlagName Bool
packageConfigFlags = Map FlagName Bool
forall a. Monoid a => a
mempty
, packageConfigGhcOptions :: [Text]
packageConfigGhcOptions = []
, packageConfigCabalConfigOpts :: [Text]
packageConfigCabalConfigOpts = []
, packageConfigCompilerVersion :: ActualCompiler
packageConfigCompilerVersion = ActualCompiler
compilerVersion
, packageConfigPlatform :: Platform
packageConfigPlatform = Platform
platform
}