Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Remove ModTime check during build (#5125) #5351

Merged
merged 4 commits into from
Aug 6, 2020
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 4 additions & 1 deletion ChangeLog.md
Original file line number Diff line number Diff line change
Expand Up @@ -39,6 +39,9 @@ Bug fixes:
* Fix `stack sdist` introducing unneded sublibrary syntax when using
pvp-bounds. See
[#5289](https://github.com/commercialhaskell/stack/issues/5289)
* Fix modified time busting caches by always calculating sha256 digest
during the build process.
[#5125](https://github.com/commercialhaskell/stack/issues/5125)

## v2.3.1

Expand Down Expand Up @@ -116,7 +119,7 @@ Other enhancements:
prefixes each build log output line with a timestamp.

* Show warning about `local-programs-path` with spaces on windows
when running scripts. See
when running scripts. See
[#5013](https://github.com/commercialhaskell/stack/pull/5013)

* Add `ls dependencies json` which will print dependencies as JSON.
Expand Down
12 changes: 4 additions & 8 deletions src/Stack/Build/Execute.hs
Original file line number Diff line number Diff line change
Expand Up @@ -59,7 +59,6 @@ import qualified Distribution.Text as C
import Distribution.Types.PackageName (mkPackageName)
import Distribution.Types.UnqualComponentName (mkUnqualComponentName)
import Distribution.Version (mkVersion)
import Foreign.C.Types (CTime)
import Path
import Path.CheckInstall
import Path.Extra (toFilePathNoTrailingSep, rejectMissingFile)
Expand Down Expand Up @@ -91,7 +90,6 @@ import System.FileLock (withTryFileLock, SharedExclusive (Exclusive),
import qualified System.FilePath as FP
import System.IO.Error (isDoesNotExistError)
import System.PosixCompat.Files (createLink, modificationTime, getFileStatus)
import System.PosixCompat.Time (epochTime)
import RIO.PrettyPrint
import RIO.Process
import Pantry.Internal.Companion
Expand Down Expand Up @@ -1601,11 +1599,10 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap

-- FIXME: only output these if they're in the build plan.

preBuildTime <- liftIO epochTime
let postBuildCheck _succeeded = do
mlocalWarnings <- case taskType of
TTLocalMutable lp -> do
warnings <- checkForUnlistedFiles taskType preBuildTime pkgDir
warnings <- checkForUnlistedFiles taskType pkgDir
-- TODO: Perhaps only emit these warnings for non extra-dep?
return (Just (lpCabalFile lp, warnings))
_ -> return Nothing
Expand Down Expand Up @@ -1829,12 +1826,11 @@ checkExeStatus platform distDir name = do
file = T.unpack name

-- | Check if any unlisted files have been found, and add them to the build cache.
checkForUnlistedFiles :: HasEnvConfig env => TaskType -> CTime -> Path Abs Dir -> RIO env [PackageWarning]
checkForUnlistedFiles (TTLocalMutable lp) preBuildTime pkgDir = do
checkForUnlistedFiles :: HasEnvConfig env => TaskType -> Path Abs Dir -> RIO env [PackageWarning]
checkForUnlistedFiles (TTLocalMutable lp) pkgDir = do
caches <- runMemoizedWith $ lpNewBuildCaches lp
(addBuildCache,warnings) <-
addUnlistedToBuildCache
preBuildTime
(lpPackage lp)
(lpCabalFile lp)
(lpComponents lp)
Expand All @@ -1844,7 +1840,7 @@ checkForUnlistedFiles (TTLocalMutable lp) preBuildTime pkgDir = do
writeBuildCache pkgDir component $
Map.unions (cache : newToCache)
return warnings
checkForUnlistedFiles TTRemotePackage{} _ _ = return []
checkForUnlistedFiles TTRemotePackage{} _ = return []

-- | Implements running a package's tests. Also handles producing
-- coverage reports if coverage is enabled.
Expand Down
73 changes: 21 additions & 52 deletions src/Stack/Build/Source.hs
Original file line number Diff line number Diff line change
Expand Up @@ -19,16 +19,13 @@ module Stack.Build.Source

import Stack.Prelude
import qualified Pantry.SHA256 as SHA256
import qualified Data.ByteString as S
import Data.ByteString.Builder (toLazyByteString)
import Conduit (ZipSink (..), withSourceFile)
import qualified Data.Conduit.List as CL
import qualified Distribution.PackageDescription as C
import Data.List
import qualified Data.Map as Map
import qualified Data.Map.Strict as M
import qualified Data.Set as Set
import Foreign.C.Types (CTime)
import Stack.Build.Cache
import Stack.Build.Haddock (shouldHaddockDeps)
import Stack.Build.Target
Expand All @@ -41,7 +38,6 @@ import Stack.Types.Package
import Stack.Types.SourceMap
import System.FilePath (takeFileName)
import System.IO.Error (isDoesNotExistError)
import System.PosixCompat.Files (modificationTime, getFileStatus)

-- | loads and returns project packages
projectLocalPackages :: HasEnvConfig env
Expand Down Expand Up @@ -406,46 +402,38 @@ checkBuildCache :: forall m. (MonadIO m)
-> 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)
mdigest <- liftIO (getFileDigestMaybe (toFilePath fp))
return (toFilePath fp, mdigest)
liftM (mconcat . Map.elems) $ sequence $
Map.mergeWithKey
(\fp mmodTime fci -> Just (go fp mmodTime (Just fci)))
(Map.mapWithKey (\fp mmodTime -> go fp mmodTime Nothing))
(\fp mdigest fci -> Just (go fp mdigest (Just fci)))
(Map.mapWithKey (\fp mdigest -> go fp mdigest Nothing))
(Map.mapWithKey (\fp fci -> go fp Nothing (Just fci)))
fileTimes
oldCache
where
go :: FilePath -> Maybe CTime -> Maybe FileCacheInfo -> m (Set FilePath, Map FilePath FileCacheInfo)
go :: FilePath -> Maybe SHA256 -> Maybe FileCacheInfo -> m (Set FilePath, Map FilePath FileCacheInfo)
-- Filter out the cabal_macros file to avoid spurious recompilations
go fp _ _ | takeFileName fp == "cabal_macros.h" = return (Set.empty, Map.empty)
-- Common case where it's in the cache and on the filesystem.
go fp (Just modTime') (Just fci)
| fciModTime fci == modTime' = return (Set.empty, Map.singleton fp fci)
| 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 (Just digest') (Just fci)
| fciHash fci == digest' = return (Set.empty, Map.singleton fp fci)
| otherwise = return (Set.singleton fp, Map.singleton fp $ FileCacheInfo digest')
-- Missing file. Add it to dirty files, but no FileCacheInfo.
go fp Nothing _ = return (Set.singleton fp, Map.empty)
-- Missing cache. Add it to dirty files and compute FileCacheInfo.
go fp (Just modTime') Nothing = do
newFci <- calcFci modTime' fp
return (Set.singleton fp, Map.singleton fp newFci)
go fp (Just digest') Nothing =
return (Set.singleton fp, Map.singleton fp $ FileCacheInfo digest')

-- | Returns entries to add to the build cache for any newly found unlisted modules
addUnlistedToBuildCache
:: HasEnvConfig env
=> CTime
-> Package
=> Package
-> Path Abs File
-> Set NamedComponent
-> Map NamedComponent (Map FilePath a)
-> RIO env (Map NamedComponent [Map FilePath FileCacheInfo], [PackageWarning])
addUnlistedToBuildCache preBuildTime pkg cabalFP nonLibComponents buildCaches = do
addUnlistedToBuildCache pkg cabalFP nonLibComponents buildCaches = do
(componentFiles, warnings) <- getPackageFilesForTargets pkg cabalFP nonLibComponents
results <- forM (M.toList componentFiles) $ \(component, files) -> do
let buildCache = M.findWithDefault M.empty component buildCaches
Expand All @@ -457,13 +445,10 @@ addUnlistedToBuildCache preBuildTime pkg cabalFP nonLibComponents buildCaches =
return (M.fromList (map fst results), concatMap snd results)
where
addFileToCache fp = do
mmodTime <- getModTimeMaybe fp
case mmodTime of
mdigest <- getFileDigestMaybe fp
case mdigest of
Nothing -> return Map.empty
Just modTime' ->
if modTime' < preBuildTime
then Map.singleton fp <$> calcFci modTime' fp
else return Map.empty
Just digest' -> return . Map.singleton fp $ FileCacheInfo digest'

-- | Gets list of Paths for files relevant to a set of components in a package.
-- Note that the library component, if any, is always automatically added to the
Expand All @@ -484,34 +469,18 @@ getPackageFilesForTargets pkg cabalFP nonLibComponents = do
M.filterWithKey (\component _ -> component `elem` components) compFiles
return (componentsFiles, warnings)

-- | Get file modification time, if it exists.
getModTimeMaybe :: MonadIO m => FilePath -> m (Maybe CTime)
getModTimeMaybe fp =
-- | Get file digest, if it exists
getFileDigestMaybe :: MonadIO m => FilePath -> m (Maybe SHA256)
getFileDigestMaybe fp = do
liftIO
(catch
(liftM
(Just . modificationTime)
(getFileStatus fp))
(liftM Just . withSourceFile fp $ getDigest)
(\e ->
if isDoesNotExistError e
then return Nothing
else throwM e))

-- | Create FileCacheInfo for a file.
calcFci :: MonadIO m => CTime -> FilePath -> m FileCacheInfo
calcFci modTime' fp = liftIO $
withSourceFile fp $ \src -> do
(size, digest) <- runConduit $ src .| getZipSink
((,)
<$> ZipSink (CL.fold
(\x y -> x + fromIntegral (S.length y))
0)
<*> ZipSink SHA256.sinkHash)
return FileCacheInfo
{ fciModTime = modTime'
, fciSize = FileSize size
, fciHash = digest
}
where
getDigest src = runConduit $ src .| getZipSink (ZipSink SHA256.sinkHash)

-- | Get 'PackageConfig' for package given its name.
getPackageConfig
Expand Down
17 changes: 5 additions & 12 deletions src/Stack/Types/Package.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,6 @@
module Stack.Types.Package where

import Stack.Prelude
import Foreign.C.Types (CTime)
import qualified RIO.Text as T
import Data.Aeson (ToJSON (..), FromJSON (..), (.=), (.:), object, withObject)
import qualified Data.Map as M
Expand Down Expand Up @@ -342,27 +341,21 @@ instance Monoid InstallLocation where
data InstalledPackageLocation = InstalledTo InstallLocation | ExtraGlobal
deriving (Show, Eq)

data FileCacheInfo = FileCacheInfo
{ fciModTime :: !CTime
, fciSize :: !FileSize
, fciHash :: !SHA256
newtype FileCacheInfo = FileCacheInfo
{ fciHash :: SHA256
}
deriving (Generic, Show, Eq, Typeable)
instance NFData FileCacheInfo

-- Provided for storing the BuildCache values in a file. But maybe
-- JSON/YAML isn't the right choice here, worth considering.
instance ToJSON FileCacheInfo where
toJSON (FileCacheInfo time size hash') = object
[ "modtime" .= time
, "size" .= size
, "hash" .= hash'
toJSON (FileCacheInfo hash') = object
[ "hash" .= hash'
]
instance FromJSON FileCacheInfo where
parseJSON = withObject "FileCacheInfo" $ \o -> FileCacheInfo
<$> o .: "modtime"
<*> o .: "size"
<*> o .: "hash"
<$> o .: "hash"

-- | A descriptor from a .cabal file indicating one of the following:
--
Expand Down