refactor(issue558): extract flipRandomBitInRandomFile from prop_flipSnapshotBit

Author: wenkokke

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,14 +161,6 @@ 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
 -- code in @PropertyM (IOSim s)@, and then we can do quantification inside the
 -- monadic property using @pick@. This complicates matters, however, because
@@ -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

test/Test/Util/FS.hs

@@ -30,6 +30,7 @@ module Test.Util.FS (
   , listDirectoryRecursive
   , listDirectoryRecursiveFiles
     -- * Corruption
+  , flipRandomBitInRandomFile
   , flipFileBit
   , hFlipBit
     -- * Errors
@@ -56,14 +57,16 @@ import           Control.Monad.IOSim (runSimOrThrow)
 import           Control.Monad.Primitive (PrimMonad)
 import           Data.Bit (MVector (..), flipBit)
 import           Data.Char (isAscii, isDigit, isLetter)
-import           Data.Foldable (foldlM)
+import           Data.Foldable (Foldable (..), foldlM)
 import           Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
 import           Data.Primitive.ByteArray (newPinnedByteArray, setByteArray)
 import           Data.Primitive.Types (sizeOf)
 import           Data.Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Text as T
+import           Data.Traversable (for)
+import           Data.Word (Word64)
 import           GHC.Stack
 import           System.FS.API as FS
 import           System.FS.BlockIO.API
@@ -79,6 +82,7 @@ import           System.FS.Sim.Stream (InternalInfo (..), Stream (..))
 import           System.IO.Temp
 import           Test.QuickCheck
 import           Test.QuickCheck.Instances ()
+import           Test.Util.QC (Choice, getChoice)
 import           Text.Printf
 
 {-------------------------------------------------------------------------------
@@ -347,6 +351,43 @@ listDirectoryFiles hfs = go Set.empty
   Corruption
 -------------------------------------------------------------------------------}
 
+-- | Flip a random bit in a random file in a given directory.
+flipRandomBitInRandomFile ::
+     (PrimMonad m, MonadThrow m)
+  => HasFS m h
+  -> Choice
+  -> FsPath
+  -> m (Maybe (FsPath, Int))
+flipRandomBitInRandomFile hfs bitChoice dir = do
+  -- List all files and their sizes
+  files <- fmap (dir </>) . toList <$> listDirectoryRecursiveFiles hfs dir
+  -- Handle the situation where there are no files
+  if null files then pure Nothing else do
+    filesAndFileSizeBits <-
+      for files $ \file -> do
+        fileSizeBytes <- withFile hfs file ReadMode (hGetSize hfs)
+        pure (file, fileSizeBytes * 8)
+    let totalFileSizeBits = sum (snd <$> filesAndFileSizeBits)
+    -- Handle the situation where there are no non-empty files
+    if totalFileSizeBits == 0 then pure Nothing else do
+      assert (totalFileSizeBits > 0) $ pure ()
+      -- Interpret `index` to point to a bit between `0` and `totalFileSize - 1`
+      let bitIndex = getChoice bitChoice (0, totalFileSizeBits - 1)
+      -- Flip the bit
+      Just <$> flipFileBitAt hfs bitIndex filesAndFileSizeBits
+
+-- | Internal helper: flip a single bit in a given list of files and sizes.
+flipFileBitAt :: (MonadThrow m, PrimMonad m) => HasFS m h -> Word64 -> [(FsPath, Word64)] -> m (FsPath, Int)
+flipFileBitAt _hfs bitIndex [] =
+  error $ printf "flipFileBitAt: bit index out of bounds (%d)" bitIndex
+flipFileBitAt hfs bitIndex ((file, fileSize) : filesAndSizes)
+  | bitIndex < fileSize = do
+    let bitIndexAsInt = fromIntegral bitIndex
+    flipFileBit hfs file bitIndexAsInt
+    pure (file, bitIndexAsInt)
+  | otherwise = do
+    flipFileBitAt hfs (bitIndex - fileSize) filesAndSizes
+
 -- | Flip a single bit in the given file.
 flipFileBit :: (MonadThrow m, PrimMonad m) => HasFS m h -> FsPath -> Int -> m ()
 flipFileBit hfs p bitOffset =

test/Test/Util/QC.hs

@@ -2,12 +2,15 @@ module Test.Util.QC (
     testClassLaws
   , testClassLawsWith
   , Proxy (..)
+  , Choice
+  , getChoice
   ) where
 
 import           Data.Proxy (Proxy (..))
+import           Data.Word (Word64)
 import           Test.QuickCheck.Classes (Laws (..))
 import           Test.Tasty (TestTree, testGroup)
-import           Test.Tasty.QuickCheck (Property, testProperty)
+import           Test.Tasty.QuickCheck (Property, Arbitrary (..), testProperty)
 
 testClassLaws :: String -> Laws -> TestTree
 testClassLaws typename laws = testClassLawsWith typename laws testProperty
@@ -22,3 +25,16 @@ testClassLawsWith typename Laws {lawsTypeclass, lawsProperties} k =
     | (name, prop) <- lawsProperties ]
 
 
+-- | A 'Choice' of a uniform random number in a range where shrinking picks smaller numbers.
+newtype Choice = Choice Word64
+  deriving stock (Show, Eq)
+  deriving newtype (Arbitrary)
+
+getChoice :: (Integral a) => Choice -> (a, a) -> a
+getChoice (Choice n) (l, u) = fromIntegral (((ni * (ui - li)) `div` mi) + li)
+  where
+    ni = toInteger n
+    li = toInteger l
+    ui = toInteger u
+    mi = toInteger (maxBound :: Word64)
+