Revisit snapshot labels

Require the user to pass in snapshot labels explicitly. The responsibility of
managing label falls on the user, just like the user has the reponsibility of
managing snapshot names.

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