{-# 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
                   ( earlierVersion, hasLowerBound, hasUpperBound, isAnyVersion
                   , orLaterVersion, simplifyVersionRange
                   )
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 \'pretty\' exceptions thrown by functions exported by the
-- "Stack.SDist" module.
data SDistPrettyException
  = CheckException (NonEmpty Check.PackageCheck)
  | CabalFilePathsInconsistentBug (Path Abs File) (Path Abs File)
  | ToTarPathException String
  deriving (Show, Typeable)

instance Pretty SDistPrettyException where
  pretty (CheckException xs) =
    "[S-6439]"
    <> line
    <> flow "Package check reported the following errors:"
    <> line
    <> bulletedList (map (string . show) (NE.toList xs) :: [StyleDoc])
  pretty (CabalFilePathsInconsistentBug cabalfp cabalfp') =
    "[S-9595]"
    <> line
    <> fillSep
         [ flow "The impossible happened! Two Cabal file paths are \
                \inconsistent:"
         , pretty cabalfp
         , "and"
         , pretty cabalfp' <> "."
         ]
  pretty (ToTarPathException e) =
    "[S-7875]"
    <> line
    <> string e

instance Exception SDistPrettyException

-- | Type representing command line options for @stack sdist@ command.
data SDistOpts = SDistOpts
  { sdoptsDirsToWorkWith :: [String]
  -- ^ Directories to package
  , sdoptsPvpBounds :: Maybe PvpBounds
  -- ^ PVP Bounds overrides
  , sdoptsIgnoreCheck :: Bool
  -- ^ Whether to ignore check of the package for common errors
  , sdoptsBuildTarball :: Bool
  -- ^ Whether to build the tarball
  , sdoptsTarPath :: Maybe FilePath
  -- ^ Where to copy the tarball
  }

-- | Function underlying the @stack sdist@ command.
sdistCmd :: SDistOpts -> RIO Runner ()
sdistCmd sdistOpts =
  withConfig YesReexec $ withDefaultEnvConfig $ do
    -- If no directories are specified, build all sdist tarballs.
    dirs' <- if null (sdoptsDirsToWorkWith sdistOpts)
      then do
        dirs <- view $
          buildConfigL.to (map ppRoot . Map.elems . smwProject . bcSMWanted)
        when (null dirs) $ do
          stackYaml <- view stackYamlL
          prettyErrorL
            [ style Shell "stack sdist"
            , flow "expects a list of targets, and otherwise defaults to all \
                   \of the project's packages. However, the configuration at"
            , pretty stackYaml
            , flow "contains no packages, so no sdist tarballs will be \
                   \generated."
            ]
          exitFailure
        pure dirs
      else mapM resolveDir' (sdoptsDirsToWorkWith sdistOpts)
    forM_ dirs' $ \dir -> do
      (tarName, tarBytes, _mcabalRevision) <-
        getSDistTarball (sdoptsPvpBounds sdistOpts) dir
      distDir <- distDirFromDir dir
      tarPath <- (distDir </>) <$> parseRelFile tarName
      ensureDir (parent tarPath)
      runConduitRes $
        sourceLazy tarBytes .|
        sinkFileCautious (toFilePath tarPath)
      prettyInfoL
        [flow "Wrote sdist-format compressed archive to"
        , pretty tarPath <> "."
        ]
      checkSDistTarball sdistOpts tarPath
      forM_ (sdoptsTarPath sdistOpts) $ copyTarToTarPath tarPath tarName
 where
  copyTarToTarPath tarPath tarName targetDir = liftIO $ do
    let targetTarPath = targetDir FP.</> tarName
    createDirectoryIfMissing True $ FP.takeDirectory targetTarPath
    copyFile (toFilePath tarPath) 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 mpvpBounds pkgDir = do
  config <- view configL
  let PvpBounds pvpBounds asRevision =
        fromMaybe (configPvpBounds config) mpvpBounds
      tweakCabal = pvpBounds /= PvpBoundsNone
      pkgFp = toFilePath pkgDir
  lp <- readLocalPackage pkgDir
  forM_ (packageSetupDeps (lpPackage lp)) $ \customSetupDeps ->
    case NE.nonEmpty (map (T.pack . packageNameString) (Map.keys customSetupDeps)) of
      Just nonEmptyDepTargets -> do
        eres <- buildLocalTargets nonEmptyDepTargets
        case eres of
          Left err ->
            logError $
              "Error: [S-8399]\n" <>
              "Error building custom-setup dependencies: " <>
              displayShow err
          Right _ ->
            pure ()
      Nothing ->
        prettyWarnS "unexpected empty custom-setup dependencies."
  sourceMap <- view $ envConfigL.to envConfigSourceMap
  installMap <- toInstallMap sourceMap
  (installedMap, _globalDumpPkgs, _snapshotDumpPkgs, _localDumpPkgs) <-
    getInstalled installMap
  let deps = Map.fromList
        [ (pid, ghcPkgId)
        | (_, Library pid ghcPkgId _) <- Map.elems installedMap]
  prettyInfoL
    [ flow "Getting the file list for"
    , style File (fromString  pkgFp) <> "."
    ]
  (fileList, cabalfp) <- getSDistFileList lp deps
  prettyInfoL
    [ flow "Building a compressed archive file in the sdist format for"
    , style File (fromString pkgFp) <> "."
    ]
  files <-
    normalizeTarballPaths (map (T.unpack . stripCR . T.pack) (lines 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.
  cabalFileRevisionRef <- liftIO (newIORef 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 isDir fp =
        case Tar.toTarPath isDir (forceUtf8Enc (pkgId FP.</> fp)) of
          Left e -> prettyThrowIO $ ToTarPathException e
          Right tp -> pure 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 = S8.unpack . T.encodeUtf8 . T.pack
      packWith f isDir fp = liftIO $ f (pkgFp FP.</> fp) =<< tarPath isDir fp
      packDir = packWith Tar.packDirectoryEntry True
      packFile fp
        -- This is a Cabal file, we're going to tweak it, but only tweak it as a
        -- revision.
        | tweakCabal && isCabalFp fp && asRevision = do
            lbsIdent <- getCabalLbs pvpBounds (Just 1) cabalfp sourceMap
            liftIO (writeIORef cabalFileRevisionRef (Just lbsIdent))
            packWith packFileEntry False fp
        -- Same, except we'll include the Cabal file in the original tarball
        -- upload.
        | tweakCabal && isCabalFp fp = do
            (_ident, lbs) <- getCabalLbs pvpBounds Nothing cabalfp sourceMap
            currTime <- liftIO getPOSIXTime -- Seconds from UNIX epoch
            tp <- liftIO $ tarPath False fp
            pure $ (Tar.fileEntry tp lbs) { Tar.entryTime = floor currTime }
        | otherwise = packWith packFileEntry False fp
      isCabalFp fp = toFilePath pkgDir FP.</> fp == toFilePath cabalfp
      tarName = pkgId FP.<.> "tar.gz"
      pkgId = packageIdentifierString (packageIdentifier (lpPackage lp))
  dirEntries <- mapM packDir (dirsFromFiles files)
  fileEntries <- mapM packFile files
  mcabalFileRevision <- liftIO (readIORef cabalFileRevisionRef)
  pure
    ( tarName
    , GZip.compress (Tar.write (dirEntries ++ fileEntries))
    , 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 pvpBounds mrev cabalfp sourceMap = do
  (gpdio, _name, cabalfp') <-
    loadCabalFilePath (Just stackProgName') (parent cabalfp)
  gpd <- liftIO $ gpdio NoPrintWarnings
  unless (cabalfp == cabalfp') $
    prettyThrowIO $ CabalFilePathsInconsistentBug cabalfp cabalfp'
  installMap <- toInstallMap sourceMap
  (installedMap, _, _, _) <- getInstalled installMap
  let internalPackages = Set.fromList $
          gpdPackageName gpd
        : map
            (Cabal.unqualComponentNameToPackageName . fst)
            (Cabal.condSubLibraries gpd)
      gpd' = gtraverseT (addBounds internalPackages installMap installedMap) gpd
      gpd'' =
        case mrev of
          Nothing -> gpd'
          Just rev -> gpd'
            { Cabal.packageDescription
             = (Cabal.packageDescription gpd')
                { Cabal.customFieldsPD
                = (("x-revision", show rev):)
                $ filter (\(x, _) -> map toLower x /= "x-revision")
                $ Cabal.customFieldsPD
                $ Cabal.packageDescription gpd'
                }
            }
      ident = Cabal.package $ Cabal.packageDescription 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 =
           fillSep
             [ flow "Bug detected in Cabal library. ((parse . render . parse) \
                    \=== id) does not hold for the Cabal file at"
             , pretty cabalfp
             ]
        <> blankLine
      (_warnings, eres) = Cabal.runParseResult
                        $ Cabal.parseGenericPackageDescription
                        $ T.encodeUtf8
                        $ T.pack
                        $ showGenericPackageDescription gpd
  case eres of
    Right roundtripped
      | roundtripped == gpd -> pure ()
      | otherwise -> prettyWarn $
             roundtripErrs
          <> flow "This seems to be fixed in development versions of Cabal, \
                  \but at time of writing, the fix is not in any released \
                  \versions."
          <> blankLine
          <> fillSep
               [ flow "Please see this GitHub issue for status:"
               , style Url "https://github.com/commercialhaskell/stack/issues/3549"
               ]
          <> blankLine
          <> fillSep
               [ flow "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 Shell "stack upgrade"
               , flow "for latest stable version or"
               , style Shell "stack upgrade --git"
               , flow "for the latest development version."
               ]
          <> blankLine
          <> fillSep
               [ flow "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 Url "https://github.com/commercialhaskell/stack/issues/new"
               ]
          <> blankLine
          <> flow "If the issue is not fixed, feel free to leave a comment \
                  \on it indicating that you would like it to be fixed."
          <> blankLine
    Left (_version, errs) -> prettyWarn $
         roundtripErrs
      <> flow "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"
      <> line
      <> bulletedList
           [ style Url "https://github.com/commercialhaskell/stack/issues/new"
           , style Url "https://github.com/haskell/cabal/issues/new"
           ]
      <> line
      <> flow ("The parse error is: " <> unlines (map show (toList errs)))
      <> blankLine
  pure
    ( ident
    , TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd''
    )
 where
  addBounds ::
       Set PackageName
    -> InstallMap
    -> InstalledMap
    -> Dependency
    -> Dependency
  addBounds internalPackages installMap installedMap dep =
    if name `Set.member` internalPackages
      then dep
      else case foundVersion of
        Nothing -> dep
        Just version -> Dependency
          name
          ( simplifyVersionRange
          $ ( if toAddUpper && not (hasUpperBound range)
                then addUpper version
                else id
            )
            -- From Cabal-3.4.0.0, 'hasLowerBound isAnyVersion' is 'True'.
          $ ( if    toAddLower
                 && (isAnyVersion range || not (hasLowerBound range))
                then addLower version
                else id
            )
            range
          )
          s
   where
    Dependency name range s = dep
    foundVersion =
      case Map.lookup name installMap of
        Just (_, version) -> Just version
        Nothing ->
          case Map.lookup name installedMap of
            Just (_, installed) -> Just (installedVersion installed)
            Nothing -> Nothing

  addUpper version = intersectVersionRanges
      (earlierVersion $ nextMajorVersion version)
  addLower version = intersectVersionRanges (orLaterVersion version)

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

-- | Traverse a data type.
gtraverseT :: (Data a,Typeable b) => (Typeable b => b -> b) -> a -> a
gtraverseT f =
  gmapT (\x -> case cast x of
                 Nothing -> gtraverseT f x
                 Just b  -> fromMaybe x (cast (f 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 pkgDir = do
  config  <- getDefaultPackageConfig
  (gpdio, _, cabalfp) <- loadCabalFilePath (Just stackProgName') pkgDir
  gpd <- liftIO $ gpdio YesPrintWarnings
  let package = resolvePackage config gpd
  pure LocalPackage
    { lpPackage = package
    , lpWanted = False -- HACK: makes it so that sdist output goes to a log
                       -- instead of a file.
    , lpCabalFile = cabalfp
    -- NOTE: these aren't the 'correct values, but aren't used in
    -- the usage of this function in this module.
    , lpTestBench = Nothing
    , lpBuildHaddocks = False
    , lpForceDirty = False
    , lpDirtyFiles = pure Nothing
    , lpNewBuildCaches = pure Map.empty
    , lpComponentFiles = pure Map.empty
    , lpComponents = Set.empty
    , lpUnbuildable = 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 lp deps =
  withSystemTempDir (stackProgName <> "-sdist") $ \tmpdir -> do
    let bopts = defaultBuildOpts
    let boptsCli = defaultBuildOptsCLI
    baseConfigOpts <- mkBaseConfigOpts boptsCli
    locals <- projectLocalPackages
    withExecuteEnv bopts boptsCli baseConfigOpts locals
      [] [] [] Nothing -- provide empty list of globals. This is a hack around
                       -- custom Setup.hs files
      $ \ee ->
      withSingleContext ac ee task deps (Just "sdist") $
        \_package cabalfp _pkgDir cabal _announce _outputType -> do
          let outFile = toFilePath tmpdir FP.</> "source-files-list"
          cabal
            CloseOnException
            KeepTHLoading
            ["sdist", "--list-sources", outFile]
          contents <- liftIO (S.readFile outFile)
          pure (T.unpack $ T.decodeUtf8With T.lenientDecode contents, cabalfp)
 where
  package = lpPackage lp
  ac = ActionContext Set.empty [] ConcurrencyAllowed
  task = Task
    { taskProvides =
        PackageIdentifier (packageName package) (packageVersion package)
    , taskType = TTLocalMutable lp
    , taskConfigOpts = TaskConfigOpts
        { tcoMissing = Set.empty
        , tcoOpts = \_ -> ConfigureOpts [] []
        }
    , taskBuildHaddock = False
    , taskPresent = Map.empty
    , taskAllInOne = True
    , taskCachePkgSrc = CacheSrcLocal (toFilePath (parent $ lpCabalFile lp))
    , taskAnyMissing = True
    , taskBuildTypeConfig = False
    }

normalizeTarballPaths ::
     (HasRunner env, HasTerm env)
  => [FilePath]
  -> RIO env [FilePath]
normalizeTarballPaths fps = do
  -- TODO: consider whether erroring out is better - otherwise the user might
  -- upload an incomplete tar?
  unless (null outsideDir) $
    prettyWarn $
         flow "These files are outside of the package directory, and will be \
              \omitted from the tarball:"
      <> line
      <> bulletedList (map (style File . fromString) outsideDir)
  pure (nubOrd files)
 where
  (outsideDir, files) = partitionEithers (map pathToEither fps)
  pathToEither fp = maybe (Left fp) Right (normalizePath fp)

normalizePath :: FilePath -> Maybe FilePath
normalizePath = fmap FP.joinPath . go . FP.splitDirectories . FP.normalise
 where
  go [] = Just []
  go ("..":_) = Nothing
  go (_:"..":xs) = go xs
  go (x:xs) = (x :) <$> go xs

dirsFromFiles :: [FilePath] -> [FilePath]
dirsFromFiles dirs = Set.toAscList (Set.delete "." results)
 where
  results = foldl' (\s -> go s . FP.takeDirectory) Set.empty dirs
  go s x
    | Set.member x s = s
    | otherwise = go (Set.insert x s) (FP.takeDirectory 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 opts tarball = withTempTarGzContents tarball $ \pkgDir' -> do
  pkgDir <- (pkgDir' </>) <$>
    (parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball)
  --               ^ drop ".tar"     ^ drop ".gz"
  when (sdoptsBuildTarball opts)
    ( buildExtractedTarball ResolvedPath
        { resolvedRelative = RelFilePath "this-is-not-used" -- ugly hack
        , resolvedAbsolute = pkgDir
        }
    )
  unless (sdoptsIgnoreCheck opts) (checkPackageInExtractedTarball pkgDir)

checkPackageInExtractedTarball ::
     HasEnvConfig env
  => Path Abs Dir -- ^ Absolute path to tarball
  -> RIO env ()
checkPackageInExtractedTarball pkgDir = do
  (gpdio, name, _cabalfp) <- loadCabalFilePath (Just stackProgName') pkgDir
  gpd <- liftIO $ gpdio YesPrintWarnings
  config <- getDefaultPackageConfig
  let PackageDescriptionPair pkgDesc _ = resolvePackageDescription config gpd
  prettyInfoL
    [ flow "Checking package"
    , style Current (fromString $ packageNameString name)
    , flow "for common mistakes."
    ]
  let 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 Check.checkPackage gpd Nothing of
          [] -> Check.checkPackage gpd (Just pkgDesc)
          x -> x
  fileChecks <-
    liftIO $ Check.checkPackageFiles minBound pkgDesc (toFilePath pkgDir)
  let checks = pkgChecks ++ fileChecks
      (errors, warnings) =
        let criticalIssue (Check.PackageBuildImpossible _) = True
            criticalIssue (Check.PackageDistInexcusable _) = True
            criticalIssue _ = False
        in  List.partition criticalIssue checks
  unless (null warnings) $
    prettyWarn $
         flow "Package check reported the following warnings:"
      <> line
      <> bulletedList (map (fromString . show) warnings)
  case NE.nonEmpty errors of
    Nothing -> pure ()
    Just ne -> prettyThrowM $ CheckException ne

buildExtractedTarball :: HasEnvConfig env => ResolvedPath Dir -> RIO env ()
buildExtractedTarball pkgDir = do
  envConfig <- view envConfigL
  localPackageToBuild <- readLocalPackage $ resolvedAbsolute pkgDir
  -- We remove the path based on the name of the package
  let isPathToRemove path = do
        localPackage <- readLocalPackage path
        pure
          $  packageName (lpPackage localPackage)
          == packageName (lpPackage localPackageToBuild)
  pathsToKeep <- Map.fromList <$> filterM
    (fmap not . isPathToRemove . resolvedAbsolute . ppResolvedDir . snd)
    (Map.toList (smwProject (bcSMWanted (envConfigBuildConfig envConfig))))
  pp <- mkProjectPackage YesPrintWarnings pkgDir False
  let adjustEnvForBuild env =
        let updatedEnvConfig = envConfig
              { envConfigSourceMap =
                  updatePackagesInSourceMap (envConfigSourceMap envConfig)
              , envConfigBuildConfig =
                  updateBuildConfig (envConfigBuildConfig envConfig)
              }
            updateBuildConfig bc = bc
              { bcConfig = (bcConfig bc)
                 { configBuild = defaultBuildOpts { boptsTests = True } }
              }
        in  set envConfigL updatedEnvConfig env
      updatePackagesInSourceMap sm =
        sm {smProject = Map.insert (cpName $ ppCommon pp) pp pathsToKeep}
  local adjustEnvForBuild $ build 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' opts name bytes = withSystemTempDir "stack" $ \tpath -> do
  npath <- (tpath </>) <$> parseRelFile name
  liftIO $ L.writeFile (toFilePath npath) bytes
  checkSDistTarball opts 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 apath f = withSystemTempDir "stack" $ \tpath -> do
  archive <- liftIO $ L.readFile (toFilePath apath)
  liftIO . Tar.unpack (toFilePath tpath) . Tar.read . GZip.decompress $ archive
  f 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 = do
  mtime <- getModTime filepath
  perms <- getPermissions filepath
  content <- S.readFile filepath
  let size = fromIntegral (S.length content)
      entryContent = Tar.NormalFile (L.fromStrict content) size
      entry = Tar.simpleEntry tarpath entryContent
  pure entry
    { Tar.entryPermissions = if executable perms
                               then Tar.executableFilePermissions
                               else Tar.ordinaryFilePermissions
    , Tar.entryTime = mtime
    }

getModTime :: FilePath -> IO Tar.EpochTime
getModTime path = do
  t <- getModificationTime path
  pure $ floor . utcTimeToPOSIXSeconds $ t

getDefaultPackageConfig ::
     (MonadIO m, MonadReader env m, HasEnvConfig env)
  => m PackageConfig
getDefaultPackageConfig = do
  platform <- view platformL
  compilerVersion <- view actualCompilerVersionL
  pure PackageConfig
    { packageConfigEnableTests = False
    , packageConfigEnableBenchmarks = False
    , packageConfigFlags = mempty
    , packageConfigGhcOptions = []
    , packageConfigCabalConfigOpts = []
    , packageConfigCompilerVersion = compilerVersion
    , packageConfigPlatform = platform
    }