Change representation for snapshot of a run

Again, the goal is to make the representation more self-contained so
that less information needs to be supplied from the context during
snapshot restore. And again the intnded use case is merging trees, and
runs within them.

In the case of a run it is the disk caching policy, and the index type.
So overall for a run we store the run number (to find the disk files),
the index type (so we know how to restore the index) and the caching
policy.

Arguably the index type should not need to be known in advance and the
index file format should simply say which kind of index it is.

Author: dcoutts

src/Database/LSMTree/Internal.hs

@@ -1308,7 +1308,7 @@ openSnapshot sesh label tableType override snap resolve = do
         (tableWriteBuffer, tableWriteBufferBlobs) <- openWriteBuffer reg resolve hfs hbio uc activeDir snapWriteBufferPaths
 
         -- Hard link runs into the active directory,
-        snapLevels' <- openRuns reg hfs hbio conf (sessionUniqCounter seshEnv) snapDir activeDir snapLevels
+        snapLevels' <- openRuns reg hfs hbio (sessionUniqCounter seshEnv) snapDir activeDir snapLevels
 
         -- Convert from the snapshot format, restoring merge progress in the process
         tableLevels <- fromSnapLevels reg hfs hbio conf (sessionUniqCounter seshEnv) resolve activeDir snapLevels'

src/Database/LSMTree/Internal/Index.hs

@@ -25,6 +25,7 @@ module Database.LSMTree.Internal.Index
 (
     -- * Index types
     IndexType (Compact, Ordinary),
+    indexToIndexType,
 
     -- * Indexes
     Index (CompactIndex, OrdinaryIndex),
@@ -88,6 +89,10 @@ instance NFData Index where
     rnf (CompactIndex  index) = rnf index
     rnf (OrdinaryIndex index) = rnf index
 
+indexToIndexType :: Index -> IndexType
+indexToIndexType CompactIndex{}  = Compact
+indexToIndexType OrdinaryIndex{} = Ordinary
+
 {-|
     Searches for a page span that contains a key–value pair with the given key.
     If there is indeed such a pair, the result is the corresponding page span;

src/Database/LSMTree/Internal/Run.hs

@@ -14,15 +14,18 @@ module Database.LSMTree.Internal.Run (
   , sizeInPages
   , runFsPaths
   , runFsPathsNumber
+  , runDataCaching
+  , runIndexType
   , mkRawBlobRef
   , mkWeakBlobRef
     -- ** Run creation
   , fromMutable
   , fromWriteBuffer
   , RunParams (..)
-  , RunDataCaching (..)
     -- * Snapshot
   , openFromDisk
+  , RunDataCaching (..)
+  , IndexType (..)
   ) where
 
 import           Control.DeepSeq (NFData (..), rwhnf)
@@ -41,8 +44,8 @@ import qualified Database.LSMTree.Internal.BlobRef as BlobRef
 import           Database.LSMTree.Internal.BloomFilter (bloomFilterFromSBS)
 import qualified Database.LSMTree.Internal.CRC32C as CRC
 import           Database.LSMTree.Internal.Entry (NumEntries (..))
-import           Database.LSMTree.Internal.Index (Index, IndexType)
-import qualified Database.LSMTree.Internal.Index as Index (fromSBS, sizeInPages)
+import           Database.LSMTree.Internal.Index (Index, IndexType (..))
+import qualified Database.LSMTree.Internal.Index as Index
 import           Database.LSMTree.Internal.Page (NumPages)
 import           Database.LSMTree.Internal.Paths as Paths
 import           Database.LSMTree.Internal.RunBuilder (RunBuilder,
@@ -113,6 +116,15 @@ runFsPaths (DeRef r) = runRunFsPaths r
 runFsPathsNumber :: Ref (Run m h) -> RunNumber
 runFsPathsNumber = Paths.runNumber . runFsPaths
 
+-- | See 'openFromDisk'
+runIndexType :: Ref (Run m h) -> IndexType
+runIndexType (DeRef r) = Index.indexToIndexType (runIndex r)
+
+-- | See 'openFromDisk'
+runDataCaching :: Ref (Run m h) -> RunDataCaching
+runDataCaching (DeRef r) = runRunDataCaching r
+
+
 -- | Helper function to make a 'WeakBlobRef' that points into a 'Run'.
 mkRawBlobRef :: Run m h -> BlobSpan -> RawBlobRef m h
 mkRawBlobRef Run{runBlobFile} blobspan =
@@ -237,6 +249,15 @@ fromWriteBuffer fs hbio params fsPaths buffer blobs = do
 --
 -- Exceptions will be raised when any of the file's contents don't match their
 -- checksum ('ChecksumError') or can't be parsed ('FileFormatError').
+--
+-- The 'RunDataCaching' and 'IndexType' parameters need to be saved and
+-- restored separately because these are not stored in the on-disk
+-- representation. Use 'runDataCaching' and 'runIndexType' to obtain these
+-- parameters from the open run before persisting to disk.
+--
+-- TODO: it may make more sense to persist these parameters with the run's
+-- on-disk representation.
+--
 openFromDisk ::
      forall m h.
      (MonadSTM m, MonadMask m, PrimMonad m)

src/Database/LSMTree/Internal/Snapshot.hs

@@ -14,6 +14,7 @@ module Database.LSMTree.Internal.Snapshot (
   , snapshotWriteBuffer
   , openWriteBuffer
     -- * Runs
+  , SnapshotRun (..)
   , snapshotRuns
   , openRuns
   , releaseRuns
@@ -110,7 +111,7 @@ data SnapshotMetaData = SnapshotMetaData {
     -- | The write buffer.
   , snapWriteBuffer   :: !RunNumber
     -- | The shape of the levels of the LSM tree.
-  , snapMetaLevels    :: !(SnapLevels RunNumber)
+  , snapMetaLevels    :: !(SnapLevels SnapshotRun)
   }
   deriving stock Eq
 
@@ -353,12 +354,28 @@ openWriteBuffer reg resolve hfs hbio uc activeDir snapWriteBufferPaths = do
   Runs
 -------------------------------------------------------------------------------}
 
+-- | Information needed to open a 'Run' from disk using 'snapshotRuns' and
+-- 'openRuns'.
+--
+-- TODO: one could imagine needing only the 'RunNumber' to identify the files
+-- on disk, and the other parameters being stored with the run itself, rather
+-- than needing to be supplied.
+data SnapshotRun = SnapshotRun {
+       snapRunNumber  :: !RunNumber,
+       snapRunCaching :: !Run.RunDataCaching,
+       snapRunIndex   :: !Run.IndexType
+     }
+  deriving stock Eq
+
+instance NFData SnapshotRun where
+  rnf (SnapshotRun a b c) = rnf a `seq` rnf b `seq` rnf c
+
 {-# SPECIALISE snapshotRuns ::
      ActionRegistry IO
   -> UniqCounter IO
   -> NamedSnapshotDir
   -> SnapLevels (Ref (Run IO h))
-  -> IO (SnapLevels RunNumber) #-}
+  -> IO (SnapLevels SnapshotRun) #-}
 -- | @'snapshotRuns' _ _ snapUc targetDir levels@ creates hard links for all run
 -- files associated with the runs in @levels@, and puts the new directory
 -- entries in the @targetDir@ directory. The entries are renamed using @snapUc@.
@@ -368,7 +385,7 @@ snapshotRuns ::
   -> UniqCounter m
   -> NamedSnapshotDir
   -> SnapLevels (Ref (Run m h))
-  -> m (SnapLevels RunNumber)
+  -> m (SnapLevels SnapshotRun)
 snapshotRuns reg snapUc (NamedSnapshotDir targetDir) levels = do
     for levels $ \run@(DeRef Run.Run {
         Run.runHasFS = hfs,
@@ -378,17 +395,20 @@ snapshotRuns reg snapUc (NamedSnapshotDir targetDir) levels = do
         let sourcePaths = Run.runFsPaths run
         let targetPaths = sourcePaths { runDir = targetDir , runNumber = rn}
         hardLinkRunFiles reg hfs hbio sourcePaths targetPaths
-        pure (runNumber targetPaths)
+        pure SnapshotRun {
+               snapRunNumber  = runNumber targetPaths,
+               snapRunCaching = Run.runDataCaching run,
+               snapRunIndex   = Run.runIndexType run
+             }
 
 {-# SPECIALISE openRuns ::
      ActionRegistry IO
   -> HasFS IO h
   -> HasBlockIO IO h
-  -> TableConfig
   -> UniqCounter IO
   -> NamedSnapshotDir
   -> ActiveDir
-  -> SnapLevels RunNumber
+  -> SnapLevels SnapshotRun
   -> IO (SnapLevels (Ref (Run IO h))) #-}
 -- | @'openRuns' _ _ _ _ uniqCounter sourceDir targetDir levels@ takes all run
 -- files that are referenced by @levels@, and hard links them from @sourceDir@
@@ -402,23 +422,19 @@ openRuns ::
   => ActionRegistry m
   -> HasFS m h
   -> HasBlockIO m h
-  -> TableConfig
   -> UniqCounter m
   -> NamedSnapshotDir
   -> ActiveDir
-  -> SnapLevels RunNumber
+  -> SnapLevels SnapshotRun
   -> m (SnapLevels (Ref (Run m h)))
-openRuns
-  reg hfs hbio TableConfig{..} uc
-  (NamedSnapshotDir sourceDir) (ActiveDir targetDir) (SnapLevels levels) = do
-    levels' <-
-      V.iforM levels $ \i level ->
-        let ln = LevelNo (i+1) in
-        let
-          caching   = diskCachePolicyForLevel confDiskCachePolicy ln
-          indexType = indexTypeForRun confFencePointerIndex
-        in
-        for level $ \runNum -> do
+openRuns reg hfs hbio uc (NamedSnapshotDir sourceDir) (ActiveDir targetDir)
+         levels =
+    for levels $
+      \SnapshotRun {
+         snapRunNumber  = runNum,
+         snapRunCaching = caching,
+         snapRunIndex   = indexType
+       } -> do
           let sourcePaths = RunFsPaths sourceDir runNum
           runNum' <- uniqueToRunNumber <$> incrUniqCounter uc
           let targetPaths = RunFsPaths targetDir runNum'
@@ -427,7 +443,6 @@ openRuns
           withRollback reg
             (Run.openFromDisk hfs hbio caching indexType targetPaths)
             releaseRef
-    pure (SnapLevels levels')
 
 {-# SPECIALISE releaseRuns ::
      ActionRegistry IO -> SnapLevels (Ref (Run IO h)) -> IO ()

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

@@ -262,6 +262,25 @@ instance DecodeVersioned SnapshotTableType where
         2 -> pure SnapFullTable
         _ -> fail ("[SnapshotTableType] Unexpected tag: " <> show tag)
 
+instance Encode SnapshotRun where
+  encode SnapshotRun { snapRunNumber, snapRunCaching, snapRunIndex } =
+         encodeListLen 4
+      <> encodeWord 0
+      <> encode snapRunNumber
+      <> encode snapRunCaching
+      <> encode snapRunIndex
+
+instance DecodeVersioned SnapshotRun where
+  decodeVersioned v@V0 = do
+      n <- decodeListLen
+      tag <- decodeWord
+      case (n, tag) of
+        (4, 0) -> do snapRunNumber  <- decodeVersioned v
+                     snapRunCaching <- decodeVersioned v
+                     snapRunIndex   <- decodeVersioned v
+                     pure SnapshotRun{..}
+        _ -> fail ("[SnapshotRun] Unexpected combination of list length and tag: " <> show (n, tag))
+
 {-------------------------------------------------------------------------------
   Encoding and decoding: TableConfig
 -------------------------------------------------------------------------------}
@@ -499,38 +518,38 @@ instance DecodeVersioned MergeSchedule where
 
 -- SnapLevels
 
-instance Encode (SnapLevels RunNumber) where
+instance Encode r => Encode (SnapLevels r) where
   encode (SnapLevels levels) =
          encodeListLen (fromIntegral (V.length levels))
       <> V.foldMap encode levels
 
-instance DecodeVersioned (SnapLevels RunNumber) where
+instance DecodeVersioned r => DecodeVersioned (SnapLevels r) where
   decodeVersioned v@V0 = do
       n <- decodeListLen
       SnapLevels <$> V.replicateM n (decodeVersioned v)
 
 -- SnapLevel
 
-instance Encode (SnapLevel RunNumber) where
+instance Encode r => Encode (SnapLevel r) where
   encode (SnapLevel incomingRuns residentRuns) =
          encodeListLen 2
       <> encode incomingRuns
       <> encode residentRuns
 
 
-instance DecodeVersioned (SnapLevel RunNumber) where
+instance DecodeVersioned r => DecodeVersioned (SnapLevel r) where
   decodeVersioned v@V0 = do
       _ <- decodeListLenOf 2
       SnapLevel <$> decodeVersioned v <*> decodeVersioned v
 
--- Vector RunNumber
+-- Vector
 
-instance Encode (V.Vector RunNumber) where
+instance Encode r => Encode (V.Vector r) where
   encode rns =
          encodeListLen (fromIntegral (V.length rns))
       <> V.foldMap encode rns
 
-instance DecodeVersioned (V.Vector RunNumber) where
+instance DecodeVersioned r => DecodeVersioned (V.Vector r) where
   decodeVersioned v@V0 = do
       n <- decodeListLen
       V.replicateM n (decodeVersioned v)
@@ -545,7 +564,7 @@ instance DecodeVersioned RunNumber where
 
 -- SnapIncomingRun
 
-instance Encode (SnapIncomingRun RunNumber) where
+instance Encode r => Encode (SnapIncomingRun r) where
   encode (SnapMergingRun mpfl nd nc smrs) =
        encodeListLen 5
     <> encodeWord 0
@@ -558,7 +577,7 @@ instance Encode (SnapIncomingRun RunNumber) where
     <> encodeWord 1
     <> encode x
 
-instance DecodeVersioned (SnapIncomingRun RunNumber) where
+instance DecodeVersioned r => DecodeVersioned (SnapIncomingRun r) where
   decodeVersioned v@V0 = do
       n <- decodeListLen
       tag <- decodeWord
@@ -592,22 +611,22 @@ instance DecodeVersioned MergePolicyForLevel where
 
 -- SnapMergingRunState
 
-instance Encode t => Encode (SnapMergingRunState t RunNumber) where
+instance (Encode t, Encode r) => Encode (SnapMergingRunState t r) where
   encode (SnapCompletedMerge nr md r) =
          encodeListLen 4
       <> encodeWord 0
       <> encode nr
       <> encode md
       <> encode r
-  encode (SnapOngoingMerge ln mc rs mt) =
+  encode (SnapOngoingMerge rp mc rs mt) =
          encodeListLen 5
       <> encodeWord 1
-      <> encode ln
+      <> encode rp
       <> encode mc
       <> encode rs
       <> encode mt
 
-instance DecodeVersioned t => DecodeVersioned (SnapMergingRunState t RunNumber) where
+instance (DecodeVersioned t, DecodeVersioned r) => DecodeVersioned (SnapMergingRunState t r) where
   decodeVersioned v@V0 = do
       n <- decodeListLen
       tag <- decodeWord