diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/src/Tahoe/Storage/Testing/Spec.hs b/src/Tahoe/Storage/Testing/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/Storage/Testing/Spec.hs @@ -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 diff --git a/tahoe-great-black-swamp-testing.cabal b/tahoe-great-black-swamp-testing.cabal new file mode 100644 --- /dev/null +++ b/tahoe-great-black-swamp-testing.cabal @@ -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