lsm-tree-1.0.0.0: test/Test/Database/LSMTree/Internal/Snapshot/FS.hs
{-# LANGUAGE OverloadedStrings #-}
-- | Tests for snapshots and their interaction with the file system
module Test.Database.LSMTree.Internal.Snapshot.FS (tests) where
import Control.Monad.Class.MonadThrow
import Control.Monad.IOSim (runSimOrThrow)
import Control.Tracer
import Data.Bifunctor (Bifunctor (..))
import qualified Data.Vector as V
import Data.Word
import Database.LSMTree.Extras (showPowersOf10)
import Database.LSMTree.Extras.Generators ()
import qualified Database.LSMTree.Internal.BloomFilter as Bloom
import Database.LSMTree.Internal.Config
import Database.LSMTree.Internal.Config.Override
(noTableConfigOverride)
import Database.LSMTree.Internal.Entry
import Database.LSMTree.Internal.Paths
import Database.LSMTree.Internal.Serialise
import Database.LSMTree.Internal.Snapshot
import Database.LSMTree.Internal.Snapshot.Codec
import Database.LSMTree.Internal.Unsafe
import qualified System.FS.API as FS
import System.FS.API
import System.FS.Sim.Error hiding (genErrors)
import qualified System.FS.Sim.MockFS as MockFS
import Test.Database.LSMTree.Internal.Snapshot.Codec ()
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Util.FS
import Test.Util.QC (Choice)
tests :: TestTree
tests = testGroup "Test.Database.LSMTree.Internal.Snapshot.FS" [
testProperty "prop_fsRoundtripSnapshotMetaData" $
prop_fsRoundtripSnapshotMetaData
, testProperty "prop_fault_fsRoundtripSnapshotMetaData"
prop_fault_fsRoundtripSnapshotMetaData
, testProperty "prop_flipSnapshotBit" prop_flipSnapshotBit
]
-- | @readFileSnapshotMetaData . writeFileSnapshotMetaData = id@
--
-- NOTE: prop_fault_fsRoundtripSnapshotMetaData with empty errors is equivalent
-- to prop_fsRoundtripSnapshotMetaData. I (Joris) chose to keep the properties
-- separate, so that there are fewer cases to account for (like @allNull@
-- errors) in prop_fault_fsRoundtripSnapshotMetaData
prop_fsRoundtripSnapshotMetaData :: SnapshotMetaData -> Property
prop_fsRoundtripSnapshotMetaData metadata =
ioProperty $
withTempIOHasFS "temp" $ \hfs -> do
writeFileSnapshotMetaData hfs contentPath checksumPath metadata
snapshotMetaData' <-
try @_ @FileCorruptedError (readFileSnapshotMetaData hfs contentPath checksumPath)
pure $ case snapshotMetaData' of
Left e -> counterexample (show e) False
Right metadata' -> metadata === metadata'
where
contentPath = mkFsPath ["content"]
checksumPath = mkFsPath ["checksum"]
-- | @readFileSnapshotMetaData . writeFileSnapshotMetaData = id@, even if
-- exceptions happened.
--
-- NOTE: we can be more precise about the success scenarios for this property,
-- but it complicates the test a lot, so I (Joris) decided not to include it for
-- now. For example, if the read part fails with a deserialise failure, then we
-- *could* check that file corruption took place during the write part.
prop_fault_fsRoundtripSnapshotMetaData ::
TestErrors
-> SnapshotMetaData
-> Property
prop_fault_fsRoundtripSnapshotMetaData testErrs metadata =
ioProperty $
withSimErrorHasFS propNoOpenHandles MockFS.empty emptyErrors $ \hfs _fsVar errsVar -> do
writeResult <-
try @_ @FsError $
withErrors errsVar (writeErrors testErrs) $
writeFileSnapshotMetaData hfs metadataPath checksumPath metadata
readResult <-
try @_ @SomeException $
withErrors errsVar (readErrors testErrs) $
readFileSnapshotMetaData hfs metadataPath checksumPath
let
-- Regardless of whether the write part failed with an exception, if
-- metadata was returned from read+deserialise it should be exactly
-- equal to the metadata that was written to disk.
prop =
case readResult of
Right metadata' -> metadata === metadata'
_ -> property True
pure $
-- TODO: there are some scenarios that we never hit, like deserialise
-- failures. We could tweak the error(stream) generator distribution to
-- hit these cases more often. One neat idea would be to "prime" the
-- generator for errors as follows:
--
-- 1. run the property without errors, but count how often each
-- primitive is used
-- 2. generate errors based on the counts/distribution we obtained in step 1
-- 3. run the property with these errors
tabulate "Write result vs. read result" [mkLabel writeResult readResult] $
prop
where
metadataPath = mkFsPath ["metadata"]
checksumPath = mkFsPath ["checksum"]
-- This label is mainly there to print the success/failure of the write
-- part, the read part, and the deserialisation part. The concrete error
-- contents are not printed.
mkLabel ::
Either FsError ()
-> Either SomeException SnapshotMetaData
-> String
mkLabel writeResult readResult =
"(" <> mkLabelWriteResult writeResult <>
", " <> mkLabelReadResult readResult <>
")"
mkLabelWriteResult :: Either FsError () -> String
mkLabelWriteResult = \case
Left FsError{} -> "Left FSError"
Right () -> "Right ()"
mkLabelReadResult ::
Either SomeException SnapshotMetaData
-> String
mkLabelReadResult = \case
Left e
| Just FsError{} <- fromException e ->
"Left FSError"
| Just ErrFileFormatInvalid{} <- fromException e ->
"Left ErrFileFormatInvalid"
| Just ErrFileChecksumMismatch{} <- fromException e ->
"Left ErrFileChecksumMismatch"
| otherwise ->
error ("impossible: " <> show e)
Right (_ :: SnapshotMetaData) ->
"Right SnapshotMetaData"
data TestErrors = TestErrors {
writeErrors :: Errors
, readErrors :: Errors
}
deriving stock Show
instance Arbitrary TestErrors where
arbitrary = TestErrors <$> arbitrary <*> arbitrary
shrink TestErrors{writeErrors, readErrors} =
[ TestErrors writeErrors' readErrors'
| (writeErrors', readErrors') <- shrink (writeErrors, readErrors)
]
{-------------------------------------------------------------------------------
Snapshot corruption
-------------------------------------------------------------------------------}
testSalt :: Bloom.Salt
testSalt = 4
-- TODO: an alternative to generating a Choice a priori is to run the monadic
-- code in @PropertyM (IOSim s)@, and then we can do quantification inside the
-- monadic property using @pick@. This complicates matters, however, because
-- functions like @withSimHasBlockIO@ and @withTable@ would have to run in
-- @PropertyM (IOSim s)@ as well. It's not clear whether the refactoring is
-- worth it.
prop_flipSnapshotBit ::
Positive (Small Int)
-> V.Vector (Word64, Entry Word64 Word64)
-> Choice -- ^ Used to pick which file/bit to corrupt.
-> Property
prop_flipSnapshotBit (Positive (Small bufferSize)) es pickFileBit =
runSimOrThrow $
withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _fsVar ->
withOpenSession nullTracer hfs hbio testSalt root $ \s ->
withTable s conf $ \t -> do
-- Create a table, populate it, and create a snapshot
updates resolve es' t
createSnap t
-- Corrupt the snapshot
flipRandomBitInRandomFile hfs pickFileBit (getNamedSnapshotDir namedSnapDir) >>= \case
Nothing -> pure $ property False
Just (path, j) -> do
-- Some info for the test output
let tabCorruptedFile = tabulate "Corrupted file" [show path]
counterCorruptedFile = counterexample ("Corrupted file: " ++ show path)
tabFlippedBit = tabulate "Flipped bit" [showPowersOf10 j]
counterFlippedBit = counterexample ("Flipped bit: " ++ show j)
t' <- try @_ @SomeException $ bracket (openSnap s) close $ \_ -> pure ()
pure $
tabCorruptedFile $ counterCorruptedFile $ tabFlippedBit $ counterFlippedBit $
case t' of
-- If we find an error, we detected corruption. Success!
Left e ->
tabulate
"Result"
["Corruption detected: " <> getConstructorName e]
True
-- The corruption was not detected. Failure!
Right _ -> property False
where
root = FS.mkFsPath []
namedSnapDir = namedSnapshotDir (SessionRoot root) snapName
conf = defaultTableConfig {
confWriteBufferAlloc = AllocNumEntries bufferSize
, confFencePointerIndex = CompactIndex
}
es' = fmap (bimap serialiseKey (bimap serialiseValue serialiseBlob)) es
resolve (SerialisedValue x) (SerialisedValue y) =
SerialisedValue (x <> y)
snapName = toSnapshotName "snap"
snapLabel = SnapshotLabel "label"
createSnap t =
saveSnapshot snapName snapLabel t
openSnap s =
openTableFromSnapshot noTableConfigOverride s snapName snapLabel resolve
getConstructorName e = takeWhile (/= ' ') (show e)