Use binary-tagged, remove WithTag

src/Data/Binary/VersionTagged.hs

@@ -1,17 +1,18 @@
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ConstraintKinds #-}
 -- | Tag a Binary instance with the stack version number to ensure we're
 -- reading a compatible format.
 module Data.Binary.VersionTagged
     ( taggedDecodeOrLoad
     , taggedEncodeFile
     , Binary (..)
-    , BinarySchema (..)
+    , BinarySchema
+    , HasStructuralInfo
+    , HasSemanticVersion
     , decodeFileOrFailDeep
-    , encodeFile
     , NFData (..)
     , genericRnf
     ) where
@@ -21,50 +22,26 @@ import Control.Exception (Exception)
 import Control.Monad.Catch (MonadThrow (..))
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Logger
-import Data.Binary (Binary (..), encodeFile, decodeFileOrFail, putWord8, getWord8)
+import Data.Binary (Binary (..))
 import Data.Binary.Get (ByteOffset)
+import Data.Binary.Tagged (HasStructuralInfo, HasSemanticVersion)
+import qualified Data.Binary.Tagged as BinaryTagged
 import Data.Typeable (Typeable)
 import Control.Exception.Enclosed (tryAnyDeep)
 import System.FilePath (takeDirectory)
 import System.Directory (createDirectoryIfMissing)
-import qualified Data.ByteString as S
-import Data.ByteString (ByteString)
-import Control.Monad (forM_, when)
-import Data.Proxy
 import qualified Data.Text as T
 
-magic :: ByteString
-magic = "stack"
+type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a)
 
--- | A @Binary@ instance that also has a schema version
-class (Binary a, NFData a) => BinarySchema a where
-    binarySchema :: Proxy a -> Int
-
-newtype WithTag a = WithTag a
-    deriving NFData
-instance forall a. BinarySchema a => Binary (WithTag a) where
-    get = do
-        forM_ (S.unpack magic) $ \w -> do
-            w' <- getWord8
-            when (w /= w')
-                $ fail "Mismatched magic string, forcing a recompute"
-        tag' <- get
-        if binarySchema (Proxy :: Proxy a) == tag'
-            then fmap WithTag get
-            else fail "Mismatched tags, forcing a recompute"
-    put (WithTag x) = do
-        mapM_ putWord8 $ S.unpack magic
-        put (binarySchema (Proxy :: Proxy a))
-        put x
-
--- | Write to the given file, with a version tag.
+-- | Write to the given file, with a binary-tagged tag.
 taggedEncodeFile :: (BinarySchema a, MonadIO m)
                  => FilePath
                  -> a
                  -> m ()
 taggedEncodeFile fp x = liftIO $ do
     createDirectoryIfMissing True $ takeDirectory fp
-    encodeFile fp $ WithTag x
+    BinaryTagged.taggedEncodeFile fp x
 
 -- | 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
@@ -82,18 +59,18 @@ taggedDecodeOrLoad fp mx = do
             x <- mx
             taggedEncodeFile fp x
             return x
-        Right (WithTag x) -> do
+        Right x -> do
             $logDebug $ T.pack $ "Success decoding " ++ fp
             return x
 
 -- | Ensure that there are no lurking exceptions deep inside the parsed
 -- value... because that happens unfortunately. See
 -- https://github.com/commercialhaskell/stack/issues/554
-decodeFileOrFailDeep :: (Binary a, NFData a, MonadIO m, MonadThrow n)
+decodeFileOrFailDeep :: (BinarySchema a, MonadIO m, MonadThrow n)
                      => FilePath
                      -> m (n a)
 decodeFileOrFailDeep fp = liftIO $ fmap (either throwM return) $ tryAnyDeep $ do
-    eres <- decodeFileOrFail fp
+    eres <- BinaryTagged.taggedDecodeFileOrFail fp
     case eres of
         Left (offset, str) -> throwM $ DecodeFileFailure fp offset str
         Right x -> return x

src/Stack/Build/Cache.hs

@@ -36,7 +36,7 @@ import           Control.Monad.IO.Class
 import           Control.Monad.Logger (MonadLogger)
 import           Control.Monad.Reader
 import qualified Crypto.Hash.SHA256 as SHA256
-import qualified Data.Binary as Binary
+import qualified Data.Binary as Binary (encode)
 import           Data.Binary.VersionTagged
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Base16 as B16
@@ -96,6 +96,8 @@ data BuildCache = BuildCache
     }
     deriving (Generic)
 instance Binary BuildCache
+instance HasStructuralInfo BuildCache
+instance HasSemanticVersion BuildCache
 instance NFData BuildCache where
     rnf = genericRnf
 
@@ -115,7 +117,7 @@ tryGetCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, Mo
 tryGetCabalMod = tryGetCache configCabalMod
 
 -- | Try to load a cache.
-tryGetCache :: (MonadIO m, Binary a, NFData a)
+tryGetCache :: (MonadIO m, BinarySchema a)
             => (Path Abs Dir -> m (Path Abs File))
             -> Path Abs Dir
             -> m (Maybe a)
@@ -158,14 +160,14 @@ deleteCaches dir = do
     removeFileIfExists cfp
 
 -- | Write to a cache.
-writeCache :: (Binary a, MonadIO m)
+writeCache :: (BinarySchema a, MonadIO m)
            => Path Abs Dir
            -> (Path Abs Dir -> m (Path Abs File))
            -> a
            -> m ()
 writeCache dir get' content = do
     fp <- get' dir
-    liftIO $ encodeFile (toFilePath fp) content
+    taggedEncodeFile (toFilePath fp) content
 
 flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)
               => Installed
@@ -193,7 +195,7 @@ writeFlagCache gid cache = do
     file <- flagCacheFile gid
     liftIO $ do
         createTree (parent file)
-        encodeFile (toFilePath file) cache
+        taggedEncodeFile (toFilePath file) cache
 
 -- | Mark a test suite as having succeeded
 setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
@@ -335,7 +337,7 @@ writePrecompiledCache baseConfigOpts pkgident copts mghcPkgId exes = do
     exes' <- forM (Set.toList exes) $ \exe -> do
         name <- parseRelFile $ T.unpack exe
         return $ toFilePath $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name
-    liftIO $ encodeFile (toFilePath file) PrecompiledCache
+    liftIO $ taggedEncodeFile (toFilePath file) PrecompiledCache
         { pcLibrary = mlibpath
         , pcExes = exes'
         }

src/Stack/PackageDump.hs

@@ -62,10 +62,9 @@ import           System.Process.Read
 -- | Cached information on whether package have profiling libraries and haddocks.
 newtype InstalledCache = InstalledCache (IORef InstalledCacheInner)
 newtype InstalledCacheInner = InstalledCacheInner (Map GhcPkgId InstalledCacheEntry)
-    deriving (Binary, NFData)
-instance BinarySchema InstalledCacheInner where
-    -- Don't forget to update this if you change the datatype in any way!
-    binarySchema _ = 2
+    deriving (Binary, NFData, Generic)
+instance HasStructuralInfo InstalledCacheInner
+instance HasSemanticVersion InstalledCacheInner
 
 -- | Cached information on whether a package has profiling libraries and haddocks.
 data InstalledCacheEntry = InstalledCacheEntry
@@ -74,6 +73,7 @@ data InstalledCacheEntry = InstalledCacheEntry
     , installedCacheIdent :: !PackageIdentifier }
     deriving (Eq, Generic)
 instance Binary InstalledCacheEntry
+instance HasStructuralInfo InstalledCacheEntry
 instance NFData InstalledCacheEntry where
     rnf = genericRnf
 

src/Stack/PackageIndex.hs

@@ -88,16 +88,18 @@ data PackageCache = PackageCache
     -- ^ size in bytes of the .cabal file
     , pcDownload :: !(Maybe PackageDownload)
     }
-    deriving Generic
+    deriving (Generic)
+
 instance Binary.Binary PackageCache
 instance NFData PackageCache where
     rnf = genericRnf
+instance HasStructuralInfo PackageCache
 
 newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache)
-    deriving (Binary.Binary, NFData)
-instance BinarySchema PackageCacheMap where
-    -- Don't forget to update this if you change the datatype in any way!
-    binarySchema _ = 1
+    deriving (Generic, Binary, NFData)
+instance HasStructuralInfo PackageCacheMap
+instance HasSemanticVersion PackageCacheMap
+
 -- | Populate the package index caches and return them.
 populateCache
     :: (MonadIO m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
@@ -363,6 +365,7 @@ data PackageDownload = PackageDownload
     }
     deriving (Show, Generic)
 instance Binary.Binary PackageDownload
+instance HasStructuralInfo PackageDownload
 instance NFData PackageDownload where
     rnf = genericRnf
 instance FromJSON PackageDownload where

src/Stack/Types/Build.hs

@@ -522,6 +522,9 @@ instance Binary ConfigCache where
 instance NFData ConfigCache where
     rnf = genericRnf
 
+instance HasStructuralInfo ConfigCache
+instance HasSemanticVersion ConfigCache
+
 -- | A task to perform when building
 data Task = Task
     { taskProvides        :: !PackageIdentifier        -- ^ the package/version to be built
@@ -712,6 +715,7 @@ data ConfigureOpts = ConfigureOpts
     }
     deriving (Show, Eq, Generic)
 instance Binary ConfigureOpts
+instance HasStructuralInfo ConfigureOpts
 instance NFData ConfigureOpts where
     rnf = genericRnf
 
@@ -726,5 +730,7 @@ data PrecompiledCache = PrecompiledCache
     }
     deriving (Show, Eq, Generic)
 instance Binary PrecompiledCache
+instance HasSemanticVersion PrecompiledCache
+instance HasStructuralInfo PrecompiledCache
 instance NFData PrecompiledCache where
     rnf = genericRnf

src/Stack/Types/BuildPlan.hs

@@ -250,8 +250,8 @@ newtype Maintainer = Maintainer { unMaintainer :: Text }
 
 -- | Name of an executable.
 newtype ExeName = ExeName { unExeName :: ByteString }
-    deriving (Show, Eq, Ord, Hashable, IsString, Generic, NFData)
-instance Binary ExeName
+    deriving (Show, Eq, Ord, Hashable, IsString, Generic, Binary, NFData)
+instance HasStructuralInfo ExeName
 instance ToJSON ExeName where
     toJSON = toJSON . S8.unpack . unExeName
 instance FromJSON ExeName where
@@ -377,9 +377,8 @@ data MiniBuildPlan = MiniBuildPlan
 instance Binary MiniBuildPlan
 instance NFData MiniBuildPlan where
     rnf = genericRnf
-instance BinarySchema MiniBuildPlan where
-    -- Don't forget to update this if you change the datatype in any way!
-    binarySchema _ = 2
+instance HasStructuralInfo MiniBuildPlan
+instance HasSemanticVersion MiniBuildPlan
 
 -- | Information on a single package for the 'MiniBuildPlan'.
 data MiniPackageInfo = MiniPackageInfo
@@ -398,6 +397,7 @@ data MiniPackageInfo = MiniPackageInfo
     }
     deriving (Generic, Show, Eq)
 instance Binary MiniPackageInfo
+instance HasStructuralInfo MiniPackageInfo
 instance NFData MiniPackageInfo where
     rnf = genericRnf
 

src/Stack/Types/Compiler.hs

@@ -7,7 +7,7 @@ module Stack.Types.Compiler where
 import           Control.DeepSeq
 import           Control.DeepSeq.Generics (genericRnf)
 import           Data.Aeson
-import           Data.Binary (Binary)
+import           Data.Binary.VersionTagged (Binary, HasStructuralInfo)
 import           Data.Monoid ((<>))
 import qualified Data.Text as T
 import           GHC.Generics (Generic)
@@ -34,6 +34,7 @@ data CompilerVersion
         {-# UNPACK #-} !Version -- GHC version
     deriving (Generic, Show, Eq, Ord)
 instance Binary CompilerVersion
+instance HasStructuralInfo CompilerVersion
 instance NFData CompilerVersion where
     rnf = genericRnf
 instance ToJSON CompilerVersion where

src/Stack/Types/FlagName.hs

@@ -55,6 +55,7 @@ instance Show FlagNameParseFail where
 newtype FlagName =
   FlagName ByteString
   deriving (Typeable,Data,Generic,Hashable,Binary,NFData)
+instance HasStructuralInfo FlagName
 instance Eq FlagName where
     x == y = (compare x y) == EQ
 instance Ord FlagName where

src/Stack/Types/GhcPkgId.hs

@@ -54,6 +54,7 @@ instance Binary GhcPkgId where
         fmap GhcPkgId get
 instance NFData GhcPkgId where
     rnf = genericRnf
+instance HasStructuralInfo GhcPkgId
 
 instance Show GhcPkgId where
   show = show . ghcPkgIdString

src/Stack/Types/Package.hs

@@ -228,13 +228,17 @@ data FileCacheInfo = FileCacheInfo
     }
     deriving (Generic, Show)
 instance Binary FileCacheInfo
+instance HasStructuralInfo FileCacheInfo
 instance NFData FileCacheInfo where
     rnf = genericRnf
 
 -- | Used for storage and comparison.
 newtype ModTime = ModTime (Integer,Rational)
   deriving (Ord,Show,Generic,Eq,NFData,Binary)
 
+instance HasStructuralInfo ModTime
+instance HasSemanticVersion ModTime
+
 -- | A descriptor from a .cabal file indicating one of the following:
 --
 -- exposed-modules: Foo

src/Stack/Types/PackageIdentifier.hs

@@ -25,7 +25,7 @@ import           Control.Exception (Exception)
 import           Control.Monad.Catch (MonadThrow, throwM)
 import           Data.Aeson.Extended
 import           Data.Attoparsec.ByteString.Char8
-import           Data.Binary (Binary)
+import           Data.Binary.VersionTagged (Binary, HasStructuralInfo)
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as S8
 import           Data.Data
@@ -58,6 +58,7 @@ instance NFData PackageIdentifier where
 
 instance Hashable PackageIdentifier
 instance Binary PackageIdentifier
+instance HasStructuralInfo PackageIdentifier
 
 instance Show PackageIdentifier where
   show = show . packageIdentifierString

src/Stack/Types/PackageName.hs

@@ -31,7 +31,7 @@ import           Control.Monad.Catch
 import           Data.Aeson.Extended
 import           Data.Attoparsec.ByteString.Char8
 import           Data.Attoparsec.Combinators
-import           Data.Binary (Binary)
+import           Data.Binary.VersionTagged (Binary, HasStructuralInfo)
 import           Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as S8
 import           Data.Char (isLetter)
@@ -73,6 +73,8 @@ instance Lift PackageName where
 instance Show PackageName where
   show (PackageName n) = S8.unpack n
 
+instance HasStructuralInfo PackageName
+
 instance ToJSON PackageName where
     toJSON = toJSON . packageNameText
 instance FromJSON PackageName where

src/Stack/Types/Version.hs

@@ -32,7 +32,7 @@ import           Control.DeepSeq
 import           Control.Monad.Catch
 import           Data.Aeson.Extended
 import           Data.Attoparsec.ByteString.Char8
-import           Data.Binary (Binary)
+import           Data.Binary.VersionTagged (Binary, HasStructuralInfo)
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as S8
 import           Data.Data
@@ -66,7 +66,7 @@ instance Show VersionParseFail where
 newtype Version =
   Version {unVersion :: Vector Word}
   deriving (Eq,Ord,Typeable,Data,Generic,Binary,NFData)
-
+instance HasStructuralInfo Version
 
 instance Hashable Version where
   hashWithSalt i = hashWithSalt i . V.toList . unVersion

stack-7.8.yaml

@@ -9,4 +9,5 @@ extra-deps:
 - http-client-0.4.19
 - http-conduit-2.1.8
 - ignore-0.1.1.0
+- binary-tagged-0.1.1.0
 - fsnotify-0.2.1

stack.cabal

@@ -110,6 +110,7 @@ library
                    , base64-bytestring
                    , bifunctors >= 4.2.1
                    , binary >= 0.7
+                   , binary-tagged >= 0.1.1
                    , blaze-builder
                    , byteable
                    , bytestring

stack.yaml

@@ -1,6 +1,7 @@
 resolver: lts-3.0
 extra-deps:
 - ignore-0.1.1.0
+- binary-tagged-0.1.1.0
 flags:
   ignore:
     without-pcre: true