diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index d32e6cc3cf..af8f53fd27 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -86,7 +86,13 @@ build setLocalFiles mbuildLk boptsCli = fixCodePage $ do liftIO $ setLocalFiles $ Set.insert stackYaml $ Set.unions - $ map lpFiles locals + -- The `locals` value above only contains local project + -- packages, not local dependencies. This will get _all_ + -- of the local files we're interested in + -- watching. Arguably, we should not bother watching repo + -- and archive files, since those shouldn't + -- change. That's a possible optimization to consider. + [lpFiles lp | PSFiles lp _ <- Map.elems sourceMap] (installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <- getInstalled menv @@ -220,14 +226,9 @@ warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do collect [ (exe,pkgName) | (pkgName,task) <- Map.toList (planTasks plan) - , isLocal task - , exe <- (Set.toList . exeComponents . lpComponents . taskLP) task + , TTFiles lp _ <- [taskType task] -- FIXME analyze logic here, do we need to check for Local? + , exe <- (Set.toList . exeComponents . lpComponents) lp ] - where - isLocal Task{taskType = (TTLocal _)} = True - isLocal _ = False - taskLP Task{taskType = (TTLocal lp)} = lp - taskLP _ = error "warnIfExecutablesWithSameNameCouldBeOverwritten/taskLP: task isn't local" localExes :: Map Text (NonEmpty PackageName) localExes = collect diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index d8de1e0873..a8975582ef 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -308,7 +308,7 @@ mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps = then Nothing else Just $ fromMaybe "" $ Map.lookup name dirtyReason -- Check if we're no longer using the local version - | Just (PSUpstream _ Snap _ _ _) <- Map.lookup name sourceMap + | Just (piiLocation -> Snap) <- Map.lookup name sourceMap = Just "Switching to snapshot installed package" -- Check if a dependency is going to be unregistered | (dep, _):_ <- mapMaybe (`Map.lookup` toUnregister) deps @@ -350,7 +350,7 @@ addFinal lp package isAllInOne = do Local package , taskPresent = present - , taskType = TTLocal lp + , taskType = TTFiles lp Local -- FIXME we can rely on this being Local, right? , taskAllInOne = isAllInOne , taskCachePkgSrc = CacheSrcLocal (toFilePath (lpDir lp)) } @@ -391,32 +391,37 @@ addDep treatAsDep' name = do -- recommendation available Nothing -> return $ Left $ UnknownPackage name Just (PIOnlyInstalled loc installed) -> do - -- slightly hacky, no flags since they likely won't affect executable names - tellExecutablesUpstream name (installedVersion installed) loc Map.empty + -- FIXME Slightly hacky, no flags since + -- they likely won't affect executable + -- names. This code does not feel right. + tellExecutablesUpstream + (PackageIdentifierRevision (PackageIdentifier name (installedVersion installed)) CFILatest) + loc + Map.empty return $ Right $ ADRFound loc installed Just (PIOnlySource ps) -> do - tellExecutables name ps + tellExecutables ps installPackage name ps Nothing Just (PIBoth ps installed) -> do - tellExecutables name ps + tellExecutables ps installPackage name ps (Just installed) updateLibMap name res return res -tellExecutables :: PackageName -> PackageSource -> M () -tellExecutables _ (PSLocal lp) +-- FIXME what's the purpose of this? Add a Haddock! +tellExecutables :: PackageSource -> M () +tellExecutables (PSFiles lp _) | lpWanted lp = tellExecutablesPackage Local $ lpPackage lp | otherwise = return () -- Ignores ghcOptions because they don't matter for enumerating -- executables. -tellExecutables name (PSUpstream version loc flags _ghcOptions _gitSha) = - tellExecutablesUpstream name version loc flags +tellExecutables (PSIndex loc flags _ghcOptions pir) = + tellExecutablesUpstream pir loc flags -tellExecutablesUpstream :: PackageName -> Version -> InstallLocation -> Map FlagName Bool -> M () -tellExecutablesUpstream name version loc flags = do +tellExecutablesUpstream :: PackageIdentifierRevision -> InstallLocation -> Map FlagName Bool -> M () +tellExecutablesUpstream pir@(PackageIdentifierRevision (PackageIdentifier name _) _) loc flags = do ctx <- ask when (name `Set.member` extraToBuild ctx) $ do - let pir = PackageIdentifierRevision (PackageIdentifier name version) CFILatest -- FIXME get the real CabalFileInfo p <- liftIO $ loadPackage ctx (PLIndex pir) flags [] tellExecutablesPackage loc p @@ -431,10 +436,10 @@ tellExecutablesPackage loc p = do Just (PIOnlySource ps) -> goSource ps Just (PIBoth ps _) -> goSource ps - goSource (PSLocal lp) + goSource (PSFiles lp _) | lpWanted lp = exeComponents (lpComponents lp) | otherwise = Set.empty - goSource PSUpstream{} = Set.empty + goSource PSIndex{} = Set.empty tell mempty { wInstall = Map.fromList $ map (, loc) $ Set.toList $ filterComps myComps $ packageExes p } where @@ -452,11 +457,11 @@ installPackage installPackage name ps minstalled = do ctx <- ask case ps of - PSUpstream _ _ flags ghcOptions pkgLoc -> do + PSIndex _ flags ghcOptions pkgLoc -> do planDebug $ "installPackage: Doing all-in-one build for upstream package " ++ show name - package <- liftIO $ loadPackage ctx pkgLoc flags ghcOptions + package <- liftIO $ loadPackage ctx (PLIndex pkgLoc) flags ghcOptions -- FIXME be more efficient! Get this from the LoadedPackageInfo! resolveDepsAndInstall True ps package minstalled - PSLocal lp -> + PSFiles lp _ -> case lpTestBench lp of Nothing -> do planDebug $ "installPackage: No test / bench component for " ++ show name ++ " so doing an all-in-one build." @@ -551,8 +556,8 @@ installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minL , taskPresent = present , taskType = case ps of - PSLocal lp -> TTLocal lp - PSUpstream _ loc _ _ pkgLoc -> TTUpstream package (loc <> minLoc) pkgLoc + PSFiles lp loc -> TTFiles lp (loc <> minLoc) + PSIndex loc _ _ pkgLoc -> TTIndex package (loc <> minLoc) pkgLoc , taskAllInOne = isAllInOne , taskCachePkgSrc = toCachePkgSrc ps } @@ -681,8 +686,8 @@ checkDirtiness ps installed package present wanted = do , configCacheDeps = Set.fromList $ Map.elems present , configCacheComponents = case ps of - PSLocal lp -> Set.map renderComponent $ lpComponents lp - PSUpstream{} -> Set.empty + PSFiles lp _ -> Set.map renderComponent $ lpComponents lp + PSIndex{} -> Set.empty , configCacheHaddock = shouldHaddockPackage buildOpts wanted (packageName package) || -- Disabling haddocks when old config had haddocks doesn't make dirty. @@ -772,16 +777,16 @@ describeConfigDiff config old new pkgSrcName CacheSrcUpstream = "upstream source" psForceDirty :: PackageSource -> Bool -psForceDirty (PSLocal lp) = lpForceDirty lp -psForceDirty PSUpstream{} = False +psForceDirty (PSFiles lp _) = lpForceDirty lp +psForceDirty PSIndex{} = False psDirty :: PackageSource -> Maybe (Set FilePath) -psDirty (PSLocal lp) = lpDirtyFiles lp -psDirty PSUpstream{} = Nothing -- files never change in an upstream package +psDirty (PSFiles lp _) = lpDirtyFiles lp +psDirty PSIndex{} = Nothing -- files never change in an upstream package psLocal :: PackageSource -> Bool -psLocal (PSLocal _) = True -psLocal PSUpstream{} = False +psLocal (PSFiles _ loc) = loc == Local -- FIXME this is probably not the right logic, see configureOptsNoDir. We probably want to check if this appears in packages: +psLocal PSIndex{} = False -- | Get all of the dependencies for a given package, including guessed build -- tool dependencies. @@ -853,11 +858,7 @@ stripLocals plan = plan , planInstallExes = Map.filter (/= Local) $ planInstallExes plan } where - checkTask task = - case taskType task of - TTLocal _ -> False - TTUpstream _ Local _ -> False - TTUpstream _ Snap _ -> True + checkTask task = taskLocation task == Snap stripNonDeps :: Set PackageName -> Plan -> Plan stripNonDeps deps plan = plan diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 5c473f79f7..1a97006b25 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -70,10 +70,8 @@ import Stack.Fetch as Fetch import Stack.GhcPkg import Stack.Package import Stack.PackageDump -import Stack.PackageLocation import Stack.PrettyPrint import Stack.Types.Build -import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.GhcPkgId @@ -112,14 +110,12 @@ preFetch plan intercalate ", " (map packageIdentifierString $ Set.toList idents) fetchPackages idents where - idents = Set.unions $ map toIdent $ Map.toList $ planTasks plan + idents = Set.unions $ map toIdent $ Map.elems $ planTasks plan - toIdent (name, task) = + toIdent task = case taskType task of - TTLocal _ -> Set.empty - TTUpstream package _ _ -> Set.singleton $ PackageIdentifier - name - (packageVersion package) + TTFiles{} -> Set.empty + TTIndex _ _ (PackageIdentifierRevision ident _) -> Set.singleton ident -- | Print a description of build plan for human consumption. printPlan :: HasRunner env => Plan -> RIO env () @@ -186,8 +182,8 @@ displayTask task = T.pack $ concat Local -> "local" , ", source=" , case taskType task of - TTLocal lp -> toFilePath $ lpDir lp - TTUpstream{} -> "package index" + TTFiles lp _ -> toFilePath $ lpDir lp + TTIndex{} -> "package index" , if Set.null missing then "" else ", after: " ++ intercalate "," (map packageIdentifierString $ Set.toList missing) @@ -740,7 +736,7 @@ getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBenc -- 'stack test'. See: -- https://github.com/commercialhaskell/stack/issues/805 case taskType of - TTLocal lp -> + TTFiles lp _ -> -- FIXME: make this work with exact-configuration. -- Not sure how to plumb the info atm. See -- https://github.com/commercialhaskell/stack/issues/2049 @@ -771,8 +767,8 @@ getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBenc , configCacheDeps = allDeps , configCacheComponents = case taskType of - TTLocal lp -> Set.map renderComponent $ lpComponents lp - TTUpstream{} -> Set.empty + TTFiles lp _ -> Set.map renderComponent $ lpComponents lp + TTIndex{} -> Set.empty , configCacheHaddock = shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides) , configCachePkgSrc = taskCachePkgSrc @@ -883,8 +879,8 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md wanted = case taskType of - TTLocal lp -> lpWanted lp - TTUpstream{} -> False + TTFiles lp _ -> lpWanted lp + TTIndex{} -> False console = wanted && all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining) @@ -892,14 +888,10 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md withPackage inner = case taskType of - TTLocal lp -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp) - TTUpstream package _ pkgLoc -> do + TTFiles lp _ -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp) + TTIndex package _ pir -> do mdist <- distRelativeDir - menv <- getMinimalEnvOverride - root <- view projectRootL - dir <- case pkgLoc of - PLIndex pir -> unpackPackageIdent eeTempDir mdist pir - PLOther pkgLoc' -> resolveSinglePackageLocation menv root pkgLoc' + dir <- unpackPackageIdent eeTempDir mdist pir let name = packageIdentifierName taskProvides cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal" @@ -915,7 +907,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md -- We only want to dump logs for local non-dependency packages case taskType of - TTLocal lp | lpWanted lp -> + TTFiles lp _ | lpWanted lp -> liftIO $ atomically $ writeTChan eeLogFiles (pkgDir, logPath) _ -> return () @@ -974,7 +966,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md warnCustomNoDeps :: RIO env () warnCustomNoDeps = case (taskType, packageBuildType package) of - (TTLocal{}, Just C.Custom) -> do + (TTFiles lp Local, Just C.Custom) | lpWanted lp -> do $logWarn $ T.pack $ concat [ "Package " , packageNameString $ packageName package @@ -1206,18 +1198,18 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in , ["bench" | enableBenchmarks] ] (hasLib, hasExe) = case taskType of - TTLocal lp -> (packageHasLibrary (lpPackage lp), not (Set.null (exesToBuild executableBuildStatuses lp))) + TTFiles lp Local -> (packageHasLibrary (lpPackage lp), not (Set.null (exesToBuild executableBuildStatuses lp))) -- This isn't true, but we don't want to have this info for -- upstream deps. - TTUpstream{} -> (False, False) + _ -> (False, False) getPrecompiled cache = case taskLocation task of Snap | not shouldHaddockPackage' -> do mpc <- - case taskType of - TTUpstream _ _ loc -> readPrecompiledCache - loc + case taskLocation task of + Snap -> readPrecompiledCache + (ttPackageLocation taskType) (configCacheOpts cache) (configCacheDeps cache) _ -> return Nothing @@ -1345,17 +1337,17 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in markExeNotInstalled (taskLocation task) taskProvides case taskType of - TTLocal lp -> do + TTFiles lp _ -> do -- FIXME should this only be for local packages? when enableTests $ unsetTestSuccess pkgDir writeBuildCache pkgDir $ lpNewBuildCache lp - TTUpstream{} -> return () + TTIndex{} -> return () -- FIXME: only output these if they're in the build plan. preBuildTime <- modTime <$> liftIO getCurrentTime let postBuildCheck _succeeded = do mlocalWarnings <- case taskType of - TTLocal lp -> do + TTFiles lp Local | lpWanted lp -> do -- FIXME is lpWanted correct here? warnings <- checkForUnlistedFiles taskType preBuildTime pkgDir return (Just (lpCabalFile lp, warnings)) _ -> return Nothing @@ -1385,10 +1377,10 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in cabal stripTHLoading (("build" :) $ (++ extraOpts) $ case (taskType, taskAllInOne, isFinalBuild) of (_, True, True) -> error "Invariant violated: cannot have an all-in-one build that also has a final build step." - (TTLocal lp, False, False) -> primaryComponentOptions executableBuildStatuses lp - (TTLocal lp, False, True) -> finalComponentOptions lp - (TTLocal lp, True, False) -> primaryComponentOptions executableBuildStatuses lp ++ finalComponentOptions lp - (TTUpstream{}, _, _) -> []) + (TTFiles lp _, False, False) -> primaryComponentOptions executableBuildStatuses lp + (TTFiles lp _, False, True) -> finalComponentOptions lp + (TTFiles lp _, True, False) -> primaryComponentOptions executableBuildStatuses lp ++ finalComponentOptions lp + (TTIndex{}, _, _) -> []) `catch` \ex -> case ex of CabalExitedUnsuccessfully{} -> postBuildCheck False >> throwM ex _ -> throwM ex @@ -1447,26 +1439,23 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in markExeInstalled (taskLocation task) taskProvides -- TODO unify somehow with writeFlagCache? return $ Executable ident - case (taskLocation task, taskType) of - (Snap, TTUpstream _ _ loc) -> + case taskLocation task of + Snap -> writePrecompiledCache eeBaseConfigOpts - loc + (ttPackageLocation taskType) (configCacheOpts cache) (configCacheDeps cache) mpkgid (packageExes package) _ -> return () case taskType of - -- For upstream packages from a package index, pkgDir is in the tmp - -- directory. We eagerly delete it if no other tasks require it, to - -- reduce space usage in tmp (#3018). - TTUpstream _ _ loc -> - case loc of - PLIndex _ -> do - let remaining = filter (\(ActionId x _) -> x == taskProvides) (Set.toList acRemaining) - when (null remaining) $ removeDirRecur pkgDir - _ -> return () + -- For packages from a package index, pkgDir is in the tmp + -- directory. We eagerly delete it if no other tasks + -- require it, to reduce space usage in tmp (#3018). + TTIndex{} -> do + let remaining = filter (\(ActionId x _) -> x == taskProvides) (Set.toList acRemaining) + when (null remaining) $ removeDirRecur pkgDir _ -> return () return mpkgid @@ -1532,7 +1521,7 @@ checkExeStatus compiler platform distDir name = do -- | Check if any unlisted files have been found, and add them to the build cache. checkForUnlistedFiles :: HasEnvConfig env => TaskType -> ModTime -> Path Abs Dir -> RIO env [PackageWarning] -checkForUnlistedFiles (TTLocal lp) preBuildTime pkgDir = do +checkForUnlistedFiles (TTFiles lp _) preBuildTime pkgDir = do (addBuildCache,warnings) <- addUnlistedToBuildCache preBuildTime @@ -1543,7 +1532,7 @@ checkForUnlistedFiles (TTLocal lp) preBuildTime pkgDir = do writeBuildCache pkgDir $ Map.unions (lpNewBuildCache lp : addBuildCache) return warnings -checkForUnlistedFiles TTUpstream{} _ _ = return [] +checkForUnlistedFiles TTIndex{} _ _ = return [] -- | Determine if all of the dependencies given are installed depsPresent :: InstalledMap -> Map PackageName VersionRange -> Bool @@ -1875,8 +1864,8 @@ finalComponentOptions lp = taskComponents :: Task -> Set NamedComponent taskComponents task = case taskType task of - TTLocal lp -> lpComponents lp - TTUpstream{} -> Set.empty + TTFiles lp _ -> lpComponents lp -- FIXME probably just want Local, maybe even just lpWanted + TTIndex{} -> Set.empty -- | Take the given list of package dependencies and the contents of the global -- package database, and construct a set of installed package IDs that: diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 701b445d4f..5be820cc3a 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -31,9 +31,10 @@ import qualified Data.Map.Strict as M import qualified Data.Set as Set import Stack.Build.Cache import Stack.Build.Target -import Stack.Config (getLocalPackages) +import Stack.Config (getLocalPackages, getNamedComponents) import Stack.Constants (wiredInPackages) import Stack.Package +import Stack.PackageLocation import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Config @@ -71,7 +72,7 @@ loadSourceMapFull :: HasEnvConfig env -> RIO env ( Map PackageName Target , LoadedSnapshot - , [LocalPackage] + , [LocalPackage] -- FIXME do we really want this? it's in the SourceMap , Set PackageName -- non-project targets , SourceMap ) @@ -88,17 +89,38 @@ loadSourceMapFull needTargets boptsCli = do -- Combine the local packages, extra-deps, and LoadedSnapshot into -- one unified source map. - let sourceMap = Map.unions - [ Map.fromList $ map (\lp' -> (packageName $ lpPackage lp', PSLocal lp')) locals - , flip Map.mapWithKey localDeps $ \n lpi -> - let configOpts = getGhcOptions bconfig boptsCli n False False - -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon - in PSUpstream (lpiVersion lpi) Local (lpiFlags lpi) configOpts (lpiLocation lpi) - , flip Map.mapWithKey (lsPackages ls) $ \n lpi -> - let configOpts = getGhcOptions bconfig boptsCli n False False - -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon - in PSUpstream (lpiVersion lpi) Snap (lpiFlags lpi) configOpts (lpiLocation lpi) - ] + let goLPI loc n lpi = do + let configOpts = getGhcOptions bconfig boptsCli n False False + case lpiLocation lpi of + -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon + PLIndex pir -> return $ PSIndex loc (lpiFlags lpi) configOpts pir + PLOther pl -> do + -- FIXME lots of code duplication with getLocalPackages + menv <- getMinimalEnvOverride + root <- view projectRootL + dir <- resolveSinglePackageLocation menv root pl + cabalfp <- findOrGenerateCabalFile dir + bs <- liftIO (S.readFile (toFilePath cabalfp)) + (warnings, gpd) <- + case rawParseGPD bs of + Left e -> throwM $ InvalidCabalFileInLocal (PLOther pl) e bs + Right x -> return x + mapM_ (printCabalFileWarning cabalfp) warnings + lp' <- loadLocalPackage boptsCli targets (n, LocalPackageView + { lpvVersion = lpiVersion lpi + , lpvRoot = dir + , lpvCabalFP = cabalfp + , lpvComponents = getNamedComponents gpd + , lpvGPD = gpd + , lpvLoc = pl + }) + return $ PSFiles lp' loc + sourceMap' <- Map.unions <$> sequence + [ return $ Map.fromList $ map (\lp' -> (packageName $ lpPackage lp', PSFiles lp' Local)) locals + , sequence $ Map.mapWithKey (goLPI Local) localDeps + , sequence $ Map.mapWithKey (goLPI Snap) (lsPackages ls) + ] + let sourceMap = sourceMap' `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) return @@ -286,6 +308,7 @@ loadLocalPackage boptsCli targets (name, lpv) = do (exes `Set.difference` packageExes pkg) (tests `Set.difference` Map.keysSet (packageTests pkg)) (benches `Set.difference` packageBenchmarks pkg) + , lpLocation = lpvLoc lpv } -- | Ensure that the flags specified in the stack.yaml file and on the command diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 59b417b555..1c5ae21e6b 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -45,6 +45,7 @@ module Stack.Config ,defaultConfigYaml ,getProjectConfig ,LocalConfigStatus(..) + ,getNamedComponents ) where import Control.Monad.Extra (firstJustM) @@ -697,18 +698,19 @@ getLocalPackages = do { lpProject = Map.fromList packages , lpDependencies = Map.fromList deps } + +getNamedComponents :: C.GenericPackageDescription -> Set NamedComponent +getNamedComponents gpkg = Set.fromList $ concat + [ maybe [] (const [CLib]) (C.condLibrary gpkg) + , go CExe (map fst . C.condExecutables) + , go CTest (map fst . C.condTestSuites) + , go CBench (map fst . C.condBenchmarks) + ] where - getNamedComponents gpkg = Set.fromList $ concat - [ maybe [] (const [CLib]) (C.condLibrary gpkg) - , go CExe (map fst . C.condExecutables) - , go CTest (map fst . C.condTestSuites) - , go CBench (map fst . C.condBenchmarks) - ] - where - go :: (T.Text -> NamedComponent) - -> (C.GenericPackageDescription -> [String]) - -> [NamedComponent] - go wrapper f = map (wrapper . T.pack) $ f gpkg + go :: (T.Text -> NamedComponent) + -> (C.GenericPackageDescription -> [String]) + -> [NamedComponent] + go wrapper f = map (wrapper . T.pack) $ f gpkg -- | Check if there are any duplicate package names and, if so, throw an -- exception. diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index ca24be5572..5844178312 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -212,11 +212,13 @@ createDepLoader :: Applicative m createDepLoader sourceMap installed globalDumpMap globalIdMap loadPackageDeps pkgName = if not (pkgName `HashSet.member` wiredInPackages) then case Map.lookup pkgName sourceMap of - Just (PSLocal lp) -> pure (packageAllDeps pkg, payloadFromLocal pkg) + Just (PSFiles lp _) -> pure (packageAllDeps pkg, payloadFromLocal pkg) where pkg = localPackageToPackage lp - Just (PSUpstream version _ flags ghcOptions loc) -> - loadPackageDeps pkgName version loc flags ghcOptions + Just (PSIndex _ flags ghcOptions loc) -> + -- FIXME pretty certain this could be cleaned up a lot by including more info in PackageSource + let PackageIdentifierRevision (PackageIdentifier name version) _ = loc + in assert (pkgName == name) (loadPackageDeps pkgName version (PLIndex loc) flags ghcOptions) Nothing -> pure (Set.empty, payloadFromInstalled (Map.lookup pkgName installed)) -- For wired-in-packages, use information from ghc-pkg (see #3084) else case Map.lookup pkgName globalDumpMap of diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index d3bfedf976..9ce485ee45 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -694,7 +694,7 @@ getExtraLoadDeps loadAllDeps sourceMap targets = getDeps :: PackageName -> [PackageName] getDeps name = case M.lookup name sourceMap of - Just (PSLocal lp) -> M.keys (packageDeps (lpPackage lp)) + Just (PSFiles lp _) -> M.keys (packageDeps (lpPackage lp)) -- FIXME just Local? _ -> [] go :: PackageName -> State (Map PackageName (Maybe (Path Abs File, Target))) Bool go name = do @@ -702,7 +702,7 @@ getExtraLoadDeps loadAllDeps sourceMap targets = case (M.lookup name cache, M.lookup name sourceMap) of (Just (Just _), _) -> return True (Just Nothing, _) | not loadAllDeps -> return False - (_, Just (PSLocal lp)) -> do + (_, Just (PSFiles lp _)) -> do let deps = M.keys (packageDeps (lpPackage lp)) shouldLoad <- liftM or $ mapM go deps if shouldLoad @@ -712,7 +712,7 @@ getExtraLoadDeps loadAllDeps sourceMap targets = else do modify (M.insert name Nothing) return False - (_, Just PSUpstream{}) -> return loadAllDeps + (_, Just PSIndex{}) -> return loadAllDeps (_, _) -> return False preprocessCabalMacros :: MonadIO m => [GhciPkgInfo] -> Path Abs File -> m [String] diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 9e0f20de7a..f36c024d1b 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -209,8 +209,7 @@ getCabalLbs pvpBounds mrev fp = do where lookupVersion name = case Map.lookup name sourceMap of - Just (PSLocal lp) -> Just $ packageVersion $ lpPackage lp - Just (PSUpstream version _ _ _ _) -> Just version + Just ps -> Just (piiVersion ps) Nothing -> case Map.lookup name installedMap of Just (_, installed) -> Just (installedVersion installed) @@ -260,6 +259,7 @@ readLocalPackage pkgDir = do , lpFiles = Set.empty , lpComponents = Set.empty , lpUnbuildable = Set.empty + , lpLocation = PLFilePath $ toFilePath pkgDir } -- | Returns a newline-separate list of paths, and the absolute path to the .cabal file. @@ -285,7 +285,7 @@ getSDistFileList lp = ac = ActionContext Set.empty [] task = Task { taskProvides = PackageIdentifier (packageName package) (packageVersion package) - , taskType = TTLocal lp + , taskType = TTFiles lp Local , taskConfigOpts = TaskConfigOpts { tcoMissing = Set.empty , tcoOpts = \_ -> ConfigureOpts [] [] diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index a247aea988..ca6fd4be95 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -23,15 +23,11 @@ module Stack.Snapshot import Stack.Prelude import Control.Monad.State.Strict (get, put, StateT, execStateT) -import Crypto.Hash (hash, SHA256(..), Digest) import Crypto.Hash.Conduit (hashFile) import Data.Aeson (withObject, (.!=), (.:), (.:?), Value (Object)) import Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings, (..!=), (..:?), jsonSubWarningsT, withObjectWarnings, (..:)) import Data.Aeson.Types (Parser, parseEither) import Data.Store.VersionTagged -import qualified Data.ByteArray as Mem (convert) -import qualified Data.ByteString.Base64.URL as B64URL -import qualified Data.ByteString.Char8 as S8 import qualified Data.Conduit.List as CL import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map @@ -249,7 +245,7 @@ loadResolver (ResolverCustom url loc) = do where download' :: Request -> RIO env (Path Abs File) download' req = do - let urlHash = S8.unpack $ trimmedSnapshotHash $ doHash $ encodeUtf8 url + let urlHash = T.unpack $ trimmedSnapshotHash $ snapshotHashFromBS $ encodeUtf8 url hashFP <- parseRelFile $ urlHash ++ ".yaml" customPlanDir <- getCustomPlanDir let cacheFP = customPlanDir $(mkRelDir "yaml") hashFP @@ -298,7 +294,7 @@ loadResolver (ResolverCustom url loc) = do -- Calculate the hash of the current file, and then combine it -- with parent hashes if necessary below. - rawHash :: SnapshotHash <- fromDigest <$> hashFile fp :: RIO env SnapshotHash + rawHash :: SnapshotHash <- snapshotHashFromDigest <$> hashFile fp :: RIO env SnapshotHash (parent', hash') <- case parentResolver' of @@ -334,17 +330,11 @@ loadResolver (ResolverCustom url loc) = do <*> (o ..:? "resolver") <*> (o ..:? "compiler") - fromDigest :: Digest SHA256 -> SnapshotHash - fromDigest = SnapshotHash . B64URL.encode . Mem.convert - combineHash :: SnapshotHash -> SnapshotHash -> SnapshotHash - combineHash (SnapshotHash x) (SnapshotHash y) = doHash (x <> y) + combineHash x y = snapshotHashFromBS (snapshotHashToBS x <> snapshotHashToBS y) snapNameToHash :: SnapName -> SnapshotHash - snapNameToHash = doHash . encodeUtf8 . renderSnapName - - doHash :: ByteString -> SnapshotHash - doHash = fromDigest . hash + snapNameToHash = snapshotHashFromBS . encodeUtf8 . renderSnapName -- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot' loadSnapshot diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 1cd00569e7..4384a6cb05 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -32,6 +32,7 @@ module Stack.Types.Build ,BuildSubset(..) ,defaultBuildOpts ,TaskType(..) + ,ttPackageLocation ,TaskConfigOpts(..) ,BuildCache(..) ,buildCacheVC @@ -69,7 +70,7 @@ import Path (mkRelDir, parseRelDir, ()) import Path.Extra (toFilePathNoTrailingSep) import Paths_stack as Meta import Stack.Constants -import Stack.Types.BuildPlan (PackageLocationIndex) +import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Config @@ -384,15 +385,15 @@ instance Store CachePkgSrc instance NFData CachePkgSrc toCachePkgSrc :: PackageSource -> CachePkgSrc -toCachePkgSrc (PSLocal lp) = CacheSrcLocal (toFilePath (lpDir lp)) -toCachePkgSrc PSUpstream{} = CacheSrcUpstream +toCachePkgSrc (PSFiles lp _) = CacheSrcLocal (toFilePath (lpDir lp)) +toCachePkgSrc PSIndex{} = CacheSrcUpstream configCacheVC :: VersionConfig ConfigCache configCacheVC = storeVersionConfig "config-v3" "z7N_NxX7Gbz41Gi9AGEa1zoLE-4=" -- | A task to perform when building data Task = Task - { taskProvides :: !PackageIdentifier + { taskProvides :: !PackageIdentifier -- FIXME turn this into a function on taskType? -- ^ the package/version to be built , taskType :: !TaskType -- ^ the task type, telling us how to build this @@ -422,21 +423,25 @@ instance Show TaskConfigOpts where -- | The type of a task, either building local code or something from the -- package index (upstream) -data TaskType = TTLocal LocalPackage - | TTUpstream Package InstallLocation (PackageLocationIndex FilePath) -- FIXME major overhaul for PackageLocation? +data TaskType = TTFiles LocalPackage InstallLocation + | TTIndex Package InstallLocation PackageIdentifierRevision -- FIXME major overhaul for PackageLocation? deriving Show +ttPackageLocation :: TaskType -> PackageLocationIndex FilePath +ttPackageLocation (TTFiles lp _) = PLOther (lpLocation lp) +ttPackageLocation (TTIndex _ _ pir) = PLIndex pir + taskIsTarget :: Task -> Bool taskIsTarget t = case taskType t of - TTLocal lp -> lpWanted lp + TTFiles lp _ -> lpWanted lp _ -> False taskLocation :: Task -> InstallLocation taskLocation task = case taskType task of - TTLocal _ -> Local - TTUpstream _ loc _ -> loc + TTFiles _ loc -> loc + TTIndex _ loc _ -> loc -- | A complete plan of what needs to be built and how to do it data Plan = Plan diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 3fb335e73c..af0ba5d63c 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -39,7 +39,7 @@ import qualified Data.Set as Set import Data.Store.Version import Data.Store.VersionTagged import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text.Encoding (encodeUtf8) import qualified Distribution.ModuleName as C import qualified Distribution.Version as C import Network.HTTP.Client (parseRequest) @@ -106,7 +106,7 @@ sdRawPathName sd = where go (ResolverSnapshot name) = renderSnapName name go (ResolverCompiler version) = compilerVersionText version - go (ResolverCustom _ hash) = "custom-" <> sdResolverName sd <> "-" <> decodeUtf8 (trimmedSnapshotHash hash) + go (ResolverCustom _ hash) = "custom-" <> sdResolverName sd <> "-" <> trimmedSnapshotHash hash -- | Modify the wanted compiler version in this snapshot. This is used -- when overriding via the `compiler` value in a custom snapshot or diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index a1837d4c95..ba52dd250f 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -25,7 +25,7 @@ import Distribution.Package hiding (Package,PackageName,packageName,pa import Distribution.PackageDescription (TestSuiteInterface, BuildType) import Distribution.System (Platform (..)) import Path as FL -import Stack.Types.BuildPlan (PackageLocationIndex) +import Stack.Types.BuildPlan (PackageLocation, PackageLocationIndex (..)) import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName @@ -184,19 +184,24 @@ type SourceMap = Map PackageName PackageSource -- | Where the package's source is located: local directory or package index data PackageSource - = PSLocal LocalPackage - | PSUpstream Version InstallLocation (Map FlagName Bool) [Text] (PackageLocationIndex FilePath) -- FIXME still seems like we could do better... Minimum: rename from Upstream to Dependency and Local to Project - -- ^ Upstream packages could be installed in either local or snapshot - -- databases; this is what 'InstallLocation' specifies. + = PSFiles LocalPackage InstallLocation + -- ^ Package which exist on the filesystem (as opposed to an index tarball) + | PSIndex InstallLocation (Map FlagName Bool) [Text] PackageIdentifierRevision + -- ^ Package which is in an index, and the files do not exist on the + -- filesystem yet. deriving Show piiVersion :: PackageSource -> Version -piiVersion (PSLocal lp) = packageVersion $ lpPackage lp -piiVersion (PSUpstream v _ _ _ _) = v +piiVersion (PSFiles lp _) = packageVersion $ lpPackage lp +piiVersion (PSIndex _ _ _ (PackageIdentifierRevision (PackageIdentifier _ v) _)) = v piiLocation :: PackageSource -> InstallLocation -piiLocation (PSLocal _) = Local -piiLocation (PSUpstream _ loc _ _ _) = loc +piiLocation (PSFiles _ loc) = loc +piiLocation (PSIndex loc _ _ _) = loc + +piiPackageLocation :: PackageSource -> PackageLocationIndex FilePath +piiPackageLocation (PSFiles lp _) = PLOther (lpLocation lp) +piiPackageLocation (PSIndex _ _ _ pir) = PLIndex pir -- | Information on a locally available package of source code data LocalPackage = LocalPackage @@ -208,7 +213,7 @@ data LocalPackage = LocalPackage , lpUnbuildable :: !(Set NamedComponent) -- ^ Components explicitly requested for build, that are marked -- "buildable: false". - , lpWanted :: !Bool + , lpWanted :: !Bool -- FIXME Should completely drop this "wanted" terminology, it's unclear -- ^ Whether this package is wanted as a target. , lpTestDeps :: !(Map PackageName VersionRange) -- ^ Used for determining if we can use --enable-tests in a normal build. @@ -231,6 +236,8 @@ data LocalPackage = LocalPackage -- ^ current state of the files , lpFiles :: !(Set (Path Abs File)) -- ^ all files used by this package + , lpLocation :: !(PackageLocation FilePath) + -- ^ Where this source code came from } deriving Show diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index 0d5e8cb232..95c975743d 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -31,8 +31,10 @@ module Stack.Types.PackageIdentifier , StaticSHA256 , mkStaticSHA256FromText , mkStaticSHA256FromFile + , mkStaticSHA256FromDigest , staticSHA256ToText , staticSHA256ToBase16 + , staticSHA256ToRaw ) where @@ -138,10 +140,10 @@ mkStaticSHA256FromText t = -- | Generate a 'StaticSHA256' value from the contents of a file. mkStaticSHA256FromFile :: MonadIO m => Path Abs File -> m StaticSHA256 -mkStaticSHA256FromFile fp = liftIO $ fromDigest <$> hashFile (toFilePath fp) +mkStaticSHA256FromFile fp = liftIO $ mkStaticSHA256FromDigest <$> hashFile (toFilePath fp) -fromDigest :: Hash.Digest Hash.SHA256 -> StaticSHA256 -fromDigest digest +mkStaticSHA256FromDigest :: Hash.Digest Hash.SHA256 -> StaticSHA256 +mkStaticSHA256FromDigest digest = StaticSHA256 $ either impureThrow id $ toStaticExact @@ -155,6 +157,9 @@ staticSHA256ToText = decodeUtf8 . staticSHA256ToBase16 staticSHA256ToBase16 :: StaticSHA256 -> ByteString staticSHA256ToBase16 (StaticSHA256 x) = Mem.convertToBase Mem.Base16 x +staticSHA256ToRaw :: StaticSHA256 -> ByteString +staticSHA256ToRaw (StaticSHA256 x) = Data.ByteArray.convert x + -- | Generate a 'CabalHash' value from a base16-encoded SHA256 hash. mkCabalHashFromSHA256 :: Text -> Either SomeException CabalHash mkCabalHashFromSHA256 = fmap CabalHash . mkStaticSHA256FromText @@ -165,7 +170,7 @@ cabalHashToText = staticSHA256ToText . unCabalHash -- | Compute a 'CabalHash' value from a cabal file's contents. computeCabalHash :: L.ByteString -> CabalHash -computeCabalHash = CabalHash . fromDigest . Hash.hashlazy +computeCabalHash = CabalHash . mkStaticSHA256FromDigest . Hash.hashlazy showCabalHash :: CabalHash -> Text showCabalHash = T.append (T.pack "sha256:") . cabalHashToText diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs index 7756e244bd..0d37a27018 100644 --- a/src/Stack/Types/Resolver.hs +++ b/src/Stack/Types/Resolver.hs @@ -31,18 +31,24 @@ module Stack.Types.Resolver ,Snapshots (..) ,renderSnapName ,parseSnapName - ,SnapshotHash (..) + ,SnapshotHash ,trimmedSnapshotHash + ,snapshotHashToBS + ,snapshotHashFromBS + ,snapshotHashFromDigest ,parseCustomLocation ) where +import Crypto.Hash as Hash (hash, Digest, SHA256) import Data.Aeson.Extended (ToJSON, toJSON, FromJSON, parseJSON, withObject, (.:), withText) -import qualified Data.ByteString as BS +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.HashMap.Strict as HashMap import qualified Data.IntMap.Strict as IntMap import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) import Data.Text.Read (decimal) import Data.Time (Day) import Network.HTTP.Client (Request, parseUrlThrow) @@ -51,6 +57,7 @@ import qualified Options.Applicative.Types as OA import Path import Stack.Prelude import Stack.Types.Compiler +import Stack.Types.PackageIdentifier import qualified System.FilePath as FP data IsLoaded = Loaded | NotLoaded @@ -228,10 +235,24 @@ instance FromJSON Snapshots where Right (LTS x y) -> return $ IntMap.singleton x y Right (Nightly _) -> fail "Unexpected nightly value" -newtype SnapshotHash = SnapshotHash { unShapshotHash :: ByteString } +newtype SnapshotHash = SnapshotHash { unSnapshotHash :: StaticSHA256 } deriving (Generic, Typeable, Show, Data, Eq) instance Store SnapshotHash instance NFData SnapshotHash -trimmedSnapshotHash :: SnapshotHash -> ByteString -trimmedSnapshotHash = BS.take 12 . unShapshotHash +-- | Return the first 12 characters of the hash as a B64URL-encoded +-- string. +trimmedSnapshotHash :: SnapshotHash -> Text +trimmedSnapshotHash = decodeUtf8 . B.take 12 . B64URL.encode . staticSHA256ToRaw . unSnapshotHash + +-- | Return the raw bytes in the hash +snapshotHashToBS :: SnapshotHash -> ByteString +snapshotHashToBS = staticSHA256ToRaw . unSnapshotHash + +-- | Create a new SnapshotHash by SHA256 hashing the given contents +snapshotHashFromBS :: ByteString -> SnapshotHash +snapshotHashFromBS = snapshotHashFromDigest . Hash.hash + +-- | Create a new SnapshotHash from the given digest +snapshotHashFromDigest :: Digest SHA256 -> SnapshotHash +snapshotHashFromDigest = SnapshotHash . mkStaticSHA256FromDigest