From 3dcfe27572cd07c73028471d8e71dcf3521069f8 Mon Sep 17 00:00:00 2001 From: Gershom Bazerman Date: Thu, 5 Aug 2021 22:52:51 -0400 Subject: [PATCH] lazily decode cache files for checking invalidation --- Cabal/src/Distribution/Utils/Structured.hs | 22 +++++++++++- .../src/Distribution/Client/FileMonitor.hs | 35 +++++++++++-------- 2 files changed, 41 insertions(+), 16 deletions(-) diff --git a/Cabal/src/Distribution/Utils/Structured.hs b/Cabal/src/Distribution/Utils/Structured.hs index 560bbf1c015..7715d6858cd 100644 --- a/Cabal/src/Distribution/Utils/Structured.hs +++ b/Cabal/src/Distribution/Utils/Structured.hs @@ -53,6 +53,7 @@ module Distribution.Utils.Structured ( structuredDecode, structuredDecodeOrFailIO, structuredDecodeFileOrFail, + structuredDecodeTriple, -- * Structured class Structured (structure), MD5, @@ -101,6 +102,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as LT import qualified Data.Time as Time import qualified Distribution.Compat.Binary as Binary +import Data.Binary.Get (runGetOrFail) #ifdef MIN_VERSION_aeson import qualified Data.Aeson as Aeson @@ -207,7 +209,7 @@ structureBuilder s0 = State.evalState (go s0) Map.empty where Nothing -> return $ mconcat [ Builder.word8 0, Builder.stringUtf8 (show t) ] Just acc' -> do State.put acc' - k + k goSop :: SopStructure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder goSop sop = do @@ -292,6 +294,24 @@ structuredDecodeOrFailIO bs = handler (ErrorCall str) = return $ Left str #endif +structuredDecodeTriple + :: forall a b c. (Structured (a,b,c), Binary.Binary a, Binary.Binary b, Binary.Binary c) + => LBS.ByteString -> Either String (a, b, Either String c) +structuredDecodeTriple lbs = + let partialDecode = + (`runGetOrFail` lbs) $ do + (_ :: Tag (a,b,c)) <- Binary.get + (a :: a) <- Binary.get + (b :: b) <- Binary.get + pure (a, b) + cleanEither (Left (_, pos, msg)) = Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) + cleanEither (Right (_,_,v)) = Right v + + in case partialDecode of + Left (_, pos, msg) -> Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) + Right (lbs', _, (x,y)) -> Right (x, y, cleanEither $ runGetOrFail (Binary.get :: Binary.Get c) lbs') + + -- | Lazily reconstruct a value previously written to a file. structuredDecodeFileOrFail :: (Binary.Binary a, Structured a) => FilePath -> IO (Either String a) structuredDecodeFileOrFail f = structuredDecodeOrFailIO =<< LBS.readFile f diff --git a/cabal-install/src/Distribution/Client/FileMonitor.hs b/cabal-install/src/Distribution/Client/FileMonitor.hs index b93fdd91dde..ec7be64554f 100644 --- a/cabal-install/src/Distribution/Client/FileMonitor.hs +++ b/cabal-install/src/Distribution/Client/FileMonitor.hs @@ -61,7 +61,7 @@ import Distribution.Compat.Time import Distribution.Client.Glob import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) import Distribution.Client.Utils (mergeBy, MergeResult(..)) -import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode) +import Distribution.Utils.Structured (structuredEncode, structuredDecodeTriple) import System.FilePath import System.Directory import System.IO @@ -432,16 +432,18 @@ checkFileMonitorChanged handleDoesNotExist (MonitorChanged MonitorFirstRun) $ handleErrorCall (MonitorChanged MonitorCorruptCache) $ - readCacheFile monitor - >>= either (\_ -> return (MonitorChanged MonitorCorruptCache)) - checkStatusCache + withCacheFile monitor $ + either (\_ -> return (MonitorChanged MonitorCorruptCache)) + checkStatusCache where checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do change <- checkForChanges case change of Just reason -> return (MonitorChanged reason) - Nothing -> return (MonitorUnchanged cachedResult monitorFiles) + Nothing -> case cachedResult of + Left _ -> pure (MonitorChanged MonitorCorruptCache) + Right cr -> return (MonitorUnchanged cr monitorFiles) where monitorFiles = reconstructMonitorFilePaths cachedFileStatus where -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that @@ -486,21 +488,25 @@ checkFileMonitorChanged -- But we might still want to update the cache whenCacheChanged cacheStatus $ - rewriteCacheFile monitor cachedFileStatus' cachedKey cachedResult + case cachedResult of + Left _ -> pure () + Right cr -> rewriteCacheFile monitor cachedFileStatus' cachedKey cr return Nothing + -- | Helper for reading the cache file. -- -- This determines the type and format of the binary cache file. -- -readCacheFile :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b - -> IO (Either String (MonitorStateFileSet, a, b)) -readCacheFile FileMonitor {fileMonitorCacheFile} = +withCacheFile :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -> (Either String (MonitorStateFileSet, a, Either String b) -> IO r) + -> IO r +withCacheFile (FileMonitor {fileMonitorCacheFile}) k = withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do - contents <- BS.hGetContents hnd - structuredDecodeOrFailIO contents + contents <- structuredDecodeTriple <$> BS.hGetContents hnd + k contents -- | Helper for writing the cache file. -- @@ -983,8 +989,8 @@ readCacheFileHashes :: (Binary a, Structured a, Binary b, Structured b) => FileMonitor a b -> IO FileHashCache readCacheFileHashes monitor = handleDoesNotExist Map.empty $ - handleErrorCall Map.empty $ do - res <- readCacheFile monitor + handleErrorCall Map.empty $ + withCacheFile monitor $ \res -> case res of Left _ -> return Map.empty Right (msfs, _, _) -> return (mkFileHashCache msfs) @@ -1127,4 +1133,3 @@ handleIOException e = ------------------------------------------------------------------------------ -- Instances -- -