Skip to content

Commit c0baf1e

Browse files
mgsloanmgsloan
authored
Merge branch 'stable' into fix-snapshot-promotion
2 parents 9c6a9ea + baf5505 commit c0baf1e

9 files changed

Lines changed: 120 additions & 72 deletions

File tree

‎ChangeLog.md‎

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -14,13 +14,22 @@ Bug fixes:
1414
* 1.6.1 introduced a change that made some precompiled cache files use
1515
longer paths, sometimes causing builds to fail on windows. This has been
1616
fixed. See [#3649](https://github.com/commercialhaskell/stack/issues/3649)
17+
* Some unnecessary rebuilds when no files were changed are now avoided, by
18+
having a separate build cache for each component of a package. See
19+
[#3732](https://github.com/commercialhaskell/stack/issues/3732).
1720
* Correct the behavior of promoting a package from snapshot to local
1821
package. This would get triggered when version bounds conflicted in
1922
a snapshot, which could be triggered via Hackage revisions for old
2023
packages. This also should allow custom snapshots to define
2124
conflicting versions of packages without issue. See
2225
[Stackage issue #3185](https://github.com/fpco/stackage/issues/3185).
23-
26+
* When promoting packages from snapshot to local, we were
27+
occassionally discarding the actual package location content and
28+
instead defaulting to pulling the package from the index. We now
29+
correctly retain this information. Note that if you were affected by
30+
this bug, you will likely need to delete the binary build cache
31+
associated with the relevant custom snapshot. See
32+
[#3714](https://github.com/commercialhaskell/stack/issues/3714).
2433

2534
## v1.6.3
2635

‎src/Stack/Build/Cache.hs‎

Lines changed: 46 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE CPP #-}
12
{-# LANGUAGE NoImplicitPrelude #-}
23
{-# LANGUAGE DeriveGeneric #-}
34
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -32,14 +33,16 @@ module Stack.Build.Cache
3233
, BuildCache(..)
3334
) where
3435

35-
import Stack.Constants
3636
import Stack.Prelude
3737
import Crypto.Hash (hashWith, SHA256(..))
3838
import Control.Monad.Trans.Maybe
3939
import qualified Data.ByteArray as Mem (convert)
4040
import qualified Data.ByteString.Base64.URL as B64URL
4141
import qualified Data.ByteString as B
4242
import qualified Data.ByteString.Char8 as S8
43+
#ifdef mingw32_HOST_OS
44+
import Data.Char (ord)
45+
#endif
4346
import qualified Data.Map as M
4447
import qualified Data.Set as Set
4548
import qualified Data.Store as Store
@@ -107,10 +110,24 @@ markExeNotInstalled loc ident = do
107110
ident' <- parseRelFile $ packageIdentifierString ident
108111
liftIO $ ignoringAbsence (removeFile $ dir </> ident')
109112

113+
buildCacheFile :: (HasEnvConfig env, MonadReader env m, MonadThrow m)
114+
=> Path Abs Dir
115+
-> NamedComponent
116+
-> m (Path Abs File)
117+
buildCacheFile dir component = do
118+
cachesDir <- buildCachesDir dir
119+
let nonLibComponent prefix name = prefix <> "-" <> T.unpack name
120+
cacheFileName <- parseRelFile $ case component of
121+
CLib -> "lib"
122+
CExe name -> nonLibComponent "exe" name
123+
CTest name -> nonLibComponent "test" name
124+
CBench name -> nonLibComponent "bench" name
125+
return $ cachesDir </> cacheFileName
126+
110127
-- | Try to read the dirtiness cache for the given package directory.
111128
tryGetBuildCache :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, MonadLogger m, HasEnvConfig env)
112-
=> Path Abs Dir -> m (Maybe (Map FilePath FileCacheInfo))
113-
tryGetBuildCache dir = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir
129+
=> Path Abs Dir -> NamedComponent -> m (Maybe (Map FilePath FileCacheInfo))
130+
tryGetBuildCache dir component = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir component
114131

115132
-- | Try to read the dirtiness cache for the given package directory.
116133
tryGetConfigCache :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m)
@@ -124,9 +141,9 @@ tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir
124141

125142
-- | Write the dirtiness cache for this package's files.
126143
writeBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m)
127-
=> Path Abs Dir -> Map FilePath FileCacheInfo -> m ()
128-
writeBuildCache dir times = do
129-
fp <- buildCacheFile dir
144+
=> Path Abs Dir -> NamedComponent -> Map FilePath FileCacheInfo -> m ()
145+
writeBuildCache dir component times = do
146+
fp <- buildCacheFile dir component
130147
$(versionedEncodeFile buildCacheVC) fp BuildCache
131148
{ buildCacheTimes = times
132149
}
@@ -287,14 +304,12 @@ precompiledCacheFile loc copts installedPackageIDs = do
287304
-- See #3649 - shorten the paths on windows if MAX_PATH will be
288305
-- violated. Doing this only when necessary allows use of existing
289306
-- precompiled packages.
290-
case maxPathLength of
291-
Nothing -> return longPath
292-
Just maxPath
293-
| length (toFilePath longPath) > maxPath -> do
294-
shortPkg <- shaPath pkg
295-
shortHash <- shaPath hashPath
296-
return $ precompiledDir </> shortPkg </> shortHash
297-
| otherwise -> return longPath
307+
if pathTooLong (toFilePath longPath) then do
308+
shortPkg <- shaPath pkg
309+
shortHash <- shaPath hashPath
310+
return $ precompiledDir </> shortPkg </> shortHash
311+
else
312+
return longPath
298313

299314
-- | Write out information about a newly built package
300315
writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m)
@@ -353,3 +368,20 @@ readPrecompiledCache loc copts depIDs = runMaybeT $
353368
{ pcLibrary = mkAbs' <$> pcLibrary pc0
354369
, pcExes = mkAbs' <$> pcExes pc0
355370
}
371+
372+
-- | Check if a filesystem path is too long.
373+
pathTooLong :: FilePath -> Bool
374+
#ifdef mingw32_HOST_OS
375+
pathTooLong path = utf16StringLength path >= win32MaxPath
376+
where
377+
win32MaxPath = 260
378+
-- Calculate the length of a string in 16-bit units
379+
-- if it were converted to utf-16.
380+
utf16StringLength :: String -> Integer
381+
utf16StringLength = sum . map utf16CharLength
382+
where
383+
utf16CharLength c | ord c < 0x10000 = 1
384+
| otherwise = 2
385+
#else
386+
pathTooLong _ = False
387+
#endif

‎src/Stack/Build/Execute.hs‎

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1372,7 +1372,8 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
13721372
case taskType of
13731373
TTFiles lp _ -> do -- FIXME should this only be for local packages?
13741374
when enableTests $ unsetTestSuccess pkgDir
1375-
writeBuildCache pkgDir $ lpNewBuildCache lp
1375+
mapM_ (uncurry (writeBuildCache pkgDir))
1376+
(Map.toList $ lpNewBuildCaches lp)
13761377
TTIndex{} -> return ()
13771378

13781379
-- FIXME: only output these if they're in the build plan.
@@ -1566,10 +1567,11 @@ checkForUnlistedFiles (TTFiles lp _) preBuildTime pkgDir = do
15661567
(lpPackage lp)
15671568
(lpCabalFile lp)
15681569
(lpComponents lp)
1569-
(lpNewBuildCache lp)
1570-
unless (null addBuildCache) $
1571-
writeBuildCache pkgDir $
1572-
Map.unions (lpNewBuildCache lp : addBuildCache)
1570+
(lpNewBuildCaches lp)
1571+
forM_ (M.toList addBuildCache) $ \(component, newToCache) -> do
1572+
let cache = Map.findWithDefault Map.empty component (lpNewBuildCaches lp)
1573+
writeBuildCache pkgDir component $
1574+
Map.unions (cache : newToCache)
15731575
return warnings
15741576
checkForUnlistedFiles TTIndex{} _ _ = return []
15751577

‎src/Stack/Build/Source.hs‎

Lines changed: 41 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -265,28 +265,36 @@ loadLocalPackage isLocal boptsCli targets (name, lpv) = do
265265
testpkg = resolvePackage testconfig gpkg
266266
benchpkg = resolvePackage benchconfig gpkg
267267

268-
mbuildCache <- tryGetBuildCache $ lpvRoot lpv
269-
270-
(files,_) <- getPackageFilesForTargets pkg (lpvCabalFP lpv) nonLibComponents
271-
272-
(dirtyFiles, newBuildCache) <- checkBuildCache
273-
(fromMaybe Map.empty mbuildCache)
274-
(Set.toList files)
268+
(componentFiles,_) <- getPackageFilesForTargets pkg (lpvCabalFP lpv) nonLibComponents
269+
270+
checkCacheResults <- forM (Map.toList componentFiles) $ \(component, files) -> do
271+
mbuildCache <- tryGetBuildCache (lpvRoot lpv) component
272+
checkCacheResult <- checkBuildCache
273+
(fromMaybe Map.empty mbuildCache)
274+
(Set.toList files)
275+
return (component, checkCacheResult)
276+
277+
let allDirtyFiles =
278+
Set.unions $
279+
map (\(_, (dirtyFiles, _)) -> dirtyFiles) checkCacheResults
280+
newBuildCaches =
281+
M.fromList $
282+
map (\(c, (_, cache)) -> (c, cache)) checkCacheResults
275283

276284
return LocalPackage
277285
{ lpPackage = pkg
278286
, lpTestDeps = packageDeps testpkg
279287
, lpBenchDeps = packageDeps benchpkg
280288
, lpTestBench = btpkg
281-
, lpFiles = files
289+
, lpComponentFiles = componentFiles
282290
, lpForceDirty = boptsForceDirty bopts
283291
, lpDirtyFiles =
284-
if not (Set.null dirtyFiles)
292+
if not (Set.null allDirtyFiles)
285293
then let tryStripPrefix y =
286294
fromMaybe y (stripPrefix (toFilePath $ lpvRoot lpv) y)
287-
in Just $ Set.map tryStripPrefix dirtyFiles
295+
in Just $ Set.map tryStripPrefix allDirtyFiles
288296
else Nothing
289-
, lpNewBuildCache = newBuildCache
297+
, lpNewBuildCaches = newBuildCaches
290298
, lpCabalFile = lpvCabalFP lpv
291299
, lpDir = lpvRoot lpv
292300
, lpWanted = isWanted
@@ -394,15 +402,18 @@ addUnlistedToBuildCache
394402
-> Package
395403
-> Path Abs File
396404
-> Set NamedComponent
397-
-> Map FilePath a
398-
-> RIO env ([Map FilePath FileCacheInfo], [PackageWarning])
399-
addUnlistedToBuildCache preBuildTime pkg cabalFP nonLibComponents buildCache = do
400-
(files,warnings) <- getPackageFilesForTargets pkg cabalFP nonLibComponents
401-
let newFiles =
402-
Set.toList $
403-
Set.map toFilePath files `Set.difference` Map.keysSet buildCache
404-
addBuildCache <- mapM addFileToCache newFiles
405-
return (addBuildCache, warnings)
405+
-> Map NamedComponent (Map FilePath a)
406+
-> RIO env (Map NamedComponent [Map FilePath FileCacheInfo], [PackageWarning])
407+
addUnlistedToBuildCache preBuildTime pkg cabalFP nonLibComponents buildCaches = do
408+
(componentFiles, warnings) <- getPackageFilesForTargets pkg cabalFP nonLibComponents
409+
results <- forM (M.toList componentFiles) $ \(component, files) -> do
410+
let buildCache = M.findWithDefault M.empty component buildCaches
411+
newFiles =
412+
Set.toList $
413+
Set.map toFilePath files `Set.difference` Map.keysSet buildCache
414+
addBuildCache <- mapM addFileToCache newFiles
415+
return ((component, addBuildCache), warnings)
416+
return (M.fromList (map fst results), concatMap snd results)
406417
where
407418
addFileToCache fp = do
408419
mmodTime <- getModTimeMaybe fp
@@ -420,16 +431,18 @@ addUnlistedToBuildCache preBuildTime pkg cabalFP nonLibComponents buildCache = d
420431
-- set of components.
421432
getPackageFilesForTargets
422433
:: HasEnvConfig env
423-
=> Package -> Path Abs File -> Set NamedComponent -> RIO env (Set (Path Abs File), [PackageWarning])
424-
getPackageFilesForTargets pkg cabalFP components = do
434+
=> Package
435+
-> Path Abs File
436+
-> Set NamedComponent
437+
-> RIO env (Map NamedComponent (Set (Path Abs File)), [PackageWarning])
438+
getPackageFilesForTargets pkg cabalFP nonLibComponents = do
425439
(_,compFiles,otherFiles,warnings) <-
426440
getPackageFiles (packageFiles pkg) cabalFP
427-
let filesForComponent cn = Set.map dotCabalGetPath
428-
$ M.findWithDefault mempty cn compFiles
429-
files = Set.unions
430-
$ otherFiles
431-
: map filesForComponent (Set.toList $ Set.insert CLib components)
432-
return (files, warnings)
441+
let components = Set.insert CLib nonLibComponents
442+
componentsFiles =
443+
M.map (\files -> Set.union otherFiles (Set.map dotCabalGetPath files)) $
444+
M.filterWithKey (\component _ -> component `Set.member` components) compFiles
445+
return (componentsFiles, warnings)
433446

434447
-- | Get file modification time, if it exists.
435448
getModTimeMaybe :: MonadIO m => FilePath -> m (Maybe ModTime)

‎src/Stack/Constants.hs‎

Lines changed: 0 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,3 @@
1-
{-# LANGUAGE CPP #-}
21
{-# LANGUAGE NoImplicitPrelude #-}
32
{-# LANGUAGE OverloadedStrings #-}
43
{-# LANGUAGE TemplateHaskell #-}
@@ -33,7 +32,6 @@ module Stack.Constants
3332
,minTerminalWidth
3433
,maxTerminalWidth
3534
,defaultTerminalWidth
36-
,maxPathLength
3735
)
3836
where
3937

@@ -243,12 +241,3 @@ maxTerminalWidth = 200
243241
-- automatically detect it and when the user doesn't supply one.
244242
defaultTerminalWidth :: Int
245243
defaultTerminalWidth = 100
246-
247-
-- | Maximum length to use in paths. Is only a 'Just' value on windows,
248-
-- corresponding to MAX_PATH.
249-
maxPathLength :: Maybe Int
250-
#ifdef mingw32_HOST_OS
251-
maxPathLength = Just 260
252-
#else
253-
maxPathLength = Nothing
254-
#endif

‎src/Stack/Constants/Config.hs‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ module Stack.Constants.Config
99
, projectDockerSandboxDir
1010
, configCacheFile
1111
, configCabalMod
12-
, buildCacheFile
12+
, buildCachesDir
1313
, testSuccessFile
1414
, testBuiltFile
1515
, hpcRelativeDir
@@ -32,13 +32,13 @@ objectInterfaceDirL = to $ \env -> -- FIXME is this idomatic lens code?
3232
root = view projectRootL env
3333
in root </> workDir </> $(mkRelDir "odir/")
3434

35-
-- | The filename used for dirtiness check of source files.
36-
buildCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
35+
-- | The directory containing the files used for dirtiness check of source files.
36+
buildCachesDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
3737
=> Path Abs Dir -- ^ Package directory.
38-
-> m (Path Abs File)
39-
buildCacheFile dir =
38+
-> m (Path Abs Dir)
39+
buildCachesDir dir =
4040
liftM
41-
(</> $(mkRelFile "stack-build-cache"))
41+
(</> $(mkRelDir "stack-build-caches"))
4242
(distDirFromDir dir)
4343

4444
-- | The filename used to mark tests as having succeeded

‎src/Stack/SDist.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -308,8 +308,8 @@ readLocalPackage pkgDir = do
308308
, lpTestBench = Nothing
309309
, lpForceDirty = False
310310
, lpDirtyFiles = Nothing
311-
, lpNewBuildCache = Map.empty
312-
, lpFiles = Set.empty
311+
, lpNewBuildCaches = Map.empty
312+
, lpComponentFiles = Map.empty
313313
, lpComponents = Set.empty
314314
, lpUnbuildable = Set.empty
315315
, lpLocation = PLFilePath $ toFilePath pkgDir

‎src/Stack/Snapshot.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -482,7 +482,7 @@ calculatePackagePromotion
482482

483483
-- Put together the two split out groups of packages
484484
noLongerGlobals3 :: Map PackageName (LoadedPackageInfo SinglePackageLocation)
485-
noLongerGlobals3 = Map.union (Map.mapWithKey globalToSnapshot noLongerGlobals1) noLongerGlobals2
485+
noLongerGlobals3 = Map.mapWithKey globalToSnapshot (Map.union noLongerGlobals1 noLongerGlobals2)
486486

487487
-- Now do the same thing with parent packages: take out the
488488
-- packages to be upgraded and then split out unmet
@@ -715,14 +715,14 @@ globalToSnapshot name lpi = lpi
715715
splitUnmetDeps :: Map PackageName Version -- ^ extra dependencies available
716716
-> Map PackageName (LoadedPackageInfo loc)
717717
-> ( Map PackageName (LoadedPackageInfo loc)
718-
, Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath))
718+
, Map PackageName (LoadedPackageInfo loc)
719719
)
720720
splitUnmetDeps extra =
721721
start Map.empty . Map.toList
722722
where
723723
start newGlobals0 toProcess0
724724
| anyAdded = start newGlobals1 toProcess1
725-
| otherwise = (newGlobals1, Map.mapWithKey globalToSnapshot $ Map.fromList toProcess1)
725+
| otherwise = (newGlobals1, Map.fromList toProcess1)
726726
where
727727
(newGlobals1, toProcess1, anyAdded) = loop False newGlobals0 id toProcess0
728728

‎src/Stack/Types/Package.hs‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -248,9 +248,9 @@ data LocalPackage = LocalPackage
248248
-- ^ Nothing == not dirty, Just == dirty. Note that the Set may be empty if
249249
-- we forced the build to treat packages as dirty. Also, the Set may not
250250
-- include all modified files.
251-
, lpNewBuildCache :: !(Map FilePath FileCacheInfo)
251+
, lpNewBuildCaches :: !(Map NamedComponent (Map FilePath FileCacheInfo))
252252
-- ^ current state of the files
253-
, lpFiles :: !(Set (Path Abs File))
253+
, lpComponentFiles :: !(Map NamedComponent (Set (Path Abs File)))
254254
-- ^ all files used by this package
255255
, lpLocation :: !(PackageLocation FilePath)
256256
-- ^ Where this source code came from
@@ -303,6 +303,9 @@ isCBench :: NamedComponent -> Bool
303303
isCBench CBench{} = True
304304
isCBench _ = False
305305

306+
lpFiles :: LocalPackage -> Set.Set (Path Abs File)
307+
lpFiles = Set.unions . M.elems . lpComponentFiles
308+
306309
-- | A location to install a package into, either snapshot or local
307310
data InstallLocation = Snap | Local
308311
deriving (Show, Eq)

0 commit comments

Comments
 (0)