tahoe-great-black-swamp-testing (empty) → 0.5.0.0
raw patch · 4 files changed
+951/−0 lines, 4 filesdep +QuickCheckdep +basedep +base32string
Dependencies added: QuickCheck, base, base32string, bytestring, composition, containers, data-interval, hspec, hspec-expectations, http-types, quickcheck-classes, quickcheck-instances, tahoe-great-black-swamp-types, text, utility-ht
Files
- CHANGELOG.md +5/−0
- LICENSE +202/−0
- src/Tahoe/Storage/Testing/Spec.hs +635/−0
- tahoe-great-black-swamp-testing.cabal +109/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for tahoe-great-black-swamp-testing++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ src/Tahoe/Storage/Testing/Spec.hs view
@@ -0,0 +1,635 @@+{-# 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
+ tahoe-great-black-swamp-testing.cabal view
@@ -0,0 +1,109 @@+cabal-version: 2.4++-- The cabal-version field refers to the version of the .cabal specification,+-- and can be different from the cabal-install (the tool) version and the+-- Cabal (the library) version you are using. As such, the Cabal (the library)+-- version used must be equal or greater than the version stated in this field.+-- Starting from the specification version 2.2, the cabal-version field must be+-- the first thing in the cabal file.++-- Initial package description 'tahoe-great-black-swamp-testing' generated by+-- 'cabal init'. For further documentation, see:+-- http://haskell.org/cabal/users-guide/+--+-- The name of the package.+name: tahoe-great-black-swamp-testing++-- The package version.+-- See the Haskell package versioning policy (PVP) for standards+-- guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.5.0.0++-- A short (one-line) description of the package.+synopsis: An HSpec for Great Black Swamp storage backends++-- A longer description of the package.+description:+ A library for creating test-suites for Tahoe-LAFS Great Black Swamp backend implementations++-- URL for the project homepage or repository.+homepage:+ https://gitlab.com/tahoe-lafs/tahoe-great-black-swamp-testing++-- The license under which the package is released.+license: Apache-2.0++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Jean-Paul Calderone++-- An email address to which users can send suggestions, bug reports, and patches.+maintainer: exarkun@twistedmatrix.com++-- A copyright notice.+-- copyright:+category: Testing+build-type: Simple++-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.+extra-doc-files: CHANGELOG.md++-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files:++source-repository head+ type: git+ location:+ git@gitlab.com:tahoe-lafs/tahoe-great-black-swamp-testing.git++common warnings+ ghc-options: -Wall++library+ -- Import common warning flags.+ import: warnings++ -- Modules exported by the library.+ exposed-modules: Tahoe.Storage.Testing.Spec++ -- Modules included in this library but not exported.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ -- Other library packages from which modules are imported.+ build-depends:+ , base ^>=4.14.3.0+ , base32string >=0.9.1 && <0.10+ , bytestring >=0.10.8.2 && <0.11+ , composition >=1.0 && <1.1+ , containers >=0.6.0.1 && <0.7+ , data-interval >=2.0.1 && <2.2+ , hspec <2.12+ , hspec-expectations <0.9+ , http-types >=0.12.3 && <0.13+ , QuickCheck <2.15+ , quickcheck-classes >=0.6 && <0.7+ , quickcheck-instances <0.4+ , tahoe-great-black-swamp-types >=0.5 && <0.6+ , text >=1.2.3.1 && <1.3+ , utility-ht >=0.0 && <0.1++ -- Directories containing source files.+ hs-source-dirs: src++ -- Base language which the package is written in.+ default-language: Haskell2010+ default-extensions:+ DerivingStrategies+ GeneralizedNewtypeDeriving+ OverloadedStrings+ RecordWildCards+ ScopedTypeVariables