{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE TypeFamilies          #-}
-- Create a source distribution tarball
module Stack.SDist
    ( getSDistTarball
    , checkSDistTarball
    , checkSDistTarball'
    , SDistOpts (..)
    ) where

import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import           Control.Applicative
import           Control.Concurrent.Execute (ActionContext(..), Concurrency(..))
import           Stack.Prelude hiding (Display (..))
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import           Data.Char (toLower)
import           Data.Data (cast)
import           Data.List
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import           Data.Time.Clock.POSIX
import           Distribution.Package (Dependency (..))
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription.Check as Check
import qualified Distribution.PackageDescription.Parsec as Cabal
import           Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
import qualified Distribution.Types.UnqualComponentName as Cabal
import           Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion, hasUpperBound, hasLowerBound)
import           Path
import           Path.IO hiding (getModificationTime, getPermissions, withSystemTempDir)
import           RIO.PrettyPrint
import           Stack.Build (mkBaseConfigOpts, build)
import           Stack.Build.Execute
import           Stack.Build.Installed
import           Stack.Build.Source (projectLocalPackages)
import           Stack.Package
import           Stack.SourceMap
import           Stack.Types.Build
import           Stack.Types.Config
import           Stack.Types.Package
import           Stack.Types.SourceMap
import           Stack.Types.Version
import           System.Directory (getModificationTime, getPermissions)
import qualified System.FilePath as FP

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

data SDistOpts = SDistOpts
  { SDistOpts -> [String]
sdoptsDirsToWorkWith :: [String]
  -- ^ Directories to package
  , SDistOpts -> Maybe PvpBounds
sdoptsPvpBounds :: Maybe PvpBounds
  -- ^ PVP Bounds overrides
  , SDistOpts -> Bool
sdoptsIgnoreCheck :: Bool
  -- ^ Whether to ignore check of the package for common errors
  , SDistOpts -> Bool
sdoptsBuildTarball :: Bool
  -- ^ Whether to build the tarball
  , SDistOpts -> Maybe String
sdoptsTarPath :: Maybe FilePath
  -- ^ Where to copy the tarball
  }

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

instance Exception CheckException

instance Show CheckException where
  show :: CheckException -> String
show (CheckException NonEmpty PackageCheck
xs) =
    String
"Package check reported the following errors:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
    (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String)
-> (NonEmpty PackageCheck -> [String])
-> NonEmpty PackageCheck
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageCheck -> String) -> [PackageCheck] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageCheck -> String
forall a. Show a => a -> String
show ([PackageCheck] -> [String])
-> (NonEmpty PackageCheck -> [PackageCheck])
-> NonEmpty PackageCheck
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PackageCheck -> [PackageCheck]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty PackageCheck -> String)
-> NonEmpty PackageCheck -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty PackageCheck
xs)

-- | Given the path to a local package, creates its source
-- distribution tarball.
--
-- While this yields a 'FilePath', the name of the tarball, this
-- tarball is not written to the disk and instead yielded as a lazy
-- bytestring.
getSDistTarball
  :: HasEnvConfig env
  => Maybe PvpBounds            -- ^ Override Config value
  -> Path Abs Dir               -- ^ Path to local package
  -> RIO env (FilePath, L.ByteString, Maybe (PackageIdentifier, L.ByteString))
  -- ^ Filename, tarball contents, and option cabal file revision to upload
getSDistTarball :: Maybe PvpBounds
-> Path Abs Dir
-> RIO
     env (String, 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
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 :: String
pkgFp = Path Abs Dir -> String
forall b t. Path b t -> String
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
    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
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
    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
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
pkgFp
    (String
fileList, Path Abs File
cabalfp) <- LocalPackage -> RIO env (String, Path Abs File)
forall env.
HasEnvConfig env =>
LocalPackage -> RIO env (String, Path Abs File)
getSDistFileList LocalPackage
lp
    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
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
pkgFp
    [String]
files <- [String] -> RIO env [String]
forall env. HasRunner env => [String] -> RIO env [String]
normalizeTarballPaths (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String) -> (String -> Text) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
stripCR (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (String -> [String]
lines String
fileList))

    -- We're going to loop below and eventually find the cabal
    -- file. When we do, we'll upload this reference, if the
    -- mpvpBounds value indicates that we should be uploading a cabal
    -- file revision.
    IORef (Maybe (PackageIdentifier, ByteString))
cabalFileRevisionRef <- IO (IORef (Maybe (PackageIdentifier, ByteString)))
-> RIO env (IORef (Maybe (PackageIdentifier, ByteString)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe (PackageIdentifier, ByteString)
-> IO (IORef (Maybe (PackageIdentifier, ByteString)))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe (PackageIdentifier, ByteString)
forall a. Maybe a
Nothing)

    -- NOTE: Could make this use lazy I/O to only read files as needed
    -- for upload (both GZip.compress and Tar.write are lazy).
    -- However, it seems less error prone and more predictable to read
    -- everything in at once, so that's what we're doing for now:
    let tarPath :: Bool -> String -> IO TarPath
tarPath Bool
isDir String
fp = (String -> IO TarPath)
-> (TarPath -> IO TarPath) -> Either String TarPath -> IO TarPath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO TarPath
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString TarPath -> IO TarPath
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Bool -> String -> Either String TarPath
Tar.toTarPath Bool
isDir (ShowS
forceUtf8Enc (String
pkgId String -> ShowS
FP.</> String
fp)))
        -- convert a String of proper characters to a String of bytes
        -- in UTF8 encoding masquerading as characters. This is
        -- necessary for tricking the tar package into proper
        -- character encoding.
        forceUtf8Enc :: ShowS
forceUtf8Enc = ByteString -> String
S8.unpack (ByteString -> String) -> (String -> ByteString) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
        packWith :: (String -> TarPath -> IO Entry) -> Bool -> String -> RIO env Entry
packWith String -> TarPath -> IO Entry
f Bool
isDir String
fp = IO Entry -> RIO env Entry
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
$ String -> TarPath -> IO Entry
f (String
pkgFp String -> ShowS
FP.</> String
fp) (TarPath -> IO Entry) -> IO TarPath -> IO Entry
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> String -> IO TarPath
tarPath Bool
isDir String
fp
        packDir :: String -> RIO env Entry
packDir = (String -> TarPath -> IO Entry) -> Bool -> String -> RIO env Entry
packWith String -> TarPath -> IO Entry
Tar.packDirectoryEntry Bool
True
        packFile :: String -> RIO env Entry
packFile String
fp
            -- This is a cabal file, we're going to tweak it, but only
            -- tweak it as a revision.
            | Bool
tweakCabal Bool -> Bool -> Bool
&& String -> Bool
isCabalFp String
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 (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))
                (String -> TarPath -> IO Entry) -> Bool -> String -> RIO env Entry
packWith String -> TarPath -> IO Entry
packFileEntry Bool
False String
fp
            -- Same, except we'll include the cabal file in the
            -- original tarball upload.
            | Bool
tweakCabal Bool -> Bool -> Bool
&& String -> Bool
isCabalFp String
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime -- Seconds from UNIX epoch
                TarPath
tp <- IO TarPath -> RIO env TarPath
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 -> String -> IO TarPath
tarPath Bool
False String
fp
                Entry -> RIO env Entry
forall (m :: * -> *) a. Monad m => a -> m a
return (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 a b. (RealFrac a, Integral b) => a -> b
floor POSIXTime
currTime }
            | Bool
otherwise = (String -> TarPath -> IO Entry) -> Bool -> String -> RIO env Entry
packWith String -> TarPath -> IO Entry
packFileEntry Bool
False String
fp
        isCabalFp :: String -> Bool
isCabalFp String
fp = Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
pkgDir String -> ShowS
FP.</> String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
cabalfp
        tarName :: String
tarName = String
pkgId String -> ShowS
FP.<.> String
"tar.gz"
        pkgId :: String
pkgId = PackageIdentifier -> String
packageIdentifierString (Package -> PackageIdentifier
packageIdentifier (LocalPackage -> Package
lpPackage LocalPackage
lp))
    [Entry]
dirEntries <- (String -> RIO env Entry) -> [String] -> RIO env [Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> RIO env Entry
packDir ([String] -> [String]
dirsFromFiles [String]
files)
    [Entry]
fileEntries <- (String -> RIO env Entry) -> [String] -> RIO env [Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> RIO env Entry
packFile [String]
files
    Maybe (PackageIdentifier, ByteString)
mcabalFileRevision <- IO (Maybe (PackageIdentifier, ByteString))
-> RIO env (Maybe (PackageIdentifier, ByteString))
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)
    (String, ByteString, Maybe (PackageIdentifier, ByteString))
-> RIO
     env (String, ByteString, Maybe (PackageIdentifier, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (String
tarName, ByteString -> ByteString
GZip.compress ([Entry] -> ByteString
Tar.write ([Entry]
dirEntries [Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++ [Entry]
fileEntries)), Maybe (PackageIdentifier, ByteString)
mcabalFileRevision)

-- | Get the PVP bounds-enabled version of the given cabal file
getCabalLbs :: HasEnvConfig env
            => PvpBoundsType
            -> Maybe Int -- ^ optional revision
            -> Path Abs File -- ^ cabal file
            -> SourceMap
            -> RIO env (PackageIdentifier, L.ByteString)
getCabalLbs :: 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') <- Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (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 (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
$ String -> RIO env ()
forall a. HasCallStack => String -> a
error (String -> RIO env ()) -> String -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String
"getCabalLbs: cabalfp /= cabalfp': " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Path Abs File, Path Abs File) -> String
forall a. Show a => a -> String
show (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 :: [(String, String)]
Cabal.customFieldsPD
                  = ((String
"x-revision", Int -> String
forall a. Show a => a -> String
show Int
rev)(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:)
                  ([(String, String)] -> [(String, String)])
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(String
x, String
_) -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"x-revision")
                  ([(String, String)] -> [(String, String)])
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ PackageDescription -> [(String, String)]
Cabal.customFieldsPD
                  (PackageDescription -> [(String, String)])
-> PackageDescription -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd'
                  }
              }
        ident :: PackageIdentifier
ident = PackageDescription -> PackageIdentifier
Cabal.package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd''
    -- Sanity rendering and reparsing the input, to ensure there are no
    -- cabal bugs, since there have been bugs here before, and currently
    -- are at the time of writing:
    --
    -- https://github.com/haskell/cabal/issues/1202
    -- https://github.com/haskell/cabal/issues/2353
    -- https://github.com/haskell/cabal/issues/4863 (current issue)
    let roundtripErrs :: [StyleDoc]
roundtripErrs =
          [ String -> StyleDoc
flow String
"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
$ String -> Text
T.pack
                          (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> String
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 (m :: * -> *) a. Monad m => a -> m a
return ()
        | 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
                [ String -> StyleDoc
flow String
"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"
                , String -> StyleDoc
flow String
"for latest stable version or"
                , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack upgrade --git"
                , String -> StyleDoc
flow String
"for the latest development version."
                ]
              , StyleDoc
""
              , [StyleDoc] -> StyleDoc
fillSep
                [ String -> StyleDoc
flow String
"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
""
              , String -> StyleDoc
flow String
"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]
++
          [ String -> StyleDoc
flow String
"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"
            ]
          , String -> StyleDoc
flow (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ String
"The parse error is: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((PError -> String) -> [PError] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PError -> String
forall a. Show a => a -> String
show (NonEmpty PError -> [PError]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty PError
errs))
          , StyleDoc
""
          ]
    (PackageIdentifier, ByteString)
-> RIO env (PackageIdentifier, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return
      ( PackageIdentifier
ident
      , Text -> ByteString
TLE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
TL.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> String
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 Set 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 -> Set 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) Set LibraryName
s
      where
        foundVersion :: Maybe Version
foundVersion =
          case PackageName -> InstallMap -> Maybe (InstallLocation, Version)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstallMap
installMap of
              Just (InstallLocation
_, Version
version) -> Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version
              Maybe (InstallLocation, Version)
Nothing ->
                  case PackageName -> InstalledMap -> Maybe (InstallLocation, Installed)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstalledMap
installedMap of
                      Just (InstallLocation
_, Installed
installed) -> Version -> Maybe Version
forall a. a -> Maybe a
Just (Installed -> Version
installedVersion Installed
installed)
                      Maybe (InstallLocation, Installed)
Nothing -> Maybe Version
forall a. Maybe a
Nothing

    addUpper :: Version -> VersionRange -> VersionRange
addUpper Version
version = VersionRange -> VersionRange -> VersionRange
intersectVersionRanges
        (Version -> VersionRange
earlierVersion (Version -> VersionRange) -> Version -> VersionRange
forall a b. (a -> b) -> a -> b
$ Version -> Version
nextMajorVersion Version
version)
    addLower :: Version -> VersionRange -> VersionRange
addLower Version
version = VersionRange -> VersionRange -> VersionRange
intersectVersionRanges (Version -> VersionRange
orLaterVersion Version
version)

    (Bool
toAddLower, Bool
toAddUpper) =
      case PvpBoundsType
pvpBounds of
        PvpBoundsType
PvpBoundsNone  -> (Bool
False, Bool
False)
        PvpBoundsType
PvpBoundsUpper -> (Bool
False, Bool
True)
        PvpBoundsType
PvpBoundsLower -> (Bool
True,  Bool
False)
        PvpBoundsType
PvpBoundsBoth  -> (Bool
True,  Bool
True)

-- | Traverse a data type.
gtraverseT :: (Data a,Typeable b) => (Typeable b => b -> b) -> a -> a
gtraverseT :: (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 Typeable b => b -> b
f b
x
                 Just b
b  -> b -> Maybe b -> b
forall a. a -> Maybe a -> a
fromMaybe b
x (b -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (b -> b
Typeable b => b -> b
f b
b)))

-- | Read in a 'LocalPackage' config.  This makes some default decisions
-- about 'LocalPackage' fields that might not be appropriate for other
-- use-cases.
readLocalPackage :: HasEnvConfig env => Path Abs Dir -> RIO env LocalPackage
readLocalPackage :: 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) <- Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath Path Abs Dir
pkgDir
    GenericPackageDescription
gpd <- IO GenericPackageDescription -> RIO env GenericPackageDescription
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 (m :: * -> *) a. Monad m => a -> m a
return LocalPackage :: Package
-> Set NamedComponent
-> Set NamedComponent
-> Bool
-> Map PackageName VersionRange
-> Map PackageName VersionRange
-> Maybe Package
-> Path Abs File
-> Bool
-> Bool
-> MemoizedWith EnvConfig (Maybe (Set String))
-> MemoizedWith
     EnvConfig (Map NamedComponent (Map String FileCacheInfo))
-> MemoizedWith
     EnvConfig (Map NamedComponent (Set (Path Abs File)))
-> LocalPackage
LocalPackage
        { lpPackage :: Package
lpPackage = Package
package
        , lpWanted :: Bool
lpWanted = Bool
False -- HACK: makes it so that sdist output goes to a log instead of a file.
        , lpCabalFile :: Path Abs File
lpCabalFile = Path Abs File
cabalfp
        -- NOTE: these aren't the 'correct values, but aren't used in
        -- the usage of this function in this module.
        , lpTestDeps :: Map PackageName VersionRange
lpTestDeps = Map PackageName VersionRange
forall k a. Map k a
Map.empty
        , lpBenchDeps :: Map PackageName VersionRange
lpBenchDeps = Map PackageName VersionRange
forall k a. Map k a
Map.empty
        , 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 String))
lpDirtyFiles = Maybe (Set String) -> MemoizedWith EnvConfig (Maybe (Set String))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Set String)
forall a. Maybe a
Nothing
        , lpNewBuildCaches :: MemoizedWith
  EnvConfig (Map NamedComponent (Map String FileCacheInfo))
lpNewBuildCaches = Map NamedComponent (Map String FileCacheInfo)
-> MemoizedWith
     EnvConfig (Map NamedComponent (Map String FileCacheInfo))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map NamedComponent (Map String 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 (f :: * -> *) a. Applicative f => a -> f a
pure Map NamedComponent (Set (Path Abs File))
forall k a. Map k a
Map.empty
        , lpComponents :: Set NamedComponent
lpComponents = Set NamedComponent
forall a. Set a
Set.empty
        , lpUnbuildable :: Set NamedComponent
lpUnbuildable = Set NamedComponent
forall a. Set a
Set.empty
        }

-- | Returns a newline-separate list of paths, and the absolute path to the .cabal file.
getSDistFileList :: HasEnvConfig env => LocalPackage -> RIO env (String, Path Abs File)
getSDistFileList :: LocalPackage -> RIO env (String, Path Abs File)
getSDistFileList LocalPackage
lp =
    String
-> (Path Abs Dir -> RIO env (String, Path Abs File))
-> RIO env (String, Path Abs File)
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (Path Abs Dir -> m a) -> m a
withSystemTempDir (String
stackProgName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-sdist") ((Path Abs Dir -> RIO env (String, Path Abs File))
 -> RIO env (String, Path Abs File))
-> (Path Abs Dir -> RIO env (String, Path Abs File))
-> RIO env (String, 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 (String, Path Abs File))
-> RIO env (String, Path Abs File)
forall env a.
HasEnvConfig env =>
BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> Maybe Int
-> (ExecuteEnv -> RIO env a)
-> RIO env a
withExecuteEnv BuildOpts
bopts BuildOptsCLI
boptsCli BaseConfigOpts
baseConfigOpts [LocalPackage]
locals
            [] [] [] Maybe Int
forall a. Maybe a
Nothing -- provide empty list of globals. This is a hack around custom Setup.hs files
            ((ExecuteEnv -> RIO env (String, Path Abs File))
 -> RIO env (String, Path Abs File))
-> (ExecuteEnv -> RIO env (String, Path Abs File))
-> RIO env (String, Path Abs File)
forall a b. (a -> b) -> a -> b
$ \ExecuteEnv
ee ->
            ActionContext
-> ExecuteEnv
-> Task
-> Maybe (Map PackageIdentifier GhcPkgId)
-> Maybe String
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env (String, Path Abs File))
-> RIO env (String, Path Abs File)
forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Maybe (Map PackageIdentifier GhcPkgId)
-> Maybe String
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task Maybe (Map PackageIdentifier GhcPkgId)
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
"sdist") ((Package
  -> Path Abs File
  -> Path Abs Dir
  -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
  -> (Utf8Builder -> RIO env ())
  -> OutputType
  -> RIO env (String, Path Abs File))
 -> RIO env (String, Path Abs File))
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env (String, Path Abs File))
-> RIO env (String, Path Abs File)
forall a b. (a -> b) -> a -> b
$ \Package
_package Path Abs File
cabalfp Path Abs Dir
_pkgDir KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal Utf8Builder -> RIO env ()
_announce OutputType
_outputType -> do
                let outFile :: String
outFile = Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
tmpdir String -> ShowS
FP.</> String
"source-files-list"
                KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal KeepOutputOpen
CloseOnException ExcludeTHLoading
KeepTHLoading [String
"sdist", String
"--list-sources", String
outFile]
                ByteString
contents <- IO ByteString -> RIO env ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
S.readFile String
outFile)
                (String, Path Abs File) -> RIO env (String, Path Abs File)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> String
T.unpack (Text -> String) -> Text -> String
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 :: PackageIdentifier
-> TaskType
-> TaskConfigOpts
-> Bool
-> Map PackageIdentifier GhcPkgId
-> Bool
-> CachePkgSrc
-> Bool
-> Bool
-> 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 :: Set PackageIdentifier
-> (Map PackageIdentifier GhcPkgId -> ConfigureOpts)
-> TaskConfigOpts
TaskConfigOpts
            { tcoMissing :: Set PackageIdentifier
tcoMissing = Set PackageIdentifier
forall a. Set a
Set.empty
            , tcoOpts :: Map PackageIdentifier GhcPkgId -> ConfigureOpts
tcoOpts = \Map PackageIdentifier GhcPkgId
_ -> [String] -> [String] -> 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 = String -> CachePkgSrc
CacheSrcLocal (Path Abs Dir -> String
forall b t. Path b t -> String
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 :: [String] -> RIO env [String]
normalizeTarballPaths [String]
fps = do
    -- TODO: consider whether erroring out is better - otherwise the
    -- user might upload an incomplete tar?
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
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
<>
            [String] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow [String]
outsideDir
    [String] -> RIO env [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
files)
  where
    ([String]
outsideDir, [String]
files) = [Either String String] -> ([String], [String])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((String -> Either String String)
-> [String] -> [Either String String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Either String String
pathToEither [String]
fps)
    pathToEither :: String -> Either String String
pathToEither String
fp = Either String String
-> (String -> Either String String)
-> Maybe String
-> Either String String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String String
forall a b. a -> Either a b
Left String
fp) String -> Either String String
forall a b. b -> Either a b
Right (String -> Maybe String
normalizePath String
fp)

normalizePath :: FilePath -> Maybe FilePath
normalizePath :: String -> Maybe String
normalizePath = ([String] -> String) -> Maybe [String] -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> String
FP.joinPath (Maybe [String] -> Maybe String)
-> (String -> Maybe [String]) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Maybe [String]
forall a. (Eq a, IsString a) => [a] -> Maybe [a]
go ([String] -> Maybe [String])
-> (String -> [String]) -> String -> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
FP.splitDirectories (String -> [String]) -> ShowS -> String -> [String]
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 :: [String] -> [String]
dirsFromFiles [String]
dirs = Set String -> [String]
forall a. Set a -> [a]
Set.toAscList (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete String
"." Set String
results)
  where
    results :: Set String
results = (Set String -> String -> Set String)
-> Set String -> [String] -> Set String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Set String
s -> Set String -> String -> Set String
go Set String
s (String -> Set String) -> ShowS -> String -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeDirectory) Set String
forall a. Set a
Set.empty [String]
dirs
    go :: Set String -> String -> Set String
go Set String
s String
x
      | String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
x Set String
s = Set String
s
      | Bool
otherwise = Set String -> String -> Set String
go (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
x Set String
s) (ShowS
FP.takeDirectory String
x)

-- | Check package in given tarball. This will log all warnings
-- and will throw an exception in case of critical errors.
--
-- Note that we temporarily decompress the archive to analyze it.
checkSDistTarball
  :: HasEnvConfig env
  => SDistOpts -- ^ The configuration of what to check
  -> Path Abs File -- ^ Absolute path to tarball
  -> RIO env ()
checkSDistTarball :: 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`
        (String -> RIO env (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (String -> RIO env (Path Rel Dir))
-> (Path Abs File -> String)
-> 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 -> String) -> Path Abs File -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeBaseName ShowS -> (Path Abs File -> String) -> Path Abs File -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> RIO env (Path Rel Dir))
-> Path Abs File -> RIO env (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs File
tarball)
    --               ^ drop ".tar"     ^ drop ".gz"
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SDistOpts -> Bool
sdoptsBuildTarball SDistOpts
opts) (ResolvedPath Dir -> RIO env ()
forall env. HasEnvConfig env => ResolvedPath Dir -> RIO env ()
buildExtractedTarball ResolvedPath :: forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath
                                      { resolvedRelative :: RelFilePath
resolvedRelative = Text -> RelFilePath
RelFilePath Text
"this-is-not-used" -- ugly hack
                                      , resolvedAbsolute :: Path Abs Dir
resolvedAbsolute = Path Abs Dir
pkgDir
                                      })
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SDistOpts -> Bool
sdoptsIgnoreCheck SDistOpts
opts) (Path Abs Dir -> RIO env ()
forall env. HasEnvConfig env => Path Abs Dir -> RIO env ()
checkPackageInExtractedTarball Path Abs Dir
pkgDir)

checkPackageInExtractedTarball
  :: HasEnvConfig env
  => Path Abs Dir -- ^ Absolute path to tarball
  -> RIO env ()
checkPackageInExtractedTarball :: Path Abs Dir -> RIO env ()
checkPackageInExtractedTarball Path Abs Dir
pkgDir = do
    (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
name, Path Abs File
_cabalfp) <- Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath Path Abs Dir
pkgDir
    GenericPackageDescription
gpd <- IO GenericPackageDescription -> RIO env GenericPackageDescription
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
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
name) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"' for common mistakes"
    let pkgChecks :: [PackageCheck]
pkgChecks =
          -- MSS 2017-12-12: Try out a few different variants of
          -- pkgDesc to try and provoke an error or warning. I don't
          -- know why, but when using `Just pkgDesc`, it appears that
          -- Cabal does not detect that `^>=` is used with
          -- `cabal-version: 1.24` or earlier. It seems like pkgDesc
          -- (the one we create) does not populate the `buildDepends`
          -- field, whereas flattenPackageDescription from Cabal
          -- does. In any event, using `Nothing` seems more logical
          -- for this check anyway, and the fallback to `Just pkgDesc`
          -- is just a crazy sanity check.
          case GenericPackageDescription
-> Maybe PackageDescription -> [PackageCheck]
Check.checkPackage GenericPackageDescription
gpd Maybe PackageDescription
forall a. Maybe a
Nothing of
            [] -> GenericPackageDescription
-> Maybe PackageDescription -> [PackageCheck]
Check.checkPackage GenericPackageDescription
gpd (PackageDescription -> Maybe PackageDescription
forall a. a -> Maybe a
Just PackageDescription
pkgDesc)
            [PackageCheck]
x -> [PackageCheck]
x
    [PackageCheck]
fileChecks <- IO [PackageCheck] -> RIO env [PackageCheck]
forall (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 -> String -> IO [PackageCheck]
Check.checkPackageFiles Verbosity
forall a. Bounded a => a
minBound PackageDescription
pkgDesc (Path Abs Dir -> String
forall b t. Path b t -> String
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 String
_) = Bool
True
              criticalIssue (Check.PackageDistInexcusable String
_) = Bool
True
              criticalIssue PackageCheck
_ = Bool
False
          in (PackageCheck -> Bool)
-> [PackageCheck] -> ([PackageCheck], [PackageCheck])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition PackageCheck -> Bool
criticalIssue [PackageCheck]
checks
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageCheck] -> 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]
intersperse Utf8Builder
"\n" ([Utf8Builder] -> [Utf8Builder])
-> ([PackageCheck] -> [Utf8Builder])
-> [PackageCheck]
-> [Utf8Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageCheck -> Utf8Builder) -> [PackageCheck] -> [Utf8Builder]
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 (m :: * -> *) a. Monad m => a -> m a
return ()
        Just NonEmpty PackageCheck
ne -> CheckException -> RIO env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (CheckException -> RIO env ()) -> CheckException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ NonEmpty PackageCheck -> CheckException
CheckException NonEmpty PackageCheck
ne

buildExtractedTarball :: HasEnvConfig env => ResolvedPath Dir -> RIO env ()
buildExtractedTarball :: ResolvedPath Dir -> RIO env ()
buildExtractedTarball ResolvedPath Dir
pkgDir = do
  EnvConfig
envConfig <- Getting EnvConfig env EnvConfig -> RIO env EnvConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EnvConfig env EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL
  LocalPackage
localPackageToBuild <- Path Abs Dir -> RIO env LocalPackage
forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage (Path Abs Dir -> RIO env LocalPackage)
-> Path Abs Dir -> RIO env LocalPackage
forall a b. (a -> b) -> a -> b
$ ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
pkgDir
  -- We remove the path based on the name of the package
  let isPathToRemove :: Path Abs Dir -> RIO env Bool
isPathToRemove Path Abs Dir
path = do
        LocalPackage
localPackage <- Path Abs Dir -> RIO env LocalPackage
forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
path
        Bool -> RIO env Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (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 (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 (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
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 r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local env -> env
adjustEnvForBuild (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
build Maybe (Set (Path Abs File) -> IO ())
forall a. Maybe a
Nothing

-- | Version of 'checkSDistTarball' that first saves lazy bytestring to
-- temporary directory and then calls 'checkSDistTarball' on it.
checkSDistTarball'
  :: HasEnvConfig env
  => SDistOpts
  -> String       -- ^ Tarball name
  -> L.ByteString -- ^ Tarball contents as a byte string
  -> RIO env ()
checkSDistTarball' :: SDistOpts -> String -> ByteString -> RIO env ()
checkSDistTarball' SDistOpts
opts String
name ByteString
bytes = String -> (Path Abs Dir -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (Path Abs Dir -> m a) -> m a
withSystemTempDir String
"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` String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
name
    IO () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
L.writeFile (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
npath) ByteString
bytes
    SDistOpts -> Path Abs File -> RIO env ()
forall env.
HasEnvConfig env =>
SDistOpts -> Path Abs File -> RIO env ()
checkSDistTarball SDistOpts
opts Path Abs File
npath

withTempTarGzContents
  :: Path Abs File                     -- ^ Location of tarball
  -> (Path Abs Dir -> RIO env a) -- ^ Perform actions given dir with tarball contents
  -> RIO env a
withTempTarGzContents :: Path Abs File -> (Path Abs Dir -> RIO env a) -> RIO env a
withTempTarGzContents Path Abs File
apath Path Abs Dir -> RIO env a
f = String -> (Path Abs Dir -> RIO env a) -> RIO env a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (Path Abs Dir -> m a) -> m a
withSystemTempDir String
"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 (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
$ String -> IO ByteString
L.readFile (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
apath)
    IO () -> RIO env ()
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
. String -> Entries FormatError -> IO ()
forall e. Exception e => String -> Entries e -> IO ()
Tar.unpack (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
tpath) (Entries FormatError -> IO ())
-> (ByteString -> Entries FormatError) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read (ByteString -> Entries FormatError)
-> (ByteString -> ByteString) -> ByteString -> Entries FormatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.decompress (ByteString -> RIO env ()) -> ByteString -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ByteString
archive
    Path Abs Dir -> RIO env a
f Path Abs Dir
tpath

--------------------------------------------------------------------------------

-- Copy+modified from the tar package to avoid issues with lazy IO ( see
-- https://github.com/commercialhaskell/stack/issues/1344 )

packFileEntry :: FilePath -- ^ Full path to find the file on the local disk
              -> Tar.TarPath  -- ^ Path to use for the tar Entry in the archive
              -> IO Tar.Entry
packFileEntry :: String -> TarPath -> IO Entry
packFileEntry String
filepath TarPath
tarpath = do
  EpochTime
mtime   <- String -> IO EpochTime
getModTime String
filepath
  Permissions
perms   <- String -> IO Permissions
getPermissions String
filepath
  ByteString
content <- String -> IO ByteString
S.readFile String
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 (m :: * -> *) a. Monad m => a -> m a
return (TarPath -> EntryContent -> Entry
Tar.simpleEntry TarPath
tarpath (ByteString -> EpochTime -> EntryContent
Tar.NormalFile (ByteString -> ByteString
L.fromStrict ByteString
content) EpochTime
size)) {
    entryPermissions :: Permissions
Tar.entryPermissions = if Permissions -> Bool
executable Permissions
perms then Permissions
Tar.executableFilePermissions
                                               else Permissions
Tar.ordinaryFilePermissions,
    entryTime :: EpochTime
Tar.entryTime = EpochTime
mtime
  }

getModTime :: FilePath -> IO Tar.EpochTime
getModTime :: String -> IO EpochTime
getModTime String
path = do
    UTCTime
t <- String -> IO UTCTime
getModificationTime String
path
    EpochTime -> IO EpochTime
forall (m :: * -> *) a. Monad m => a -> m a
return (EpochTime -> IO EpochTime)
-> (UTCTime -> EpochTime) -> UTCTime -> IO EpochTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> EpochTime
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 :: 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
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
actualCompilerVersionL
  PackageConfig -> m PackageConfig
forall (m :: * -> *) a. Monad m => a -> m a
return PackageConfig :: Bool
-> Bool
-> Map FlagName Bool
-> [Text]
-> [Text]
-> ActualCompiler
-> Platform
-> PackageConfig
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
    }