Merge pull request #564 from IntersectMBO/wenkokke/issue558

feat(issue558): test silent snapshot corruption

Author: wenkokke

src-control/Control/ActionRegistry.hs

@@ -25,6 +25,7 @@ module Control.ActionRegistry (
   , CommitActionRegistryError (..)
   , AbortActionRegistryError (..)
   , AbortActionRegistryReason (..)
+  , getReasonExitCaseException
     -- * Registering actions #registeringActions#
     -- $registering-actions
   , withRollback
@@ -372,6 +373,11 @@ data AbortActionRegistryReason =
   | ReasonExitCaseAbort
   deriving stock Show
 
+getReasonExitCaseException :: AbortActionRegistryReason -> Maybe SomeException
+getReasonExitCaseException = \case
+  ReasonExitCaseException e -> Just e
+  ReasonExitCaseAbort -> Nothing
+
 data AbortActionRegistryError =
     AbortActionRegistryError AbortActionRegistryReason (NonEmpty ActionError)
   deriving stock Show

test/Database/LSMTree/Class.hs

@@ -14,6 +14,7 @@ module Database.LSMTree.Class (
   , module Types
   ) where
 
+import           Control.Monad (void)
 import           Control.Monad.Class.MonadThrow (MonadThrow (..))
 import           Data.Kind (Constraint, Type)
 import           Data.List.NonEmpty (NonEmpty)
@@ -24,6 +25,11 @@ import           Database.LSMTree as Types (LookupResult (..), QueryResult (..),
                      resolveDeserialised)
 import qualified Database.LSMTree as R
 import           Database.LSMTree.Class.Common as Common
+import qualified Database.LSMTree.Internal as RI (SessionEnv (..), Table (..),
+                     Table' (..), withOpenSession)
+import qualified Database.LSMTree.Internal.Paths as RIP
+import           Test.Util.FS (flipRandomBitInRandomFileHardlinkSafe)
+import           Test.Util.QC (Choice)
 
 -- | Class abstracting over table operations.
 --
@@ -140,6 +146,14 @@ class (IsSession (Session h)) => IsTable h where
         -> h m k v b
         -> m ()
 
+    corruptSnapshot ::
+           ( IOLike m
+           )
+        => Choice
+        -> SnapshotName
+        -> h m k v b
+        -> m ()
+
     openSnapshot ::
            ( IOLike m
            , C k v b
@@ -222,6 +236,21 @@ withCursor offset tbl = bracket (newCursor offset tbl) (closeCursor (Proxy @h))
   Real instance
 -------------------------------------------------------------------------------}
 
+-- | Snapshot corruption for the real instance.
+--   Implemented here, instead of as part of the public API.
+rCorruptSnapshot ::
+      IOLike m
+   => Choice
+   -> SnapshotName
+   -> R.Table m k v b
+   -> m ()
+rCorruptSnapshot choice name (RI.Table' t) =
+   RI.withOpenSession (RI.tableSession t) $ \seshEnv ->
+      let hfs = RI.sessionHasFS seshEnv
+          root = RI.sessionRoot seshEnv
+          namedSnapDir = RIP.getNamedSnapshotDir (RIP.namedSnapshotDir root name)
+       in void $ flipRandomBitInRandomFileHardlinkSafe hfs choice namedSnapDir
+
 instance IsTable R.Table where
     type Session R.Table = R.Session
     type TableConfig R.Table = R.TableConfig
@@ -244,6 +273,7 @@ instance IsTable R.Table where
     readCursor _ = R.readCursor
 
     createSnapshot = R.createSnapshot
+    corruptSnapshot = rCorruptSnapshot
     openSnapshot sesh snap = R.openSnapshot sesh R.configNoOverride snap
 
     duplicate = R.duplicate

test/Database/LSMTree/Model/IO.hs

@@ -85,6 +85,7 @@ instance Class.IsTable Table where
       runInOpenSession s (Model.readCursor x1 c)
 
     createSnapshot x1 x2 (Table s t) = runInOpenSession s (Model.createSnapshot x1 x2 t)
+    corruptSnapshot _ x (Table s _t) = runInOpenSession s (Model.corruptSnapshot x)
     openSnapshot s x1 x2 = Table s <$> runInOpenSession s (Model.openSnapshot x1 x2)
 
     duplicate (Table s t) = Table s <$> runInOpenSession s (Model.duplicate t)

test/Database/LSMTree/Model/Session.hs

@@ -32,7 +32,7 @@ module Database.LSMTree.Model.Session (
   , runModelM
   , runModelMWithInjectedErrors
     -- ** Errors
-  , Err (.., DefaultErrDiskFault)
+  , Err (.., DefaultErrDiskFault, DefaultErrSnapshotCorrupted)
     -- * Tables
   , Table
   , TableConfig (..)
@@ -241,19 +241,23 @@ runModelMWithInjectedErrors (Just _) _ onErrors st =
 pattern DefaultErrDiskFault :: Err
 pattern DefaultErrDiskFault = ErrDiskFault "default"
 
+-- | The default 'ErrSnapshotCorrupted' that model operations will throw.
+pattern DefaultErrSnapshotCorrupted :: Err
+pattern DefaultErrSnapshotCorrupted = ErrSnapshotCorrupted "default"
+
 --
 -- Errors
 --
 
 data Err =
     ErrTableClosed
-  | ErrSnapshotCorrupted
   | ErrSnapshotExists
   | ErrSnapshotDoesNotExist
   | ErrSnapshotWrongType
   | ErrBlobRefInvalidated
   | ErrCursorClosed
     -- | Something went wrong with the file system.
+  | ErrSnapshotCorrupted String
   | ErrDiskFault String
   | ErrOther String
   deriving stock Eq
@@ -262,8 +266,6 @@ instance Show Err where
   showsPrec d = \case
       ErrTableClosed ->
         showString "ErrTableClosed"
-      ErrSnapshotCorrupted ->
-        showString "ErrSnapshotCorrupted"
       ErrSnapshotExists ->
         showString "ErrSnapshotExists"
       ErrSnapshotDoesNotExist ->
@@ -274,6 +276,10 @@ instance Show Err where
         showString "ErrBlobRefInvalidated"
       ErrCursorClosed ->
         showString "ErrCursorClosed"
+      ErrSnapshotCorrupted s ->
+        showParen (d > appPrec) $
+        showString "ErrSnapshotCorrupted " .
+        showParen True (showString s)
       ErrDiskFault s ->
         showParen (d > appPrec) $
         showString "ErrDiskFault " .
@@ -577,7 +583,7 @@ openSnapshot label name = do
         throwError ErrSnapshotDoesNotExist
       Just (Snapshot conf label' tbl corrupted) -> do
         when corrupted $
-          throwError ErrSnapshotCorrupted
+          throwError DefaultErrSnapshotCorrupted
         when (label /= label') $
           throwError ErrSnapshotWrongType
         case fromSomeTable tbl of
@@ -592,6 +598,9 @@ openSnapshot label name = do
           Just table' ->
             newTableWith conf table'
 
+-- To match the implementation of the real table, this should not corrupt the
+-- snapshot if there are _no non-empty files_; however, since there are no such
+-- snapshots, this is probably fine.
 corruptSnapshot ::
      (MonadState Model m, MonadError Err m)
   => SnapshotName

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

@@ -9,7 +9,6 @@ import           Control.Monad.IOSim (runSimOrThrow)
 import           Control.Tracer
 import           Data.Bifunctor (Bifunctor (..))
 import           Data.Maybe (fromJust)
-import qualified Data.Set as Set
 import qualified Data.Vector as V
 import           Data.Word
 import           Database.LSMTree.Extras (showPowersOf10)
@@ -28,10 +27,10 @@ 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.QuickCheck.Gen (genDouble)
 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" [
@@ -162,15 +161,7 @@ instance Arbitrary TestErrors where
   Snapshot corruption
 -------------------------------------------------------------------------------}
 
--- | A 'Double' in the @[0, 1)@ range.
-newtype Double_0_1 = Double_0_1 Double
-  deriving stock (Show, Eq)
-
-instance Arbitrary Double_0_1 where
-  arbitrary = Double_0_1 <$> genDouble
-  shrink (Double_0_1 x) = [Double_0_1 x' | x' <- shrink x, 0 <= x', x' < 1]
-
--- TODO: an alternative to generating doubles a priori is to run the monadic
+-- 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
@@ -179,14 +170,9 @@ instance Arbitrary Double_0_1 where
 prop_flipSnapshotBit ::
      Positive (Small Int)
   -> V.Vector (Word64, Entry Word64 Word64)
-  -> Double_0_1 -- ^ Used to pick which file to corrupt
-  -> Double_0_1 -- ^ Used to pick which bit to flip in the file we picked
+  -> Choice -- ^ Used to pick which file/bit to corrupt.
   -> Property
-prop_flipSnapshotBit
-  (Positive (Small bufferSize))
-  es
-  (Double_0_1 pickFile)
-  (Double_0_1 pickBit) =
+prop_flipSnapshotBit (Positive (Small bufferSize)) es pickFileBit =
     runSimOrThrow $
     withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _fsVar ->
     withSession nullTracer hfs hbio root $ \s ->
@@ -195,42 +181,28 @@ prop_flipSnapshotBit
       updates resolve es' t
       createSnap t
 
-      -- Pick a random file from the named snapshot directory
-      files <- listDirectoryRecursiveFiles hfs (getNamedSnapshotDir namedSnapDir)
-      let i = round (fromIntegral (Set.size files - 1) * pickFile)
-      let file = Set.elemAt i files
-      let path = getNamedSnapshotDir namedSnapDir </> file
-      -- Pick a random bit from the file that we want to corrupt
-      n <- withFile hfs path ReadMode $ hGetSize hfs
-      let j = round (fromIntegral (n * 8 - 1) * pickBit)
-
-      -- 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)
-
-      -- TODO: check forgotten refs
-      if n <= 0 then -- file is empty
-        pure $ tabulate "Result" ["No corruption applied"] True
-      else do -- file is non-empty
-
-        -- Flip a bit and try to open the snapshot
-        flipFileBit hfs path 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
+      -- 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