Use new Data.Store.Version to address #2296

src/Data/Store/VersionTagged.hs

@@ -4,12 +4,14 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
 -- | Tag a Store instance with structural version info to ensure we're
 -- reading a compatible format.
 module Data.Store.VersionTagged
-    ( taggedDecodeOrLoad
-    , taggedEncodeFile
-    , decodeFileMaybe
+    ( versionedEncodeFile
+    , versionedDecodeOrLoad
+    , versionedDecodeFile
+    , storeVersionConfig
     ) where
 
 import Control.Applicative
@@ -18,60 +20,88 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Logger
 import Control.Monad.Trans.Control (MonadBaseControl)
 import qualified Data.ByteString as BS
+import Data.Data (Data)
+import qualified Data.Map as M
 import Data.Monoid ((<>))
+import qualified Data.Set as S
 import Data.Store
-import Data.Store.TypeHash
+import Data.Store.Version
 import qualified Data.Text as T
+import Language.Haskell.TH
 import Path
 import Path.IO (ensureDir)
 import Prelude
 
--- | Write to the given file, with a binary-tagged tag.
-taggedEncodeFile :: (Store a, HasTypeHash a, MonadIO m, MonadLogger m, Eq a)
-                 => Path Abs File
-                 -> a
-                 -> m ()
-taggedEncodeFile fp x = do
+versionedEncodeFile :: (Store a, Data a) => VersionConfig a -> Q Exp
+versionedEncodeFile vc = [e| \fp x -> storeEncodeFile fp ($(wrapVersion vc) x) |]
+
+versionedDecodeOrLoad :: (Store a, Data a, Eq a) => VersionConfig a -> Q Exp
+versionedDecodeOrLoad vc = [| versionedDecodeOrLoadImpl $(wrapVersion vc) $(checkVersion vc) |]
+
+versionedDecodeFile :: (Store a, Data a) => VersionConfig a -> Q Exp
+versionedDecodeFile vc = [e| versionedDecodeFileImpl $(checkVersion vc) |]
+
+-- | Write to the given file.
+storeEncodeFile :: (Store a, MonadIO m, MonadLogger m, Eq a)
+                => Path Abs File
+                -> a
+                -> m ()
+storeEncodeFile fp x = do
     let fpt = T.pack (toFilePath fp)
     $logDebug $ "Encoding " <> fpt
     ensureDir (parent fp)
-    let encoded = encode (Tagged x)
-    assert (decodeEx encoded == Tagged x) $ liftIO $ BS.writeFile (toFilePath fp) encoded
+    let encoded = encode x
+    assert (decodeEx encoded == x) $ liftIO $ BS.writeFile (toFilePath fp) encoded
     $logDebug $ "Finished writing " <> fpt
 
 -- | Read from the given file. If the read fails, run the given action and
 -- write that back to the file. Always starts the file off with the
 -- version tag.
-taggedDecodeOrLoad :: (Store a, HasTypeHash a, Eq a, MonadIO m, MonadLogger m, MonadBaseControl IO m)
-                   => Path Abs File
-                   -> m a
-                   -> m a
-taggedDecodeOrLoad fp mx = do
+versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadIO m, MonadLogger m, MonadBaseControl IO m)
+                          => (a -> WithVersion a)
+                          -> (WithVersion a -> Either VersionCheckException a)
+                          -> Path Abs File
+                          -> m a
+                          -> m a
+versionedDecodeOrLoadImpl wrap check fp mx = do
     let fpt = T.pack (toFilePath fp)
     $logDebug $ "Trying to decode " <> fpt
-    mres <- decodeFileMaybe fp
+    mres <- versionedDecodeFileImpl check fp
     case mres of
-        Nothing -> do
-            $logDebug $ "Failure decoding " <> fpt
-            x <- mx
-            taggedEncodeFile fp x
-            return x
         Just x -> do
             $logDebug $ "Success decoding " <> fpt
             return x
+        _ -> do
+            $logDebug $ "Failure decoding " <> fpt
+            x <- mx
+            storeEncodeFile fp (wrap x)
+            return x
 
-decodeFileMaybe :: (Store a, HasTypeHash a, MonadIO m, MonadLogger m, MonadBaseControl IO m)
-                => Path loc File
-                -> m (Maybe a)
-decodeFileMaybe fp = do
+versionedDecodeFileImpl :: (Store a, MonadIO m, MonadLogger m, MonadBaseControl IO m)
+                        => (WithVersion a -> Either VersionCheckException a)
+                        -> Path loc File
+                        -> m (Maybe a)
+versionedDecodeFileImpl check fp = do
     mbs <- liftIO (Just <$> BS.readFile (toFilePath fp)) `catch` \(err :: IOException) -> do
         $logDebug ("Exception ignored when attempting to load " <> T.pack (toFilePath fp) <> ": " <> T.pack (show err))
         return Nothing
     case mbs of
         Nothing -> return Nothing
         Just bs ->
-            liftIO (do (Tagged res) <- decodeIO bs
-                       return (Just res)) `catch` \(err :: PeekException) -> do
+            liftIO (do decoded <- decodeIO bs
+                       return $ case check decoded of
+                           Right res -> Just res
+                           _ -> Nothing) `catch` \(err :: PeekException) -> do
                  let fpt = T.pack (toFilePath fp)
                  $logDebug ("Error while decoding " <> fpt <> ": " <> T.pack (show err) <> " (this might not be an error, when switching between stack versions)")
                  return Nothing
+
+storeVersionConfig :: String -> String -> VersionConfig a
+storeVersionConfig name hash = (namedVersionConfig name hash)
+    { vcIgnore = S.fromList
+        [ "Data.Vector.Unboxed.Base.Vector GHC.Types.Word"
+        , "Data.ByteString.Internal.ByteString"
+        ]
+    , vcRenames = M.fromList
+        [ ( "Data.Maybe.Maybe", "GHC.Base.Maybe") ]
+    }

src/Stack/Build/Cache.hs

@@ -54,14 +54,11 @@ import           Data.Maybe (fromMaybe, mapMaybe)
 import           Data.Monoid ((<>))
 import           Data.Set (Set)
 import qualified Data.Set as Set
-import           Data.Store (Store)
 import qualified Data.Store as Store
-import           Data.Store.TypeHash (HasTypeHash, mkManyHasTypeHash)
 import           Data.Store.VersionTagged
 import           Data.Text (Text)
 import qualified Data.Text as T
 import           Data.Traversable (forM)
-import           GHC.Generics (Generic)
 import           Path
 import           Path.IO
 import           Stack.Constants
@@ -108,64 +105,47 @@ markExeNotInstalled loc ident = do
     ident' <- parseRelFile $ packageIdentifierString ident
     ignoringAbsence (removeFile $ dir </> ident')
 
--- | Stored on disk to know whether the flags have changed or any
--- files have changed.
-data BuildCache = BuildCache
-    { buildCacheTimes :: !(Map FilePath FileCacheInfo)
-      -- ^ Modification times of files.
-    }
-    deriving (Generic, Eq, Show)
-instance Store BuildCache
-instance NFData BuildCache
-
 -- | Try to read the dirtiness cache for the given package directory.
 tryGetBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, MonadLogger m, HasEnvConfig env, MonadBaseControl IO m)
                  => Path Abs Dir -> m (Maybe (Map FilePath FileCacheInfo))
-tryGetBuildCache = liftM (fmap buildCacheTimes) . tryGetCache buildCacheFile
+tryGetBuildCache dir = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir
 
 -- | Try to read the dirtiness cache for the given package directory.
 tryGetConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m)
                   => Path Abs Dir -> m (Maybe ConfigCache)
-tryGetConfigCache = tryGetCache configCacheFile
+tryGetConfigCache dir = $(versionedDecodeFile configCacheVC) =<< configCacheFile dir
 
 -- | Try to read the mod time of the cabal file from the last build
 tryGetCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m)
                => Path Abs Dir -> m (Maybe ModTime)
-tryGetCabalMod = tryGetCache configCabalMod
-
--- | Try to load a cache.
-tryGetCache :: (MonadIO m, Store a, HasTypeHash a, MonadBaseControl IO m, MonadLogger m)
-            => (Path Abs Dir -> m (Path Abs File))
-            -> Path Abs Dir
-            -> m (Maybe a)
-tryGetCache get' dir = do
-    fp <- get' dir
-    decodeFileMaybe fp
+tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir
 
 -- | Write the dirtiness cache for this package's files.
 writeBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m)
                 => Path Abs Dir -> Map FilePath FileCacheInfo -> m ()
-writeBuildCache dir times =
-    writeCache
-        dir
-        buildCacheFile
-        BuildCache
-         { buildCacheTimes = times
-         }
+writeBuildCache dir times = do
+    fp <- buildCacheFile dir
+    $(versionedEncodeFile buildCacheVC) fp BuildCache
+        { buildCacheTimes = times
+        }
 
 -- | Write the dirtiness cache for this package's configuration.
 writeConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m)
                 => Path Abs Dir
                 -> ConfigCache
                 -> m ()
-writeConfigCache dir = writeCache dir configCacheFile
+writeConfigCache dir x = do
+    fp <- configCacheFile dir
+    $(versionedEncodeFile configCacheVC) fp x
 
 -- | See 'tryGetCabalMod'
 writeCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m)
               => Path Abs Dir
               -> ModTime
               -> m ()
-writeCabalMod dir = writeCache dir configCabalMod
+writeCabalMod dir x = do
+    fp <- configCabalMod dir
+    $(versionedEncodeFile modTimeVC) fp x
 
 -- | Delete the caches for the project.
 deleteCaches :: (MonadIO m, MonadReader env m, MonadCatch m, HasEnvConfig env)
@@ -178,16 +158,6 @@ deleteCaches dir = do
     cfp <- configCacheFile dir
     ignoringAbsence (removeFile cfp)
 
--- | Write to a cache.
-writeCache :: (Store a, HasTypeHash a, Eq a, MonadIO m, MonadLogger m)
-           => Path Abs Dir
-           -> (Path Abs Dir -> m (Path Abs File))
-           -> a
-           -> m ()
-writeCache dir get' content = do
-    fp <- get' dir
-    taggedEncodeFile fp content
-
 flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)
               => Installed
               -> m (Path Abs File)
@@ -205,7 +175,7 @@ tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env
                 -> m (Maybe ConfigCache)
 tryGetFlagCache gid = do
     fp <- flagCacheFile gid
-    decodeFileMaybe fp
+    $(versionedDecodeFile configCacheVC) fp
 
 writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, MonadLogger m)
                => Installed
@@ -214,27 +184,23 @@ writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m,
 writeFlagCache gid cache = do
     file <- flagCacheFile gid
     ensureDir (parent file)
-    taggedEncodeFile file cache
+    $(versionedEncodeFile configCacheVC) file cache
 
 -- | Mark a test suite as having succeeded
 setTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m)
                => Path Abs Dir
                -> m ()
-setTestSuccess dir =
-    writeCache
-        dir
-        testSuccessFile
-        True
+setTestSuccess dir = do
+    fp <- testSuccessFile dir
+    $(versionedEncodeFile testSuccessVC) fp True
 
 -- | Mark a test suite as not having succeeded
 unsetTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m)
                  => Path Abs Dir
                  -> m ()
-unsetTestSuccess dir =
-    writeCache
-        dir
-        testSuccessFile
-        False
+unsetTestSuccess dir = do
+    fp <- testSuccessFile dir
+    $(versionedEncodeFile testSuccessVC) fp False
 
 -- | Check if the test suite already passed
 checkTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m)
@@ -243,7 +209,7 @@ checkTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig en
 checkTestSuccess dir =
     liftM
         (fromMaybe False)
-        (tryGetCache testSuccessFile dir)
+        ($(versionedDecodeFile testSuccessVC) =<< testSuccessFile dir)
 
 --------------------------------------
 -- Precompiled Cache
@@ -325,7 +291,7 @@ writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do
         name <- parseRelFile $ T.unpack exe
         relPath <- stackRootRelative $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name
         return $ toFilePath $ relPath
-    taggedEncodeFile file PrecompiledCache
+    $(versionedEncodeFile precompiledCacheVC) file PrecompiledCache
         { pcLibrary = mlibpath
         , pcExes = exes'
         }
@@ -350,7 +316,7 @@ readPrecompiledCache pkgident copts depIDs = do
                   }
 
     (file, getOldFile) <- precompiledCacheFile pkgident copts depIDs
-    mres <- decodeFileMaybe file
+    mres <- $(versionedDecodeFile precompiledCacheVC) file
     case mres of
         Just res -> return (Just $ toAbsPC res)
         Nothing -> do
@@ -359,7 +325,7 @@ readPrecompiledCache pkgident copts depIDs = do
             mpc <- fmap (fmap toAbsPC) $ binaryDecodeFileOrFailDeep oldFile
             -- Write out file in new format. Keep old file around for
             -- the benefit of older stack versions.
-            forM_ mpc (taggedEncodeFile file)
+            forM_ mpc ($(versionedEncodeFile precompiledCacheVC) file)
             return mpc
 
 -- | Ensure that there are no lurking exceptions deep inside the parsed
@@ -375,10 +341,3 @@ binaryDecodeFileOrFailDeep fp = liftIO $ fmap (either (\_ -> Nothing) id) $ tryA
         Right x -> return (Just x)
 
 type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a)
-
-$(mkManyHasTypeHash
-    [ [t| BuildCache |]
-    -- TODO: put this orphan elsewhere? Not sure if we want tons of
-    -- instances of HasTypeHash or not.
-    , [t| Bool |]
-    ])

src/Stack/BuildPlan.hs

@@ -45,7 +45,7 @@ import           Control.Monad.State.Strict      (State, execState, get, modify,
 import           Control.Monad.Trans.Control (MonadBaseControl)
 import qualified Crypto.Hash.SHA256 as SHA256
 import           Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings)
-import           Data.Store.VersionTagged (taggedDecodeOrLoad, decodeFileMaybe, taggedEncodeFile)
+import           Data.Store.VersionTagged
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Base64.URL as B64URL
 import qualified Data.ByteString.Char8 as S8
@@ -452,7 +452,7 @@ loadMiniBuildPlan
     -> m MiniBuildPlan
 loadMiniBuildPlan name = do
     path <- configMiniBuildPlanCache name
-    taggedDecodeOrLoad path $ liftM buildPlanFixes $ do
+    $(versionedDecodeOrLoad miniBuildPlanVC) path $ liftM buildPlanFixes $ do
         bp <- loadBuildPlan name
         toMiniBuildPlan
             (siCompilerVersion $ bpSystemInfo bp)
@@ -979,7 +979,7 @@ parseCustomMiniBuildPlan mconfigPath0 url0 = do
                    -- cases.
                    binaryPath <- getBinaryPath hash
                    alreadyCached <- doesFileExist binaryPath
-                   unless alreadyCached $ taggedEncodeFile binaryPath mbp
+                   unless alreadyCached $ $(versionedEncodeFile miniBuildPlanVC) binaryPath mbp
                    return (mbp, hash)
   where
     downloadCustom url req = do
@@ -991,7 +991,7 @@ parseCustomMiniBuildPlan mconfigPath0 url0 = do
         yamlBS <- liftIO $ S.readFile $ toFilePath cacheFP
         let yamlHash = doHash yamlBS
         binaryPath <- getBinaryPath yamlHash
-        liftM (, yamlHash) $ taggedDecodeOrLoad binaryPath $ do
+        liftM (, yamlHash) $ $(versionedDecodeOrLoad miniBuildPlanVC) binaryPath $ do
             (cs, mresolver) <- decodeYaml yamlBS
             parentMbp <- case (csCompilerVersion cs, mresolver) of
                 (Nothing, Nothing) -> throwM (NeitherCompilerOrResolverSpecified url)
@@ -1028,7 +1028,7 @@ parseCustomMiniBuildPlan mconfigPath0 url0 = do
                                 exists <- doesFileExist binaryPath
                                 if exists
                                     then do
-                                        eres <- decodeFileMaybe binaryPath
+                                        eres <- $(versionedDecodeFile miniBuildPlanVC) binaryPath
                                         case eres of
                                             Just mbp -> return mbp
                                             -- Invalid format cache file, remove.