Start using the new snapshot metadata encoders/decoders

Author: jorisdral

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

@@ -229,6 +229,10 @@ runOptsP = pure RunOpts
     <*> O.switch (O.long "pipelined" <> O.help "Use pipelined mode")
     <*> O.switch (O.long "lookup-only" <> O.help "Use lookup only mode")
 
+deriving stock instance Read LSM.DiskCachePolicy
+deriving stock instance Read LSM.BloomFilterAlloc
+deriving stock instance Read LSM.NumEntries
+
 -------------------------------------------------------------------------------
 -- measurements
 -------------------------------------------------------------------------------

src/Database/LSMTree/Internal.hs

@@ -66,6 +66,7 @@ module Database.LSMTree.Internal (
   , duplicate
   ) where
 
+import           Codec.CBOR.Read
 import           Control.Concurrent.Class.MonadMVar.Strict
 import           Control.Concurrent.Class.MonadSTM (MonadSTM (..))
 import           Control.Concurrent.Class.MonadSTM.RWVar (RWVar)
@@ -79,7 +80,6 @@ import           Control.Monad.Primitive
 import           Control.TempRegistry
 import           Control.Tracer
 import           Data.Arena (ArenaManager, newArenaManager)
-import qualified Data.ByteString.Char8 as BSC
 import           Data.Char (isNumber)
 import           Data.Foldable
 import           Data.Functor.Compose (Compose (..))
@@ -119,7 +119,6 @@ import qualified System.FS.API as FS
 import           System.FS.API (FsError, FsErrorPath (..), FsPath, Handle,
                      HasFS)
 import qualified System.FS.API.Lazy as FS
-import qualified System.FS.API.Strict as FS
 import qualified System.FS.BlockIO.API as FS
 import           System.FS.BlockIO.API (HasBlockIO)
 
@@ -166,6 +165,9 @@ instance NFData (MonoidalCursor m k v) where
 -------------------------------------------------------------------------------}
 
 -- TODO: give this a nicer Show instance.
+--
+-- TODO: the snapshot-related errors could be put in a separate type, since each
+-- gets a SnapshotName.
 data LSMTreeError =
     SessionDirDoesNotExist FsErrorPath
     -- | The session directory is already locked
@@ -186,7 +188,15 @@ data LSMTreeError =
   | ErrCursorClosed
   | ErrSnapshotExists SnapshotName
   | ErrSnapshotNotExists SnapshotName
-  | ErrSnapshotWrongType SnapshotName
+  | ErrSnapshotDeserialiseFailure DeserialiseFailure SnapshotName
+  | ErrSnapshotWrongTableType
+      SnapshotName
+      SnapshotTableType -- ^ Expected type
+      SnapshotTableType -- ^ Actual type
+  | ErrSnapshotWrongLabel
+      SnapshotName
+      SnapshotLabel -- ^ Expected label
+      SnapshotLabel -- ^ Actual label
     -- | Something went wrong during batch lookups.
   | ErrLookup ByteCountDiscrepancy
     -- | A 'BlobRef' used with 'retrieveBlobs' was invalid.
@@ -1081,6 +1091,7 @@ readCursorWhile resolve keyIsWanted n Cursor {..} fromEntry = do
      ResolveSerialisedValue
   -> SnapshotName
   -> SnapshotLabel
+  -> SnapshotTableType
   -> Table IO h
   -> IO Int #-}
 -- |  See 'Database.LSMTree.Normal.snapshot''.
@@ -1089,9 +1100,10 @@ snapshot ::
   => ResolveSerialisedValue
   -> SnapshotName
   -> SnapshotLabel
+  -> SnapshotTableType
   -> Table m h
   -> m Int
-snapshot resolve snap label t = do
+snapshot resolve snap label tableType t = do
     traceWith (tableTracer t) $ TraceSnapshot snap
     let conf = tableConfig t
     withOpenTable t $ \thEnv -> do
@@ -1129,19 +1141,20 @@ snapshot resolve snap label t = do
       -- consistent.
 
       snappedLevels <- snapLevels (tableLevels content)
-      let snapContents = BSC.pack $ show (label, snappedLevels, tableConfig t)
+      let snapContents = encodeSnapshotMetaData (SnapshotMetaData label tableType (tableConfig t) snappedLevels)
 
       FS.withFile
         (tableHasFS thEnv)
         snapPath
         (FS.WriteMode FS.MustBeNew) $ \h ->
-          void $ FS.hPutAllStrict (tableHasFS thEnv) h snapContents
+          void $ FS.hPutAll (tableHasFS thEnv) h snapContents
 
       pure $! numSnapRuns snappedLevels
 
 {-# SPECIALISE open ::
      Session IO h
   -> SnapshotLabel
+  -> SnapshotTableType
   -> TableConfigOverride
   -> SnapshotName
   -> ResolveSerialisedValue
@@ -1151,11 +1164,12 @@ open ::
      (MonadFix m, MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
   => Session m h
   -> SnapshotLabel -- ^ Expected label
+  -> SnapshotTableType -- ^ Expected table type
   -> TableConfigOverride -- ^ Optional config override
   -> SnapshotName
   -> ResolveSerialisedValue
   -> m (Table m h)
-open sesh label override snap resolve = do
+open sesh label tableType override snap resolve = do
     traceWith (sessionTracer sesh) $ TraceOpenSnapshot snap override
     withOpenSession sesh $ \seshEnv -> do
       withTempRegistry $ \reg -> do
@@ -1169,8 +1183,18 @@ open sesh label override snap resolve = do
                 snapPath
                 FS.ReadMode $ \h ->
                   FS.hGetAll (sessionHasFS seshEnv) h
-        let (label', snappedLevels, conf) = read $ BSC.unpack $ BSC.toStrict $ bs
-        unless (label == label') $ throwIO (ErrSnapshotWrongType snap)
+
+        snapMetaData <- case decodeSnapshotMetaData bs of
+          Left e  -> throwIO (ErrSnapshotDeserialiseFailure e snap)
+          Right x -> pure x
+        let SnapshotMetaData label' tableType' conf snappedLevels = snapMetaData
+
+        unless (tableType == tableType') $
+          throwIO (ErrSnapshotWrongTableType snap tableType tableType')
+
+        unless (label == label') $
+          throwIO (ErrSnapshotWrongLabel snap label label')
+
         let conf' = applyOverride override conf
         am <- newArenaManager
         blobpath <- Paths.tableBlobPath (sessionRoot seshEnv) <$>

src/Database/LSMTree/Internal/Config.hs

@@ -1,7 +1,3 @@
--- TODO: this should be removed once we have proper snapshotting with proper
--- persistence of the config to disk.
-{-# OPTIONS_GHC -Wno-orphans #-}
-
 module Database.LSMTree.Internal.Config (
     LevelNo (..)
     -- * Table configuration
@@ -359,7 +355,7 @@ data DiskCachePolicy =
        -- Use this policy if expected access pattern for the table has poor
        -- spatial or temporal locality, such as uniform random access.
      | DiskCacheNone
-  deriving stock (Eq, Show, Read)
+  deriving stock (Eq, Show)
 
 instance NFData DiskCachePolicy where
   rnf DiskCacheAll                 = ()
@@ -403,7 +399,7 @@ data MergeSchedule =
     -- merges are fully completed in time for when new merges are started on the
     -- same level.
   | Incremental
-  deriving stock (Eq, Show, Read)
+  deriving stock (Eq, Show)
 
 instance NFData MergeSchedule where
   rnf OneShot     = ()

src/Database/LSMTree/Internal/Snapshot.hs

@@ -1,6 +1,3 @@
--- TODO: remove once we properly implement snapshots
-{-# OPTIONS_GHC -Wno-orphans #-}
-
 module Database.LSMTree.Internal.Snapshot (
     -- * Versioning
     SnapshotVersion (..)
@@ -142,10 +139,10 @@ isCompatible otherVersion = do
 
 -- | Custom text to include in a snapshot file
 newtype SnapshotLabel = SnapshotLabel Text
-  deriving stock (Show, Eq, Read)
+  deriving stock (Show, Eq)
 
 data SnapshotTableType = SnapNormalTable | SnapMonoidalTable
-  deriving stock (Show, Eq, Read)
+  deriving stock (Show, Eq)
 
 data SnapshotMetaData = SnapshotMetaData {
     -- | Custom, user-supplied text that is included in the metadata.
@@ -195,22 +192,22 @@ data SnapLevel = SnapLevel {
     snapIncomingRuns :: !SnapMergingRun
   , snapResidentRuns :: !(V.Vector RunNumber)
   }
-  deriving stock (Show, Eq, Read)
+  deriving stock (Show, Eq)
 
 data SnapMergingRun =
     SnapMergingRun !MergePolicyForLevel !NumRuns !SnapMergingRunState
   | SnapSingleRun !RunNumber
-  deriving stock (Show, Eq, Read)
+  deriving stock (Show, Eq)
 
 data SnapMergingRunState =
     SnapCompletedMerge !RunNumber
   | SnapOngoingMerge !(V.Vector RunNumber) !TotalCredits !Merge.Level
-  deriving stock (Show, Eq, Read)
+  deriving stock (Show, Eq)
 
 -- | The total number of supplied credits. This total is used on snapshot load
 -- to restore merging work that was lost when the snapshot was created.
 newtype TotalCredits = TotalCredits Int
-  deriving stock (Show, Eq, Read)
+  deriving stock (Show, Eq)
 
 {-------------------------------------------------------------------------------
   Conversion to snapshot format
@@ -347,27 +344,6 @@ openLevels reg hfs hbio conf@TableConfig{..} uc sessionRoot resolve levels =
               Nothing -> error "openLevels: merges can not be empty"
               Just m  -> pure (Just totalCredits, OngoingMerge rs totalStepsVar totalCreditsVar m)
 
-{-------------------------------------------------------------------------------
-  Levels
--------------------------------------------------------------------------------}
-
-deriving stock instance Read NumRuns
-deriving stock instance Read MergePolicyForLevel
-deriving newtype instance Read RunNumber
-deriving stock instance Read Merge.Level
-
-{-------------------------------------------------------------------------------
-  Config
--------------------------------------------------------------------------------}
-
-deriving stock instance Read TableConfig
-deriving stock instance Read WriteBufferAlloc
-deriving stock instance Read NumEntries
-deriving stock instance Read SizeRatio
-deriving stock instance Read MergePolicy
-deriving stock instance Read BloomFilterAlloc
-deriving stock instance Read FencePointerIndex
-
 {-------------------------------------------------------------------------------
   Encoding and decoding
 -------------------------------------------------------------------------------}

src/Database/LSMTree/Monoidal.hs

@@ -559,7 +559,7 @@ snapshot :: forall m k v.
   -> Table m k v
   -> m ()
 snapshot snap (Internal.MonoidalTable t) =
-    void $ Internal.snapshot (resolve @v Proxy) snap label t
+    void $ Internal.snapshot (resolve @v Proxy) snap label Internal.SnapMonoidalTable t
   where
     label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v))
 
@@ -603,7 +603,14 @@ open :: forall m k v.
   -> SnapshotName
   -> m (Table m k v)
 open (Internal.Session' sesh) override snap =
-    Internal.MonoidalTable <$> Internal.open sesh label override snap (resolve @v Proxy)
+    Internal.MonoidalTable <$>
+      Internal.open
+        sesh
+        label
+        Internal.SnapMonoidalTable
+        override
+        snap
+        (resolve @v Proxy)
   where
     label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v))
 

src/Database/LSMTree/Normal.hs

@@ -685,7 +685,8 @@ snapshot :: forall m k v blob.
   => SnapshotName
   -> Table m k v blob
   -> m ()
-snapshot snap (Internal.NormalTable t) = void $ Internal.snapshot const snap label t
+snapshot snap (Internal.NormalTable t) =
+    void $ Internal.snapshot const snap label Internal.SnapNormalTable t
   where
     label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, blob))
 
@@ -732,7 +733,7 @@ open :: forall m k v blob.
   -> SnapshotName
   -> m (Table m k v blob)
 open (Internal.Session' sesh) override snap =
-    Internal.NormalTable <$!> Internal.open sesh label override snap const
+    Internal.NormalTable <$!> Internal.open sesh label Internal.SnapNormalTable override snap const
   where
     label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, blob))
 

test/Test/Database/LSMTree/Internal.hs

@@ -29,7 +29,8 @@ import           Database.LSMTree.Internal.Entry
 import           Database.LSMTree.Internal.MergeSchedule
 import           Database.LSMTree.Internal.Paths (mkSnapshotName)
 import           Database.LSMTree.Internal.Serialise
-import           Database.LSMTree.Internal.Snapshot (SnapshotLabel (..))
+import           Database.LSMTree.Internal.Snapshot (SnapshotLabel (..),
+                     SnapshotTableType (..))
 import qualified System.FS.API as FS
 import qualified Test.Database.LSMTree.Internal.Lookup as Test
 import           Test.Database.LSMTree.Internal.Lookup
@@ -174,8 +175,8 @@ prop_interimOpenTable dat = ioProperty $
         withTable sesh conf $ \t -> do
           updates const upds t
           let snap = fromMaybe (error "invalid name") $ mkSnapshotName "snap"
-          numRunsSnapped <- snapshot const snap (SnapshotLabel "someLabel") t
-          t' <- open sesh (SnapshotLabel "someLabel") configNoOverride snap const
+          numRunsSnapped <- snapshot const snap (SnapshotLabel "someLabel") SnapNormalTable t
+          t' <- open sesh (SnapshotLabel "someLabel") SnapNormalTable configNoOverride snap const
           lhs <- fetchBlobs hfs =<< lookups const ks t
           rhs <- fetchBlobs hfs =<< lookups const ks t'
           -- We must fetch blobs because comparing blob references is meaningless

test/Test/Database/LSMTree/Normal/StateMachine.hs

@@ -341,7 +341,7 @@ realHandler = Handler $ pure . handler'
     handler' ErrCursorClosed              = Just Model.ErrCursorClosed
     handler' (ErrSnapshotNotExists _snap) = Just Model.ErrSnapshotDoesNotExist
     handler' (ErrSnapshotExists _snap)    = Just Model.ErrSnapshotExists
-    handler' (ErrSnapshotWrongType _snap) = Just Model.ErrSnapshotWrongType
+    handler' ErrSnapshotWrongTableType{}  = Just Model.ErrSnapshotWrongType
     handler' (ErrBlobRefInvalid _)        = Just Model.ErrBlobRefInvalidated
     handler' _                            = Nothing
 

test/Test/Database/LSMTree/Normal/UnitTests.hs

@@ -13,6 +13,7 @@ import qualified Data.Vector as V
 import           Data.Word
 import qualified System.FS.API as FS
 
+import           Database.LSMTree.Internal.Snapshot (SnapshotLabel (..))
 import           Database.LSMTree.Normal as R
 
 import           Control.Exception (Exception, try)
@@ -132,7 +133,9 @@ unit_snapshots =
       assertException (ErrSnapshotExists snap1) $
         snapshot snap1 tbl
 
-      assertException (ErrSnapshotWrongType snap1) $ do
+      assertException (ErrSnapshotWrongLabel snap1
+                        (SnapshotLabel "Key2 Value2 Blob2")
+                        (SnapshotLabel "Key1 Value1 Blob1")) $ do
         _ <- open @_ @Key2 @Value2 @Blob2 sess configNoOverride snap1
         return ()