Golden test suite for snapshot codec

.gitattributes

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

lsm-tree.cabal

@@ -380,6 +380,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
@@ -443,6 +444,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/Snapshot.hs

@@ -87,7 +87,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

@@ -21,6 +21,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
@@ -46,6 +48,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,259 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Test.Database.LSMTree.Internal.Snapshot.Codec.Golden
+  (goldenFileTests) where
+
+import           Codec.CBOR.Write (toLazyByteString)
+import           Control.Monad (when)
+import qualified Data.ByteString.Lazy as BSL (writeFile)
+import           Data.Foldable (fold)
+import           Data.Vector (Vector)
+import qualified Data.Vector as V
+import           Database.LSMTree.Common (BloomFilterAlloc (..),
+                     DiskCachePolicy (..), NumEntries (..), TableConfig (..),
+                     WriteBufferAlloc (..), defaultTableConfig)
+import           Database.LSMTree.Internal.Config (FencePointerIndex (..),
+                     MergePolicy (..), MergeSchedule (..), SizeRatio (..))
+import           Database.LSMTree.Internal.Merge (MergeType (..))
+import           Database.LSMTree.Internal.MergeSchedule (MergePolicyForLevel (..))
+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
+
+-- | Compare the serialization of snapshot metadata with a known reference file.
+goldenFileTests :: TestTree
+goldenFileTests =  handleOutputFiles . testGroup
+    "Test.Database.LSMTree.Internal.Snapshot.Codec.Golden" $
+    [ 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.
+snapshotCodecTest
+  :: String -- ^ Name of the test
+  -> SnapshotMetaData -- ^ Data to be serialized
+  -> TestTree
+snapshotCodecTest name datum =
+  let -- Various paths
+      --
+      -- 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
+      snapshotFsPath = mkFsPath [name] <.> "snapshot"
+      snapshotHsPath = fsToFilePath goldenDataMountPoint snapshotFsPath
+      snapshotAuPath = snapshotHsPath <> ".golden"
+
+      -- IO actions
+      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
+        -- Ensure that if the output file already exists, we remove it and
+        -- re-write out the serialized data. This ensures that there are no
+        -- false-positives, false-negatives, or irrelavent I/O exceptions.
+        removeIfExists snapshotFsPath
+        BSL.writeFile snapshotHsPath . toLazyByteString $ encode datum
+
+  in  Au.goldenVsFile name snapshotAuPath snapshotHsPath outputAction
+
+testCodecSnapshotLabel :: TestTree
+testCodecSnapshotLabel =
+  let assembler (tagA, valA) =
+        let (tagB, valB) = basicSnapshotTableType
+            (tagC, valC) = basicTableConfig
+            (tagD, valD) = basicRunNumber
+            (tagE, valE) = basicSnapLevels
+        in  (fold [tagA, tagB, tagC, tagD, tagE ], SnapshotMetaData valA valB valC valD valE)
+  in  testCodecBuilder "SnapshotLabels" $ assembler <$> enumerateSnapshotLabel
+
+testCodecSnapshotTableType :: TestTree
+testCodecSnapshotTableType =
+  let assembler (tagB, valB) =
+        let (tagA, valA) = basicSnapshotLabel
+            (tagC, valC) = basicTableConfig
+            (tagD, valD) = basicRunNumber
+            (tagE, valE) = basicSnapLevels
+        in  (fold [tagA, tagB, tagC, tagD, tagE ], SnapshotMetaData valA valB valC valD valE)
+  in  testCodecBuilder "SnapshotTables" $ assembler <$> enumerateSnapshotTableType
+
+testCodecTableConfig :: TestTree
+testCodecTableConfig =
+  let assembler (tagC, valC) =
+        let (tagA, valA) = basicSnapshotLabel
+            (tagB, valB) = basicSnapshotTableType
+            (tagD, valD) = basicRunNumber
+            (tagE, valE) = basicSnapLevels
+        in  (fold [tagA, tagB, tagC, tagD, tagE ], SnapshotMetaData valA valB valC valD valE)
+  in  testCodecBuilder "SnapshotConfig" $ assembler <$> enumerateTableConfig
+
+testCodecSnapLevels :: TestTree
+testCodecSnapLevels =
+  let assembler (tagE, valE) =
+        let (tagA, valA) = basicSnapshotLabel
+            (tagB, valB) = basicSnapshotTableType
+            (tagC, valC) = basicTableConfig
+            (tagD, valD) = basicRunNumber
+        in  (fold [tagA, tagB, tagC, tagD, tagE ], SnapshotMetaData valA valB valC valD valE)
+  in  testCodecBuilder "SnapshotLevels" $ assembler <$> enumerateSnapLevels
+
+testCodecBuilder :: TestName -> [(ComponentAnnotation, SnapshotMetaData)] -> TestTree
+testCodecBuilder tName metadata =
+  testGroup tName $ uncurry snapshotCodecTest <$> metadata
+
+type ComponentAnnotation = String
+
+{----------------
+Defaults used when the SnapshotMetaData sub-component is not under test
+----------------}
+
+basicSnapshotLabel :: (ComponentAnnotation, SnapshotLabel)
+basicSnapshotLabel = head enumerateSnapshotLabel
+
+basicSnapshotTableType :: (ComponentAnnotation, SnapshotTableType)
+basicSnapshotTableType = head enumerateSnapshotTableType
+
+basicTableConfig :: (ComponentAnnotation, TableConfig)
+basicTableConfig = ("T", defaultTableConfig)
+
+basicRunNumber :: (ComponentAnnotation, RunNumber)
+basicRunNumber = ("W", enumerateRunNumbers)
+
+basicSnapLevels :: (ComponentAnnotation, SnapLevels RunNumber)
+basicSnapLevels = head enumerateSnapLevels
+
+{----------------
+Enumeration of SnapshotMetaData sub-components
+----------------}
+
+enumerateSnapshotLabel :: [(ComponentAnnotation, SnapshotLabel)]
+enumerateSnapshotLabel =
+  [ ("Bs", SnapshotLabel "UserProvidedLabel")
+  , ("Bn", SnapshotLabel "")
+  ]
+
+enumerateSnapshotTableType :: [(ComponentAnnotation, SnapshotTableType)]
+enumerateSnapshotTableType =
+  [ ("Nn", SnapNormalTable)
+  , ("Nm", SnapMonoidalTable)
+  , ("Nf", SnapFullTable)
+  ]
+
+enumerateTableConfig :: [(ComponentAnnotation, TableConfig)]
+enumerateTableConfig =
+    [ ( fold [ "T", a, b, c, d, e, f, g ]
+      , TableConfig
+        policy
+        ratio
+        allocs
+        bloom
+        fence
+        cache
+        merge
+      )
+    | (a, policy) <- [("", MergePolicyLazyLevelling)]
+    , (b, ratio ) <- [("", Four)]
+    , (c, allocs) <- fmap (AllocNumEntries . NumEntries) <$> [("", magicNumber1)]
+    , (d, bloom ) <- enumerateBloomFilterAlloc
+    , (e, fence ) <- [("Ic", CompactIndex), ("Io", OrdinaryIndex)]
+    , (f, cache ) <- enumerateDiskCachePolicy
+    , (g, merge ) <- [("Go", OneShot), ("Gi", Incremental)]
+    ]
+
+enumerateSnapLevels :: [(ComponentAnnotation, SnapLevels RunNumber)]
+enumerateSnapLevels = fmap (SnapLevels . V.singleton) <$> enumerateSnapLevel
+
+{----------------
+Enumeration of SnapLevel sub-components
+----------------}
+
+enumerateSnapLevel :: [(ComponentAnnotation, SnapLevel RunNumber)]
+enumerateSnapLevel = do
+  (a, run) <- enumerateSnapIncomingRun
+  (b, vec) <- enumerateVectorRunNumber
+  [(a <> b, SnapLevel run vec)]
+
+enumerateSnapIncomingRun :: [(ComponentAnnotation, SnapIncomingRun RunNumber)]
+enumerateSnapIncomingRun =
+  let
+      inSnaps =
+        [ (fold ["Rm", "P", a, b], SnapMergingRun policy numRuns entries credits sState)
+        | (a, policy ) <- [("t", LevelTiering), ("g", LevelLevelling)]
+        , numRuns <- NumRuns <$> [ magicNumber1 ]
+        , entries <- NumEntries  <$> [ magicNumber2 ]
+        , credits <- UnspentCredits <$> [ magicNumber1 ]
+        , (b, sState ) <- enumerateSnapMergingRunState
+        ]
+  in  fold
+      [ [("Rs", SnapSingleRun enumerateRunNumbers)]
+      , inSnaps
+      ]
+
+enumerateSnapMergingRunState :: [(ComponentAnnotation, SnapMergingRunState RunNumber)]
+enumerateSnapMergingRunState = ("Mc", SnapCompletedMerge enumerateRunNumbers) :
+  [ (fold ["Mo",a,b,c], SnapOngoingMerge runVec credits mType)
+  | (a, runVec ) <- enumerateVectorRunNumber
+  , (b, credits) <- [("" , SpentCredits magicNumber1 )]
+  , (c, mType  ) <- [("Mm", MergeMidLevel), ("Ml", MergeLastLevel), ("Mu", MergeUnion)]
+  ]
+
+enumerateVectorRunNumber :: [(ComponentAnnotation, Vector RunNumber)]
+enumerateVectorRunNumber =
+  [ ("V0", mempty)
+  , ("V1", V.fromList [RunNumber magicNumber1])
+  , ("V2", V.fromList [RunNumber magicNumber1, RunNumber magicNumber2 ])
+  ]
+
+{----------------
+Enumeration of SnapshotMetaData sub-sub-components and so on...
+----------------}
+
+enumerateBloomFilterAlloc :: [(ComponentAnnotation, BloomFilterAlloc)]
+enumerateBloomFilterAlloc =
+  [ ("Af",AllocFixed magicNumber3)
+  , ("Ar",AllocRequestFPR pi)
+  , ("Am",AllocMonkey magicNumber3 . NumEntries $ magicNumber3 `div` 4)
+  ]
+
+enumerateDiskCachePolicy :: [(ComponentAnnotation, DiskCachePolicy)]
+enumerateDiskCachePolicy =
+  [ ("Da", DiskCacheAll)
+  , ("Dn", DiskCacheNone)
+  , ("Db", DiskCacheLevelsAtOrBelow 1)
+  ]
+
+enumerateRunNumbers :: RunNumber
+enumerateRunNumbers = RunNumber magicNumber2
+
+-- Randomly chosen numbers
+magicNumber1, magicNumber2, magicNumber3 :: Enum e => e
+magicNumber1 = toEnum 42
+magicNumber2 = toEnum 88
+magicNumber3 = toEnum 1024