Skip to content

Commit 76716b3

Browse files
snoybergsnoyberg
committed
Merge pull request commercialhaskell#954 from phadej/889-binary-tagged
Use binary-tagged, remove WithTag
2 parents 804b7e3 + 05dd573 commit 76716b3

17 files changed

Lines changed: 64 additions & 61 deletions

‎ChangeLog.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ Other enhancements:
1111
* `--file-watch` is more discerning about which files to rebuild for [#912](https://github.com/commercialhaskell/stack/issues/912)
1212
* `stack path` now supports `--global-pkg-db` and `--ghc-package-path`
1313
* `--reconfigure` flag [#914](https://github.com/commercialhaskell/stack/issues/914) [#946](https://github.com/commercialhaskell/stack/issues/946)
14+
* Cached data is written with a checksum of its structure [#889](https://github.com/commercialhaskell/stack/issues/889)
1415

1516
Bug fixes:
1617

‎src/Data/Binary/VersionTagged.hs‎

Lines changed: 13 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -1,17 +1,18 @@
11
{-# LANGUAGE DeriveDataTypeable #-}
2-
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
32
{-# LANGUAGE OverloadedStrings #-}
43
{-# LANGUAGE ScopedTypeVariables #-}
54
{-# LANGUAGE TemplateHaskell #-}
5+
{-# LANGUAGE ConstraintKinds #-}
66
-- | Tag a Binary instance with the stack version number to ensure we're
77
-- reading a compatible format.
88
module Data.Binary.VersionTagged
99
( taggedDecodeOrLoad
1010
, taggedEncodeFile
1111
, Binary (..)
12-
, BinarySchema (..)
12+
, BinarySchema
13+
, HasStructuralInfo
14+
, HasSemanticVersion
1315
, decodeFileOrFailDeep
14-
, encodeFile
1516
, NFData (..)
1617
, genericRnf
1718
) where
@@ -21,50 +22,26 @@ import Control.Exception (Exception)
2122
import Control.Monad.Catch (MonadThrow (..))
2223
import Control.Monad.IO.Class (MonadIO, liftIO)
2324
import Control.Monad.Logger
24-
import Data.Binary (Binary (..), encodeFile, decodeFileOrFail, putWord8, getWord8)
25+
import Data.Binary (Binary (..))
2526
import Data.Binary.Get (ByteOffset)
27+
import Data.Binary.Tagged (HasStructuralInfo, HasSemanticVersion)
28+
import qualified Data.Binary.Tagged as BinaryTagged
2629
import Data.Typeable (Typeable)
2730
import Control.Exception.Enclosed (tryAnyDeep)
2831
import System.FilePath (takeDirectory)
2932
import System.Directory (createDirectoryIfMissing)
30-
import qualified Data.ByteString as S
31-
import Data.ByteString (ByteString)
32-
import Control.Monad (forM_, when)
33-
import Data.Proxy
3433
import qualified Data.Text as T
3534

36-
magic :: ByteString
37-
magic = "stack"
35+
type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a)
3836

39-
-- | A @Binary@ instance that also has a schema version
40-
class (Binary a, NFData a) => BinarySchema a where
41-
binarySchema :: Proxy a -> Int
42-
43-
newtype WithTag a = WithTag a
44-
deriving NFData
45-
instance forall a. BinarySchema a => Binary (WithTag a) where
46-
get = do
47-
forM_ (S.unpack magic) $ \w -> do
48-
w' <- getWord8
49-
when (w /= w')
50-
$ fail "Mismatched magic string, forcing a recompute"
51-
tag' <- get
52-
if binarySchema (Proxy :: Proxy a) == tag'
53-
then fmap WithTag get
54-
else fail "Mismatched tags, forcing a recompute"
55-
put (WithTag x) = do
56-
mapM_ putWord8 $ S.unpack magic
57-
put (binarySchema (Proxy :: Proxy a))
58-
put x
59-
60-
-- | Write to the given file, with a version tag.
37+
-- | Write to the given file, with a binary-tagged tag.
6138
taggedEncodeFile :: (BinarySchema a, MonadIO m)
6239
=> FilePath
6340
-> a
6441
-> m ()
6542
taggedEncodeFile fp x = liftIO $ do
6643
createDirectoryIfMissing True $ takeDirectory fp
67-
encodeFile fp $ WithTag x
44+
BinaryTagged.taggedEncodeFile fp x
6845

6946
-- | Read from the given file. If the read fails, run the given action and
7047
-- write that back to the file. Always starts the file off with the version
@@ -82,18 +59,18 @@ taggedDecodeOrLoad fp mx = do
8259
x <- mx
8360
taggedEncodeFile fp x
8461
return x
85-
Right (WithTag x) -> do
62+
Right x -> do
8663
$logDebug $ T.pack $ "Success decoding " ++ fp
8764
return x
8865

8966
-- | Ensure that there are no lurking exceptions deep inside the parsed
9067
-- value... because that happens unfortunately. See
9168
-- https://github.com/commercialhaskell/stack/issues/554
92-
decodeFileOrFailDeep :: (Binary a, NFData a, MonadIO m, MonadThrow n)
69+
decodeFileOrFailDeep :: (BinarySchema a, MonadIO m, MonadThrow n)
9370
=> FilePath
9471
-> m (n a)
9572
decodeFileOrFailDeep fp = liftIO $ fmap (either throwM return) $ tryAnyDeep $ do
96-
eres <- decodeFileOrFail fp
73+
eres <- BinaryTagged.taggedDecodeFileOrFail fp
9774
case eres of
9875
Left (offset, str) -> throwM $ DecodeFileFailure fp offset str
9976
Right x -> return x

‎src/Stack/Build/Cache.hs‎

Lines changed: 9 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE MultiParamTypeClasses #-}
33
{-# LANGUAGE TemplateHaskell #-}
44
{-# LANGUAGE TupleSections #-}
5+
{-# LANGUAGE ConstraintKinds #-}
56
-- | Cache information about previous builds
67
module Stack.Build.Cache
78
( tryGetBuildCache
@@ -36,7 +37,7 @@ import Control.Monad.IO.Class
3637
import Control.Monad.Logger (MonadLogger)
3738
import Control.Monad.Reader
3839
import qualified Crypto.Hash.SHA256 as SHA256
39-
import qualified Data.Binary as Binary
40+
import qualified Data.Binary as Binary (encode)
4041
import Data.Binary.VersionTagged
4142
import qualified Data.ByteString.Char8 as S8
4243
import qualified Data.ByteString.Base16 as B16
@@ -96,6 +97,8 @@ data BuildCache = BuildCache
9697
}
9798
deriving (Generic)
9899
instance Binary BuildCache
100+
instance HasStructuralInfo BuildCache
101+
instance HasSemanticVersion BuildCache
99102
instance NFData BuildCache where
100103
rnf = genericRnf
101104

@@ -115,7 +118,7 @@ tryGetCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, Mo
115118
tryGetCabalMod = tryGetCache configCabalMod
116119

117120
-- | Try to load a cache.
118-
tryGetCache :: (MonadIO m, Binary a, NFData a)
121+
tryGetCache :: (MonadIO m, BinarySchema a)
119122
=> (Path Abs Dir -> m (Path Abs File))
120123
-> Path Abs Dir
121124
-> m (Maybe a)
@@ -158,14 +161,14 @@ deleteCaches dir = do
158161
removeFileIfExists cfp
159162

160163
-- | Write to a cache.
161-
writeCache :: (Binary a, MonadIO m)
164+
writeCache :: (BinarySchema a, MonadIO m)
162165
=> Path Abs Dir
163166
-> (Path Abs Dir -> m (Path Abs File))
164167
-> a
165168
-> m ()
166169
writeCache dir get' content = do
167170
fp <- get' dir
168-
liftIO $ encodeFile (toFilePath fp) content
171+
taggedEncodeFile (toFilePath fp) content
169172

170173
flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)
171174
=> Installed
@@ -193,7 +196,7 @@ writeFlagCache gid cache = do
193196
file <- flagCacheFile gid
194197
liftIO $ do
195198
createTree (parent file)
196-
encodeFile (toFilePath file) cache
199+
taggedEncodeFile (toFilePath file) cache
197200

198201
-- | Mark a test suite as having succeeded
199202
setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
@@ -335,7 +338,7 @@ writePrecompiledCache baseConfigOpts pkgident copts mghcPkgId exes = do
335338
exes' <- forM (Set.toList exes) $ \exe -> do
336339
name <- parseRelFile $ T.unpack exe
337340
return $ toFilePath $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name
338-
liftIO $ encodeFile (toFilePath file) PrecompiledCache
341+
liftIO $ taggedEncodeFile (toFilePath file) PrecompiledCache
339342
{ pcLibrary = mlibpath
340343
, pcExes = exes'
341344
}

‎src/Stack/PackageDump.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -62,10 +62,9 @@ import System.Process.Read
6262
-- | Cached information on whether package have profiling libraries and haddocks.
6363
newtype InstalledCache = InstalledCache (IORef InstalledCacheInner)
6464
newtype InstalledCacheInner = InstalledCacheInner (Map GhcPkgId InstalledCacheEntry)
65-
deriving (Binary, NFData)
66-
instance BinarySchema InstalledCacheInner where
67-
-- Don't forget to update this if you change the datatype in any way!
68-
binarySchema _ = 2
65+
deriving (Binary, NFData, Generic)
66+
instance HasStructuralInfo InstalledCacheInner
67+
instance HasSemanticVersion InstalledCacheInner
6968

7069
-- | Cached information on whether a package has profiling libraries and haddocks.
7170
data InstalledCacheEntry = InstalledCacheEntry
@@ -74,6 +73,7 @@ data InstalledCacheEntry = InstalledCacheEntry
7473
, installedCacheIdent :: !PackageIdentifier }
7574
deriving (Eq, Generic)
7675
instance Binary InstalledCacheEntry
76+
instance HasStructuralInfo InstalledCacheEntry
7777
instance NFData InstalledCacheEntry where
7878
rnf = genericRnf
7979

‎src/Stack/PackageIndex.hs‎

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -88,16 +88,18 @@ data PackageCache = PackageCache
8888
-- ^ size in bytes of the .cabal file
8989
, pcDownload :: !(Maybe PackageDownload)
9090
}
91-
deriving Generic
91+
deriving (Generic)
92+
9293
instance Binary.Binary PackageCache
9394
instance NFData PackageCache where
9495
rnf = genericRnf
96+
instance HasStructuralInfo PackageCache
9597

9698
newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache)
97-
deriving (Binary.Binary, NFData)
98-
instance BinarySchema PackageCacheMap where
99-
-- Don't forget to update this if you change the datatype in any way!
100-
binarySchema _ = 1
99+
deriving (Generic, Binary, NFData)
100+
instance HasStructuralInfo PackageCacheMap
101+
instance HasSemanticVersion PackageCacheMap
102+
101103
-- | Populate the package index caches and return them.
102104
populateCache
103105
:: (MonadIO m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
@@ -363,6 +365,7 @@ data PackageDownload = PackageDownload
363365
}
364366
deriving (Show, Generic)
365367
instance Binary.Binary PackageDownload
368+
instance HasStructuralInfo PackageDownload
366369
instance NFData PackageDownload where
367370
rnf = genericRnf
368371
instance FromJSON PackageDownload where

‎src/Stack/Types/Build.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -522,6 +522,9 @@ instance Binary ConfigCache where
522522
instance NFData ConfigCache where
523523
rnf = genericRnf
524524

525+
instance HasStructuralInfo ConfigCache
526+
instance HasSemanticVersion ConfigCache
527+
525528
-- | A task to perform when building
526529
data Task = Task
527530
{ taskProvides :: !PackageIdentifier -- ^ the package/version to be built
@@ -712,6 +715,7 @@ data ConfigureOpts = ConfigureOpts
712715
}
713716
deriving (Show, Eq, Generic)
714717
instance Binary ConfigureOpts
718+
instance HasStructuralInfo ConfigureOpts
715719
instance NFData ConfigureOpts where
716720
rnf = genericRnf
717721

@@ -726,5 +730,7 @@ data PrecompiledCache = PrecompiledCache
726730
}
727731
deriving (Show, Eq, Generic)
728732
instance Binary PrecompiledCache
733+
instance HasSemanticVersion PrecompiledCache
734+
instance HasStructuralInfo PrecompiledCache
729735
instance NFData PrecompiledCache where
730736
rnf = genericRnf

‎src/Stack/Types/BuildPlan.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -250,8 +250,8 @@ newtype Maintainer = Maintainer { unMaintainer :: Text }
250250

251251
-- | Name of an executable.
252252
newtype ExeName = ExeName { unExeName :: ByteString }
253-
deriving (Show, Eq, Ord, Hashable, IsString, Generic, NFData)
254-
instance Binary ExeName
253+
deriving (Show, Eq, Ord, Hashable, IsString, Generic, Binary, NFData)
254+
instance HasStructuralInfo ExeName
255255
instance ToJSON ExeName where
256256
toJSON = toJSON . S8.unpack . unExeName
257257
instance FromJSON ExeName where
@@ -377,9 +377,8 @@ data MiniBuildPlan = MiniBuildPlan
377377
instance Binary MiniBuildPlan
378378
instance NFData MiniBuildPlan where
379379
rnf = genericRnf
380-
instance BinarySchema MiniBuildPlan where
381-
-- Don't forget to update this if you change the datatype in any way!
382-
binarySchema _ = 2
380+
instance HasStructuralInfo MiniBuildPlan
381+
instance HasSemanticVersion MiniBuildPlan
383382

384383
-- | Information on a single package for the 'MiniBuildPlan'.
385384
data MiniPackageInfo = MiniPackageInfo
@@ -398,6 +397,7 @@ data MiniPackageInfo = MiniPackageInfo
398397
}
399398
deriving (Generic, Show, Eq)
400399
instance Binary MiniPackageInfo
400+
instance HasStructuralInfo MiniPackageInfo
401401
instance NFData MiniPackageInfo where
402402
rnf = genericRnf
403403

‎src/Stack/Types/Compiler.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,7 @@ module Stack.Types.Compiler where
77
import Control.DeepSeq
88
import Control.DeepSeq.Generics (genericRnf)
99
import Data.Aeson
10-
import Data.Binary (Binary)
10+
import Data.Binary.VersionTagged (Binary, HasStructuralInfo)
1111
import Data.Monoid ((<>))
1212
import qualified Data.Text as T
1313
import GHC.Generics (Generic)
@@ -34,6 +34,7 @@ data CompilerVersion
3434
{-# UNPACK #-} !Version -- GHC version
3535
deriving (Generic, Show, Eq, Ord)
3636
instance Binary CompilerVersion
37+
instance HasStructuralInfo CompilerVersion
3738
instance NFData CompilerVersion where
3839
rnf = genericRnf
3940
instance ToJSON CompilerVersion where

‎src/Stack/Types/FlagName.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -55,6 +55,7 @@ instance Show FlagNameParseFail where
5555
newtype FlagName =
5656
FlagName ByteString
5757
deriving (Typeable,Data,Generic,Hashable,Binary,NFData)
58+
instance HasStructuralInfo FlagName
5859
instance Eq FlagName where
5960
x == y = (compare x y) == EQ
6061
instance Ord FlagName where

‎src/Stack/Types/GhcPkgId.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -54,6 +54,7 @@ instance Binary GhcPkgId where
5454
fmap GhcPkgId get
5555
instance NFData GhcPkgId where
5656
rnf = genericRnf
57+
instance HasStructuralInfo GhcPkgId
5758

5859
instance Show GhcPkgId where
5960
show = show . ghcPkgIdString

0 commit comments

Comments
 (0)