From ea64dbd4a251a8125d2184407e36d255c8b21c65 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Fri, 20 Dec 2024 14:51:13 +0100 Subject: [PATCH] Test roundtrips of snapshot metadata to disk with FS error injection This test is similar to the roundtrip test we already had, but now we test that the roundtrip holds even if there was a disk exception at some point, in particular during the part where we write metadata files to disk. --- src/Database/LSMTree/Internal/CRC32C.hs | 1 + .../Database/LSMTree/Internal/Snapshot/FS.hs | 117 +++++++++++++++++- 2 files changed, 113 insertions(+), 5 deletions(-) diff --git a/src/Database/LSMTree/Internal/CRC32C.hs b/src/Database/LSMTree/Internal/CRC32C.hs index bb1acbc75..0d2acfaaa 100644 --- a/src/Database/LSMTree/Internal/CRC32C.hs +++ b/src/Database/LSMTree/Internal/CRC32C.hs @@ -38,6 +38,7 @@ module Database.LSMTree.Internal.CRC32C ( -- $checksum-files ChecksumsFile, ChecksumsFileName(..), + ChecksumsFileFormatError (..), readChecksumsFile, writeChecksumsFile, writeChecksumsFile', diff --git a/test/Test/Database/LSMTree/Internal/Snapshot/FS.hs b/test/Test/Database/LSMTree/Internal/Snapshot/FS.hs index 65bc708c8..0fa34580a 100644 --- a/test/Test/Database/LSMTree/Internal/Snapshot/FS.hs +++ b/test/Test/Database/LSMTree/Internal/Snapshot/FS.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MagicHash #-} + {-# OPTIONS_GHC -Wno-orphans #-} -- | Tests for snapshots and their interaction with the file system @@ -5,21 +7,34 @@ -- TODO: add fault injection tests using fs-sim module Test.Database.LSMTree.Internal.Snapshot.FS (tests) where +import Codec.CBOR.Read (DeserialiseFailure) +import Control.Exception +import Database.LSMTree.Internal.CRC32C +import Database.LSMTree.Internal.Run import Database.LSMTree.Internal.Snapshot import Database.LSMTree.Internal.Snapshot.Codec -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.Tasty -import Test.Tasty.QuickCheck +import Test.Tasty.QuickCheck as QC import Test.Util.FS tests :: TestTree tests = testGroup "Test.Database.LSMTree.Internal.Snapshot.FS" [ - testProperty "prop_fsRoundtripSnapshotMetaData" + testProperty "prop_fsRoundtripSnapshotMetaData" $ prop_fsRoundtripSnapshotMetaData + , testProperty "prop_fault_fsRoundtripSnapshotMetaData" + prop_fault_fsRoundtripSnapshotMetaData ] -- | @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 $ @@ -30,5 +45,97 @@ prop_fsRoundtripSnapshotMetaData metaData = Left e -> counterexample (show e) False Right metaData' -> metaData === metaData' where - contentPath = FS.mkFsPath ["content"] - checksumPath = FS.mkFsPath ["checksum"] + contentPath = mkFsPath ["content"] + checksumPath = mkFsPath ["checksum"] + +-- | @readFileSnapshotMetaData . writeFileSnapshotMetaData = id@, even if +-- exceptions happened. +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 (Right metadata') -> metadata === metadata' + _ -> property True + + pure $ + -- TODO: there are some scenarios that we never hit, like deserialise + -- failures. We should tweak the error(stream) generator distribution to + -- hit these cases. One neat idea would be to "prime" the arbitrary + -- instance: + -- + -- 1. run the property without errors, but count how often each + -- primitive is entered + -- 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 (Either DeserialiseFailure SnapshotMetaData) + -> String + mkLabel writeResult readResult = + "(" <> mkLabelWriteResult writeResult <> + ", " <> mkLabelReadResult readResult <> + ")" + + mkLabelWriteResult :: Either FsError () -> String + mkLabelWriteResult = \case + Left FsError{} -> "Left FSError" + Right () -> "Right ()" + + mkLabelReadResult :: + Either SomeException (Either DeserialiseFailure SnapshotMetaData) + -> String + mkLabelReadResult = \case + Left e + | Just FsError{} <- fromException e -> + "Left FSError" + | Just FileFormatError{} <- fromException e -> + "Left FileFormatError" + | Just ChecksumsFileFormatError{} <- fromException e -> + "Left ChecksumsFileFormatError" + | otherwise -> + error ("impossible: " <> show e) + Right (Left (_ :: DeserialiseFailure)) -> + "Right (Left DeserialiseFailure)" + Right (Right (_ :: SnapshotMetaData)) -> + "Right (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) + ]