diff --git a/Cabal/src/Distribution/Utils/Structured.hs b/Cabal/src/Distribution/Utils/Structured.hs index 560bbf1c015..901047eb5a8 100644 --- a/Cabal/src/Distribution/Utils/Structured.hs +++ b/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 diff --git a/cabal-install/src/Distribution/Client/FileMonitor.hs b/cabal-install/src/Distribution/Client/FileMonitor.hs index 72f1d0678ef..65a3a368c8d 100644 --- a/cabal-install/src/Distribution/Client/FileMonitor.hs +++ b/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 -- -