Merge pull request #7516 from haskell/gb/speed-cache-reading

lazily decode cache files for checking invalidation

Author: gbaz

Cabal/src/Distribution/Utils/Structured.hs

@@ -64,6 +64,7 @@ module Distribution.Utils.Structured (
     containerStructure,
     -- * Structure type
     Structure (..),
+    Tag (..),
     TypeName,
     ConstructorName,
     TypeVersion,
@@ -207,7 +208,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

cabal-install/src/Distribution/Client/FileMonitor.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving,
-             NamedFieldPuns, BangPatterns #-}
+             NamedFieldPuns, BangPatterns, ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -45,8 +45,10 @@ module Distribution.Client.FileMonitor (
 
 import Prelude ()
 import Distribution.Client.Compat.Prelude
+import qualified Distribution.Compat.Binary as Binary
 
 import qualified Data.Map.Strict as Map
+import Data.Binary.Get (runGetOrFail)
 import qualified Data.ByteString.Lazy as BS
 import qualified Data.Hashable as Hashable
 
@@ -62,7 +64,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, Tag (..))
 import           System.FilePath
 import           System.Directory
 import           System.IO
@@ -434,17 +436,19 @@ checkFileMonitorChanged
 
     handleDoesNotExist (MonitorChanged MonitorFirstRun) $
     handleErrorCall    (MonitorChanged MonitorCorruptCache) $
-          readCacheFile monitor
-      >>= either (\_ -> return (MonitorChanged MonitorCorruptCache))
-                 checkStatusCache
+    withCacheFile monitor $
+        either (\_ -> return (MonitorChanged MonitorCorruptCache))
+               checkStatusCache
 
   where
-    checkStatusCache :: (MonitorStateFileSet, a, b) -> IO (MonitorChanged a b)
+    checkStatusCache :: (MonitorStateFileSet, a, Either String b) -> IO (MonitorChanged a b)
     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
@@ -479,7 +483,7 @@ checkFileMonitorChanged
       = return Nothing
 
     -- Check if any file has changed
-    checkFileChange :: MonitorStateFileSet -> a -> b -> IO (Maybe (MonitorChangedReason a))
+    checkFileChange :: MonitorStateFileSet -> a -> Either String b -> IO (Maybe (MonitorChangedReason a))
     checkFileChange cachedFileStatus cachedKey cachedResult = do
       res <- probeFileSystem root cachedFileStatus
       case res of
@@ -492,21 +496,50 @@ 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
 
+-- | Lazily decode a triple, parsing the first two fields strictly and
+-- returning a lazy value containing either the last one or an error.
+-- This is helpful for cabal cache files where the first two components
+-- contain header data that lets one test if the cache is still valid,
+-- and the last (potentially large) component is the cached value itself.
+-- This way we can test for cache validity without needing to pay the
+-- cost of the decode of stale cache data. This lives here rather than
+-- Distribution.Utils.Structured because it depends on a newer version of
+-- binary than supported in the Cabal library proper.
+structuredDecodeTriple
+  :: forall a b c. (Structured a, Structured b, Structured c, Binary.Binary a, Binary.Binary b, Binary.Binary c)
+  => BS.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')
+
 -- | 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)
+withCacheFile :: (Binary a, Structured a, Binary b, Structured b)
               => FileMonitor a b
-              -> IO (Either String (MonitorStateFileSet, a, b))
-readCacheFile FileMonitor {fileMonitorCacheFile} =
+              -> (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.
 --
@@ -989,8 +1022,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)
@@ -1136,4 +1169,3 @@ handleIOException e =
 ------------------------------------------------------------------------------
 -- Instances
 --
-