Grafting golden tests into the 'Snapshot/Codec' branch of the TestTre…

…e for serialization backwards compatibility testing.

.gitattributes

@@ -0,0 +1 @@
+*.golden	-text

lsm-tree.cabal

@@ -375,6 +375,7 @@ test-suite lsm-tree-test
     Test.Database.LSMTree.Internal.Serialise
     Test.Database.LSMTree.Internal.Serialise.Class
     Test.Database.LSMTree.Internal.Snapshot.Codec
+    Test.Database.LSMTree.Internal.Snapshot.Codec.Golden
     Test.Database.LSMTree.Internal.Snapshot.FS
     Test.Database.LSMTree.Internal.Vector
     Test.Database.LSMTree.Internal.Vector.Growing
@@ -434,6 +435,7 @@ test-suite lsm-tree-test
     , split
     , stm
     , tasty
+    , tasty-golden
     , tasty-hunit
     , tasty-quickcheck
     , temporary

src/Database/LSMTree/Internal/Config.hs

@@ -156,7 +156,8 @@ data MergePolicy =
 {- TODO: disabled for now
   | MergePolicyLevelling
 -}
-  deriving stock (Show, Eq)
+  -- @Bounded@ and @Enum@ instances are required for test-case enumeration.
+  deriving stock (Bounded, Enum, Eq, Show)
 
 instance NFData MergePolicy where
   rnf MergePolicyLazyLevelling = ()
@@ -166,7 +167,8 @@ instance NFData MergePolicy where
 -------------------------------------------------------------------------------}
 
 data SizeRatio = Four
-  deriving stock (Show, Eq)
+  -- @Bounded@ and @Enum@ instances are required for test-case enumeration.
+  deriving stock (Bounded, Enum, Eq, Show)
 
 instance NFData SizeRatio where
   rnf Four = ()
@@ -303,7 +305,8 @@ data FencePointerIndex =
     -- | Use an ordinary fence pointer index, without any constraints on
     -- serialised keys.
   | OrdinaryIndex
-  deriving stock (Show, Eq)
+  -- @Bounded@ and @Enum@ instances are required for test-case enumeration.
+  deriving stock (Bounded, Enum, Eq, Show)
 
 instance NFData FencePointerIndex where
   rnf CompactIndex  = ()
@@ -355,7 +358,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)
+  deriving stock (Show, Eq)
 
 instance NFData DiskCachePolicy where
   rnf DiskCacheAll                 = ()
@@ -399,7 +402,8 @@ data MergeSchedule =
     -- merges are fully completed in time for when new merges are started on the
     -- same level.
   | Incremental
-  deriving stock (Eq, Show)
+  -- @Bounded@ and @Enum@ instances are required for test-case enumeration.
+  deriving stock (Bounded, Enum, Eq, Show)
 
 instance NFData MergeSchedule where
   rnf OneShot     = ()

src/Database/LSMTree/Internal/Merge.hs

@@ -73,7 +73,8 @@ data MergeState =
   | Closed
 
 data Level = MidLevel | LastLevel
-  deriving stock (Eq, Show)
+  -- @Bounded@ and @Enum@ instances are required for test-case enumeration.
+  deriving stock (Bounded, Enum, Eq, Show)
 
 instance NFData Level where
   rnf MidLevel  = ()

src/Database/LSMTree/Internal/MergingRun.hs

@@ -70,7 +70,7 @@ instance RefCounted m (MergingRun m h) where
     getRefCounter = mergeRefCounter
 
 data MergePolicyForLevel = LevelTiering | LevelLevelling
-  deriving stock (Show, Eq)
+  deriving stock (Bounded, Enum, Eq, Show)
 
 instance NFData MergePolicyForLevel where
   rnf LevelTiering   = ()

src/Database/LSMTree/Internal/Snapshot.hs

@@ -73,7 +73,7 @@ newtype SnapshotLabel = SnapshotLabel Text
 
 -- TODO: revisit if we need three table types.
 data SnapshotTableType = SnapNormalTable | SnapMonoidalTable | SnapFullTable
-  deriving stock (Show, Eq)
+  deriving stock (Bounded, Enum, Eq, Show)
 
 instance NFData SnapshotTableType where
   rnf SnapNormalTable   = ()

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

@@ -22,6 +22,8 @@ import           Database.LSMTree.Internal.MergingRun
 import           Database.LSMTree.Internal.RunNumber
 import           Database.LSMTree.Internal.Snapshot
 import           Database.LSMTree.Internal.Snapshot.Codec
+import           Test.Database.LSMTree.Internal.Snapshot.Codec.Golden
+                     (goldenFileTests)
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
 import           Test.Util.Arbitrary
@@ -47,6 +49,7 @@ tests = testGroup "Test.Database.LSMTree.Internal.Snapshot.Codec" [
         testAll $ \(p :: Proxy a) ->
           testGroup (show $ typeRep p) $
             prop_arbitraryAndShrinkPreserveInvariant @a deepseqInvariant
+    , goldenFileTests
     ]
 
 {-------------------------------------------------------------------------------

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

@@ -0,0 +1,269 @@
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# OPTIONS_GHC -fspecialize-aggressively #-}
+module Test.Database.LSMTree.Internal.Snapshot.Codec.Golden
+  (goldenFileTests) where
+
+import           Control.Monad (when)
+import           Control.Monad.ST.Strict (ST, runST)
+import           Data.Foldable (fold)
+import           Data.STRef
+import           Data.Vector (Vector)
+import qualified Data.Vector as V
+import           Database.LSMTree.Common (BloomFilterAlloc (..),
+                     DiskCachePolicy (..), NumEntries (..), TableConfig (..),
+                     WriteBufferAlloc (..), defaultTableConfig)
+import           Database.LSMTree.Internal.MergingRun (NumRuns (..))
+import           Database.LSMTree.Internal.RunNumber (RunNumber (..))
+import           Database.LSMTree.Internal.Snapshot
+import           Database.LSMTree.Internal.Snapshot.Codec
+import qualified System.FS.API as FS
+import           System.FS.API.Types (FsPath, MountPoint (..), fsToFilePath,
+                     mkFsPath, (<.>))
+import           System.FS.IO (HandleIO, ioHasFS)
+import qualified Test.Tasty as Tasty
+import           Test.Tasty (TestName, TestTree, testGroup)
+import qualified Test.Tasty.Golden as Au
+import           Text.Printf (printf)
+
+
+-- |
+-- Compare the serialization of snapshot metadata with a known reference file.
+goldenFileTests :: TestTree
+goldenFileTests =  handleOutputFiles . testGroup "Golden File Comparisons" $
+    [ testCodecSnapshotLabel
+    , testCodecSnapshotTableType
+    , testCodecTableConfig
+    , testCodecSnapLevels
+    ]
+
+-- |
+-- The mount point is defined as the location of the golden file data directory
+-- relative to the project root.
+goldenDataMountPoint :: MountPoint
+goldenDataMountPoint = MountPoint "test/golden-file-data/snapshot-codec"
+
+-- |
+-- Delete output files on test-case success.
+-- Change the option here if this is undesireable.
+handleOutputFiles :: TestTree -> TestTree
+handleOutputFiles = Tasty.localOption Au.OnPass
+
+-- |
+--
+-- Internally, the function will infer the correct filepath names.
+--
+-- There are three paths for both the checksum and the snapshot files:
+--   1. The filepath of type @FsPath@ to which data is written.
+--   2. The filepath of type @FilePath@ from which data is read.
+--   3. The filepath of type @FilePath@ against which the data is compared.
+--
+-- These file types' bindings have the following infix annotations, respectively:
+--   1. (Fs) for FsPath
+--   2. (Hs) for "Haskell" path
+--   3. (Au) for "Golden file" path
+snapshotCodecTest
+  :: String -- ^ Name of the test
+  -> SnapshotMetaData -- ^ Data to be serialized
+  -> TestTree
+snapshotCodecTest name datum =
+  let -- Various paths
+      checksumFsPath = mkFsPath [name] <.> "checksum"
+      snapshotFsPath = mkFsPath [name] <.> "snapshot"
+      snapshotHsPath = fsToFilePath goldenDataMountPoint snapshotFsPath
+      snapshotAuPath = snapshotHsPath <> ".golden"
+
+      -- IO actions
+      tidyUpAction :: a -> IO ()
+      tidyUpAction = const $ removeIfExists checksumFsPath
+      runnerIO :: FS.HasFS IO HandleIO
+      runnerIO = ioHasFS goldenDataMountPoint
+      removeIfExists :: FsPath -> IO ()
+      removeIfExists fp =
+        FS.doesFileExist runnerIO fp >>= (`when` (FS.removeFile runnerIO fp))
+      outputAction :: IO ()
+      outputAction = do
+        removeIfExists snapshotFsPath
+        removeIfExists checksumFsPath
+        writeFileSnapshotMetaData
+          runnerIO
+          snapshotFsPath
+          checksumFsPath
+          datum
+
+      -- File comparison test-cases against authoritative "golden" files
+      testCaseSnapshot :: TestTree
+      testCaseSnapshot = Au.goldenVsFile name snapshotAuPath snapshotHsPath outputAction
+
+      -- Be sure to use Tasty's @withResource@ constructor to ensure that the
+      -- codec serialization occurs only /once/ and extranerous "checksum" files
+      -- are cleaned up after the test case.
+  in  Tasty.withResource outputAction tidyUpAction $ \tok ->
+        tok `seq` testCaseSnapshot
+
+testCodecSnapshotLabel :: TestTree
+testCodecSnapshotLabel =
+  let assembler label =
+        SnapshotMetaData
+          label
+          basicSnapshotTableType
+          basicTableConfig
+          basicSnapLevels
+  in  testCodecBuilder "SnapshotLabel" $ assembler <$> enumerateSnapshotLabel
+
+testCodecSnapshotTableType :: TestTree
+testCodecSnapshotTableType =
+  let assembler tType =
+        SnapshotMetaData
+          basicSnapshotLabel
+          tType
+          basicTableConfig
+          basicSnapLevels
+  in  testCodecBuilder "SnapshotTableType" $ assembler <$> enumerateSnapshotTableType
+
+testCodecTableConfig :: TestTree
+testCodecTableConfig =
+  let assembler tConfig =
+        SnapshotMetaData
+          basicSnapshotLabel
+          basicSnapshotTableType
+          tConfig
+          basicSnapLevels
+  in  testCodecBuilder "TableConfig" $ assembler <$> enumerateTableConfig
+
+testCodecSnapLevels :: TestTree
+testCodecSnapLevels =
+  let assembler levels =
+        SnapshotMetaData
+          basicSnapshotLabel
+          basicSnapshotTableType
+          basicTableConfig
+          levels
+  in  testCodecBuilder "SnapLevels" $ assembler <$> enumerateSnapLevels
+
+testCodecBuilder :: TestName -> [SnapshotMetaData] -> TestTree
+testCodecBuilder tName metadata =
+    let finalizer :: STRef s Word -> SnapshotMetaData -> ST s TestTree
+        finalizer ref datum = do
+          curr <- readSTRef ref
+          modifySTRef' ref succ
+          pure $ snapshotCodecTest (tName <> printf "-%03d" curr) datum
+
+        testSubtree = runST $ do
+          counter <- newSTRef 0
+          traverse (finalizer counter) metadata
+
+    in  testGroup tName testSubtree
+
+{----------------
+Defaults used when the SnapshotMetaData sub-component is not under test
+----------------}
+
+basicSnapshotLabel :: SnapshotLabel
+basicSnapshotLabel = head enumerateSnapshotLabel
+
+basicSnapshotTableType :: SnapshotTableType
+basicSnapshotTableType = minBound
+
+basicTableConfig :: TableConfig
+basicTableConfig = defaultTableConfig
+
+basicSnapLevels :: SnapLevels RunNumber
+basicSnapLevels = head enumerateSnapLevels
+
+{----------------
+Enumeration of SnapshotMetaData sub-components
+----------------}
+
+enumerateSnapshotLabel :: [SnapshotLabel]
+enumerateSnapshotLabel = [ SnapshotLabel "UserProvidedLabel", SnapshotLabel "" ]
+
+enumerateSnapshotTableType :: [SnapshotTableType]
+enumerateSnapshotTableType = [minBound .. maxBound]
+
+enumerateTableConfig :: [TableConfig]
+enumerateTableConfig =
+    [ TableConfig
+        policy
+        ratio
+        allocs
+        bloom
+        fence
+        cache
+        merge
+    | policy <- [minBound .. maxBound]
+    , ratio <- [minBound .. maxBound]
+    , allocs <- AllocNumEntries . NumEntries <$> [magicNumber1]
+    , bloom <- enumerateBloomFilterAlloc
+    , fence <- [minBound .. maxBound]
+    , cache <- enumerateDiskCachePolicy
+    , merge <- [minBound .. maxBound]
+    ]
+
+enumerateSnapLevels :: [SnapLevels RunNumber]
+enumerateSnapLevels = SnapLevels . V.singleton <$> enumerateSnapLevel
+
+{----------------
+Enumeration of SnapshotMetaData sub-sub-components and so on...
+----------------}
+
+enumerateBloomFilterAlloc :: [BloomFilterAlloc]
+enumerateBloomFilterAlloc =
+  [ AllocFixed magicNumber3
+  , AllocRequestFPR pi
+  , AllocMonkey magicNumber3 . NumEntries $ magicNumber3 `div` 4
+  ]
+
+enumerateDiskCachePolicy :: [DiskCachePolicy]
+enumerateDiskCachePolicy =
+  [ DiskCacheAll
+  , DiskCacheNone
+  , DiskCacheLevelsAtOrBelow 1
+  ]
+
+enumerateSnapLevel :: [SnapLevel RunNumber]
+enumerateSnapLevel = SnapLevel <$> enumerateSnapIncomingRun <*> enumerateVectorRunNumber
+
+enumerateSnapIncomingRun :: [SnapIncomingRun RunNumber]
+enumerateSnapIncomingRun =
+  let
+      inSnaps = (SnapSingleRun <$> enumerateRunNumbers) <>
+        [ SnapMergingRun policy numRuns entries credits sState
+        | policy <- [minBound .. maxBound]
+        , numRuns <- NumRuns <$> [ magicNumber1 ]
+        , entries <- NumEntries  <$> [ magicNumber2 ]
+        , credits <- UnspentCredits <$> [ magicNumber1 ]
+        , sState <- enumerateSnapMergingRunState
+        ]
+  in  fold
+      [ SnapSingleRun <$> enumerateRunNumbers
+      , inSnaps
+      ]
+
+enumerateSnapMergingRunState :: [SnapMergingRunState RunNumber]
+enumerateSnapMergingRunState = (SnapCompletedMerge <$> enumerateRunNumbers) <>
+  [ SnapOngoingMerge runVec credits level
+  | runVec <- enumerateVectorRunNumber
+  , credits <- SpentCredits <$> [ magicNumber1]
+  , level <- [minBound .. maxBound]
+  ]
+
+enumerateVectorRunNumber :: [Vector RunNumber]
+enumerateVectorRunNumber =
+  [ mempty
+  , V.fromList [RunNumber magicNumber1]
+  , V.fromList [RunNumber magicNumber1, RunNumber magicNumber2 ]
+  ]
+
+enumerateRunNumbers :: [RunNumber]
+enumerateRunNumbers = RunNumber <$> [ magicNumber2 ]
+
+-- Randomly chosen numbers
+magicNumber1, magicNumber2, magicNumber3 :: Enum e => e
+magicNumber1 = toEnum 42
+magicNumber2 = toEnum 88
+magicNumber3 = toEnum 1024