stack-2.9.3: src/Stack/SDist.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
-- Create a source distribution tarball
module Stack.SDist
( getSDistTarball
, checkSDistTarball
, checkSDistTarball'
, SDistOpts (..)
) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import Control.Applicative
import Control.Concurrent.Execute
( ActionContext (..), Concurrency (..) )
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Char ( toLower )
import Data.Data ( cast )
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Time.Clock.POSIX
import Distribution.Package ( Dependency (..) )
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription.Check as Check
import qualified Distribution.PackageDescription.Parsec as Cabal
import Distribution.PackageDescription.PrettyPrint
( showGenericPackageDescription )
import Distribution.Version
( simplifyVersionRange, orLaterVersion, earlierVersion
, hasUpperBound, hasLowerBound
)
import Path
import Path.IO
hiding
( getModificationTime, getPermissions, withSystemTempDir )
import Stack.Build ( mkBaseConfigOpts, build, buildLocalTargets )
import Stack.Build.Execute
import Stack.Build.Installed
import Stack.Build.Source ( projectLocalPackages )
import Stack.Package
import Stack.Prelude hiding ( Display (..) )
import Stack.SourceMap
import Stack.Types.Build
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.Package
import Stack.Types.SourceMap
import Stack.Types.Version
import System.Directory ( getModificationTime, getPermissions )
import qualified System.FilePath as FP
-- | 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 (Show, Typeable)
instance Exception SDistException where
displayException (CheckException xs) = unlines $
[ "Error: [S-6439]"
, "Package check reported the following errors:"
] <> fmap show (NE.toList xs)
displayException (CabalFilePathsInconsistentBug cabalfp cabalfp') = concat
[ "Error: [S-9595]\n"
, "The impossible happened! Two Cabal file paths are inconsistent: "
, show (cabalfp, cabalfp')
]
displayException (ToTarPathException e) =
"Error: [S-7875\n"
++ e
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
}
-- | 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 ->
logWarn "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]
logInfo $ "Getting file list for " <> fromString pkgFp
(fileList, cabalfp) <- getSDistFileList lp deps
logInfo $ "Building sdist tarball for " <> 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 -> throwIO $ 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') $
throwIO $ 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 =
[ flow "Bug detected in Cabal library. ((parse . render . parse) === \
\id) does not hold for the Cabal file at"
<+> pretty cabalfp
, ""
]
(_warnings, eres) = Cabal.runParseResult
$ Cabal.parseGenericPackageDescription
$ T.encodeUtf8
$ T.pack
$ showGenericPackageDescription gpd
case eres of
Right roundtripped
| roundtripped == gpd -> pure ()
| otherwise -> do
prettyWarn $ vsep $ roundtripErrs ++
[ "This seems to be fixed in development versions of Cabal, but \
\at time of writing, the fix is not in any released versions."
, ""
, "Please see this GitHub issue for status:" <+> style Url "https://github.com/commercialhaskell/stack/issues/3549"
, ""
, 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."
]
, ""
, 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"
]
, ""
, flow "If the issue is not fixed, feel free to leave a comment \
\on it indicating that you would like it to be fixed."
, ""
]
Left (_version, errs) -> do
prettyWarn $ vsep $ 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"
, bulletedList
[ style Url "https://github.com/commercialhaskell/stack/issues/new"
, style Url "https://github.com/haskell/cabal/issues/new"
]
, flow $ "The parse error is: " ++ unlines (map show (toList errs))
, ""
]
pure
( ident
, TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd''
)
where
addBounds :: Set PackageName -> InstallMap -> InstalledMap -> Dependency -> Dependency
addBounds internalPackages installMap installedMap dep@(Dependency name range s) =
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)
$ (if toAddLower && not (hasLowerBound range) then addLower version else id)
range) s
where
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 => [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) $
logWarn $
"Warning: These files are outside of the package directory, and will be omitted from the tarball: " <>
displayShow 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' </>) `liftM`
(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
logInfo $
"Checking package '" <> fromString (packageNameString name) <> "' 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) $
logWarn $ "Package check reported the following warnings:\n" <>
mconcat (List.intersperse "\n" . fmap displayShow $ warnings)
case NE.nonEmpty errors of
Nothing -> pure ()
Just ne -> throwM $ 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
<- fmap Map.fromList
$ flip filterM (Map.toList (smwProject (bcSMWanted (envConfigBuildConfig envConfig))))
$ fmap not . isPathToRemove . resolvedAbsolute . ppResolvedDir . snd
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 </>) `liftM` 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)
pure (Tar.simpleEntry tarpath (Tar.NormalFile (L.fromStrict content) size)) {
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
}