Try supporting V1 snapshot format

Partly to see how the scheme works in practice. It looks like we have to
_not_ match on the version most of the time.

Author: dcoutts

bench/macro/lsm-tree-bench-wp8.hs

@@ -594,7 +594,7 @@ doRun gopts opts = do
         tbl <- if check opts
                 then let conf = mkTableConfigRun gopts opts benchTableConfig
                       in LSM.newTableWith @IO @K @V @B conf session
-                else let conf = mkOverrideDiskCachePolicy gopts opts
+                else let conf = mkTableConfigOverride gopts opts
                       in LSM.openTableFromSnapshotWith @IO @K @V @B conf session name label
 
         -- In checking mode, compare each output against a pure reference.

src/Database/LSMTree/Internal/Snapshot/Codec.hs

@@ -22,7 +22,6 @@ import           Codec.CBOR.Decoding
 import           Codec.CBOR.Encoding
 import           Codec.CBOR.Read
 import           Codec.CBOR.Write
-import           Control.Monad (unless)
 import           Control.Monad.Class.MonadThrow (Exception (displayException),
                      MonadThrow (..))
 import           Data.Bifunctor (Bifunctor (..))
@@ -58,23 +57,25 @@ import           Text.Printf
 -- for more. Forwards compatibility is not provided at all: snapshots with a
 -- later version than the current version for the library release will always
 -- fail.
-data SnapshotVersion = V0
-  deriving stock (Show, Eq)
+data SnapshotVersion = V0 | V1
+  deriving stock (Show, Eq, Ord)
 
 -- >>> prettySnapshotVersion currentSnapshotVersion
--- "v0"
+-- "1"
 prettySnapshotVersion :: SnapshotVersion -> String
 prettySnapshotVersion V0 = "v0"
+prettySnapshotVersion V1 = "v1"
 
 -- >>> currentSnapshotVersion
 -- V0
 currentSnapshotVersion :: SnapshotVersion
-currentSnapshotVersion = V0
+currentSnapshotVersion = V1
 
 isCompatible :: SnapshotVersion -> Either String ()
-isCompatible otherVersion = do
-    case ( currentSnapshotVersion, otherVersion ) of
-      (V0, V0) -> Right ()
+isCompatible otherVersion
+    -- for the moment, all versions are backwards compatible:
+  | currentSnapshotVersion >= otherVersion = Right ()
+  | otherwise = Left "forward compatibility not supported"
 
 {-------------------------------------------------------------------------------
   Writing and reading files
@@ -198,13 +199,15 @@ instance Encode SnapshotVersion where
          encodeListLen 1
       <> case ver of
            V0 -> encodeWord 0
+           V1 -> encodeWord 1
 
 instance Decode SnapshotVersion where
   decode = do
       _ <- decodeListLenOf 1
       ver <- decodeWord
       case ver of
         0 -> pure V0
+        1 -> pure V1
         _ -> fail ("Unknown snapshot format version number: " <>  show ver)
 
 {-------------------------------------------------------------------------------
@@ -232,13 +235,22 @@ instance DecodeVersioned SnapshotMetaData where
         <*> decodeVersioned ver
         <*> decodeMaybe ver
 
+  decodeVersioned V1 = do
+      _ <- decodeListLenOf 5
+      SnapshotMetaData
+        <$> decodeVersioned V0
+        <*> decodeVersioned V1
+        <*> decodeVersioned V0
+        <*> decodeVersioned V0
+        <*> decodeMaybe V0
+
 -- SnapshotLabel
 
 instance Encode SnapshotLabel where
   encode (SnapshotLabel s) = encodeString s
 
 instance DecodeVersioned SnapshotLabel where
-  decodeVersioned V0 = SnapshotLabel <$> decodeString
+  decodeVersioned _v = SnapshotLabel <$> decodeString
 
 instance Encode SnapshotRun where
   encode SnapshotRun { snapRunNumber, snapRunCaching, snapRunIndex } =
@@ -249,7 +261,7 @@ instance Encode SnapshotRun where
       <> encode snapRunIndex
 
 instance DecodeVersioned SnapshotRun where
-  decodeVersioned v@V0 = do
+  decodeVersioned v = do
       n <- decodeListLen
       tag <- decodeWord
       case (n, tag) of
@@ -290,19 +302,28 @@ instance Encode TableConfig where
 
 instance DecodeVersioned TableConfig where
   decodeVersioned v@V0 = do
-      n <- decodeListLen
-      unless (n >= 7 && n <= 8) $
-        fail "TableConfig: expected record of length 7 or 8"
+      decodeListLenOf 7
+      confMergePolicy <- decodeVersioned v
+      confMergeSchedule <- decodeVersioned v
+      confSizeRatio <- decodeVersioned v
+      confWriteBufferAlloc <- decodeVersioned v
+      confBloomFilterAlloc <- decodeVersioned v
+      confFencePointerIndex <- decodeVersioned v
+      confDiskCachePolicy <- decodeVersioned v
+      let confMergeBatchSize = case confWriteBufferAlloc of
+                                 AllocNumEntries n -> MergeBatchSize n
+      pure TableConfig {..}
+
+  decodeVersioned v@V1 = do
+      decodeListLenOf 8
       confMergePolicy <- decodeVersioned v
       confMergeSchedule <- decodeVersioned v
       confSizeRatio <- decodeVersioned v
       confWriteBufferAlloc <- decodeVersioned v
       confBloomFilterAlloc <- decodeVersioned v
       confFencePointerIndex <- decodeVersioned v
       confDiskCachePolicy <- decodeVersioned v
-      confMergeBatchSize <- if n == 8
-                              then decodeVersioned v
-                              else pure (confMergeBatchSize defaultTableConfig)
+      confMergeBatchSize <- decodeVersioned v
       pure TableConfig {..}
 
 -- MergePolicy
@@ -311,7 +332,7 @@ instance Encode MergePolicy where
   encode LazyLevelling = encodeWord 0
 
 instance DecodeVersioned MergePolicy where
-  decodeVersioned V0 =  do
+  decodeVersioned _v =  do
       tag <- decodeWord
       case tag of
         0 -> pure LazyLevelling
@@ -323,7 +344,7 @@ instance Encode SizeRatio where
   encode Four = encodeInt 4
 
 instance DecodeVersioned SizeRatio where
-  decodeVersioned V0 = do
+  decodeVersioned _v = do
       x <- decodeWord64
       case x of
         4 -> pure Four
@@ -338,7 +359,7 @@ instance Encode WriteBufferAlloc where
       <> encodeInt numEntries
 
 instance DecodeVersioned WriteBufferAlloc where
-  decodeVersioned V0 = do
+  decodeVersioned _v = do
       _ <- decodeListLenOf 2
       tag <- decodeWord
       case tag of
@@ -356,7 +377,7 @@ instance Encode RunParams where
       <> encode runParamIndex
 
 instance DecodeVersioned RunParams where
-  decodeVersioned v@V0 = do
+  decodeVersioned v = do
       n <- decodeListLen
       tag <- decodeWord
       case (n, tag) of
@@ -371,7 +392,7 @@ instance Encode RunDataCaching where
   encode NoCacheRunData = encodeWord 1
 
 instance DecodeVersioned RunDataCaching where
-  decodeVersioned V0 = do
+  decodeVersioned _v = do
     tag <- decodeWord
     case tag of
       0 -> pure CacheRunData
@@ -383,7 +404,7 @@ instance Encode IndexType where
   encode Compact  = encodeWord 1
 
 instance DecodeVersioned IndexType where
-  decodeVersioned V0 = do
+  decodeVersioned _v = do
     tag <- decodeWord
     case tag of
       0 -> pure Ordinary
@@ -401,7 +422,7 @@ instance Encode RunBloomFilterAlloc where
       <> encodeDouble fpr
 
 instance DecodeVersioned RunBloomFilterAlloc where
-  decodeVersioned V0 = do
+  decodeVersioned _v = do
       n <- decodeListLen
       tag <- decodeWord
       case (n, tag) of
@@ -422,7 +443,7 @@ instance Encode BloomFilterAlloc where
       <> encodeDouble x
 
 instance DecodeVersioned BloomFilterAlloc where
-  decodeVersioned V0 = do
+  decodeVersioned _v = do
       n <- decodeListLen
       tag <- decodeWord
       case (n, tag) of
@@ -455,7 +476,7 @@ instance Encode FencePointerIndexType where
   encode OrdinaryIndex = encodeWord 1
 
 instance DecodeVersioned FencePointerIndexType where
-   decodeVersioned V0 = do
+   decodeVersioned _v = do
       tag <- decodeWord
       case tag of
         0 -> pure CompactIndex
@@ -477,7 +498,7 @@ instance Encode DiskCachePolicy where
       <> encodeWord 2
 
 instance DecodeVersioned DiskCachePolicy where
-  decodeVersioned V0 = do
+  decodeVersioned _v = do
       n <- decodeListLen
       tag <- decodeWord
       case (n, tag) of
@@ -493,7 +514,7 @@ instance Encode MergeSchedule where
   encode Incremental = encodeWord 1
 
 instance DecodeVersioned MergeSchedule where
-  decodeVersioned V0 = do
+  decodeVersioned _v = do
       tag <- decodeWord
       case tag of
         0 -> pure OneShot
@@ -506,7 +527,7 @@ instance Encode MergeBatchSize where
   encode (MergeBatchSize n) = encodeInt n
 
 instance DecodeVersioned MergeBatchSize where
-  decodeVersioned V0 = MergeBatchSize <$> decodeInt
+  decodeVersioned _v = MergeBatchSize <$> decodeInt
 
 {-------------------------------------------------------------------------------
   Encoding and decoding: SnapLevels
@@ -518,7 +539,7 @@ instance Encode r => Encode (SnapLevels r) where
   encode (SnapLevels levels) = encode levels
 
 instance DecodeVersioned r => DecodeVersioned (SnapLevels r) where
-  decodeVersioned v@V0 = SnapLevels <$> decodeVersioned v
+  decodeVersioned v = SnapLevels <$> decodeVersioned v
 
 -- SnapLevel
 
@@ -530,7 +551,7 @@ instance Encode r => Encode (SnapLevel r) where
 
 
 instance DecodeVersioned r => DecodeVersioned (SnapLevel r) where
-  decodeVersioned v@V0 = do
+  decodeVersioned v = do
       _ <- decodeListLenOf 2
       SnapLevel <$> decodeVersioned v <*> decodeVersioned v
 
@@ -548,7 +569,7 @@ instance Encode RunNumber where
   encode (RunNumber x) = encodeInt x
 
 instance DecodeVersioned RunNumber where
-  decodeVersioned V0 = RunNumber <$> decodeInt
+  decodeVersioned _v = RunNumber <$> decodeInt
 
 -- SnapIncomingRun
 
@@ -566,7 +587,7 @@ instance Encode r => Encode (SnapIncomingRun r) where
     <> encode x
 
 instance DecodeVersioned r => DecodeVersioned (SnapIncomingRun r) where
-  decodeVersioned v@V0 = do
+  decodeVersioned v = do
       n <- decodeListLen
       tag <- decodeWord
       case (n, tag) of
@@ -583,7 +604,7 @@ instance Encode MergePolicyForLevel where
   encode LevelLevelling = encodeWord 1
 
 instance DecodeVersioned MergePolicyForLevel where
-  decodeVersioned V0 = do
+  decodeVersioned _v = do
       tag <- decodeWord
       case tag of
         0 -> pure LevelTiering
@@ -607,7 +628,7 @@ instance (Encode t, Encode r) => Encode (SnapMergingRun t r) where
       <> encode mt
 
 instance (DecodeVersioned t, DecodeVersioned r) => DecodeVersioned (SnapMergingRun t r) where
-  decodeVersioned v@V0 = do
+  decodeVersioned v = do
       n <- decodeListLen
       tag <- decodeWord
       case (n, tag) of
@@ -623,25 +644,25 @@ instance Encode NominalDebt where
   encode (NominalDebt x) = encodeInt x
 
 instance DecodeVersioned NominalDebt where
-  decodeVersioned V0 = NominalDebt <$> decodeInt
+  decodeVersioned _v = NominalDebt <$> decodeInt
 
 instance Encode NominalCredits where
   encode (NominalCredits x) = encodeInt x
 
 instance DecodeVersioned NominalCredits where
-  decodeVersioned V0 = NominalCredits <$> decodeInt
+  decodeVersioned _v = NominalCredits <$> decodeInt
 
 instance Encode MergeDebt where
   encode (MergeDebt (MergeCredits x)) = encodeInt x
 
 instance DecodeVersioned MergeDebt where
-  decodeVersioned V0 = (MergeDebt . MergeCredits) <$> decodeInt
+  decodeVersioned _v = (MergeDebt . MergeCredits) <$> decodeInt
 
 instance Encode MergeCredits where
   encode (MergeCredits x) = encodeInt x
 
 instance DecodeVersioned MergeCredits where
-  decodeVersioned V0 = MergeCredits <$> decodeInt
+  decodeVersioned _v = MergeCredits <$> decodeInt
 
 -- MergeType
 
@@ -650,7 +671,7 @@ instance Encode MR.LevelMergeType  where
   encode MR.MergeLastLevel = encodeWord 1
 
 instance DecodeVersioned MR.LevelMergeType where
-  decodeVersioned V0 = do
+  decodeVersioned _v = do
       tag <- decodeWord
       case tag of
         0 -> pure MR.MergeMidLevel
@@ -672,7 +693,7 @@ instance Encode MR.TreeMergeType  where
   encode MR.MergeUnion = encodeWord 2
 
 instance DecodeVersioned MR.TreeMergeType where
-  decodeVersioned V0 = do
+  decodeVersioned _v = do
       tag <- decodeWord
       case tag of
         1 -> pure MR.MergeLevel
@@ -689,7 +710,7 @@ instance Encode r => Encode (SnapMergingTree r) where
   encode (SnapMergingTree tState) = encode tState
 
 instance DecodeVersioned r => DecodeVersioned (SnapMergingTree r) where
-  decodeVersioned ver@V0 = SnapMergingTree <$> decodeVersioned ver
+  decodeVersioned ver = SnapMergingTree <$> decodeVersioned ver
 
 -- SnapMergingTreeState
 
@@ -708,7 +729,7 @@ instance Encode r => Encode (SnapMergingTreeState r) where
     <> encode smrs
 
 instance DecodeVersioned r => DecodeVersioned (SnapMergingTreeState r) where
-  decodeVersioned v@V0 = do
+  decodeVersioned v = do
       n <- decodeListLen
       tag <- decodeWord
       case (n, tag) of
@@ -731,7 +752,7 @@ instance Encode r => Encode (SnapPendingMerge r) where
    <> encodeList mts
 
 instance DecodeVersioned r => DecodeVersioned (SnapPendingMerge r) where
-  decodeVersioned v@V0 = do
+  decodeVersioned v = do
       n <- decodeListLen
       tag <- decodeWord
       case (n, tag) of
@@ -752,7 +773,7 @@ instance Encode r => Encode (SnapPreExistingRun r) where
     <> encode smrs
 
 instance DecodeVersioned r => DecodeVersioned (SnapPreExistingRun r) where
-  decodeVersioned v@V0 = do
+  decodeVersioned v = do
       n <- decodeListLen
       tag <- decodeWord
       case (n, tag) of
@@ -770,7 +791,7 @@ encodeMaybe = \case
   Just en -> encode en
 
 decodeMaybe :: DecodeVersioned a => SnapshotVersion -> Decoder s (Maybe a)
-decodeMaybe v@V0 = do
+decodeMaybe v = do
     tok <- peekTokenType
     case tok of
       TypeNull -> Nothing <$ decodeNull

test/Test/Database/LSMTree/Internal/Snapshot/Codec.hs

@@ -191,8 +191,9 @@ testAll test = [
 -------------------------------------------------------------------------------}
 
 instance Arbitrary SnapshotVersion where
-  arbitrary = elements [V0]
+  arbitrary = elements [V0, V1]
   shrink V0 = []
+  shrink V1 = [V0]
 
 deriving newtype instance Arbitrary a => Arbitrary (Versioned a)