{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
module Stack.SDist
( getSDistTarball
, checkSDistTarball
, checkSDistTarball'
, SDistOpts (..)
) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import Control.Applicative
import Control.Concurrent.Execute (ActionContext(..), Concurrency(..))
import Stack.Prelude hiding (Display (..))
import Control.Monad.Reader.Class (local)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Char (toLower)
import Data.Data (cast)
import Data.List
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Time.Clock.POSIX
import Distribution.Package (Dependency (..))
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription.Check as Check
import qualified Distribution.PackageDescription.Parsec as Cabal
import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
import qualified Distribution.Types.UnqualComponentName as Cabal
import Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion, hasUpperBound, hasLowerBound)
import Lens.Micro (set)
import Path
import Path.IO hiding (getModificationTime, getPermissions, withSystemTempDir)
import RIO.PrettyPrint
import Stack.Build (mkBaseConfigOpts, build)
import Stack.Build.Execute
import Stack.Build.Installed
import Stack.Build.Source (projectLocalPackages)
import Stack.Package
import Stack.SourceMap
import Stack.Types.Build
import Stack.Types.Config
import Stack.Types.Package
import Stack.Types.SourceMap
import Stack.Types.Version
import System.Directory (getModificationTime, getPermissions)
import qualified System.FilePath as FP
data SDistOpts = SDistOpts
{ sdoptsDirsToWorkWith :: [String]
, sdoptsPvpBounds :: Maybe PvpBounds
, sdoptsIgnoreCheck :: Bool
, sdoptsBuildTarball :: Bool
, sdoptsTarPath :: Maybe FilePath
}
newtype CheckException
= CheckException (NonEmpty Check.PackageCheck)
deriving (Typeable)
instance Exception CheckException
instance Show CheckException where
show (CheckException xs) =
"Package check reported the following errors:\n" ++
(intercalate "\n" . fmap show . NE.toList $ xs)
getSDistTarball
:: HasEnvConfig env
=> Maybe PvpBounds
-> Path Abs Dir
-> RIO env (FilePath, L.ByteString, Maybe (PackageIdentifier, L.ByteString))
getSDistTarball mpvpBounds pkgDir = do
config <- view configL
let PvpBounds pvpBounds asRevision = fromMaybe (configPvpBounds config) mpvpBounds
tweakCabal = pvpBounds /= PvpBoundsNone
pkgFp = toFilePath pkgDir
lp <- readLocalPackage pkgDir
sourceMap <- view $ envConfigL.to envConfigSourceMap
logInfo $ "Getting file list for " <> fromString pkgFp
(fileList, cabalfp) <- getSDistFileList lp
logInfo $ "Building sdist tarball for " <> fromString pkgFp
files <- normalizeTarballPaths (map (T.unpack . stripCR . T.pack) (lines fileList))
cabalFileRevisionRef <- liftIO (newIORef Nothing)
let tarPath isDir fp = either throwString return
(Tar.toTarPath isDir (forceUtf8Enc (pkgId FP.</> fp)))
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
| tweakCabal && isCabalFp fp && asRevision = do
lbsIdent <- getCabalLbs pvpBounds (Just 1) cabalfp sourceMap
liftIO (writeIORef cabalFileRevisionRef (Just lbsIdent))
packWith packFileEntry False fp
| tweakCabal && isCabalFp fp = do
(_ident, lbs) <- getCabalLbs pvpBounds Nothing cabalfp sourceMap
currTime <- liftIO getPOSIXTime
tp <- liftIO $ tarPath False fp
return $ (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)
return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries)), mcabalFileRevision)
getCabalLbs :: HasEnvConfig env
=> PvpBoundsType
-> Maybe Int
-> Path Abs File
-> SourceMap
-> RIO env (PackageIdentifier, L.ByteString)
getCabalLbs pvpBounds mrev cabalfp sourceMap = do
(gpdio, _name, cabalfp') <- loadCabalFilePath (parent cabalfp)
gpd <- liftIO $ gpdio NoPrintWarnings
unless (cabalfp == cabalfp')
$ error $ "getCabalLbs: cabalfp /= cabalfp': " ++ show (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''
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 -> return ()
| 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 errs)
, ""
]
return
( ident
, TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd''
)
where
addBounds :: Set PackageName -> InstallMap -> InstalledMap -> Dependency -> Dependency
addBounds internalPackages installMap installedMap dep@(Dependency name range) =
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
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)
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)))
readLocalPackage :: HasEnvConfig env => Path Abs Dir -> RIO env LocalPackage
readLocalPackage pkgDir = do
config <- getDefaultPackageConfig
(gpdio, _, cabalfp) <- loadCabalFilePath pkgDir
gpd <- liftIO $ gpdio YesPrintWarnings
let package = resolvePackage config gpd
return LocalPackage
{ lpPackage = package
, lpWanted = False
, lpCabalFile = cabalfp
, lpTestDeps = Map.empty
, lpBenchDeps = Map.empty
, lpTestBench = Nothing
, lpBuildHaddocks = False
, lpForceDirty = False
, lpDirtyFiles = pure Nothing
, lpNewBuildCaches = pure Map.empty
, lpComponentFiles = pure Map.empty
, lpComponents = Set.empty
, lpUnbuildable = Set.empty
}
getSDistFileList :: HasEnvConfig env => LocalPackage -> RIO env (String, Path Abs File)
getSDistFileList lp =
withSystemTempDir (stackProgName <> "-sdist") $ \tmpdir -> do
let bopts = defaultBuildOpts
let boptsCli = defaultBuildOptsCLI
baseConfigOpts <- mkBaseConfigOpts boptsCli
locals <- projectLocalPackages
withExecuteEnv bopts boptsCli baseConfigOpts locals
[] [] [] Nothing
$ \ee ->
withSingleContext ac ee task Nothing (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)
return (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
unless (null outsideDir) $
logWarn $
"Warning: These files are outside of the package directory, and will be omitted from the tarball: " <>
displayShow outsideDir
return (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)
checkSDistTarball
:: HasEnvConfig env
=> SDistOpts
-> Path Abs File
-> RIO env ()
checkSDistTarball opts tarball = withTempTarGzContents tarball $ \pkgDir' -> do
pkgDir <- (pkgDir' </>) `liftM`
(parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball)
when (sdoptsBuildTarball opts) (buildExtractedTarball ResolvedPath
{ resolvedRelative = RelFilePath "this-is-not-used"
, resolvedAbsolute = pkgDir
})
unless (sdoptsIgnoreCheck opts) (checkPackageInExtractedTarball pkgDir)
checkPackageInExtractedTarball
:: HasEnvConfig env
=> Path Abs Dir
-> RIO env ()
checkPackageInExtractedTarball pkgDir = do
(gpdio, name, _cabalfp) <- loadCabalFilePath pkgDir
gpd <- liftIO $ gpdio YesPrintWarnings
config <- getDefaultPackageConfig
let PackageDescriptionPair pkgDesc _ = resolvePackageDescription config gpd
logInfo $
"Checking package '" <> fromString (packageNameString name) <> "' for common mistakes"
let pkgChecks =
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 partition criticalIssue checks
unless (null warnings) $
logWarn $ "Package check reported the following warnings:\n" <>
mconcat (intersperse "\n" . fmap displayShow $ warnings)
case NE.nonEmpty errors of
Nothing -> return ()
Just ne -> throwM $ CheckException ne
buildExtractedTarball :: HasEnvConfig env => ResolvedPath Dir -> RIO env ()
buildExtractedTarball pkgDir = do
envConfig <- view envConfigL
localPackageToBuild <- readLocalPackage $ resolvedAbsolute pkgDir
let isPathToRemove path = do
localPackage <- readLocalPackage path
return $ 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
checkSDistTarball'
:: HasEnvConfig env
=> SDistOpts
-> String
-> L.ByteString
-> 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
-> (Path Abs Dir -> RIO env a)
-> 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
packFileEntry :: FilePath
-> Tar.TarPath
-> IO Tar.Entry
packFileEntry filepath tarpath = do
mtime <- getModTime filepath
perms <- getPermissions filepath
content <- S.readFile filepath
let size = fromIntegral (S.length content)
return (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
return . floor . utcTimeToPOSIXSeconds $ t
getDefaultPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env)
=> m PackageConfig
getDefaultPackageConfig = do
platform <- view platformL
compilerVersion <- view actualCompilerVersionL
return PackageConfig
{ packageConfigEnableTests = False
, packageConfigEnableBenchmarks = False
, packageConfigFlags = mempty
, packageConfigGhcOptions = []
, packageConfigCabalConfigOpts = []
, packageConfigCompilerVersion = compilerVersion
, packageConfigPlatform = platform
}