Merge pull request #5351 from aschmois/master

Remove ModTime check during build (#5125)

Author: snoyberg

ChangeLog.md

@@ -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)
 
 * Fix `stack test --coverage` when using Cabal 3
 
@@ -118,7 +121,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.

src/Stack/Build/Execute.hs

@@ -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)
@@ -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
@@ -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
@@ -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)
@@ -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.

src/Stack/Build/Source.hs

@@ -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
@@ -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
@@ -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
@@ -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
@@ -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

src/Stack/Types/Package.hs

@@ -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
@@ -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:
 --