{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TypeFamilies       #-}

-- Types and functions related to Stack's @sdist@ command.

module Stack.SDist
  ( SDistOpts (..)
  , sdistCmd
  , getSDistTarball
  , checkSDistTarball
  , checkSDistTarball'
  ) where

import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import           Conduit ( runConduitRes, sourceLazy, sinkFileCautious )
import           Control.Concurrent.Execute
                   ( ActionContext (..), Concurrency (..) )
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import           Data.Char ( toLower )
import           Data.Data ( cast )
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import           Data.Time.Clock.POSIX ( getPOSIXTime, utcTimeToPOSIXSeconds )
import           Distribution.Package ( Dependency (..) )
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription.Check as Check
import qualified Distribution.PackageDescription.Parsec as Cabal
import           Distribution.PackageDescription.PrettyPrint
                   ( showGenericPackageDescription )
import           Distribution.Version
                   ( simplifyVersionRange, orLaterVersion, earlierVersion
                   , hasUpperBound, hasLowerBound
                   )
import           Path ( (</>), parent, parseRelDir, parseRelFile )
import           Path.IO ( ensureDir, resolveDir' )
import           Stack.Build ( mkBaseConfigOpts, build, buildLocalTargets )
import           Stack.Build.Execute
                   ( ExcludeTHLoading (..), KeepOutputOpen (..), withExecuteEnv
                   , withSingleContext
                   )
import           Stack.Build.Installed ( getInstalled, toInstallMap )
import           Stack.Build.Source ( projectLocalPackages )
import           Stack.Constants ( stackProgName, stackProgName' )
import           Stack.Constants.Config ( distDirFromDir )
import           Stack.Package
                   ( PackageDescriptionPair (..), resolvePackage
                   , resolvePackageDescription
                   )
import           Stack.Prelude
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withDefaultEnvConfig )
import           Stack.SourceMap ( mkProjectPackage )
import           Stack.Types.Build
                   ( CachePkgSrc (..), Task (..), TaskConfigOpts (..)
                   , TaskType (..)
                   )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..), stackYamlL )
import           Stack.Types.BuildOpts
                   ( BuildOpts (..), defaultBuildOpts, defaultBuildOptsCLI )
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.ConfigureOpts ( ConfigureOpts (..) )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.Package
                   ( InstallMap, Installed (..), InstalledMap, LocalPackage (..)
                   , Package (..), PackageConfig (..), installedVersion
                   , packageIdentifier
                   )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.PvpBounds ( PvpBounds (..), PvpBoundsType (..) )
import           Stack.Types.Runner ( HasRunner, Runner )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), ProjectPackage (..), SMWanted (..)
                   , SourceMap (..), ppRoot
                   )
import           Stack.Types.Version
                   ( intersectVersionRanges, nextMajorVersion )
import           System.Directory
                   ( copyFile, createDirectoryIfMissing, executable
                   , getModificationTime, getPermissions
                   )
import qualified System.FilePath as FP

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.SDist" module.

data SDistException
  = CheckException (NonEmpty Check.PackageCheck)
  | CabalFilePathsInconsistentBug (Path Abs File) (Path Abs File)
  | ToTarPathException String
  deriving (Int -> SDistException -> ShowS
[SDistException] -> ShowS
SDistException -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [SDistException] -> ShowS
$cshowList :: [SDistException] -> ShowS
show :: SDistException -> FilePath
$cshow :: SDistException -> FilePath
showsPrec :: Int -> SDistException -> ShowS
$cshowsPrec :: Int -> SDistException -> ShowS
Show, Typeable)

instance Exception SDistException where
  displayException :: SDistException -> FilePath
displayException (CheckException NonEmpty PackageCheck
xs) = [FilePath] -> FilePath
unlines forall a b. (a -> b) -> a -> b
$
    [ FilePath
"Error: [S-6439]"
    , FilePath
"Package check reported the following errors:"
    ] forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> FilePath
show (forall a. NonEmpty a -> [a]
NE.toList NonEmpty PackageCheck
xs)
  displayException (CabalFilePathsInconsistentBug Path Abs File
cabalfp Path Abs File
cabalfp') = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ FilePath
"Error: [S-9595]\n"
    , FilePath
"The impossible happened! Two Cabal file paths are inconsistent: "
    , forall a. Show a => a -> FilePath
show (Path Abs File
cabalfp, Path Abs File
cabalfp')
    ]
  displayException (ToTarPathException FilePath
e) =
    FilePath
"Error: [S-7875\n"
    forall a. [a] -> [a] -> [a]
++ FilePath
e
-- | Type representing command line options for @stack sdist@ command.

data SDistOpts = SDistOpts
  { SDistOpts -> [FilePath]
sdoptsDirsToWorkWith :: [String]
  -- ^ Directories to package

  , SDistOpts -> Maybe PvpBounds
sdoptsPvpBounds :: Maybe PvpBounds
  -- ^ PVP Bounds overrides

  , SDistOpts -> Bool
sdoptsIgnoreCheck :: Bool
  -- ^ Whether to ignore check of the package for common errors

  , SDistOpts -> Bool
sdoptsBuildTarball :: Bool
  -- ^ Whether to build the tarball

  , SDistOpts -> Maybe FilePath
sdoptsTarPath :: Maybe FilePath
  -- ^ Where to copy the tarball

  }

-- | Function underlying the @stack sdist@ command.

sdistCmd :: SDistOpts -> RIO Runner ()
sdistCmd :: SDistOpts -> RIO Runner ()
sdistCmd SDistOpts
sdistOpts =
  forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec forall a b. (a -> b) -> a -> b
$ forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig forall a b. (a -> b) -> a -> b
$ do
    -- If no directories are specified, build all sdist tarballs.

    [Path Abs Dir]
dirs' <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (SDistOpts -> [FilePath]
sdoptsDirsToWorkWith SDistOpts
sdistOpts)
      then do
        [Path Abs Dir]
dirs <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (forall a b. (a -> b) -> [a] -> [b]
map ProjectPackage -> Path Abs Dir
ppRoot forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMWanted -> Map PackageName ProjectPackage
smwProject forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs Dir]
dirs) forall a b. (a -> b) -> a -> b
$ do
          Path Abs File
stackYaml <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasBuildConfig env => Lens' env (Path Abs File)
stackYamlL
          forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyErrorL
            [ Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack sdist"
            , FilePath -> StyleDoc
flow FilePath
"expects a list of targets, and otherwise defaults to all of the project's packages."
            , FilePath -> StyleDoc
flow FilePath
"However, the configuration at"
            , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
stackYaml
            , FilePath -> StyleDoc
flow FilePath
"contains no packages, so no sdist tarballs will be generated."
            ]
          forall (m :: * -> *) a. MonadIO m => m a
exitFailure
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [Path Abs Dir]
dirs
      else forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs Dir)
resolveDir' (SDistOpts -> [FilePath]
sdoptsDirsToWorkWith SDistOpts
sdistOpts)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs Dir]
dirs' forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
      (FilePath
tarName, ByteString
tarBytes, Maybe (PackageIdentifier, ByteString)
_mcabalRevision) <-
        forall env.
HasEnvConfig env =>
Maybe PvpBounds
-> Path Abs Dir
-> RIO
     env (FilePath, ByteString, Maybe (PackageIdentifier, ByteString))
getSDistTarball (SDistOpts -> Maybe PvpBounds
sdoptsPvpBounds SDistOpts
sdistOpts) Path Abs Dir
dir
      Path Abs Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
dir
      Path Abs File
tarPath <- (Path Abs Dir
distDir </>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
tarName
      forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
tarPath)
      forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) lazy strict i.
(Monad m, LazySequence lazy strict) =>
lazy -> ConduitT i strict m ()
sourceLazy ByteString
tarBytes forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
        forall (m :: * -> *) o.
MonadResource m =>
FilePath -> ConduitM ByteString o m ()
sinkFileCautious (forall b t. Path b t -> FilePath
toFilePath Path Abs File
tarPath)
      forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
        [FilePath -> StyleDoc
flow FilePath
"Wrote sdist-format compressed archive to"
        , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
tarPath forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
        ]
      forall env.
HasEnvConfig env =>
SDistOpts -> Path Abs File -> RIO env ()
checkSDistTarball SDistOpts
sdistOpts Path Abs File
tarPath
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (SDistOpts -> Maybe FilePath
sdoptsTarPath SDistOpts
sdistOpts) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {b} {t}.
MonadIO m =>
Path b t -> FilePath -> FilePath -> m ()
copyTarToTarPath Path Abs File
tarPath FilePath
tarName
 where
  copyTarToTarPath :: Path b t -> FilePath -> FilePath -> m ()
copyTarToTarPath Path b t
tarPath FilePath
tarName FilePath
targetDir = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    let targetTarPath :: FilePath
targetTarPath = FilePath
targetDir FilePath -> ShowS
FP.</> FilePath
tarName
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ ShowS
FP.takeDirectory FilePath
targetTarPath
    FilePath -> FilePath -> IO ()
copyFile (forall b t. Path b t -> FilePath
toFilePath Path b t
tarPath) FilePath
targetTarPath

-- | Given the path to a local package, creates its source

-- distribution tarball.

--

-- While this yields a 'FilePath', the name of the tarball, this

-- tarball is not written to the disk and instead yielded as a lazy

-- bytestring.

getSDistTarball ::
     HasEnvConfig env
  => Maybe PvpBounds            -- ^ Override Config value

  -> Path Abs Dir               -- ^ Path to local package

  -> RIO env (FilePath, L.ByteString, Maybe (PackageIdentifier, L.ByteString))
  -- ^ Filename, tarball contents, and option Cabal file revision to upload

getSDistTarball :: forall env.
HasEnvConfig env =>
Maybe PvpBounds
-> Path Abs Dir
-> RIO
     env (FilePath, ByteString, Maybe (PackageIdentifier, ByteString))
getSDistTarball Maybe PvpBounds
mpvpBounds Path Abs Dir
pkgDir = do
  Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
  let PvpBounds PvpBoundsType
pvpBounds Bool
asRevision =
        forall a. a -> Maybe a -> a
fromMaybe (Config -> PvpBounds
configPvpBounds Config
config) Maybe PvpBounds
mpvpBounds
      tweakCabal :: Bool
tweakCabal = PvpBoundsType
pvpBounds forall a. Eq a => a -> a -> Bool
/= PvpBoundsType
PvpBoundsNone
      pkgFp :: FilePath
pkgFp = forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir
  LocalPackage
lp <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
pkgDir
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Package -> Maybe (Map PackageName VersionRange)
packageSetupDeps (LocalPackage -> Package
lpPackage LocalPackage
lp)) forall a b. (a -> b) -> a -> b
$ \Map PackageName VersionRange
customSetupDeps ->
    case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
packageNameString) (forall k a. Map k a -> [k]
Map.keys Map PackageName VersionRange
customSetupDeps)) of
      Just NonEmpty Text
nonEmptyDepTargets -> do
        Either SomeException ()
eres <- forall env.
HasEnvConfig env =>
NonEmpty Text -> RIO env (Either SomeException ())
buildLocalTargets NonEmpty Text
nonEmptyDepTargets
        case Either SomeException ()
eres of
          Left SomeException
err ->
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$
              Utf8Builder
"Error: [S-8399]\n" forall a. Semigroup a => a -> a -> a
<>
              Utf8Builder
"Error building custom-setup dependencies: " forall a. Semigroup a => a -> a -> a
<>
              forall a. Show a => a -> Utf8Builder
displayShow SomeException
err
          Right ()
_ ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Maybe (NonEmpty Text)
Nothing ->
        forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
FilePath -> m ()
prettyWarnS FilePath
"unexpected empty custom-setup dependencies."
  SourceMap
sourceMap <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMap
  InstallMap
installMap <- forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
  (InstalledMap
installedMap, [DumpPackage]
_globalDumpPkgs, [DumpPackage]
_snapshotDumpPkgs, [DumpPackage]
_localDumpPkgs) <-
    forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
  let deps :: Map PackageIdentifier GhcPkgId
deps = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (PackageIdentifier
pid, GhcPkgId
ghcPkgId)
        | (InstallLocation
_, Library PackageIdentifier
pid GhcPkgId
ghcPkgId Maybe (Either License License)
_) <- forall k a. Map k a -> [a]
Map.elems InstalledMap
installedMap]
  forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ FilePath -> StyleDoc
flow FilePath
"Getting the file list for"
    , Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => FilePath -> a
fromString  FilePath
pkgFp) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]
  (FilePath
fileList, Path Abs File
cabalfp) <- forall env.
HasEnvConfig env =>
LocalPackage
-> Map PackageIdentifier GhcPkgId
-> RIO env (FilePath, Path Abs File)
getSDistFileList LocalPackage
lp Map PackageIdentifier GhcPkgId
deps
  forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ FilePath -> StyleDoc
flow FilePath
"Building a compressed archive file in the sdist format for"
    , Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => FilePath -> a
fromString FilePath
pkgFp) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]
  [FilePath]
files <-
    forall env.
(HasRunner env, HasTerm env) =>
[FilePath] -> RIO env [FilePath]
normalizeTarballPaths (forall a b. (a -> b) -> [a] -> [b]
map (Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
stripCR forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack) (FilePath -> [FilePath]
lines FilePath
fileList))
  -- We're going to loop below and eventually find the cabal

  -- file. When we do, we'll upload this reference, if the

  -- mpvpBounds value indicates that we should be uploading a cabal

  -- file revision.

  IORef (Maybe (PackageIdentifier, ByteString))
cabalFileRevisionRef <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Maybe a
Nothing)
  -- NOTE: Could make this use lazy I/O to only read files as needed

  -- for upload (both GZip.compress and Tar.write are lazy).

  -- However, it seems less error prone and more predictable to read

  -- everything in at once, so that's what we're doing for now:

  let tarPath :: Bool -> FilePath -> IO TarPath
tarPath Bool
isDir FilePath
fp =
        case Bool -> FilePath -> Either FilePath TarPath
Tar.toTarPath Bool
isDir (ShowS
forceUtf8Enc (FilePath
pkgId FilePath -> ShowS
FP.</> FilePath
fp)) of
          Left FilePath
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> SDistException
ToTarPathException FilePath
e
          Right TarPath
tp -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TarPath
tp
      -- convert a String of proper characters to a String of bytes

      -- in UTF8 encoding masquerading as characters. This is

      -- necessary for tricking the tar package into proper

      -- character encoding.

      forceUtf8Enc :: ShowS
forceUtf8Enc = ByteString -> FilePath
S8.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
      packWith :: (FilePath -> TarPath -> IO Entry)
-> Bool -> FilePath -> RIO env Entry
packWith FilePath -> TarPath -> IO Entry
f Bool
isDir FilePath
fp = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> TarPath -> IO Entry
f (FilePath
pkgFp FilePath -> ShowS
FP.</> FilePath
fp) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> FilePath -> IO TarPath
tarPath Bool
isDir FilePath
fp
      packDir :: FilePath -> RIO env Entry
packDir = (FilePath -> TarPath -> IO Entry)
-> Bool -> FilePath -> RIO env Entry
packWith FilePath -> TarPath -> IO Entry
Tar.packDirectoryEntry Bool
True
      packFile :: FilePath -> RIO env Entry
packFile FilePath
fp
        -- This is a Cabal file, we're going to tweak it, but only

        -- tweak it as a revision.

        | Bool
tweakCabal Bool -> Bool -> Bool
&& FilePath -> Bool
isCabalFp FilePath
fp Bool -> Bool -> Bool
&& Bool
asRevision = do
            (PackageIdentifier, ByteString)
lbsIdent <- forall env.
HasEnvConfig env =>
PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
getCabalLbs PvpBoundsType
pvpBounds (forall a. a -> Maybe a
Just Int
1) Path Abs File
cabalfp SourceMap
sourceMap
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Maybe (PackageIdentifier, ByteString))
cabalFileRevisionRef (forall a. a -> Maybe a
Just (PackageIdentifier, ByteString)
lbsIdent))
            (FilePath -> TarPath -> IO Entry)
-> Bool -> FilePath -> RIO env Entry
packWith FilePath -> TarPath -> IO Entry
packFileEntry Bool
False FilePath
fp
        -- Same, except we'll include the Cabal file in the

        -- original tarball upload.

        | Bool
tweakCabal Bool -> Bool -> Bool
&& FilePath -> Bool
isCabalFp FilePath
fp = do
            (PackageIdentifier
_ident, ByteString
lbs) <- forall env.
HasEnvConfig env =>
PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
getCabalLbs PvpBoundsType
pvpBounds forall a. Maybe a
Nothing Path Abs File
cabalfp SourceMap
sourceMap
            POSIXTime
currTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime -- Seconds from UNIX epoch

            TarPath
tp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO TarPath
tarPath Bool
False FilePath
fp
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (TarPath -> ByteString -> Entry
Tar.fileEntry TarPath
tp ByteString
lbs) { entryTime :: EpochTime
Tar.entryTime = forall a b. (RealFrac a, Integral b) => a -> b
floor POSIXTime
currTime }
        | Bool
otherwise = (FilePath -> TarPath -> IO Entry)
-> Bool -> FilePath -> RIO env Entry
packWith FilePath -> TarPath -> IO Entry
packFileEntry Bool
False FilePath
fp
      isCabalFp :: FilePath -> Bool
isCabalFp FilePath
fp = forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir FilePath -> ShowS
FP.</> FilePath
fp forall a. Eq a => a -> a -> Bool
== forall b t. Path b t -> FilePath
toFilePath Path Abs File
cabalfp
      tarName :: FilePath
tarName = FilePath
pkgId FilePath -> ShowS
FP.<.> FilePath
"tar.gz"
      pkgId :: FilePath
pkgId = PackageIdentifier -> FilePath
packageIdentifierString (Package -> PackageIdentifier
packageIdentifier (LocalPackage -> Package
lpPackage LocalPackage
lp))
  [Entry]
dirEntries <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> RIO env Entry
packDir ([FilePath] -> [FilePath]
dirsFromFiles [FilePath]
files)
  [Entry]
fileEntries <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> RIO env Entry
packFile [FilePath]
files
  Maybe (PackageIdentifier, ByteString)
mcabalFileRevision <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe (PackageIdentifier, ByteString))
cabalFileRevisionRef)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( FilePath
tarName
    , ByteString -> ByteString
GZip.compress ([Entry] -> ByteString
Tar.write ([Entry]
dirEntries forall a. [a] -> [a] -> [a]
++ [Entry]
fileEntries))
    , Maybe (PackageIdentifier, ByteString)
mcabalFileRevision
    )

-- | Get the PVP bounds-enabled version of the given Cabal file

getCabalLbs :: HasEnvConfig env
            => PvpBoundsType
            -> Maybe Int -- ^ optional revision

            -> Path Abs File -- ^ Cabal file

            -> SourceMap
            -> RIO env (PackageIdentifier, L.ByteString)
getCabalLbs :: forall env.
HasEnvConfig env =>
PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, ByteString)
getCabalLbs PvpBoundsType
pvpBounds Maybe Int
mrev Path Abs File
cabalfp SourceMap
sourceMap = do
  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_name, Path Abs File
cabalfp') <-
    forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (forall a. a -> Maybe a
Just Text
stackProgName') (forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp)
  GenericPackageDescription
gpd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
NoPrintWarnings
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Path Abs File
cabalfp forall a. Eq a => a -> a -> Bool
== Path Abs File
cabalfp') forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs File -> SDistException
CabalFilePathsInconsistentBug Path Abs File
cabalfp Path Abs File
cabalfp'
  InstallMap
installMap <- forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
  (InstalledMap
installedMap, [DumpPackage]
_, [DumpPackage]
_, [DumpPackage]
_) <- forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
  let internalPackages :: Set PackageName
internalPackages = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$
        GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd forall a. a -> [a] -> [a]
:
        forall a b. (a -> b) -> [a] -> [b]
map (UnqualComponentName -> PackageName
Cabal.unqualComponentNameToPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
Cabal.condSubLibraries GenericPackageDescription
gpd)
      gpd' :: GenericPackageDescription
gpd' = forall a b.
(Data a, Typeable b) =>
(Typeable b => b -> b) -> a -> a
gtraverseT (Set PackageName
-> InstallMap -> InstalledMap -> Dependency -> Dependency
addBounds Set PackageName
internalPackages InstallMap
installMap InstalledMap
installedMap) GenericPackageDescription
gpd
      gpd'' :: GenericPackageDescription
gpd'' =
        case Maybe Int
mrev of
          Maybe Int
Nothing -> GenericPackageDescription
gpd'
          Just Int
rev -> GenericPackageDescription
gpd'
            { packageDescription :: PackageDescription
Cabal.packageDescription
             = (GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd')
                { customFieldsPD :: [(FilePath, FilePath)]
Cabal.customFieldsPD
                = ((FilePath
"x-revision", forall a. Show a => a -> FilePath
show Int
rev):)
                forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\(FilePath
x, FilePath
_) -> forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower FilePath
x forall a. Eq a => a -> a -> Bool
/= FilePath
"x-revision")
                forall a b. (a -> b) -> a -> b
$ PackageDescription -> [(FilePath, FilePath)]
Cabal.customFieldsPD
                forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd'
                }
            }
      ident :: PackageIdentifier
ident = PackageDescription -> PackageIdentifier
Cabal.package forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd''
  -- Sanity rendering and reparsing the input, to ensure there are no

  -- cabal bugs, since there have been bugs here before, and currently

  -- are at the time of writing:

  --

  -- https://github.com/haskell/cabal/issues/1202

  -- https://github.com/haskell/cabal/issues/2353

  -- https://github.com/haskell/cabal/issues/4863 (current issue)

  let roundtripErrs :: [StyleDoc]
roundtripErrs =
        [ FilePath -> StyleDoc
flow FilePath
"Bug detected in Cabal library. ((parse . render . parse) === \
               \id) does not hold for the Cabal file at"
        StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalfp
        , StyleDoc
""
        ]
      ([PWarning]
_warnings, Either (Maybe Version, NonEmpty PError) GenericPackageDescription
eres) = forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
Cabal.runParseResult
                        forall a b. (a -> b) -> a -> b
$ ByteString -> ParseResult GenericPackageDescription
Cabal.parseGenericPackageDescription
                        forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8
                        forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack
                        forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> FilePath
showGenericPackageDescription GenericPackageDescription
gpd
  case Either (Maybe Version, NonEmpty PError) GenericPackageDescription
eres of
    Right GenericPackageDescription
roundtripped
      | GenericPackageDescription
roundtripped forall a. Eq a => a -> a -> Bool
== GenericPackageDescription
gpd -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise ->
          forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vsep forall a b. (a -> b) -> a -> b
$ [StyleDoc]
roundtripErrs forall a. [a] -> [a] -> [a]
++
            [ StyleDoc
"This seems to be fixed in development versions of Cabal, but \
              \at time of writing, the fix is not in any released versions."
            , StyleDoc
""
            ,  StyleDoc
"Please see this GitHub issue for status:" StyleDoc -> StyleDoc -> StyleDoc
<+> Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/3549"
            , StyleDoc
""
            , [StyleDoc] -> StyleDoc
fillSep
              [ FilePath -> StyleDoc
flow FilePath
"If the issue is closed as resolved, then you may be \
                     \able to fix this by upgrading to a newer version of \
                     \Stack via"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack upgrade"
              , FilePath -> StyleDoc
flow FilePath
"for latest stable version or"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack upgrade --git"
              , FilePath -> StyleDoc
flow FilePath
"for the latest development version."
              ]
            , StyleDoc
""
            , [StyleDoc] -> StyleDoc
fillSep
              [ FilePath -> StyleDoc
flow FilePath
"If the issue is fixed, but updating doesn't solve the \
                     \problem, please check if there are similar open \
                     \issues, and if not, report a new issue to the Stack \
                     \issue tracker, at"
              , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/new"
              ]
            , StyleDoc
""
            , FilePath -> StyleDoc
flow FilePath
"If the issue is not fixed, feel free to leave a comment \
                   \on it indicating that you would like it to be fixed."
            , StyleDoc
""
            ]
    Left (Maybe Version
_version, NonEmpty PError
errs) ->
      forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vsep forall a b. (a -> b) -> a -> b
$ [StyleDoc]
roundtripErrs forall a. [a] -> [a] -> [a]
++
        [ FilePath -> StyleDoc
flow FilePath
"In particular, parsing the rendered Cabal file is yielding a \
               \parse error. Please check if there are already issues \
               \tracking this, and if not, please report new issues to the \
               \Stack and Cabal issue trackers, via"
        , [StyleDoc] -> StyleDoc
bulletedList
          [ Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/new"
          , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/haskell/cabal/issues/new"
          ]
        , FilePath -> StyleDoc
flow forall a b. (a -> b) -> a -> b
$ FilePath
"The parse error is: " forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> FilePath
show (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty PError
errs))
        , StyleDoc
""
        ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( PackageIdentifier
ident
    , Text -> ByteString
TLE.encodeUtf8 forall a b. (a -> b) -> a -> b
$ FilePath -> Text
TL.pack forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> FilePath
showGenericPackageDescription GenericPackageDescription
gpd''
    )
 where
  addBounds :: Set PackageName -> InstallMap -> InstalledMap -> Dependency -> Dependency
  addBounds :: Set PackageName
-> InstallMap -> InstalledMap -> Dependency -> Dependency
addBounds Set PackageName
internalPackages InstallMap
installMap InstalledMap
installedMap dep :: Dependency
dep@(Dependency PackageName
name VersionRange
range NonEmptySet LibraryName
s) =
    if PackageName
name forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
internalPackages
      then Dependency
dep
      else case Maybe Version
foundVersion of
        Maybe Version
Nothing -> Dependency
dep
        Just Version
version -> PackageName
-> VersionRange -> NonEmptySet LibraryName -> Dependency
Dependency PackageName
name (VersionRange -> VersionRange
simplifyVersionRange
          forall a b. (a -> b) -> a -> b
$ (if Bool
toAddUpper Bool -> Bool -> Bool
&& Bool -> Bool
not (VersionRange -> Bool
hasUpperBound VersionRange
range) then Version -> VersionRange -> VersionRange
addUpper Version
version else forall a. a -> a
id)
          forall a b. (a -> b) -> a -> b
$ (if Bool
toAddLower Bool -> Bool -> Bool
&& Bool -> Bool
not (VersionRange -> Bool
hasLowerBound VersionRange
range) then Version -> VersionRange -> VersionRange
addLower Version
version else forall a. a -> a
id)
            VersionRange
range) NonEmptySet LibraryName
s
   where
    foundVersion :: Maybe Version
foundVersion =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstallMap
installMap of
        Just (InstallLocation
_, Version
version) -> forall a. a -> Maybe a
Just Version
version
        Maybe (InstallLocation, Version)
Nothing ->
          case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstalledMap
installedMap of
            Just (InstallLocation
_, Installed
installed) -> forall a. a -> Maybe a
Just (Installed -> Version
installedVersion Installed
installed)
            Maybe (InstallLocation, Installed)
Nothing -> forall a. Maybe a
Nothing

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

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

-- | Traverse a data type.

gtraverseT :: (Data a,Typeable b) => (Typeable b => b -> b) -> a -> a
gtraverseT :: forall a b.
(Data a, Typeable b) =>
(Typeable b => b -> b) -> a -> a
gtraverseT Typeable b => b -> b
f =
  forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT (\b
x -> case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
x of
                 Maybe b
Nothing -> forall a b.
(Data a, Typeable b) =>
(Typeable b => b -> b) -> a -> a
gtraverseT Typeable b => b -> b
f b
x
                 Just b
b  -> forall a. a -> Maybe a -> a
fromMaybe b
x (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (Typeable b => b -> b
f b
b)))

-- | Read in a 'LocalPackage' config.  This makes some default decisions

-- about 'LocalPackage' fields that might not be appropriate for other

-- use-cases.

readLocalPackage :: HasEnvConfig env => Path Abs Dir -> RIO env LocalPackage
readLocalPackage :: forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
pkgDir = do
  PackageConfig
config  <- forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasEnvConfig env) =>
m PackageConfig
getDefaultPackageConfig
  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
cabalfp) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (forall a. a -> Maybe a
Just Text
stackProgName') Path Abs Dir
pkgDir
  GenericPackageDescription
gpd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings
  let package :: Package
package = PackageConfig -> GenericPackageDescription -> Package
resolvePackage PackageConfig
config GenericPackageDescription
gpd
  forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalPackage
    { lpPackage :: Package
lpPackage = Package
package
    , lpWanted :: Bool
lpWanted = Bool
False -- HACK: makes it so that sdist output goes to a log instead of a file.

    , lpCabalFile :: Path Abs File
lpCabalFile = Path Abs File
cabalfp
    -- NOTE: these aren't the 'correct values, but aren't used in

    -- the usage of this function in this module.

    , lpTestBench :: Maybe Package
lpTestBench = forall a. Maybe a
Nothing
    , lpBuildHaddocks :: Bool
lpBuildHaddocks = Bool
False
    , lpForceDirty :: Bool
lpForceDirty = Bool
False
    , lpDirtyFiles :: MemoizedWith EnvConfig (Maybe (Set FilePath))
lpDirtyFiles = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    , lpNewBuildCaches :: MemoizedWith
  EnvConfig (Map NamedComponent (Map FilePath FileCacheInfo))
lpNewBuildCaches = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
    , lpComponentFiles :: MemoizedWith EnvConfig (Map NamedComponent (Set (Path Abs File)))
lpComponentFiles = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
    , lpComponents :: Set NamedComponent
lpComponents = forall a. Set a
Set.empty
    , lpUnbuildable :: Set NamedComponent
lpUnbuildable = forall a. Set a
Set.empty
    }

-- | Returns a newline-separate list of paths, and the absolute path to the

-- Cabal file.

getSDistFileList ::
     HasEnvConfig env
  => LocalPackage
  -> Map PackageIdentifier GhcPkgId
  -> RIO env (String, Path Abs File)
getSDistFileList :: forall env.
HasEnvConfig env =>
LocalPackage
-> Map PackageIdentifier GhcPkgId
-> RIO env (FilePath, Path Abs File)
getSDistFileList LocalPackage
lp Map PackageIdentifier GhcPkgId
deps =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (Path Abs Dir -> m a) -> m a
withSystemTempDir (FilePath
stackProgName forall a. Semigroup a => a -> a -> a
<> FilePath
"-sdist") forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tmpdir -> do
    let bopts :: BuildOpts
bopts = BuildOpts
defaultBuildOpts
    let boptsCli :: BuildOptsCLI
boptsCli = BuildOptsCLI
defaultBuildOptsCLI
    BaseConfigOpts
baseConfigOpts <- forall env.
HasEnvConfig env =>
BuildOptsCLI -> RIO env BaseConfigOpts
mkBaseConfigOpts BuildOptsCLI
boptsCli
    [LocalPackage]
locals <- forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
    forall env a.
HasEnvConfig env =>
BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> Maybe Int
-> (ExecuteEnv -> RIO env a)
-> RIO env a
withExecuteEnv BuildOpts
bopts BuildOptsCLI
boptsCli BaseConfigOpts
baseConfigOpts [LocalPackage]
locals
      [] [] [] forall a. Maybe a
Nothing -- provide empty list of globals. This is a hack around custom Setup.hs files

      forall a b. (a -> b) -> a -> b
$ \ExecuteEnv
ee ->
      forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageIdentifier GhcPkgId
-> Maybe FilePath
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task Map PackageIdentifier GhcPkgId
deps (forall a. a -> Maybe a
Just FilePath
"sdist") forall a b. (a -> b) -> a -> b
$
        \Package
_package Path Abs File
cabalfp Path Abs Dir
_pkgDir KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ()
cabal Utf8Builder -> RIO env ()
_announce OutputType
_outputType -> do
          let outFile :: FilePath
outFile = forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
tmpdir FilePath -> ShowS
FP.</> FilePath
"source-files-list"
          KeepOutputOpen -> ExcludeTHLoading -> [FilePath] -> RIO env ()
cabal
            KeepOutputOpen
CloseOnException
            ExcludeTHLoading
KeepTHLoading
            [FilePath
"sdist", FilePath
"--list-sources", FilePath
outFile]
          ByteString
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ByteString
S.readFile FilePath
outFile)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> FilePath
T.unpack forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode ByteString
contents, Path Abs File
cabalfp)
 where
  package :: Package
package = LocalPackage -> Package
lpPackage LocalPackage
lp
  ac :: ActionContext
ac = Set ActionId -> [Action] -> Concurrency -> ActionContext
ActionContext forall a. Set a
Set.empty [] Concurrency
ConcurrencyAllowed
  task :: Task
task = Task
    { taskProvides :: PackageIdentifier
taskProvides =
        PackageName -> Version -> PackageIdentifier
PackageIdentifier (Package -> PackageName
packageName Package
package) (Package -> Version
packageVersion Package
package)
    , taskType :: TaskType
taskType = LocalPackage -> TaskType
TTLocalMutable LocalPackage
lp
    , taskConfigOpts :: TaskConfigOpts
taskConfigOpts = TaskConfigOpts
        { tcoMissing :: Set PackageIdentifier
tcoMissing = forall a. Set a
Set.empty
        , tcoOpts :: Map PackageIdentifier GhcPkgId -> ConfigureOpts
tcoOpts = \Map PackageIdentifier GhcPkgId
_ -> [FilePath] -> [FilePath] -> ConfigureOpts
ConfigureOpts [] []
        }
    , taskBuildHaddock :: Bool
taskBuildHaddock = Bool
False
    , taskPresent :: Map PackageIdentifier GhcPkgId
taskPresent = forall k a. Map k a
Map.empty
    , taskAllInOne :: Bool
taskAllInOne = Bool
True
    , taskCachePkgSrc :: CachePkgSrc
taskCachePkgSrc = FilePath -> CachePkgSrc
CacheSrcLocal (forall b t. Path b t -> FilePath
toFilePath (forall b t. Path b t -> Path b Dir
parent forall a b. (a -> b) -> a -> b
$ LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp))
    , taskAnyMissing :: Bool
taskAnyMissing = Bool
True
    , taskBuildTypeConfig :: Bool
taskBuildTypeConfig = Bool
False
    }

normalizeTarballPaths ::
     (HasRunner env, HasTerm env)
  => [FilePath]
  -> RIO env [FilePath]
normalizeTarballPaths :: forall env.
(HasRunner env, HasTerm env) =>
[FilePath] -> RIO env [FilePath]
normalizeTarballPaths [FilePath]
fps = do
  -- TODO: consider whether erroring out is better - otherwise the

  -- user might upload an incomplete tar?

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
outsideDir) forall a b. (a -> b) -> a -> b
$
    forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
         FilePath -> StyleDoc
flow FilePath
"These files are outside of the package directory, and will be \
              \omitted from the tarball:"
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => FilePath -> a
fromString) [FilePath]
outsideDir)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Ord a => [a] -> [a]
nubOrd [FilePath]
files)
 where
  ([FilePath]
outsideDir, [FilePath]
files) = forall a b. [Either a b] -> ([a], [b])
partitionEithers (forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Either FilePath FilePath
pathToEither [FilePath]
fps)
  pathToEither :: FilePath -> Either FilePath FilePath
pathToEither FilePath
fp = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left FilePath
fp) forall a b. b -> Either a b
Right (FilePath -> Maybe FilePath
normalizePath FilePath
fp)

normalizePath :: FilePath -> Maybe FilePath
normalizePath :: FilePath -> Maybe FilePath
normalizePath = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FilePath] -> FilePath
FP.joinPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Eq a, IsString a) => [a] -> Maybe [a]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
FP.splitDirectories forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.normalise
 where
  go :: [a] -> Maybe [a]
go [] = forall a. a -> Maybe a
Just []
  go (a
"..":[a]
_) = forall a. Maybe a
Nothing
  go (a
_:a
"..":[a]
xs) = [a] -> Maybe [a]
go [a]
xs
  go (a
x:[a]
xs) = (a
x :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Maybe [a]
go [a]
xs

dirsFromFiles :: [FilePath] -> [FilePath]
dirsFromFiles :: [FilePath] -> [FilePath]
dirsFromFiles [FilePath]
dirs = forall a. Set a -> [a]
Set.toAscList (forall a. Ord a => a -> Set a -> Set a
Set.delete FilePath
"." Set FilePath
results)
 where
  results :: Set FilePath
results = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Set FilePath
s -> Set FilePath -> FilePath -> Set FilePath
go Set FilePath
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeDirectory) forall a. Set a
Set.empty [FilePath]
dirs
  go :: Set FilePath -> FilePath -> Set FilePath
go Set FilePath
s FilePath
x
    | forall a. Ord a => a -> Set a -> Bool
Set.member FilePath
x Set FilePath
s = Set FilePath
s
    | Bool
otherwise = Set FilePath -> FilePath -> Set FilePath
go (forall a. Ord a => a -> Set a -> Set a
Set.insert FilePath
x Set FilePath
s) (ShowS
FP.takeDirectory FilePath
x)

-- | Check package in given tarball. This will log all warnings

-- and will throw an exception in case of critical errors.

--

-- Note that we temporarily decompress the archive to analyze it.

checkSDistTarball ::
     HasEnvConfig env
  => SDistOpts -- ^ The configuration of what to check

  -> Path Abs File -- ^ Absolute path to tarball

  -> RIO env ()
checkSDistTarball :: forall env.
HasEnvConfig env =>
SDistOpts -> Path Abs File -> RIO env ()
checkSDistTarball SDistOpts
opts Path Abs File
tarball = forall env a.
Path Abs File -> (Path Abs Dir -> RIO env a) -> RIO env a
withTempTarGzContents Path Abs File
tarball forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
pkgDir' -> do
  Path Abs Dir
pkgDir  <- (Path Abs Dir
pkgDir' </>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeBaseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
FP.takeBaseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> FilePath
toFilePath forall a b. (a -> b) -> a -> b
$ Path Abs File
tarball)
  --               ^ drop ".tar"     ^ drop ".gz"

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SDistOpts -> Bool
sdoptsBuildTarball SDistOpts
opts)
    ( forall env. HasEnvConfig env => ResolvedPath Dir -> RIO env ()
buildExtractedTarball ResolvedPath
        { resolvedRelative :: RelFilePath
resolvedRelative = Text -> RelFilePath
RelFilePath Text
"this-is-not-used" -- ugly hack

        , resolvedAbsolute :: Path Abs Dir
resolvedAbsolute = Path Abs Dir
pkgDir
        }
    )
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SDistOpts -> Bool
sdoptsIgnoreCheck SDistOpts
opts) (forall env. HasEnvConfig env => Path Abs Dir -> RIO env ()
checkPackageInExtractedTarball Path Abs Dir
pkgDir)

checkPackageInExtractedTarball ::
     HasEnvConfig env
  => Path Abs Dir -- ^ Absolute path to tarball

  -> RIO env ()
checkPackageInExtractedTarball :: forall env. HasEnvConfig env => Path Abs Dir -> RIO env ()
checkPackageInExtractedTarball Path Abs Dir
pkgDir = do
  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
name, Path Abs File
_cabalfp) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (forall a. a -> Maybe a
Just Text
stackProgName') Path Abs Dir
pkgDir
  GenericPackageDescription
gpd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
YesPrintWarnings
  PackageConfig
config  <- forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasEnvConfig env) =>
m PackageConfig
getDefaultPackageConfig
  let PackageDescriptionPair PackageDescription
pkgDesc PackageDescription
_ = PackageConfig
-> GenericPackageDescription -> PackageDescriptionPair
resolvePackageDescription PackageConfig
config GenericPackageDescription
gpd
  forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ FilePath -> StyleDoc
flow FilePath
"Checking package"
    , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> FilePath
packageNameString PackageName
name)
    , FilePath -> StyleDoc
flow FilePath
"for common mistakes."
    ]
  let pkgChecks :: [PackageCheck]
pkgChecks =
        -- MSS 2017-12-12: Try out a few different variants of

        -- pkgDesc to try and provoke an error or warning. I don't

        -- know why, but when using `Just pkgDesc`, it appears that

        -- Cabal does not detect that `^>=` is used with

        -- `cabal-version: 1.24` or earlier. It seems like pkgDesc

        -- (the one we create) does not populate the `buildDepends`

        -- field, whereas flattenPackageDescription from Cabal

        -- does. In any event, using `Nothing` seems more logical

        -- for this check anyway, and the fallback to `Just pkgDesc`

        -- is just a crazy sanity check.

        case GenericPackageDescription
-> Maybe PackageDescription -> [PackageCheck]
Check.checkPackage GenericPackageDescription
gpd forall a. Maybe a
Nothing of
          [] -> GenericPackageDescription
-> Maybe PackageDescription -> [PackageCheck]
Check.checkPackage GenericPackageDescription
gpd (forall a. a -> Maybe a
Just PackageDescription
pkgDesc)
          [PackageCheck]
x -> [PackageCheck]
x
  [PackageCheck]
fileChecks <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck]
Check.checkPackageFiles forall a. Bounded a => a
minBound PackageDescription
pkgDesc (forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir)
  let checks :: [PackageCheck]
checks = [PackageCheck]
pkgChecks forall a. [a] -> [a] -> [a]
++ [PackageCheck]
fileChecks
      ([PackageCheck]
errors, [PackageCheck]
warnings) =
        let criticalIssue :: PackageCheck -> Bool
criticalIssue (Check.PackageBuildImpossible CheckExplanation
_) = Bool
True
            criticalIssue (Check.PackageDistInexcusable CheckExplanation
_) = Bool
True
            criticalIssue PackageCheck
_ = Bool
False
        in  forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition PackageCheck -> Bool
criticalIssue [PackageCheck]
checks
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageCheck]
warnings) forall a b. (a -> b) -> a -> b
$
    forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
         FilePath -> StyleDoc
flow FilePath
"Package check reported the following warnings:"
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => FilePath -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show) [PackageCheck]
warnings)
  case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [PackageCheck]
errors of
    Maybe (NonEmpty PackageCheck)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just NonEmpty PackageCheck
ne -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ NonEmpty PackageCheck -> SDistException
CheckException NonEmpty PackageCheck
ne

buildExtractedTarball :: HasEnvConfig env => ResolvedPath Dir -> RIO env ()
buildExtractedTarball :: forall env. HasEnvConfig env => ResolvedPath Dir -> RIO env ()
buildExtractedTarball ResolvedPath Dir
pkgDir = do
  EnvConfig
envConfig <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL
  LocalPackage
localPackageToBuild <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage forall a b. (a -> b) -> a -> b
$ forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
pkgDir
  -- We remove the path based on the name of the package

  let isPathToRemove :: Path Abs Dir -> RIO env Bool
isPathToRemove Path Abs Dir
path = do
        LocalPackage
localPackage <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env LocalPackage
readLocalPackage Path Abs Dir
path
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          forall a b. (a -> b) -> a -> b
$  Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
localPackage)
          forall a. Eq a => a -> a -> Bool
== Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
localPackageToBuild)
  Map PackageName ProjectPackage
pathsToKeep
    <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
     forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall k a. Map k a -> [(k, a)]
Map.toList (SMWanted -> Map PackageName ProjectPackage
smwProject (BuildConfig -> SMWanted
bcSMWanted (EnvConfig -> BuildConfig
envConfigBuildConfig EnvConfig
envConfig))))
     forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> RIO env Bool
isPathToRemove forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> ResolvedPath Dir
ppResolvedDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
  ProjectPackage
pp <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
YesPrintWarnings ResolvedPath Dir
pkgDir Bool
False
  let adjustEnvForBuild :: env -> env
adjustEnvForBuild env
env =
        let updatedEnvConfig :: EnvConfig
updatedEnvConfig = EnvConfig
envConfig
              { envConfigSourceMap :: SourceMap
envConfigSourceMap =
                  SourceMap -> SourceMap
updatePackagesInSourceMap (EnvConfig -> SourceMap
envConfigSourceMap EnvConfig
envConfig)
              , envConfigBuildConfig :: BuildConfig
envConfigBuildConfig =
                  BuildConfig -> BuildConfig
updateBuildConfig (EnvConfig -> BuildConfig
envConfigBuildConfig EnvConfig
envConfig)
              }
            updateBuildConfig :: BuildConfig -> BuildConfig
updateBuildConfig BuildConfig
bc = BuildConfig
bc
              { bcConfig :: Config
bcConfig = (BuildConfig -> Config
bcConfig BuildConfig
bc)
                 { configBuild :: BuildOpts
configBuild = BuildOpts
defaultBuildOpts { boptsTests :: Bool
boptsTests = Bool
True } }
              }
        in  forall s t a b. ASetter s t a b -> b -> s -> t
set forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL EnvConfig
updatedEnvConfig env
env
      updatePackagesInSourceMap :: SourceMap -> SourceMap
updatePackagesInSourceMap SourceMap
sm =
        SourceMap
sm {smProject :: Map PackageName ProjectPackage
smProject = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (CommonPackage -> PackageName
cpName forall a b. (a -> b) -> a -> b
$ ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp) ProjectPackage
pp Map PackageName ProjectPackage
pathsToKeep}
  forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local env -> env
adjustEnvForBuild forall a b. (a -> b) -> a -> b
$ forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
build forall a. Maybe a
Nothing

-- | Version of 'checkSDistTarball' that first saves lazy bytestring to

-- temporary directory and then calls 'checkSDistTarball' on it.

checkSDistTarball' ::
     HasEnvConfig env
  => SDistOpts
  -> String       -- ^ Tarball name

  -> L.ByteString -- ^ Tarball contents as a byte string

  -> RIO env ()
checkSDistTarball' :: forall env.
HasEnvConfig env =>
SDistOpts -> FilePath -> ByteString -> RIO env ()
checkSDistTarball' SDistOpts
opts FilePath
name ByteString
bytes = forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (Path Abs Dir -> m a) -> m a
withSystemTempDir FilePath
"stack" forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tpath -> do
  Path Abs File
npath   <- (Path Abs Dir
tpath </>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
name
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
L.writeFile (forall b t. Path b t -> FilePath
toFilePath Path Abs File
npath) ByteString
bytes
  forall env.
HasEnvConfig env =>
SDistOpts -> Path Abs File -> RIO env ()
checkSDistTarball SDistOpts
opts Path Abs File
npath

withTempTarGzContents ::
     Path Abs File
     -- ^ Location of tarball

  -> (Path Abs Dir -> RIO env a)
     -- ^ Perform actions given dir with tarball contents

  -> RIO env a
withTempTarGzContents :: forall env a.
Path Abs File -> (Path Abs Dir -> RIO env a) -> RIO env a
withTempTarGzContents Path Abs File
apath Path Abs Dir -> RIO env a
f = forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (Path Abs Dir -> m a) -> m a
withSystemTempDir FilePath
"stack" forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tpath -> do
  ByteString
archive <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
L.readFile (forall b t. Path b t -> FilePath
toFilePath Path Abs File
apath)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => FilePath -> Entries e -> IO ()
Tar.unpack (forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
tpath) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.decompress forall a b. (a -> b) -> a -> b
$ ByteString
archive
  Path Abs Dir -> RIO env a
f Path Abs Dir
tpath

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


-- Copy+modified from the tar package to avoid issues with lazy IO ( see

-- https://github.com/commercialhaskell/stack/issues/1344 )


packFileEntry :: FilePath -- ^ Full path to find the file on the local disk

              -> Tar.TarPath  -- ^ Path to use for the tar Entry in the archive

              -> IO Tar.Entry
packFileEntry :: FilePath -> TarPath -> IO Entry
packFileEntry FilePath
filepath TarPath
tarpath = do
  EpochTime
mtime   <- FilePath -> IO EpochTime
getModTime FilePath
filepath
  Permissions
perms   <- FilePath -> IO Permissions
getPermissions FilePath
filepath
  ByteString
content <- FilePath -> IO ByteString
S.readFile FilePath
filepath
  let size :: EpochTime
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
S.length ByteString
content)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (TarPath -> EntryContent -> Entry
Tar.simpleEntry TarPath
tarpath (ByteString -> EpochTime -> EntryContent
Tar.NormalFile (ByteString -> ByteString
L.fromStrict ByteString
content) EpochTime
size)) {
    entryPermissions :: Permissions
Tar.entryPermissions = if Permissions -> Bool
executable Permissions
perms
                             then Permissions
Tar.executableFilePermissions
                             else Permissions
Tar.ordinaryFilePermissions,
    entryTime :: EpochTime
Tar.entryTime = EpochTime
mtime
  }

getModTime :: FilePath -> IO Tar.EpochTime
getModTime :: FilePath -> IO EpochTime
getModTime FilePath
path = do
  UTCTime
t <- FilePath -> IO UTCTime
getModificationTime FilePath
path
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds forall a b. (a -> b) -> a -> b
$ UTCTime
t

getDefaultPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env)
  => m PackageConfig
getDefaultPackageConfig :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasEnvConfig env) =>
m PackageConfig
getDefaultPackageConfig = do
  Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
  ActualCompiler
compilerVersion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
  forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageConfig
    { packageConfigEnableTests :: Bool
packageConfigEnableTests = Bool
False
    , packageConfigEnableBenchmarks :: Bool
packageConfigEnableBenchmarks = Bool
False
    , packageConfigFlags :: Map FlagName Bool
packageConfigFlags = forall a. Monoid a => a
mempty
    , packageConfigGhcOptions :: [Text]
packageConfigGhcOptions = []
    , packageConfigCabalConfigOpts :: [Text]
packageConfigCabalConfigOpts = []
    , packageConfigCompilerVersion :: ActualCompiler
packageConfigCompilerVersion = ActualCompiler
compilerVersion
    , packageConfigPlatform :: Platform
packageConfigPlatform = Platform
platform
    }