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(..))
import Control.Monad (unless, void, liftM, filterM, foldM, when)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader.Class (local)
import Control.Monad.Trans.Control (liftBaseWith)
import Control.Monad.Trans.Unlift (MonadBaseUnlift)
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 (Data, Typeable, cast, gmapT)
import Data.Either (partitionEithers)
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.List
import Data.List.Extra (nubOrd)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, catMaybes)
import Data.Monoid ((<>))
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding 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 Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
import Distribution.Text (display)
import Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion)
import Distribution.Version.Extra
import Lens.Micro (set)
import Path
import Path.IO hiding (getModificationTime, getPermissions)
import Prelude
import Stack.Build (mkBaseConfigOpts, build)
import Stack.Build.Execute
import Stack.Build.Installed
import Stack.Build.Source (loadSourceMap, getDefaultPackageConfig)
import Stack.Build.Target
import Stack.Config (resolvePackageEntry, removePathFromPackageEntry)
import Stack.Constants
import Stack.Package
import Stack.Types.Build
import Stack.Types.Config
import Stack.Types.Package
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.StackT
import Stack.Types.StringError
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
, sdoptsSign :: Bool
, sdoptsSignServerUrl :: String
, sdoptsBuildTarball :: Bool
}
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
:: (StackM env m, HasEnvConfig env)
=> Maybe PvpBounds
-> Path Abs Dir
-> m (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
$logInfo $ "Getting file list for " <> T.pack pkgFp
(fileList, cabalfp) <- getSDistFileList lp
$logInfo $ "Building sdist tarball for " <> T.pack pkgFp
files <- normalizeTarballPaths (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) $ toFilePath cabalfp
liftIO (writeIORef cabalFileRevisionRef (Just lbsIdent))
packWith packFileEntry False fp
| tweakCabal && isCabalFp fp = do
(_ident, lbs) <- getCabalLbs pvpBounds Nothing $ toFilePath cabalfp
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 :: (StackM env m, HasEnvConfig env)
=> PvpBoundsType
-> Maybe Int
-> FilePath
-> m (PackageIdentifier, L.ByteString)
getCabalLbs pvpBounds mrev fp = do
bs <- liftIO $ S.readFile fp
(_warnings, gpd) <- readPackageUnresolvedBS Nothing bs
(_, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI
menv <- getMinimalEnvOverride
(installedMap, _, _, _) <- getInstalled menv GetInstalledOpts
{ getInstalledProfiling = False
, getInstalledHaddock = False
, getInstalledSymbols = False
}
sourceMap
let gpd' = gtraverseT (addBounds sourceMap 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 <- parsePackageIdentifierFromString $ display $ Cabal.package $ Cabal.packageDescription gpd''
return
( ident
, TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd''
)
where
addBounds :: SourceMap -> InstalledMap -> Dependency -> Dependency
addBounds sourceMap installedMap dep@(Dependency cname range) =
case lookupVersion (fromCabalPackageName cname) of
Nothing -> dep
Just version -> Dependency cname $ simplifyVersionRange
$ (if toAddUpper && not (hasUpper range) then addUpper version else id)
$ (if toAddLower && not (hasLower range) then addLower version else id)
range
where
lookupVersion name =
case Map.lookup name sourceMap of
Just (PSLocal lp) -> Just $ packageVersion $ lpPackage lp
Just (PSUpstream version _ _ _ _) -> Just version
Nothing ->
case Map.lookup name installedMap of
Just (_, installed) -> Just (installedVersion installed)
Nothing -> Nothing
addUpper version = intersectVersionRanges
(earlierVersion $ toCabalVersion $ nextMajorVersion version)
addLower version = intersectVersionRanges
(orLaterVersion (toCabalVersion 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 :: (StackM env m, HasEnvConfig env) => Path Abs Dir -> m LocalPackage
readLocalPackage pkgDir = do
cabalfp <- findOrGenerateCabalFile pkgDir
config <- getDefaultPackageConfig
(warnings,package) <- readPackage config cabalfp
mapM_ (printCabalFileWarning cabalfp) warnings
return LocalPackage
{ lpPackage = package
, lpWanted = False
, lpDir = pkgDir
, lpCabalFile = cabalfp
, lpTestDeps = Map.empty
, lpBenchDeps = Map.empty
, lpTestBench = Nothing
, lpForceDirty = False
, lpDirtyFiles = Nothing
, lpNewBuildCache = Map.empty
, lpFiles = Set.empty
, lpComponents = Set.empty
, lpUnbuildable = Set.empty
}
getSDistFileList :: (StackM env m, HasEnvConfig env) => LocalPackage -> m (String, Path Abs File)
getSDistFileList lp =
withSystemTempDir (stackProgName <> "-sdist") $ \tmpdir -> do
menv <- getMinimalEnvOverride
let bopts = defaultBuildOpts
let boptsCli = defaultBuildOptsCLI
baseConfigOpts <- mkBaseConfigOpts boptsCli
(locals, _) <- loadSourceMap NeedTargets boptsCli
runInBase <- liftBaseWith $ \run -> return (void . run)
withExecuteEnv menv bopts boptsCli baseConfigOpts locals
[] [] []
$ \ee ->
withSingleContext runInBase ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do
let outFile = toFilePath tmpdir FP.</> "source-files-list"
cabal KeepTHLoading ["sdist", "--list-sources", outFile]
contents <- liftIO (readFile outFile)
return (contents, cabalfp)
where
package = lpPackage lp
ac = ActionContext Set.empty []
task = Task
{ taskProvides = PackageIdentifier (packageName package) (packageVersion package)
, taskType = TTLocal lp
, taskConfigOpts = TaskConfigOpts
{ tcoMissing = Set.empty
, tcoOpts = \_ -> ConfigureOpts [] []
}
, taskPresent = Map.empty
, taskAllInOne = True
, taskCachePkgSrc = CacheSrcLocal (toFilePath (lpDir lp))
}
normalizeTarballPaths :: (StackM env m) => [FilePath] -> m [FilePath]
normalizeTarballPaths fps = do
unless (null outsideDir) $
$logWarn $ T.concat
[ "Warning: These files are outside of the package directory, and will be omitted from the tarball: "
, T.pack (show 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 :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)
=> SDistOpts
-> Path Abs File
-> m ()
checkSDistTarball opts tarball = withTempTarGzContents tarball $ \pkgDir' -> do
pkgDir <- (pkgDir' </>) `liftM`
(parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball)
when (sdoptsBuildTarball opts) (buildExtractedTarball pkgDir)
unless (sdoptsIgnoreCheck opts) (checkPackageInExtractedTarball pkgDir)
checkPackageInExtractedTarball :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)
=> Path Abs Dir
-> m ()
checkPackageInExtractedTarball pkgDir = do
cabalfp <- findOrGenerateCabalFile pkgDir
name <- parsePackageNameFromFilePath cabalfp
config <- getDefaultPackageConfig
(gdesc, pkgDesc) <- readPackageDescriptionDir config pkgDir
$logInfo $
"Checking package '" <> packageNameText name <> "' for common mistakes"
let pkgChecks = Check.checkPackage gdesc (Just pkgDesc)
fileChecks <- liftIO $ Check.checkPackageFiles 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" <>
T.pack (intercalate "\n" . fmap show $ warnings)
case NE.nonEmpty errors of
Nothing -> return ()
Just ne -> throwM $ CheckException ne
buildExtractedTarball :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) => Path Abs Dir -> m ()
buildExtractedTarball pkgDir = do
projectRoot <- view projectRootL
envConfig <- view envConfigL
menv <- getMinimalEnvOverride
localPackageToBuild <- readLocalPackage pkgDir
let packageEntries = bcPackageEntries (envConfigBuildConfig envConfig)
getPaths entry = do
resolvedEntry <- resolvePackageEntry menv projectRoot entry
return $ fmap fst resolvedEntry
allPackagePaths <- fmap mconcat (mapM getPaths packageEntries)
let isPathToRemove path = do
localPackage <- readLocalPackage path
return $ packageName (lpPackage localPackage) == packageName (lpPackage localPackageToBuild)
pathsToRemove <- filterM isPathToRemove allPackagePaths
let adjustPackageEntries entries path = do
adjustedPackageEntries <- mapM (removePathFromPackageEntry menv projectRoot path) entries
return (catMaybes adjustedPackageEntries)
entriesWithoutBuiltPackage <- foldM adjustPackageEntries packageEntries pathsToRemove
let newEntry = PackageEntry Nothing (PLFilePath (toFilePath pkgDir)) []
newPackagesRef <- liftIO (newIORef Nothing)
let adjustEnvForBuild env =
let updatedEnvConfig = envConfig
{envConfigPackagesRef = newPackagesRef
,envConfigBuildConfig = updatePackageInBuildConfig (envConfigBuildConfig envConfig)
}
in set envConfigL updatedEnvConfig env
updatePackageInBuildConfig buildConfig = buildConfig
{ bcPackageEntries = newEntry : entriesWithoutBuiltPackage
, bcConfig = (bcConfig buildConfig)
{ configBuild = defaultBuildOpts
{ boptsTests = True
}
}
}
local adjustEnvForBuild $
build (const (return ())) Nothing defaultBuildOptsCLI
checkSDistTarball' :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)
=> SDistOpts
-> String
-> L.ByteString
-> m ()
checkSDistTarball' opts name bytes = withSystemTempDir "stack" $ \tpath -> do
npath <- (tpath </>) `liftM` parseRelFile name
liftIO $ L.writeFile (toFilePath npath) bytes
checkSDistTarball opts npath
withTempTarGzContents :: (MonadIO m, MonadMask m)
=> Path Abs File
-> (Path Abs Dir -> m a)
-> m 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