module Stack.Build.Source
( loadSourceMap
, SourceMap
, PackageSource (..)
, localFlags
, getLocalPackageViews
, loadLocalPackage
, parseTargetsFromBuildOpts
, addUnlistedToBuildCache
, getPackageConfig
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Exception (assert, catch)
import Control.Monad
import Control.Monad.Catch (MonadCatch)
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 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
import Stack.Build.Cache
import Stack.Build.Target
import Stack.BuildPlan (loadMiniBuildPlan, shadowMiniBuildPlan,
parseCustomMiniBuildPlan)
import Stack.Constants (wiredInPackages)
import Stack.Package
import Stack.Types
import qualified System.Directory as D
import System.IO (withBinaryFile, IOMode (ReadMode))
import System.IO.Error (isDoesNotExistError)
loadSourceMap :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)
=> NeedTargets
-> BuildOpts
-> m ( Map PackageName SimpleTarget
, MiniBuildPlan
, [LocalPackage]
, Set PackageName
, SourceMap
)
loadSourceMap needTargets bopts = do
bconfig <- asks getBuildConfig
rawLocals <- getLocalPackageViews
(mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOpts needTargets bopts
let latestVersion =
Map.fromListWith max $
map toTuple $
Map.keys (bcPackageCaches bconfig)
extraDeps0 <- extendExtraDeps
(bcExtraDeps bconfig)
cliExtraDeps
(Map.keysSet $ Map.filter (== STUnknown) targets)
latestVersion
locals <- mapM (loadLocalPackage bopts targets) $ Map.toList rawLocals
checkFlagsUsed bopts 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 (mpiVersion &&& mpiFlags) extraDeps1)
extraDeps3 = Map.mapWithKey
(\n (v, f) -> PSUpstream v Local $
case ( Map.lookup (Just n) $ boptsFlags bopts
, Map.lookup Nothing $ boptsFlags bopts
, Map.lookup n $ bcFlags bconfig
) of
(Nothing, Nothing, Nothing) -> f
(x, y, z) -> Map.unions
[ fromMaybe Map.empty x
, fromMaybe Map.empty y
, fromMaybe Map.empty z
])
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)
] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages))
return (targets, mbp, locals, nonLocalTargets, sourceMap)
parseTargetsFromBuildOpts
:: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)
=> NeedTargets
-> BuildOpts
-> m (MiniBuildPlan, M.Map PackageName Version, M.Map PackageName SimpleTarget)
parseTargetsFromBuildOpts needTargets bopts = do
bconfig <- asks getBuildConfig
mbp0 <-
case bcResolver bconfig of
ResolverSnapshot snapName -> do
$logDebug $ "Checking resolver: " <> renderSnapName snapName
loadMiniBuildPlan snapName
ResolverCompiler _ -> do
version <- asks (envConfigCompilerVersion . getEnvConfig)
return MiniBuildPlan
{ mbpCompilerVersion = version
, mbpPackages = Map.empty
}
ResolverCustom _ url -> do
stackYamlFP <- asks $ bcStackYaml . getBuildConfig
parseCustomMiniBuildPlan stackYamlFP url
rawLocals <- getLocalPackageViews
workingDir <- getCurrentDir
let snapshot = mpiVersion <$> mbpPackages mbp0
flagExtraDeps <- convertSnapshotToExtra
snapshot
(bcExtraDeps bconfig)
rawLocals
(catMaybes $ Map.keys $ boptsFlags bopts)
(cliExtraDeps, targets) <-
parseTargets
needTargets
(bcImplicitGlobal bconfig)
snapshot
(flagExtraDeps <> bcExtraDeps bconfig)
(fst <$> rawLocals)
workingDir
(boptsTargets bopts)
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, validWanted) -> 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 = not validWanted
, 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, MonadCatch m, MonadLogger m, MonadIO m)
=> BuildOpts
-> Map PackageName SimpleTarget
-> (PackageName, (LocalPackageView, GenericPackageDescription))
-> m LocalPackage
loadLocalPackage bopts targets (name, (lpv, gpkg)) = do
config <- getPackageConfig bopts name
let pkg = resolvePackage config gpkg
mtarget = Map.lookup name targets
(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)
let filteredFiles = Set.filter ((/= $(mkRelFile "cabal_macros.h")) . filename) files
(dirtyFiles, newBuildCache) <- checkBuildCache
(fromMaybe Map.empty mbuildCache)
(map toFilePath $ Set.toList filteredFiles)
return LocalPackage
{ lpPackage = pkg
, lpTestDeps = packageDeps testpkg
, lpBenchDeps = packageDeps benchpkg
, lpTestBench = btpkg
, lpFiles = files
, lpDirtyFiles =
if not (Set.null dirtyFiles) || boptsForceDirty bopts
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)
=> BuildOpts
-> [LocalPackage]
-> Map PackageName extraDeps
-> Map PackageName snapshot
-> m ()
checkFlagsUsed bopts lps extraDeps snapshot = do
bconfig <- asks getBuildConfig
let flags = map (, FSCommandLine) [(k, v) | (Just k, v) <- Map.toList $ boptsFlags bopts]
++ map (, FSStackYaml) (Map.toList $ 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
localFlags :: Map (Maybe PackageName) (Map FlagName Bool)
-> BuildConfig
-> PackageName
-> Map FlagName Bool
localFlags boptsflags bconfig name = Map.unions
[ Map.findWithDefault Map.empty (Just name) boptsflags
, Map.findWithDefault Map.empty Nothing boptsflags
, Map.findWithDefault Map.empty name (bcFlags bconfig)
]
extendExtraDeps :: (MonadThrow m, MonadReader env m, HasBuildConfig env)
=> Map PackageName Version
-> Map PackageName Version
-> Set PackageName
-> Map PackageName Version
-> m (Map PackageName Version)
extendExtraDeps extraDeps0 cliExtraDeps unknowns latestVersion
| null errs = return $ Map.unions $ extraDeps1 : unknowns'
| otherwise = do
bconfig <- asks getBuildConfig
throwM $ UnknownTargets
(Set.fromList errs)
Map.empty
(bcStackYaml bconfig)
where
extraDeps1 = Map.union extraDeps0 cliExtraDeps
(errs, unknowns') = partitionEithers $ map addUnknown $ Set.toList unknowns
addUnknown pn =
case Map.lookup pn extraDeps1 of
Just _ -> Right Map.empty
Nothing ->
case Map.lookup pn latestVersion of
Just v -> Right $ Map.singleton pn v
Nothing -> Left pn
checkBuildCache :: MonadIO m
=> Map FilePath FileCacheInfo
-> [FilePath]
-> m (Set FilePath, Map FilePath FileCacheInfo)
checkBuildCache oldCache files = liftIO $ do
(dirtyFiles, m) <- mconcat <$> mapM go files
return (dirtyFiles, m)
where
go fp = do
mmodTime <- getModTimeMaybe fp
case mmodTime of
Nothing -> return (Set.empty, Map.empty)
Just modTime' -> do
(isDirty, newFci) <-
case Map.lookup fp oldCache of
Just fci
| fciModTime fci == modTime' -> return (False, fci)
| otherwise -> do
newFci <- calcFci modTime' fp
let isDirty =
fciSize fci /= fciSize newFci ||
fciHash fci /= fciHash newFci
return (isDirty, newFci)
Nothing -> do
newFci <- calcFci modTime' fp
return (True, newFci)
return (if isDirty then Set.singleton fp else Set.empty, Map.singleton fp newFci)
addUnlistedToBuildCache
:: (MonadIO m, MonadReader env m, MonadCatch 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, MonadCatch 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)
]
getPackageConfig :: (MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m, MonadReader env m, HasEnvConfig env)
=> BuildOpts
-> PackageName
-> m PackageConfig
getPackageConfig bopts name = do
econfig <- asks getEnvConfig
bconfig <- asks getBuildConfig
return PackageConfig
{ packageConfigEnableTests = False
, packageConfigEnableBenchmarks = False
, packageConfigFlags = localFlags (boptsFlags bopts) bconfig name
, packageConfigCompilerVersion = envConfigCompilerVersion econfig
, packageConfigPlatform = configPlatform $ getConfig bconfig
}