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

@@ -38,6 +38,7 @@ module Database.LSMTree.Internal.CRC32C (
   -- $checksum-files
   ChecksumsFile,
   ChecksumsFileName(..),
+  ChecksumsFileFormatError (..),
   readChecksumsFile,
   writeChecksumsFile,
   writeChecksumsFile',

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

@@ -1,25 +1,40 @@
+{-# LANGUAGE MagicHash #-}
+
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 -- | Tests for snapshots and their interaction with the file system
 --
 -- 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)
+      ]