Merge pull request #473 from IntersectMBO/jdral/revisit-snapshot-label

Revisit snapshot labels

Author: jorisdral

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

@@ -87,8 +87,8 @@ type K = BS.ShortByteString
 type V = BS.ShortByteString
 type B = Void
 
-instance LSM.Labellable (K, V, B) where
-  makeSnapshotLabel _ = "K V B"
+label :: LSM.SnapshotLabel
+label = LSM.SnapshotLabel "K V B"
 
 -- | We generate 34 byte keys by using a PRNG to extend a word64 to 32 bytes
 -- and then appending two constant bytes. This corresponds relatively closely
@@ -418,7 +418,7 @@ doSetup' gopts opts = do
                 | i <- NE.toList batch
                 ]
 
-        LSM.createSnapshot name tbl
+        LSM.createSnapshot label name tbl
 
 -------------------------------------------------------------------------------
 -- dry-run
@@ -577,7 +577,7 @@ doRun gopts opts = do
         -- necessary for testing to load the whole snapshot).
         tbl <- if check opts
                 then LSM.new  @IO @K @V @B session (mkTableConfigRun gopts LSM.defaultTableConfig)
-                else LSM.openSnapshot @IO @K @V @B session (mkTableConfigOverride gopts) name
+                else LSM.openSnapshot @IO @K @V @B session (mkTableConfigOverride gopts) label name
 
         -- In checking mode, compare each output against a pure reference.
         checkvar <- newIORef $ pureReference

src/Database/LSMTree.hs

@@ -66,7 +66,7 @@ module Database.LSMTree (
     -- * Durability (snapshots)
   , SnapshotName
   , Common.mkSnapshotName
-  , Common.Labellable (..)
+  , Common.SnapshotLabel (..)
   , createSnapshot
   , openSnapshot
   , Common.TableConfigOverride
@@ -464,42 +464,40 @@ retrieveBlobs (Internal.Session' (sesh :: Internal.Session m h)) refs =
 -------------------------------------------------------------------------------}
 
 {-# SPECIALISE createSnapshot ::
-     (Common.Labellable (k, v, blob), ResolveValue v)
-  => SnapshotName
+     ResolveValue v
+  => Common.SnapshotLabel
+  -> SnapshotName
   -> Table IO k v blob
   -> IO () #-}
 createSnapshot :: forall m k v blob.
      ( IOLike m
-     , Common.Labellable (k, v, blob)
      , ResolveValue v
      )
-  => SnapshotName
+  => Common.SnapshotLabel
+  -> SnapshotName
   -> Table m k v blob
   -> m ()
-createSnapshot snap (Internal.Table' t) =
+createSnapshot label snap (Internal.Table' t) =
     void $ Internal.createSnapshot (resolve (Proxy @v)) snap label Internal.SnapFullTable t
-  where
-    label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, blob))
 
 {-# SPECIALISE openSnapshot ::
-     (Common.Labellable (k, v, blob), ResolveValue v)
+     ResolveValue v
   => Session IO
   -> Common.TableConfigOverride
+  -> Common.SnapshotLabel
   -> SnapshotName
   -> IO (Table IO k v blob ) #-}
 openSnapshot :: forall m k v blob.
      ( IOLike m
-     , Common.Labellable (k, v, blob)
      , ResolveValue v
      )
   => Session m
   -> Common.TableConfigOverride -- ^ Optional config override
+  -> Common.SnapshotLabel
   -> SnapshotName
   -> m (Table m k v blob)
-openSnapshot (Internal.Session' sesh) override snap =
+openSnapshot (Internal.Session' sesh) override label snap =
     Internal.Table' <$!> Internal.openSnapshot sesh label Internal.SnapFullTable override snap (resolve (Proxy @v))
-  where
-    label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, blob))
 
 {-------------------------------------------------------------------------------
   Mutiple writable tables

src/Database/LSMTree/Common.hs

@@ -18,7 +18,7 @@ module Database.LSMTree.Common (
     -- * Small types
   , Internal.Range (..)
     -- * Snapshots
-  , Labellable (..)
+  , SnapshotLabel (..)
   , deleteSnapshot
   , listSnapshots
     -- ** Snapshot names
@@ -52,8 +52,7 @@ import           Control.Monad.Class.MonadThrow
 import           Control.Monad.Primitive (PrimMonad)
 import           Control.Tracer (Tracer)
 import           Data.Kind (Type)
-import           Data.Text (Text)
-import           Data.Typeable (Proxy, Typeable)
+import           Data.Typeable (Typeable)
 import qualified Database.LSMTree.Internal as Internal
 import qualified Database.LSMTree.Internal.BlobRef as Internal
 import qualified Database.LSMTree.Internal.Config as Internal
@@ -62,6 +61,7 @@ import qualified Database.LSMTree.Internal.MergeSchedule as Internal
 import qualified Database.LSMTree.Internal.Paths as Internal
 import qualified Database.LSMTree.Internal.Range as Internal
 import           Database.LSMTree.Internal.Serialise.Class
+import           Database.LSMTree.Internal.Snapshot (SnapshotLabel (..))
 import           System.FS.API (FsPath, HasFS)
 import           System.FS.BlockIO.API (HasBlockIO)
 import           System.FS.IO (HandleIO)
@@ -186,13 +186,6 @@ closeSession (Internal.Session' sesh) = Internal.closeSession sesh
   Snapshots
 -------------------------------------------------------------------------------}
 
--- TODO: we might replace this with some other form of dynamic checking of
--- snapshot types. For example, we could ask the user to produce a label/version
--- directly instead, instead of deriving the label from a type using this type
--- class.
-class Labellable a where
-  makeSnapshotLabel :: Proxy a -> Text
-
 {-# SPECIALISE deleteSnapshot ::
      Session IO
   -> Internal.SnapshotName

src/Database/LSMTree/Internal/Snapshot.hs

@@ -57,7 +57,12 @@ import           System.FS.BlockIO.API (HasBlockIO)
   Snapshot metadata
 -------------------------------------------------------------------------------}
 
--- | Custom text to include in a snapshot file
+-- | Custom, user-supplied text that is included in the metadata.
+--
+-- The main use case for a 'SnapshotLabel' is for the user to supply textual
+-- information about the key\/value\/blob type for the table that corresponds to
+-- the snapshot. This information is used to dynamically check that a snapshot
+-- is opened at the correct key\/value\/blob type.
 newtype SnapshotLabel = SnapshotLabel Text
   deriving stock (Show, Eq)
 
@@ -66,17 +71,11 @@ data SnapshotTableType = SnapNormalTable | SnapMonoidalTable | SnapFullTable
   deriving stock (Show, Eq)
 
 data SnapshotMetaData = SnapshotMetaData {
-    -- | Custom, user-supplied text that is included in the metadata.
-    --
-    -- The main use case for this field is for the user to supply textual
-    -- information about the key\/value\/blob type for the table that
-    -- corresponds to the snapshot. This information can then be used to
-    -- dynamically check that a snapshot is opened at the correct
-    -- key\/value\/blob type.
+    -- | See 'SnapshotLabel'.
     --
     -- One could argue that the 'SnapshotName' could be used to to hold this
-    -- information, but the file name of snapshot metadata is not guarded by a
-    -- checksum, wherease the contents of the file are. Therefore using the
+    -- type information, but the file name of snapshot metadata is not guarded
+    -- by a checksum, wherease the contents of the file are. Therefore using the
     -- 'SnapshotLabel' is safer.
     snapMetaLabel     :: !SnapshotLabel
     -- | Whether a table is normal or monoidal.

src/Database/LSMTree/Monoidal.hs

@@ -83,7 +83,7 @@ module Database.LSMTree.Monoidal (
     -- * Durability (snapshots)
   , SnapshotName
   , Common.mkSnapshotName
-  , Common.Labellable (..)
+  , Common.SnapshotLabel (..)
   , createSnapshot
   , openSnapshot
   , Common.TableConfigOverride
@@ -517,8 +517,9 @@ mupserts t = updates t . fmap (second Mupsert)
 -------------------------------------------------------------------------------}
 
 {-# SPECIALISE createSnapshot ::
-     (ResolveValue v, Common.Labellable (k, v))
-  => SnapshotName
+     ResolveValue v
+  => Common.SnapshotLabel
+  -> SnapshotName
   -> Table IO k v
   -> IO () #-}
 -- | Make the current value of a table durable on-disk by taking a snapshot and
@@ -546,20 +547,19 @@ mupserts t = updates t . fmap (second Mupsert)
 createSnapshot :: forall m k v.
      ( IOLike m
      , ResolveValue v
-     , Common.Labellable (k, v)
      )
-  => SnapshotName
+  => Common.SnapshotLabel
+  -> SnapshotName
   -> Table m k v
   -> m ()
-createSnapshot snap (Internal.MonoidalTable t) =
+createSnapshot label snap (Internal.MonoidalTable t) =
     Internal.createSnapshot (resolve @v Proxy) snap label Internal.SnapMonoidalTable t
-  where
-    label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v))
 
 {-# SPECIALISE openSnapshot ::
-     (ResolveValue v, Common.Labellable (k, v))
+     ResolveValue v
   => Session IO
   -> Common.TableConfigOverride
+  -> Common.SnapshotLabel
   -> SnapshotName
   -> IO (Table IO k v) #-}
 -- | Open a table from a named snapshot, returning a new table.
@@ -583,13 +583,13 @@ createSnapshot snap (Internal.MonoidalTable t) =
 openSnapshot :: forall m k v.
      ( IOLike m
      , ResolveValue v
-     , Common.Labellable (k, v)
      )
   => Session m
   -> Common.TableConfigOverride -- ^ Optional config override
+  -> Common.SnapshotLabel
   -> SnapshotName
   -> m (Table m k v)
-openSnapshot (Internal.Session' sesh) override snap =
+openSnapshot (Internal.Session' sesh) override label snap =
     Internal.MonoidalTable <$>
       Internal.openSnapshot
         sesh
@@ -598,8 +598,6 @@ openSnapshot (Internal.Session' sesh) override snap =
         override
         snap
         (resolve @v Proxy)
-  where
-    label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v))
 
 {-------------------------------------------------------------------------------
   Multiple writable tables

src/Database/LSMTree/Normal.hs

@@ -84,7 +84,7 @@ module Database.LSMTree.Normal (
     -- * Durability (snapshots)
   , SnapshotName
   , Common.mkSnapshotName
-  , Common.Labellable (..)
+  , Common.SnapshotLabel (..)
   , createSnapshot
   , openSnapshot
   , Common.TableConfigOverride
@@ -115,7 +115,7 @@ import           Control.Exception (throw)
 import           Control.Monad
 import           Data.Bifunctor (Bifunctor (..))
 import           Data.Kind (Type)
-import           Data.Typeable (Proxy (..), eqT, type (:~:) (Refl))
+import           Data.Typeable (eqT, type (:~:) (Refl))
 import qualified Data.Vector as V
 import           Database.LSMTree.Common (BlobRef (BlobRef), IOLike, Range (..),
                      SerialiseKey, SerialiseValue, Session, SnapshotName,
@@ -635,8 +635,8 @@ retrieveBlobs (Internal.Session' (sesh :: Internal.Session m h)) refs =
 -------------------------------------------------------------------------------}
 
 {-# SPECIALISE createSnapshot ::
-     Common.Labellable (k, v, blob)
-  => SnapshotName
+     Common.SnapshotLabel
+  -> SnapshotName
   -> Table IO k v blob
   -> IO () #-}
 -- | Make the current value of a table durable on-disk by taking a snapshot and
@@ -647,6 +647,11 @@ retrieveBlobs (Internal.Session' (sesh :: Internal.Session m h)) refs =
 -- via that name. Names are strings and the management of the names is up to
 -- the user of the library.
 --
+-- Snapshot labels are included in the snapshot metadata when a snapshot is
+-- created. Labels are text and the management of the labels is up to the user
+-- of the library. Labels assigns a dynamically checked "type" to a snapshot.
+-- See 'Common.SnapshotLabel' for more information.
+--
 -- The names correspond to disk files, which imposes some constraints on length
 -- and what characters can be used.
 --
@@ -661,25 +666,26 @@ retrieveBlobs (Internal.Session' (sesh :: Internal.Session m h)) refs =
 -- * It is safe to concurrently make snapshots from any table, provided that
 --   the snapshot names are distinct (otherwise this would be a race).
 createSnapshot :: forall m k v blob.
-     ( IOLike m
-     , Common.Labellable (k, v, blob)
-     )
-  => SnapshotName
+     IOLike m
+  => Common.SnapshotLabel
+  -> SnapshotName
   -> Table m k v blob
   -> m ()
-createSnapshot snap (Internal.NormalTable t) =
+createSnapshot label snap (Internal.NormalTable t) =
     Internal.createSnapshot const snap label Internal.SnapNormalTable t
-  where
-    label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, blob))
 
 {-# SPECIALISE openSnapshot ::
-     Common.Labellable (k, v, blob)
-  => Session IO
+     Session IO
   -> Common.TableConfigOverride
+  -> Common.SnapshotLabel
   -> SnapshotName
   -> IO (Table IO k v blob ) #-}
 -- | Open a table from a named snapshot, returning a new table.
 --
+-- This function requires passing in an expected label that will be checked
+-- against the label that was included in the snapshot metadata. If there is a
+-- mismatch, an exception is thrown.
+--
 -- NOTE: close tables using 'close' as soon as they are
 -- unused.
 --
@@ -697,14 +703,13 @@ createSnapshot snap (Internal.NormalTable t) =
 --   'openSnapshot' \@IO \@Bool \@Bool \@Bool session "intTable"
 -- @
 openSnapshot :: forall m k v blob.
-     ( IOLike m
-     , Common.Labellable (k, v, blob)
-     )
+     IOLike m
   => Session m
   -> Common.TableConfigOverride -- ^ Optional config override
+  -> Common.SnapshotLabel
   -> SnapshotName
   -> m (Table m k v blob)
-openSnapshot (Internal.Session' sesh) override snap =
+openSnapshot (Internal.Session' sesh) override label snap =
     Internal.NormalTable <$!>
       Internal.openSnapshot
         sesh
@@ -713,8 +718,6 @@ openSnapshot (Internal.Session' sesh) override snap =
         override
         snap
         const
-  where
-    label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, blob))
 
 {-------------------------------------------------------------------------------
   Mutiple writable tables