{-# OPTIONS_GHC -Wno-orphans #-} module Tahoe.Storage.Testing.Spec ( ShareNumbers (..), SomeShareData (..), makeStorageSpec, genStorageIndex, ) where import Control.Exception (Exception, finally, throwIO, try) import Control.Monad (void, when) import qualified Data.Base32String as Base32 import Data.Bifunctor (Bifunctor (second)) import Data.Bits (Bits (xor)) import qualified Data.ByteString as B import Data.Composition ((.:)) import Data.Function (on) import Data.Interval ( Boundary (Closed, Open), Extended (..), Interval, interval, lowerBound, upperBound, ) import qualified Data.IntervalSet as IS import Data.List (foldl', nubBy) import Data.List.HT (outerProduct) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T import Data.Word (Word8) import Network.HTTP.Types (ByteRange (..), ByteRanges) import Tahoe.Storage.Backend ( AllocateBuckets (AllocateBuckets), AllocationResult (AllocationResult, allocated, alreadyHave), Backend (..), CBORSet (CBORSet), LeaseSecret (Upload), Offset, ReadResult, ReadTestWriteResult (..), ReadTestWriteVectors (..), ReadVector (..), ShareData, ShareNumber (..), Size, StorageIndex, TestOperator (Eq), TestVector (..), TestWriteVectors (..), UploadSecret (..), Version (parameters), Version1Parameters (maximumImmutableShareSize), WriteEnablerSecret (..), WriteImmutableError (..), WriteMutableError (..), WriteVector (..), readv, testv, writev, ) import Test.Hspec (Expectation, HasCallStack, Selector, Spec, context, describe, it, shouldBe, shouldReturn, shouldThrow) import Test.QuickCheck ( Arbitrary (arbitrary, shrink), Gen, NonEmptyList (NonEmpty, getNonEmpty), NonNegative (NonNegative, getNonNegative), Positive (Positive, getPositive), Property, Testable (property), chooseInt, chooseInteger, counterexample, forAll, getSize, ioProperty, label, listOf1, oneof, shuffle, suchThatMap, vector, vectorOf, withMaxSuccess, (==>), ) import Test.QuickCheck.Instances.ByteString () import Test.QuickCheck.Monadic (monadicIO, run) arbNonNeg :: (Arbitrary n, Integral n) => Gen n arbNonNeg = getNonNegative <$> arbitrary newtype ShareNumbers = ShareNumbers {getShareNumbers :: [ShareNumber]} deriving (Eq, Ord, Show) {- | All legal share numbers for all schemes in real-world use. Pre-construct this so that the ShareNumbers Arbitrary instance doesn't have to. -} allShareNums :: [ShareNumber] allShareNums = ShareNumber <$> [0 .. 255] {- | An Arbitrary instance that guarantees ShareNumbers are unique and non-empty (without invoking discard). -} instance Arbitrary ShareNumbers where arbitrary = ShareNumbers <$> nums where nums = take <$> chooseInt (1, 255) <*> shuffle allShareNums shrink (ShareNumbers []) = error "Empty ShareNumbers is not meaningful" shrink (ShareNumbers [_]) = [] shrink (ShareNumbers (_ : xs)) = [ShareNumbers xs] instance Arbitrary ShareNumber where arbitrary = ShareNumber <$> arbNonNeg shrink (ShareNumber 0) = [] shrink (ShareNumber n) = [ShareNumber (n - 1)] instance Arbitrary ReadTestWriteVectors where arbitrary = ReadTestWriteVectors <$> arbitrary <*> arbitrary instance Arbitrary TestWriteVectors where arbitrary = TestWriteVectors <$> arbitrary <*> arbitrary <*> oneof [pure Nothing, Just <$> arbNonNeg] instance Arbitrary TestVector where arbitrary = TestVector <$> arbNonNeg <*> arbNonNeg <*> pure Eq <*> arbitrary instance Arbitrary WriteVector where arbitrary = WriteVector <$> arbNonNeg <*> arbitrary instance Arbitrary ReadVector where arbitrary = ReadVector <$> arbNonNeg <*> (getPositive <$> arbitrary) newtype ArbStorageIndex = ArbStorageIndex StorageIndex deriving newtype (Show) instance Arbitrary ArbStorageIndex where arbitrary = ArbStorageIndex <$> genStorageIndex newtype SomeShareData = SomeShareData {getShareData :: B.ByteString} instance Show SomeShareData where show (SomeShareData bs) = "(SomeShareData length=" <> show (B.length bs) <> ")" -- | Generate some fairly short and some fairly long byte strings. instance Arbitrary SomeShareData where arbitrary = SomeShareData . B.pack <$> oneof [ listOf1 arbitrary , exponentialPositiveInt >>= flip vectorOf arbitrary ] -- Shrink to shorter non-empty bytestrings with distinct lengths. -- Requiring distinct lengths is an optimization. I don't think there's -- any reason two random ByteStrings of the same length would behave -- differently. If I'm wrong, at least this is only the shrinking logic -- so at worst we miss out on a shorter counterexample sometimes. shrink (SomeShareData bs) = fmap SomeShareData . nubBy ((==) `on` B.length) . filter (not . B.null) . shrinkBytes $ bs newtype SmallShareData = SmallShareData {getSmallShareData :: B.ByteString} deriving (Show) -- | Generate some fairly short byte strings. instance Arbitrary SmallShareData where arbitrary = getSize >>= \size -> SmallShareData . B.pack <$> vectorOf size arbitrary shrink (SmallShareData bs) = SmallShareData <$> shrinkBytes bs {- | Shrink B.ByteString more efficiently than QuickCheck-instances can. This implementation should be O(n) in the number of shrinks generated (not the size of the bytestring being shrunk). -} shrinkBytes :: B.ByteString -> [B.ByteString] shrinkBytes bs = [B.take n bs, B.drop n bs] where n = B.length bs `div` 2 exponentialPositiveInt :: Gen Int exponentialPositiveInt = do -- Limit the results to 2 ^ 22 so that allocating a ByteString of this -- length doesn't necessarily consume all available memory... e <- chooseInt (1, 22) chooseInt (2 ^ (e - 1 :: Int), 2 ^ e) b32table :: B.ByteString b32table = "abcdefghijklmnopqrstuvwxyz234567" b32encode :: B.ByteString -> String b32encode = T.unpack . Base32.toText . Base32.fromBytes b32table genStorageIndex :: Gen StorageIndex genStorageIndex = suchThatMap gen10ByteString (Just . b32encode) gen10ByteString :: Gen B.ByteString gen10ByteString = suchThatMap (vectorOf 10 (arbitrary :: Gen Word8)) (Just . B.pack) shouldThrowAndShow :: forall e a. (HasCallStack, Exception e, Show a) => IO a -> Selector e -> Expectation shouldThrowAndShow action selector = do result <- try action :: IO (Either e a) case result of Left exc -> throwIO exc `shouldThrow` selector Right value -> do print $ "Got a value instead of an exception: " <> show value {- | Instantiate property tests for the storage backend specification for a particular backend. -} makeStorageSpec :: Backend b => -- | An action that produces a new, empty backend. IO b -> -- | A function that produces an action to clean up any state that may -- have been created in the given backend. (b -> IO ()) -> -- | A test specification for the backend. Spec makeStorageSpec makeBackend cleanupBackend = do let runBackend = withBackend makeBackend cleanupBackend context "v1" $ do context "immutable" $ do describe "allocate a storage index" $ do it "rejects allocations above the immutable share size limit" $ withMaxSuccess few $ \(ArbStorageIndex storageIndex) (ShareNumbers shareNums) secret (Positive extra) -> do runBackend $ \backend -> do limit <- maximumImmutableShareSize . parameters <$> version backend createImmutableStorageIndex backend storageIndex (Just [Upload (UploadSecret secret)]) (AllocateBuckets shareNums (limit + extra)) `shouldThrow` (== MaximumShareSizeExceeded limit (limit + extra)) it "accounts for all allocated share numbers" $ property $ forAll genStorageIndex (alreadyHavePlusAllocatedImm runBackend) describe "write a share" $ do it "disallows writing an unallocated share" $ withMaxSuccess few $ \(ArbStorageIndex storageIndex) shareNum secret (SmallShareData shareData) -> runBackend $ \backend -> do writeImmutableShare backend storageIndex shareNum (Just [Upload (UploadSecret secret)]) shareData Nothing `shouldThrow` (== ShareNotAllocated) it "disallows writes without an upload secret" $ property $ runBackend $ \backend -> do AllocationResult [] [ShareNumber 0] <- createImmutableStorageIndex backend "storageindex" (Just [anUploadSecret]) (AllocateBuckets [ShareNumber 0] 100) writeImmutableShare backend "storageindex" (ShareNumber 0) Nothing "fooooo" Nothing `shouldThrow` (== MissingUploadSecret) it "disallows writes without a matching upload secret" $ property $ runBackend $ \backend -> do AllocationResult [] [ShareNumber 0] <- createImmutableStorageIndex backend "storageindex" (Just [anUploadSecret]) (AllocateBuckets [ShareNumber 0] 100) -- Supply the wrong secret as an upload secret and the -- right secret marked for some other use - this -- should still fail. writeImmutableShare backend "storageindex" (ShareNumber 0) (Just [Upload (UploadSecret "wrongsecret")]) "fooooo" Nothing `shouldThrow` (== IncorrectUploadSecret) it "returns the share numbers that were written" $ property $ forAll genStorageIndex (immutableWriteAndEnumerateShares runBackend) it "returns the written data when requested" $ property $ forAll genStorageIndex (immutableWriteAndReadShare runBackend) it "cannot be written more than once" $ property $ forAll genStorageIndex (immutableWriteAndRewriteShare runBackend) describe "aborting uploads" $ do it "disallows aborts without an upload secret" $ property $ runBackend $ \backend -> do abortImmutableUpload backend "storageindex" (ShareNumber 0) Nothing `shouldThrow` (== MissingUploadSecret) it "disallows upload completion after a successful abort" $ withMaxSuccess few $ \(ArbStorageIndex storageIndex) shareNum secret (SmallShareData shareData) size -> runBackend $ \backend -> do void $ createImmutableStorageIndex backend storageIndex (Just [Upload (UploadSecret secret)]) (AllocateBuckets [shareNum] size) abortImmutableUpload backend storageIndex shareNum (Just [Upload (UploadSecret secret)]) writeImmutableShare backend storageIndex shareNum (Just [Upload (UploadSecret secret)]) shareData Nothing `shouldThrow` (== ShareNotAllocated) it "disallows aborts without a matching upload secret" $ property $ runBackend $ \backend -> do AllocationResult [] [ShareNumber 0] <- createImmutableStorageIndex backend "storageindex" (Just [anUploadSecret]) (AllocateBuckets [ShareNumber 0] 100) abortImmutableUpload backend "storageindex" (ShareNumber 0) (Just [Upload (UploadSecret "wrongsecret")]) `shouldThrow` (== IncorrectUploadSecret) it "allows aborts with a matching upload secret" $ property $ runBackend $ \backend -> do AllocationResult [] [ShareNumber 0] <- createImmutableStorageIndex backend "storageindex" (Just [anUploadSecret]) (AllocateBuckets [ShareNumber 0] 100) abortImmutableUpload backend "storageindex" (ShareNumber 0) (Just [anUploadSecret]) context "mutable" $ do -- XXX There's lots of problems around supplying negative integer -- values in most places. We avoid tripping over those cases here -- but we should really fix the implementation to deal with them -- sensible. describe "write a share" $ do it "returns the share numbers that were written" $ property $ forAll genStorageIndex (mutableWriteAndEnumerateShares runBackend) it "rejects an update with the wrong write enabler" $ forAll genStorageIndex $ \storageIndex shareNum (secret, wrongSecret) (SmallShareData shareData, SmallShareData junkData) (NonNegative offset) -> (secret /= wrongSecret) && (shareData /= junkData) ==> monadicIO . run . runBackend $ \backend -> do first <- readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret secret) (writev shareNum offset shareData) success first `shouldBe` True readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret wrongSecret) (writev shareNum offset junkData) `shouldThrowAndShow` (== IncorrectWriteEnablerSecret) third <- readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret secret) (readv offset (fromIntegral $ B.length shareData)) readData third `shouldBe` Map.singleton shareNum [shareData] it "returns the written data when requested" $ forAll genStorageIndex (mutableWriteAndReadShare runBackend) it "overwrites older data with newer data" $ -- XXX We go out of our way to generate a legal storage -- index here. Illegal storage indexes aren't checked by -- the system anywhere but they really ought to be. forAll genStorageIndex $ \storageIndex (readVectors :: NonEmptyList ReadVector) secret shareNum -> do let is = readVectorToIntervalSet (getNonEmpty readVectors) sp = IS.span is (lower, upper) = toFiniteBounds sp size = upper - lower bs <- B.pack <$> vector (fromIntegral size) writeVectors <- writesThatResultIn bs lower size pure $ counterexample ("write vectors: " <> show writeVectors) $ ioProperty $ runBackend $ \backend -> do let x = foldMap (\(WriteVector off shareData) -> writev shareNum off shareData) writeVectors writeResult <- readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret secret) x success writeResult `shouldBe` True let y = foldMap (\(ReadVector off sz) -> readv off sz) (getNonEmpty readVectors) readResult <- readvAndTestvAndWritev backend storageIndex (WriteEnablerSecret secret) y Map.map B.concat (readData readResult) `shouldBe` Map.singleton shareNum (B.concat $ extractRead lower bs <$> getNonEmpty readVectors) it "accepts writes for which the test condition succeeds" $ withMaxSuccess few $ \(ArbStorageIndex storageIndex) secret -> runBackend $ \backend -> do runReadTestWrite_ backend storageIndex (WriteEnablerSecret secret) (writev (ShareNumber 0) 0 "abc") runReadTestWrite_ backend storageIndex (WriteEnablerSecret secret) (testv (ShareNumber 0) 0 "abc" <> writev (ShareNumber 0) 0 "xyz") readMutableShare backend storageIndex (ShareNumber 0) Nothing `shouldReturn` "xyz" it "rejects writes for which the test condition fails" $ withMaxSuccess few $ \(ArbStorageIndex storageIndex) secret -> runBackend $ \backend -> do runReadTestWrite_ backend storageIndex (WriteEnablerSecret secret) (writev (ShareNumber 0) 0 "abc") runReadTestWrite backend storageIndex (WriteEnablerSecret secret) (testv (ShareNumber 0) 0 "abd" <> writev (ShareNumber 0) 0 "xyz") `shouldThrow` (\WriteRefused{} -> True) readMutableShare backend storageIndex (ShareNumber 0) Nothing `shouldReturn` "abc" it "retrieves share data from before writes are applied" $ do withMaxSuccess few $ \(ArbStorageIndex storageIndex) secret -> runBackend $ \backend -> do runReadTestWrite_ backend storageIndex (WriteEnablerSecret secret) (writev (ShareNumber 0) 0 "abc") runReadTestWrite backend storageIndex (WriteEnablerSecret secret) (readv 0 3 <> writev (ShareNumber 0) 0 "xyz") `shouldReturn` Map.fromList [(ShareNumber 0, ["abc"])] runReadTestWrite backend storageIndex (WriteEnablerSecret secret) (readv 0 3) `shouldReturn` Map.fromList [(ShareNumber 0, ["xyz"])] alreadyHavePlusAllocatedImm :: Backend b => ((b -> IO ()) -> IO ()) -> -- Execute a function on the backend. StorageIndex -> -- The storage index to use ShareNumbers -> -- The share numbers to allocate Positive Size -> -- The size of each share Property alreadyHavePlusAllocatedImm runBackend storageIndex (ShareNumbers shareNumbers) (Positive size) = monadicIO $ run $ runBackend $ \backend -> do result <- createImmutableStorageIndex backend storageIndex (Just [anUploadSecret]) $ AllocateBuckets shareNumbers size when (alreadyHave result ++ allocated result /= shareNumbers) $ fail ( show (alreadyHave result) ++ " ++ " ++ show (allocated result) ++ " /= " ++ show shareNumbers ) -- The share numbers of immutable share data written to the shares of a given -- storage index can be retrieved. immutableWriteAndEnumerateShares :: Backend b => ((b -> IO ()) -> IO ()) -> -- Execute a function on the backend. StorageIndex -> ShareNumbers -> SmallShareData -> Property immutableWriteAndEnumerateShares runBackend storageIndex (ShareNumbers shareNumbers) (SmallShareData shareSeed) = do let permutedShares = outerProduct permuteShare shareNumbers [SomeShareData shareSeed] allocate = AllocateBuckets shareNumbers (fromIntegral $ B.length shareSeed) forAll (traverse jumbleForUpload permutedShares) $ \shareChunks -> monadicIO $ do run $ runBackend $ \backend -> do void $ createImmutableStorageIndex backend storageIndex uploadSecret allocate let writes = zip shareNumbers (map (second getShareData) <$> shareChunks) writeShares (\sn -> writeImmutableShare backend storageIndex sn uploadSecret) writes readShareNumbers <- getImmutableShareNumbers backend storageIndex when (readShareNumbers /= (CBORSet . Set.fromList $ shareNumbers)) $ fail (show readShareNumbers ++ " /= " ++ show shareNumbers) where uploadSecret = Just [anUploadSecret] jumbleForUpload :: [SomeShareData] -> Gen [(Maybe ByteRanges, SomeShareData)] jumbleForUpload = fmap (map (second SomeShareData)) . shuffle . snd . foldl' step (0, []) . map getShareData where step (size, accum) bs = (size + B.length bs, (Just [ByteRangeFromTo (fromIntegral size) (fromIntegral $ size + B.length bs - 1)], bs) : accum) -- Immutable share data written to the shares of a given storage index can be -- retrieved verbatim and associated with the same share numbers as were -- specified during writing. immutableWriteAndReadShare :: Backend b => ((b -> IO ()) -> IO ()) -> -- Execute a function on the backend. StorageIndex -> ShareNumbers -> NonEmptyList SomeShareData -> Property immutableWriteAndReadShare runBackend storageIndex (ShareNumbers shareNumbers) (NonEmpty shareSeed) = do let permutedShares = outerProduct permuteShare shareNumbers shareSeed size = sum (fromIntegral . B.length . getShareData <$> shareSeed) allocate = AllocateBuckets shareNumbers size label ("Share size: <" <> show (size `div` 1024 + 1) <> " KiB") $ forAll (traverse jumbleForUpload permutedShares) $ \shareChunks -> monadicIO $ do run $ runBackend $ \backend -> do createImmutableStorageIndex backend storageIndex uploadSecret allocate `shouldReturn` AllocationResult{alreadyHave = [], allocated = shareNumbers} let writes = zip shareNumbers (map (second getShareData) <$> shareChunks) writeShares (\sn -> writeImmutableShare backend storageIndex sn uploadSecret) writes readShares' <- mapM (\sn -> readImmutableShare backend storageIndex sn Nothing) shareNumbers when (fmap B.concat (fmap getShareData <$> permutedShares) /= readShares') $ fail (show permutedShares ++ " /= " ++ show readShares') where uploadSecret = Just [anUploadSecret] -- Immutable share data written to the shares of a given storage index cannot -- be rewritten by a subsequent writeImmutableShare operation. immutableWriteAndRewriteShare :: Backend b => ((b -> IO ()) -> IO ()) -> -- Execute a function on the backend. StorageIndex -> ShareNumbers -> SomeShareData -> Property immutableWriteAndRewriteShare runBackend storageIndex (ShareNumbers shareNumbers) shareSeed = monadicIO $ do let size = fromIntegral (B.length (getShareData shareSeed)) allocate = AllocateBuckets shareNumbers size aShareNumber = head shareNumbers aShare = permuteShare aShareNumber shareSeed run $ runBackend $ \backend -> do void $ createImmutableStorageIndex backend storageIndex uploadSecret allocate let write = writeImmutableShare backend storageIndex aShareNumber uploadSecret (getShareData aShare) Nothing write write `shouldThrow` (== ImmutableShareAlreadyWritten) where uploadSecret = Just [anUploadSecret] -- The share numbers of mutable share data written to the shares of a given -- storage index can be retrieved. mutableWriteAndEnumerateShares :: Backend b => ((b -> IO ()) -> IO ()) -> -- Execute a function on the backend. StorageIndex -> ShareNumbers -> SmallShareData -> Property mutableWriteAndEnumerateShares runBackend storageIndex (ShareNumbers shareNumbers) (SmallShareData shareSeed) = monadicIO $ do let permutedShares = flip permuteShare (SomeShareData shareSeed) <$> shareNumbers let nullSecret = WriteEnablerSecret "" run $ runBackend $ \backend -> do readvAndTestvAndWritev backend storageIndex nullSecret (mconcat $ zipWith3 writev shareNumbers [0 ..] (getShareData <$> permutedShares)) `shouldReturn` ReadTestWriteResult{success = True, readData = mempty} (CBORSet readShareNumbers) <- getMutableShareNumbers backend storageIndex when (readShareNumbers /= Set.fromList shareNumbers) $ fail (show readShareNumbers ++ " /= " ++ show shareNumbers) {- | After an arbitrary number of separate writes complete to construct the entire share, any range of the share's bytes can be read. -} mutableWriteAndReadShare :: Backend b => ((b -> IO ()) -> IO ()) -> -- Execute a function on the backend. StorageIndex -> B.ByteString -> MutableWriteExample -> Property mutableWriteAndReadShare runBackend storageIndex secret MutableWriteExample{..} = monadicIO . run . runBackend $ \backend -> do mapM_ (runReadTestWrite_ backend storageIndex (WriteEnablerSecret secret)) (zipWith (writev mweShareNumber) (offsetsFor mweShareData) mweShareData) readMutableShare backend storageIndex mweShareNumber mweReadRange `shouldReturn` shareRange where offsetsFor ranges = scanl (+) 0 $ map (fromIntegral . B.length) ranges shareRange :: ShareData shareRange = case mweReadRange of Nothing -> B.concat mweShareData Just ranges -> B.concat $ readRange (B.concat mweShareData) <$> ranges readRange shareData (ByteRangeFrom start) = B.drop (fromIntegral start) shareData readRange shareData (ByteRangeFromTo start end) = B.take (fromIntegral $ (end - start) + 1) . B.drop (fromIntegral start) $ shareData readRange shareData (ByteRangeSuffix len) = B.drop (B.length shareData - fromIntegral len) shareData withBackend :: Backend b => IO b -> (b -> IO ()) -> (b -> IO ()) -> IO () withBackend b cleanup action = do backend <- b action backend `finally` cleanup backend anUploadSecret :: LeaseSecret anUploadSecret = Upload $ UploadSecret "anuploadsecret" permuteShare :: ShareNumber -> SomeShareData -> SomeShareData permuteShare (ShareNumber number) (SomeShareData xs) = SomeShareData (B.map xor' xs) where xor' :: Word8 -> Word8 xor' = xor $ fromInteger number writeShares :: (ShareNumber -> shareData -> dataRange -> IO ()) -> [(ShareNumber, [(dataRange, shareData)])] -> IO () writeShares _write [] = return () writeShares write ((shareNumber, shareDatav) : rest) = do mapM_ (\(range, bs) -> write shareNumber bs range) shareDatav writeShares write rest readVectorToIntervalSet :: [ReadVector] -> IS.IntervalSet Integer readVectorToIntervalSet rvs = foldr IS.insert IS.empty (f <$> rvs) where f (ReadVector offset size) = interval (Finite offset, Closed) (Finite $ offset + size, Open) toFiniteBounds :: Show r => Interval r -> (r, r) toFiniteBounds i = (lower, upper) where lower = toFinite (lowerBound i) upper = toFinite (upperBound i) toFinite n = case n of Finite r -> r e -> error ("Non-finite bound " <> show e) writesThatResultIn :: ShareData -> Offset -> Size -> Gen [WriteVector] writesThatResultIn "" _ _ = pure [] writesThatResultIn bs offset size = oneof [ -- The whole thing as one write pure [WriteVector offset bs] , -- Or divide and conquer arbitrarily do prefixLen <- chooseInteger (0, fromIntegral $ B.length bs) pfx <- writesThatResultIn (B.take (fromIntegral prefixLen) bs) offset prefixLen sfx <- writesThatResultIn (B.drop (fromIntegral prefixLen) bs) (offset + prefixLen) (size - prefixLen) pure $ pfx <> sfx , -- Or write some other random somewhere in this range first, to -- later be overwritten. (:) <$> (WriteVector <$> chooseInteger (offset, offset + size) <*> (chooseInteger (1, size) >>= bytes)) <*> writesThatResultIn bs offset size ] bytes :: Integer -> Gen B.ByteString bytes len = B.pack <$> vector (fromIntegral len) extractRead :: Integral a => a -> ShareData -> ReadVector -> ShareData extractRead lower bs (ReadVector offset size) = B.take (fromIntegral size) . B.drop (fromIntegral offset - fromIntegral lower) $ bs {- | Define the maximum number of times some "simple" properties will be checked. These are properties where the expectation is that the cardinality of the set of paths through the implementation is very small so the cost of checking hundreds of different inputs is not worth the benefit. -} few :: Int few = 5 data MutableWriteExample = MutableWriteExample { mweShareNumber :: ShareNumber , mweShareData :: [ShareData] , mweReadRange :: Maybe ByteRanges } deriving (Show) instance Arbitrary MutableWriteExample where arbitrary = do mweShareNumber <- arbitrary mweShareData <- listOf1 (B.pack <$> listOf1 arbitrary) mweReadRange <- byteRanges (fromIntegral . sum . fmap B.length $ mweShareData) pure MutableWriteExample{..} -- | ByteRange type lets us use illegal values like -1 but then things go poorly byteRanges :: Integer -> Gen (Maybe [ByteRange]) byteRanges dataSize = oneof [ -- A request for all the bytes. pure Nothing , -- A request for bytes starting from and including some zero-indexed -- position and running to the end of the data. Just . (: []) . ByteRangeFrom <$> chooseInteger (0, dataSize - 1) , -- A request for bytes starting from and including some zero-indexed -- position and running to and including another zero-indexed -- position. Just . (: []) .: fromTo <$> chooseInteger (0, dataSize - 1) <*> chooseInteger (0, dataSize) , -- A request for a certain number of bytes of suffix. Just . (: []) . ByteRangeSuffix <$> chooseInteger (1, dataSize + 1) ] where fromTo a b = ByteRangeFromTo a (a + b) runReadTestWrite :: Backend b => b -> StorageIndex -> WriteEnablerSecret -> ReadTestWriteVectors -> IO ReadResult runReadTestWrite backend storageIndex secret rtw = do result <- readvAndTestvAndWritev backend storageIndex secret rtw if success result then pure (readData result) else throwIO WriteRefused runReadTestWrite_ :: Backend b => b -> StorageIndex -> WriteEnablerSecret -> ReadTestWriteVectors -> IO () runReadTestWrite_ backend storageIndex secret rtw = void $ runReadTestWrite backend storageIndex secret rtw data WriteRefused = WriteRefused deriving (Show, Eq) instance Exception WriteRefused