lazily decode cache files for checking invalidation

haskell · Aug 6, 2021 · 3dcfe27 · 3dcfe27
1 parent 769e4ed
commit 3dcfe27
Show file tree

Hide file tree

Showing 2 changed files with 41 additions and 16 deletions.
diff --git 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
@@ -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
 --
-