module Stack.Build.Source
( loadSourceMap
, SourceMap
, PackageSource (..)
, getLocalFlags
, getGhcOptions
, getLocalPackageViews
, parseTargetsFromBuildOpts
, addUnlistedToBuildCache
, getDefaultPackageConfig
, getPackageConfig
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Exception (assert, catch)
import Control.Monad hiding (sequence)
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Resource
import "cryptohash" Crypto.Hash (Digest, SHA256)
import Crypto.Hash.Conduit (sinkHash)
import qualified Data.ByteString as S
import Data.Byteable (toBytes)
import Data.Conduit (($$), ZipSink (..))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Either
import Data.Function
import qualified Data.HashSet as HashSet
import Data.List
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Traversable (sequence)
import Distribution.Package (pkgName, pkgVersion)
import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription)
import qualified Distribution.PackageDescription as C
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Path.IO
import Prelude hiding (sequence)
import Stack.Build.Cache
import Stack.Build.Target
import Stack.BuildPlan (shadowMiniBuildPlan)
import Stack.Constants (wiredInPackages)
import Stack.Package
import Stack.PackageIndex (getPackageVersions)
import Stack.Types
import qualified System.Directory as D
import System.FilePath (takeFileName)
import System.IO (withBinaryFile, IOMode (ReadMode))
import System.IO.Error (isDoesNotExistError)
loadSourceMap :: (MonadIO m, MonadMask m, MonadReader env m, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)
=> NeedTargets
-> BuildOptsCLI
-> m ( Map PackageName SimpleTarget
, MiniBuildPlan
, [LocalPackage]
, Set PackageName
, SourceMap
)
loadSourceMap needTargets boptsCli = do
bconfig <- asks getBuildConfig
rawLocals <- getLocalPackageViews
(mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOpts needTargets boptsCli
extraDeps0 <- extendExtraDeps
(bcExtraDeps bconfig)
cliExtraDeps
(Map.keysSet $ Map.filter (== STUnknown) targets)
locals <- mapM (loadLocalPackage boptsCli targets) $ Map.toList rawLocals
checkFlagsUsed boptsCli locals extraDeps0 (mbpPackages mbp0)
checkComponentsBuildable locals
let
nonLocalTargets :: Set PackageName
nonLocalTargets =
Map.keysSet $ Map.filter (not . isLocal) targets
where
isLocal (STLocalComps _) = True
isLocal STLocalAll = True
isLocal STUnknown = False
isLocal STNonLocal = False
shadowed = Map.keysSet rawLocals <> Map.keysSet extraDeps0
(mbp, extraDeps1) = shadowMiniBuildPlan mbp0 shadowed
extraDeps2 = Map.union
(Map.map (\v -> (v, Map.empty, [])) extraDeps0)
(Map.map (\mpi -> (mpiVersion mpi, mpiFlags mpi, mpiGhcOptions mpi)) extraDeps1)
extraDeps3 = Map.mapWithKey
(\n (v, flags0, ghcOptions0) ->
let flags =
case ( Map.lookup (Just n) $ boptsCLIFlags boptsCli
, Map.lookup Nothing $ boptsCLIFlags boptsCli
, Map.lookup n $ unPackageFlags $ bcFlags bconfig
) of
(Nothing, Nothing, Nothing) -> flags0
(x, y, z) -> Map.unions
[ fromMaybe Map.empty x
, fromMaybe Map.empty y
, fromMaybe Map.empty z
]
ghcOptions =
ghcOptions0 ++
getGhcOptions bconfig boptsCli n False False
in PSUpstream v Local flags ghcOptions Nothing)
extraDeps2
let sourceMap = Map.unions
[ Map.fromList $ flip map locals $ \lp ->
let p = lpPackage lp
in (packageName p, PSLocal lp)
, extraDeps3
, flip fmap (mbpPackages mbp) $ \mpi ->
PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi) (mpiGhcOptions mpi) (mpiGitSHA1 mpi)
] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages))
return (targets, mbp, locals, nonLocalTargets, sourceMap)
getLocalFlags
:: BuildConfig
-> BuildOptsCLI
-> PackageName
-> Map FlagName Bool
getLocalFlags bconfig boptsCli name = Map.unions
[ Map.findWithDefault Map.empty (Just name) cliFlags
, Map.findWithDefault Map.empty Nothing cliFlags
, Map.findWithDefault Map.empty name (unPackageFlags (bcFlags bconfig))
]
where
cliFlags = boptsCLIFlags boptsCli
getGhcOptions :: BuildConfig -> BuildOptsCLI -> PackageName -> Bool -> Bool -> [Text]
getGhcOptions bconfig boptsCli name isTarget isLocal = concat
[ ghcOptionsFor name (configGhcOptions config)
, concat [["-fhpc"] | isLocal && toCoverage (boptsTestOpts bopts)]
, if (boptsLibProfile bopts || boptsExeProfile bopts)
then ["-auto-all","-caf-all"]
else []
, if includeExtraOptions
then boptsCLIGhcOptions boptsCli
else []
]
where
bopts = configBuild config
config = bcConfig bconfig
includeExtraOptions =
case configApplyGhcOptions config of
AGOTargets -> isTarget
AGOLocals -> isLocal
AGOEverything -> True
parseTargetsFromBuildOpts
:: (MonadIO m, MonadMask m, MonadReader env m, MonadLogger m, HasEnvConfig env)
=> NeedTargets
-> BuildOptsCLI
-> m (MiniBuildPlan, M.Map PackageName Version, M.Map PackageName SimpleTarget)
parseTargetsFromBuildOpts needTargets boptscli = do
bconfig <- asks getBuildConfig
mbp0 <-
case bcResolver bconfig of
ResolverCompiler _ -> do
version <- asks (envConfigCompilerVersion . getEnvConfig)
return MiniBuildPlan
{ mbpCompilerVersion = version
, mbpPackages = Map.empty
}
_ -> return (bcWantedMiniBuildPlan bconfig)
rawLocals <- getLocalPackageViews
workingDir <- getCurrentDir
let snapshot = mpiVersion <$> mbpPackages mbp0
flagExtraDeps <- convertSnapshotToExtra
snapshot
(bcExtraDeps bconfig)
rawLocals
(catMaybes $ Map.keys $ boptsCLIFlags boptscli)
(cliExtraDeps, targets) <-
parseTargets
needTargets
(bcImplicitGlobal bconfig)
snapshot
(flagExtraDeps <> bcExtraDeps bconfig)
(fst <$> rawLocals)
workingDir
(boptsCLITargets boptscli)
return (mbp0, cliExtraDeps <> flagExtraDeps, targets)
convertSnapshotToExtra
:: MonadLogger m
=> Map PackageName Version
-> Map PackageName Version
-> Map PackageName a
-> [PackageName]
-> m (Map PackageName Version)
convertSnapshotToExtra snapshot extra0 locals = go Map.empty
where
go !extra [] = return extra
go extra (flag:flags)
| Just _ <- Map.lookup flag extra0 = go extra flags
| flag `Map.member` locals = go extra flags
| otherwise = case Map.lookup flag snapshot of
Nothing -> go extra flags
Just version -> do
$logWarn $ T.concat
[ "- Implicitly adding "
, T.pack $ packageNameString flag
, " to extra-deps based on command line flag"
]
go (Map.insert flag version extra) flags
getLocalPackageViews :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m)
=> m (Map PackageName (LocalPackageView, GenericPackageDescription))
getLocalPackageViews = do
econfig <- asks getEnvConfig
locals <- forM (Map.toList $ envConfigPackages econfig) $ \(dir, treatLikeExtraDep) -> do
cabalfp <- findOrGenerateCabalFile dir
(warnings,gpkg) <- readPackageUnresolved cabalfp
mapM_ (printCabalFileWarning cabalfp) warnings
let cabalID = package $ packageDescription gpkg
name = fromCabalPackageName $ pkgName cabalID
checkCabalFileName name cabalfp
let lpv = LocalPackageView
{ lpvVersion = fromCabalVersion $ pkgVersion cabalID
, lpvRoot = dir
, lpvCabalFP = cabalfp
, lpvExtraDep = treatLikeExtraDep
, lpvComponents = getNamedComponents gpkg
}
return (name, (lpv, gpkg))
checkDuplicateNames locals
return $ Map.fromList locals
where
getNamedComponents gpkg = Set.fromList $ concat
[ maybe [] (const [CLib]) (C.condLibrary gpkg)
, go CExe C.condExecutables
, go CTest C.condTestSuites
, go CBench C.condBenchmarks
]
where
go wrapper f = map (wrapper . T.pack . fst) $ f gpkg
checkDuplicateNames :: MonadThrow m => [(PackageName, (LocalPackageView, gpd))] -> m ()
checkDuplicateNames locals =
case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map toPair locals of
[] -> return ()
x -> throwM $ DuplicateLocalPackageNames x
where
toPair (pn, (lpv, _)) = (pn, [lpvRoot lpv])
hasMultiples (_, _:_:_) = True
hasMultiples _ = False
splitComponents :: [NamedComponent]
-> (Set Text, Set Text, Set Text)
splitComponents =
go id id id
where
go a b c [] = (Set.fromList $ a [], Set.fromList $ b [], Set.fromList $ c [])
go a b c (CLib:xs) = go a b c xs
go a b c (CExe x:xs) = go (a . (x:)) b c xs
go a b c (CTest x:xs) = go a (b . (x:)) c xs
go a b c (CBench x:xs) = go a b (c . (x:)) xs
loadLocalPackage
:: forall m env.
(MonadReader env m, HasEnvConfig env, MonadMask m, MonadLogger m, MonadIO m)
=> BuildOptsCLI
-> Map PackageName SimpleTarget
-> (PackageName, (LocalPackageView, GenericPackageDescription))
-> m LocalPackage
loadLocalPackage boptsCli targets (name, (lpv, gpkg)) = do
let mtarget = Map.lookup name targets
config <- getPackageConfig boptsCli name (isJust mtarget) True
bopts <- asks (configBuild . getConfig)
let pkg = resolvePackage config gpkg
(exes, tests, benches) =
case mtarget of
Just (STLocalComps comps) -> splitComponents $ Set.toList comps
Just STLocalAll ->
( packageExes pkg
, if boptsTests bopts
then Map.keysSet (packageTests pkg)
else Set.empty
, if boptsBenchmarks bopts
then packageBenchmarks pkg
else Set.empty
)
Just STNonLocal -> assert False mempty
Just STUnknown -> assert False mempty
Nothing -> mempty
toComponents e t b = Set.unions
[ Set.map CExe e
, Set.map CTest t
, Set.map CBench b
]
btconfig = config
{ packageConfigEnableTests = not $ Set.null tests
, packageConfigEnableBenchmarks = not $ Set.null benches
}
testconfig = config
{ packageConfigEnableTests = True
, packageConfigEnableBenchmarks = False
}
benchconfig = config
{ packageConfigEnableTests = False
, packageConfigEnableBenchmarks = True
}
btpkg
| Set.null tests && Set.null benches = Nothing
| otherwise = Just (resolvePackage btconfig gpkg)
testpkg = resolvePackage testconfig gpkg
benchpkg = resolvePackage benchconfig gpkg
mbuildCache <- tryGetBuildCache $ lpvRoot lpv
(files,_) <- getPackageFilesSimple pkg (lpvCabalFP lpv)
(dirtyFiles, newBuildCache) <- checkBuildCache
(fromMaybe Map.empty mbuildCache)
(Set.toList files)
return LocalPackage
{ lpPackage = pkg
, lpTestDeps = packageDeps testpkg
, lpBenchDeps = packageDeps benchpkg
, lpTestBench = btpkg
, lpFiles = files
, lpForceDirty = boptsForceDirty bopts
, lpDirtyFiles =
if not (Set.null dirtyFiles)
then let tryStripPrefix y =
fromMaybe y (stripPrefix (toFilePath $ lpvRoot lpv) y)
in Just $ Set.map tryStripPrefix dirtyFiles
else Nothing
, lpNewBuildCache = newBuildCache
, lpCabalFile = lpvCabalFP lpv
, lpDir = lpvRoot lpv
, lpWanted = isJust mtarget
, lpComponents = toComponents exes tests benches
, lpUnbuildable = toComponents
(exes `Set.difference` packageExes pkg)
(tests `Set.difference` Map.keysSet (packageTests pkg))
(benches `Set.difference` packageBenchmarks pkg)
}
checkFlagsUsed :: (MonadThrow m, MonadReader env m, HasBuildConfig env)
=> BuildOptsCLI
-> [LocalPackage]
-> Map PackageName extraDeps
-> Map PackageName snapshot
-> m ()
checkFlagsUsed boptsCli lps extraDeps snapshot = do
bconfig <- asks getBuildConfig
let flags = map (, FSCommandLine) [(k, v) | (Just k, v) <- Map.toList $ boptsCLIFlags boptsCli]
++ map (, FSStackYaml) (Map.toList $ unPackageFlags $ bcFlags bconfig)
localNameMap = Map.fromList $ map (packageName . lpPackage &&& lpPackage) lps
checkFlagUsed ((name, userFlags), source) =
case Map.lookup name localNameMap of
Nothing ->
case Map.lookup name extraDeps of
Nothing ->
case Map.lookup name snapshot of
Nothing -> Just $ UFNoPackage source name
Just _ -> Just $ UFSnapshot name
Just _ -> Nothing
Just pkg ->
let unused = Set.difference (Map.keysSet userFlags) (packageDefinedFlags pkg)
in if Set.null unused
then Nothing
else Just $ UFFlagsNotDefined source pkg unused
unusedFlags = mapMaybe checkFlagUsed flags
unless (null unusedFlags)
$ throwM
$ InvalidFlagSpecification
$ Set.fromList unusedFlags
extendExtraDeps
:: (HasBuildConfig env, MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, MonadMask m)
=> Map PackageName Version
-> Map PackageName Version
-> Set PackageName
-> m (Map PackageName Version)
extendExtraDeps extraDeps0 cliExtraDeps unknowns = do
(errs, unknowns') <- fmap partitionEithers $ mapM addUnknown $ Set.toList unknowns
case errs of
[] -> return $ Map.unions $ extraDeps1 : unknowns'
_ -> do
bconfig <- asks getBuildConfig
throwM $ UnknownTargets
(Set.fromList errs)
Map.empty
(bcStackYaml bconfig)
where
extraDeps1 = Map.union extraDeps0 cliExtraDeps
addUnknown pn = do
case Map.lookup pn extraDeps1 of
Just _ -> return (Right Map.empty)
Nothing -> do
mlatestVersion <- getLatestVersion pn
case mlatestVersion of
Just v -> return (Right $ Map.singleton pn v)
Nothing -> return (Left pn)
getLatestVersion pn = do
vs <- getPackageVersions pn
return (fmap fst (Set.maxView vs))
checkBuildCache :: forall m. (MonadIO m)
=> Map FilePath FileCacheInfo
-> [Path Abs File]
-> m (Set FilePath, Map FilePath FileCacheInfo)
checkBuildCache oldCache files = do
fileTimes <- liftM Map.fromList $ forM files $ \fp -> do
mmodTime <- liftIO (getModTimeMaybe (toFilePath fp))
return (toFilePath fp, mmodTime)
liftM (mconcat . Map.elems) $ sequence $
Map.mergeWithKey
(\fp mmodTime fci -> Just (go fp mmodTime (Just fci)))
(Map.mapWithKey (\fp mmodTime -> go fp mmodTime Nothing))
(Map.mapWithKey (\fp fci -> go fp Nothing (Just fci)))
fileTimes
oldCache
where
go :: FilePath -> Maybe ModTime -> Maybe FileCacheInfo -> m (Set FilePath, Map FilePath FileCacheInfo)
go fp _ _ | takeFileName fp == "cabal_macros.h" = return (Set.empty, Map.empty)
go fp (Just modTime') (Just fci)
| fciModTime fci == modTime' = return (Set.empty, Map.empty)
| otherwise = do
newFci <- calcFci modTime' fp
let isDirty =
fciSize fci /= fciSize newFci ||
fciHash fci /= fciHash newFci
newDirty = if isDirty then Set.singleton fp else Set.empty
return (newDirty, Map.singleton fp newFci)
go fp Nothing _ = return (Set.singleton fp, Map.empty)
go fp (Just modTime') Nothing = do
newFci <- calcFci modTime' fp
return (Set.singleton fp, Map.singleton fp newFci)
addUnlistedToBuildCache
:: (MonadIO m, MonadReader env m, MonadMask m, MonadLogger m, HasEnvConfig env)
=> ModTime
-> Package
-> Path Abs File
-> Map FilePath a
-> m ([Map FilePath FileCacheInfo], [PackageWarning])
addUnlistedToBuildCache preBuildTime pkg cabalFP buildCache = do
(files,warnings) <- getPackageFilesSimple pkg cabalFP
let newFiles =
Set.toList $
Set.map toFilePath files `Set.difference` Map.keysSet buildCache
addBuildCache <- mapM addFileToCache newFiles
return (addBuildCache, warnings)
where
addFileToCache fp = do
mmodTime <- getModTimeMaybe fp
case mmodTime of
Nothing -> return Map.empty
Just modTime' ->
if modTime' < preBuildTime
then do
newFci <- calcFci modTime' fp
return (Map.singleton fp newFci)
else return Map.empty
getPackageFilesSimple
:: (MonadIO m, MonadReader env m, MonadMask m, MonadLogger m, HasEnvConfig env)
=> Package -> Path Abs File -> m (Set (Path Abs File), [PackageWarning])
getPackageFilesSimple pkg cabalFP = do
(_,compFiles,cabalFiles,warnings) <-
getPackageFiles (packageFiles pkg) cabalFP
return
( Set.map dotCabalGetPath (mconcat (M.elems compFiles)) <> cabalFiles
, warnings)
getModTimeMaybe :: MonadIO m => FilePath -> m (Maybe ModTime)
getModTimeMaybe fp =
liftIO
(catch
(liftM
(Just . modTime)
(D.getModificationTime fp))
(\e ->
if isDoesNotExistError e
then return Nothing
else throwM e))
calcFci :: MonadIO m => ModTime -> FilePath -> m FileCacheInfo
calcFci modTime' fp = liftIO $
withBinaryFile fp ReadMode $ \h -> do
(size, digest) <- CB.sourceHandle h $$ getZipSink
((,)
<$> ZipSink (CL.fold
(\x y -> x + fromIntegral (S.length y))
0)
<*> ZipSink sinkHash)
return FileCacheInfo
{ fciModTime = modTime'
, fciSize = size
, fciHash = toBytes (digest :: Digest SHA256)
}
checkComponentsBuildable :: MonadThrow m => [LocalPackage] -> m ()
checkComponentsBuildable lps =
unless (null unbuildable) $ throwM $ SomeTargetsNotBuildable unbuildable
where
unbuildable =
[ (packageName (lpPackage lp), c)
| lp <- lps
, c <- Set.toList (lpUnbuildable lp)
]
getDefaultPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env)
=> m PackageConfig
getDefaultPackageConfig = do
econfig <- asks getEnvConfig
bconfig <- asks getBuildConfig
return PackageConfig
{ packageConfigEnableTests = False
, packageConfigEnableBenchmarks = False
, packageConfigFlags = M.empty
, packageConfigGhcOptions = []
, packageConfigCompilerVersion = envConfigCompilerVersion econfig
, packageConfigPlatform = configPlatform $ getConfig bconfig
}
getPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env)
=> BuildOptsCLI
-> PackageName
-> Bool
-> Bool
-> m PackageConfig
getPackageConfig boptsCli name isTarget isLocal = do
econfig <- asks getEnvConfig
bconfig <- asks getBuildConfig
return PackageConfig
{ packageConfigEnableTests = False
, packageConfigEnableBenchmarks = False
, packageConfigFlags = getLocalFlags bconfig boptsCli name
, packageConfigGhcOptions = getGhcOptions bconfig boptsCli name isTarget isLocal
, packageConfigCompilerVersion = envConfigCompilerVersion econfig
, packageConfigPlatform = configPlatform $ getConfig bconfig
}