diff --git a/ChangeLog.md b/ChangeLog.md index d700ba5c4b04035a73eaeaf5f4332ce53a394fa6..7a8e5ec6df60bdd4d257c1ccbfc185177e35f6cb 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -14,6 +14,10 @@ error instead of performing decoding if there are not enough consistent blocks to complete decoding. (#20) +* `decode` now checks the consistency of the ciphertext "segments" and signals + an error instead of completing decoding if the segment hashes do not match + the expected values. (#21) + * Many changes to data types to reflect more of the scheme at the type level. Most of these changes are to (exposed) implementation details rather than the primary high-level interface and should not impact most applications. diff --git a/README.md b/README.md index 0533eff9b36fe03cb86452ff96eb8a38da274974..3ee2e073e9be1e5043d1a838a69c53cc5b1531ae 100644 --- a/README.md +++ b/README.md @@ -14,7 +14,9 @@ However, its APIs are intended to be easy to integrate with such an implementati * CHK encoding is implemented but some cases are unsupported: * It is not allowed that k == 1 or k == n. * CHK decoding is implemented with the same limitations as for encoding. - * Some but *not* all authenticity checks are performed during decoding. + * The decoding process: + * Authenticates the data being decoded using the capability. + * Ensures the integrity of the data being decoded using the embedded hashes. ## Why does it exist? diff --git a/src/Tahoe/CHK.hs b/src/Tahoe/CHK.hs index edb85f20e93d6707bb00f3e4198560b2db2b620a..434f0dee9104a9a579111673128ec2529bea0be1 100644 --- a/src/Tahoe/CHK.hs +++ b/src/Tahoe/CHK.hs @@ -72,7 +72,7 @@ module Tahoe.CHK ( import qualified Codec.FEC as ZFEC import Control.Applicative (Alternative (empty)) -import Control.Lens (view, _2) +import Control.Lens (view) import Crypto.Cipher.AES128 ( AESKey128, ) @@ -109,7 +109,7 @@ import Tahoe.CHK.Merkle ( rootHash, ) import Tahoe.CHK.SHA256d (Digest' (Digest'), zero) -import Tahoe.CHK.Share (Share (..), uriExtension) +import Tahoe.CHK.Share (Share (..), crypttextHashTree, uriExtension) import Tahoe.CHK.Types ( BlockHash, CrypttextHash, @@ -122,7 +122,14 @@ import Tahoe.CHK.URIExtension ( URIExtension (..), codecParams, ) -import Tahoe.CHK.Validate (matchingBlockHashRoot, shareValidBlocks, validFingerprint, validShareRootHash) +import Tahoe.CHK.Validate ( + matchingBlockHashRoot, + matchingCrypttextHashRoot, + shareValidBlocks, + validFingerprint, + validSegments, + validShareRootHash, + ) import Tahoe.Netstring ( netstring, ) @@ -327,9 +334,6 @@ encode readKey initParams@(Parameters maximumSegmentSize total _ required) ciphe -- And make every node all nul. $ zero - -- The merkle tree of ciphertext segment hashes. - crypttextHashTree = makeTreePartial cpCrypttextHashes - -- shareTree is a MerkleTree of MerkleTree shareTree = -- trace ("shareTree: " <> show shareTree') @@ -368,7 +372,7 @@ encode readKey initParams@(Parameters maximumSegmentSize total _ required) ciphe , _dataSize = fromIntegral $ LB.length ciphertext `ceilDiv` fromIntegral required , _blocks = blocks , _plaintextHashTree = plaintextHashTree - , _crypttextHashTree = crypttextHashTree + , _crypttextHashTree = makeTreePartial cpCrypttextHashes , _blockHashTree = makeTreePartial blockHashes , _neededHashes = sort . fmap (first fromIntegral) $ computeNeededHashes shareTree sharenum , _uriExtension = uriExt @@ -409,6 +413,8 @@ data DecodeError } | -- | The hash of one or more blocks did not match the expected value. BlockHashError + | -- | The hash of one or more ciphertext segments did not match the expected value. + CiphertextHashError deriving (Eq, Ord, Show) {- | Decode some CHK shares to recover some application data. This is roughly @@ -477,11 +483,29 @@ decode reader shares -- bytes in the result. By knowing how many bytes were originally -- in our segments, we can recognize and discard these extra -- bytes. - segSize = fromIntegral . paramSegmentSize . view (_2 . uriExtension . codecParams) $ head shares + segSize = paramSegmentSize . view (uriExtension . codecParams) $ anyValidShare + + -- The final segment might be short. Find out. Note we don't + -- read the segment size from the tail codec params in the + -- URIExtension because that *includes* padding and we're trying + -- to *exclude* padding. Instead we compute the result from the + -- real application data size and the non-tail segment size. + tailSegSize = case size reader `mod` segSize of + 0 -> segSize + n -> n -- A helper that knows the correct parameters to do ZFEC decoding -- for us. - zunfec' = (LB.take segSize <$>) . zunfecLazy (fromIntegral (required reader)) (fromIntegral (total reader)) + -- + -- XXX Do we need this LB.take at the front? Shouldn't each block + -- be segSize bytes in length anyway (disregarding the tail + -- segment, which we're not doing anything to handle here anyway)? + -- We chunked the bytes up in to blocks, we know how big they are. + -- But we chunked them based on `_blockSize` from the share, not + -- `segSize` from the codec params. Perhaps if we validated those + -- are consistent then we could be confident of consistency here + -- w/o the LB.take. + zunfec' = (LB.take (fromIntegral segSize) <$>) . zunfecLazy (fromIntegral (required reader)) (fromIntegral (total reader)) -- Get ready to decode the groups of blocks back to the original -- segments, where this is possible. We might have even more than @@ -493,25 +517,41 @@ decode reader shares -- Actually do it maybeSegments <- traverse sequence getSegments :: IO [Maybe LB.ByteString] - -- This function produces a monolithic result - everything or nothing. - -- So change the structure from "results and errors for individual - -- blocks" to "a result or an error from somewhere". A function with - -- an incremental result interface could consider just completing with - -- `segments` from above. Or perhaps further transforming it to - -- - -- (Traversable t, Functor f) => t (IO (f LB.ByteString)) - case sequence maybeSegments of - Nothing -> pure . Left $ BlockHashError - Just segments -> - -- Combine the segments and perform one more truncation to get the - -- complete result. Above where we computed segSize we weren't - -- careful to find the tail segment size for use with the tail segment - -- so there might still be some extra bytes in the `segments` list - -- here. This additional truncation addresses that. - pure . Right . LB.take (fromIntegral (size reader)) . LB.concat $ segments + pure $ do + -- This function produces a monolithic result - everything or nothing. + -- So change the structure from "results and errors for individual + -- blocks" to "a result or an error from somewhere". A function with + -- an incremental result interface could consider just completing with + -- `segments` from above. Or perhaps further transforming it to + -- + -- (Traversable t, Functor f) => t (IO (f LB.ByteString)) + segments <- maybe (Left BlockHashError) Right (sequence maybeSegments) + + -- Now check the validity of the segments themselves against the + -- crypttext hash tree. + let maybeValidSegments = + validSegments + (leafHashes $ view crypttextHashTree anyValidShare) + -- Take care to validate the tail segment *without* padding. + (LB.toStrict <$> trimTailSegment (fromIntegral tailSegSize) segments) + + maybe + -- Signal overall failure if any segments were excluded by the previous step. + (Left CiphertextHashError) + -- Combine the segments to produce the complete result if they all check out. + (Right . LB.concat . (LB.fromStrict <$>)) + -- Get rid of any segments which do not agree with the hashes + -- in the crypttext hash tree. + (sequence maybeValidSegments) where -- Separate the shares into those we can use and those we cannot. - (validShares, invalidShares) = partitionShares (view Cap.verifier reader) shares + -- + -- Make the list pattern match lazy (with `~`) in case there are *no* + -- valid shares. The guard above will check if there are any valid shares + -- before we need to match that part of the pattern. This lets us bind a + -- name to some valid share which is helpful inside the body of the guard + -- where we need to read some value that is shared across all shares. + (validShares@(~((_, anyValidShare) : _)), invalidShares) = partitionShares (view Cap.verifier reader) shares -- Project the share number out across all of that share's blocks. The -- result is something we can transpose into the correct form for ZFEC @@ -523,6 +563,16 @@ decode reader shares required = view (Cap.verifier . Cap.required) total = view (Cap.verifier . Cap.total) + -- Return a list like the one given except that the last element is + -- shortened to the given length. + trimTailSegment :: Int64 -> [LB.ByteString] -> [LB.ByteString] + trimTailSegment segSize = mapLast (LB.take segSize) + + -- Apply a function to the last element of a list, if there is one. + mapLast _ [] = [] + mapLast f [x] = [f x] + mapLast f (x : xs) = x : mapLast f xs + -- | Give a reason a share is considered invalid. data InvalidShare = -- | The fingerprint in the capability does not match the fingerprint of the share. @@ -534,6 +584,10 @@ data InvalidShare -- with the root hash constructed from the "block hash tree" roots in -- the share's "needed shares" value. ShareRootHashInvalid + | -- | The "crypttext root hash" in the share's URIExtension doesn't agree + -- | with the root hash constructed from the "crypttext hash tree" + -- | hashes in the share. + CrypttextHashRootMismatch deriving (Ord, Eq, Show) {- | Split a list of shares into those which pass all of the validation checks @@ -545,6 +599,7 @@ partitionShares verifier shares = , map (`err` FingerprintMismatch) haveInvalidFingerprint ++ map (`err` BlockHashRootMismatch) haveInvalidBlockHashRoot ++ map (`err` ShareRootHashInvalid) haveInvalidShareRootHash + ++ map (`err` CrypttextHashRootMismatch) haveMismatchingCrypttextHashRoot ) where -- Helper to build our error structure @@ -557,10 +612,12 @@ partitionShares verifier shares = -- share's hash in the "needed hashes" merkle proof. (haveValidBlockHashRoot, haveInvalidBlockHashRoot) = partition (uncurry matchingBlockHashRoot) haveValidFingerprint + (haveMatchingCrypttextHashRoot, haveMismatchingCrypttextHashRoot) = partition (matchingCrypttextHashRoot . snd) haveValidBlockHashRoot + -- The "needed hashes" merkle proof must be valid with respect to the "share root hash" in the UEB. shareRootValidations = zip (validShareRootHash stillValid) stillValid where - stillValid = haveValidBlockHashRoot + stillValid = haveMatchingCrypttextHashRoot (haveValidShareRootHash, haveInvalidShareRootHash) = bimap (snd <$>) (snd <$>) $ partition fst shareRootValidations validShares = haveValidShareRootHash diff --git a/src/Tahoe/CHK/Share.hs b/src/Tahoe/CHK/Share.hs index 8caef4d1e2ea126d8df0b72b7bb19289b051c82f..f1a443b9c5cb97806113c66ecfb4fd9f1147abfb 100644 --- a/src/Tahoe/CHK/Share.hs +++ b/src/Tahoe/CHK/Share.hs @@ -83,6 +83,9 @@ import Tahoe.CHK.URIExtension ( import Tahoe.Util (chunkedBy, toStrictByteString) import Text.Megaparsec (parse) +-- | A byte string of encrypted data. +type Crypttext = BS.ByteString + -- | Structured representation of a single CHK share. data Share = Share { -- | The ZFEC block size. Legacy value. Unused. @@ -94,7 +97,7 @@ data Share = Share , -- | A merkle tree of plaintext segment hashes. Unimplemented. _plaintextHashTree :: MerkleTree BS.ByteString SHA256d , -- | A merkle tree of ciphertext segment hashes. - _crypttextHashTree :: MerkleTree BS.ByteString SHA256d + _crypttextHashTree :: MerkleTree Crypttext SHA256d , -- | A merkle tree of hashes of `shareBlocks`. _blockHashTree :: MerkleTree BS.ByteString SHA256d , -- | The information needed to complete a merkle proof for this share. diff --git a/src/Tahoe/CHK/Validate.hs b/src/Tahoe/CHK/Validate.hs index a7e3dec2aec442e6b59c2750f42fb9724bb3a452..f4a750c614789fcdabd7211213b77fee3c26c666 100644 --- a/src/Tahoe/CHK/Validate.hs +++ b/src/Tahoe/CHK/Validate.hs @@ -7,11 +7,11 @@ import Crypto.Hash (HashAlgorithm) import Data.Bifunctor (Bifunctor (first)) import qualified Data.ByteString.Lazy as LB import Tahoe.CHK.Capability (Verifier, fingerprint) -import Tahoe.CHK.Crypto (blockHash', uriExtensionHash) +import Tahoe.CHK.Crypto (blockHash', ciphertextSegmentHash', uriExtensionHash) import Tahoe.CHK.Merkle (checkMerkleProof, heightForLeafCount, leafHashes, rootHash) import Tahoe.CHK.SHA256d (Digest', SHA256d) -import Tahoe.CHK.Share (Share (..), blockHashTree, blocks, neededHashes, uriExtension) -import Tahoe.CHK.URIExtension (shareRootHash, totalShares) +import Tahoe.CHK.Share (Crypttext, Share (..), blockHashTree, blocks, crypttextHashTree, neededHashes, uriExtension) +import Tahoe.CHK.URIExtension (crypttextRootHash, shareRootHash, totalShares) {- | Determine the validity of the given share's fingerprint as defined by the given capability. @@ -19,6 +19,15 @@ import Tahoe.CHK.URIExtension (shareRootHash, totalShares) validFingerprint :: Verifier -> Share -> Bool validFingerprint cap = (== view fingerprint cap) . uriExtensionHash . _uriExtension +{- | True if the root of the crypttext hash tree in the share matches the + crypttext hash root given in the URI extension block. False otherwise. +-} +matchingCrypttextHashRoot :: Share -> Bool +matchingCrypttextHashRoot share = inShare == inUEB + where + inShare = rootHash . view crypttextHashTree $ share + inUEB = view (uriExtension . crypttextRootHash) share + {- | True if the share's own hash in the `shareNeededHashes` list equals the root of the share's block hash merkle tree, False otherwise. -} @@ -107,3 +116,15 @@ shareValidBlocks share = checkHash bs expected | blockHash' (LB.toStrict bs) == expected = Just bs | otherwise = Nothing + +{- | Compare the hash of one segment to an expected hash value and return + Nothing if it does not match or Just the segment if it does. +-} +validSegment :: Digest' SHA256d -> Crypttext -> Maybe Crypttext +validSegment expected crypttext + | ciphertextSegmentHash' crypttext == expected = Just crypttext + | otherwise = Nothing + +-- | Apply @validSegment@ to lists of values. +validSegments :: [Digest' SHA256d] -> [Crypttext] -> [Maybe Crypttext] +validSegments = zipWith validSegment diff --git a/test/Generators.hs b/test/Generators.hs index 78bdc83e4704a2a17bb1a851938026aed2a06a61..a9823f666c7cc6521304fe5157cc44d2791979d2 100644 --- a/test/Generators.hs +++ b/test/Generators.hs @@ -16,22 +16,22 @@ import Crypto.Hash.Algorithms ( SHA256 (SHA256), ) import Data.Bifunctor (Bifunctor (first)) -import Data.ByteArray (xor) +import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import Data.ByteString.Base32 (encodeBase32Unpadded) import qualified Data.ByteString.Lazy as LBS import Data.Int (Int64) -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromMaybe) import qualified Data.Text as T import Hedgehog (MonadGen) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Tahoe.CHK.Capability (Reader, fingerprint, verifier) import Tahoe.CHK.Crypto (storageIndexLength) -import Tahoe.CHK.Merkle (MerkleTree, makeTreePartial) -import Tahoe.CHK.SHA256d (Digest' (..), SHA256d, toBytes) +import Tahoe.CHK.Merkle (MerkleTree, leafHashes, makeTreePartial) +import Tahoe.CHK.SHA256d (Digest' (..), SHA256d, zero) import Tahoe.CHK.Server (StorageServerAnnouncement (StorageServerAnnouncement)) -import Tahoe.CHK.Share (Share (..), blocks, neededHashes) +import Tahoe.CHK.Share (Crypttext, Share (..), blocks, crypttextHashTree, neededHashes) import Tahoe.CHK.Types (Parameters (..), Required, ShareNum, StorageIndex, Total) import Tahoe.CHK.URIExtension (URIExtension (URIExtension)) @@ -161,19 +161,21 @@ nonZeroBytes :: MonadGen m => Range.Range Int -> m BS.ByteString nonZeroBytes = Gen.filterT (BS.any (/= 0)) . Gen.bytes -- | Represent ways we know to screw up a capability, share list pair. -data ShareBitFlips +data ShareBitFlips hash = -- | Flip some bits in the fingerprint in the capability. FingerprintBitFlips BS.ByteString | -- | Flip some bits in the "needed hashes" in the shares. ShareTreeLeafBitFlips [[BS.ByteString]] | -- | Flip some bits in some blocks of the shares. BlockBitFlips [[BS.ByteString]] + | -- | Flip some bits in the crypttext hash tree. + CrypttextTreeLeafBitFlips [MerkleTree Crypttext hash] deriving (Show) {- | Generate instructions for flipping some bits in the fingerprint or a verify capability. -} -fingerprintBitFlipper :: MonadGen m => Reader -> m ShareBitFlips +fingerprintBitFlipper :: MonadGen m => Reader -> m (ShareBitFlips hash) fingerprintBitFlipper reader = do FingerprintBitFlips <$> (Gen.bytes . Range.singleton . BS.length) (view (verifier . fingerprint) reader) @@ -182,7 +184,7 @@ conditionally :: (a -> b) -> (a -> b) -> Bool -> a -> b conditionally f g p x = if p then f x else g x -- | Generate instructions for flipping some bits in some blocks. -blockBitFlipper :: forall m. MonadGen m => Parameters -> [Share] -> m ShareBitFlips +blockBitFlipper :: forall m hash. MonadGen m => Parameters -> [Share] -> m (ShareBitFlips hash) blockBitFlipper Parameters{paramRequiredShares, paramTotalShares} shares' = do -- Pick the shares the blocks of which will be modified. whichShares <- enoughModifiedShares paramRequiredShares paramTotalShares @@ -219,27 +221,37 @@ enoughModifiedShares required total = do maxSharesToModify = total -- | Execute the ShareTreeLeafBitFlips instruction on a list of shares. -applyShareBitFlips :: ShareBitFlips -> ([Share], Reader) -> ([Share], Reader) -applyShareBitFlips (FingerprintBitFlips flips) = over (_2 . verifier . fingerprint) (xor flips) +applyShareBitFlips :: ShareBitFlips SHA256d -> ([Share], Reader) -> ([Share], Reader) +applyShareBitFlips (FingerprintBitFlips flips) = over (_2 . verifier . fingerprint) (BA.xor flips) applyShareBitFlips (ShareTreeLeafBitFlips shareFlips) = first (zipWith flipLeaves shareFlips) where flipLeaves :: [BS.ByteString] -> Share -> Share flipLeaves leafFlips share = share{_neededHashes = zipWith flipBits (view neededHashes share) leafFlips} flipBits :: forall hash a. HashAlgorithm hash => (a, Digest' hash) -> BS.ByteString -> (a, Digest' hash) - flipBits (a, x) y = (a, Digest' . fromJust . digestFromByteString @hash $ xor @BS.ByteString @BS.ByteString @BS.ByteString (toBytes x) y) + flipBits (a, x) y = (a, digestFromByteStringPartial $ BA.xor x y) applyShareBitFlips (BlockBitFlips blockFlips) = first (zipWith flipBlocks blockFlips) where flipBlocks :: [BS.ByteString] -> Share -> Share - flipBlocks masks s@Share{_blocks} = s{_blocks = LBS.fromStrict <$> zipWith xor (LBS.toStrict <$> _blocks) masks} - -{- | Generate lists of shares like the one given but with some bits in the - hashes needed to validate the merkle path to each share's "share root - hash" flipped. The generated lists will have the same length as the - input list with fewer than paramRequiredShares elements unmodified so - that they surely cannot be decoded. + flipBlocks masks s@Share{_blocks} = s{_blocks = LBS.fromStrict <$> zipWith BA.xor (LBS.toStrict <$> _blocks) masks} +applyShareBitFlips (CrypttextTreeLeafBitFlips hashFlips) = first (zipWith flipHashes hashFlips) + where + flipHashes :: MerkleTree Crypttext SHA256d -> Share -> Share + flipHashes masks = over crypttextHashTree (makeTreePartial . zipWith flipLeafHashes (leafHashes masks) . leafHashes) + + flipLeafHashes :: forall a. HashAlgorithm a => Digest' a -> Digest' a -> Digest' a + flipLeafHashes mask leaf = + -- Should not fail since we're turning a Digest into bytes and then + -- the same number of bytes back into a Digest, but hard to prove. + digestFromByteStringPartial @a $ BA.xor mask leaf + +{- | Generate instructions for making changes to the given list of shares so + that some bits in the hashes needed to validate the merkle path to each + share's "share root hash" are flipped. The modified list will have the + same length as the input list with fewer than paramRequiredShares + elements unmodified so that they surely cannot be decoded. -} -shareTreeLeafBitFlipper :: MonadGen m => Parameters -> [Share] -> m ShareBitFlips +shareTreeLeafBitFlipper :: MonadGen m => Parameters -> [Share] -> m (ShareBitFlips hash) shareTreeLeafBitFlipper Parameters{paramRequiredShares, paramTotalShares} shares' = do modifyShare <- enoughModifiedShares paramRequiredShares paramTotalShares @@ -272,3 +284,41 @@ shareTreeLeafBitFlipper Parameters{paramRequiredShares, paramTotalShares} shares flips = Gen.bytes $ Range.singleton bytesInMask -- Filter out the mask with no bits set, which would result in no bit flips. nonZeroFlips = Gen.filterT (/= zeroMask) flips + +{- | Generate instructions for making changes to the given list of shares so + that some bits in the "crypttext hash tree" leaves are flipped. The + modified list will have the same length as the input list with fewer than + paramRequiredShares elements unmodified so that they surely cannot be + decoded. +-} +crypttextTreeLeafBitFlipper :: forall m. MonadGen m => Parameters -> [Share] -> m (ShareBitFlips SHA256d) +crypttextTreeLeafBitFlipper Parameters{paramRequiredShares, paramTotalShares} shares' = do + -- Pick the shares the crypttext hash trees of which will be modified. + whichShares <- enoughModifiedShares paramRequiredShares paramTotalShares + + -- Make up some masks to do the block modification. + masks <- zipWithM (conditionally maskForShare (pure . zerosForShare)) whichShares shares' + pure $ CrypttextTreeLeafBitFlips masks + where + -- Replace all the Word8s in the hashes with 0s. + zerosForShare :: Share -> MerkleTree a SHA256d + zerosForShare share = makeTreePartial $ zero <$ leafHashes (view crypttextHashTree share) + + maskForShare :: Share -> m (MerkleTree Crypttext SHA256d) + maskForShare = go . view crypttextHashTree + where + go :: MerkleTree a SHA256d -> m (MerkleTree a SHA256d) + go = fmap makeTreePartial . mapM nonZeroDigest . leafHashes + + nonZeroDigest :: forall a. HashAlgorithm a => Digest' a -> m (Digest' a) + nonZeroDigest _ = digestFromByteStringPartial <$> nonZeroBytes (Range.singleton (hashDigestSize @a undefined)) + +{- | Make a @Digest'@ out of a @BS.ByteString@ of the right length. If the + length is wrong, error. +-} +digestFromByteStringPartial :: HashAlgorithm hash => BS.ByteString -> Digest' hash +digestFromByteStringPartial = + maybe + (error "digestFromByteStringPartial could not construct Digest") + Digest' + . digestFromByteString diff --git a/test/SpecCHK.hs b/test/SpecCHK.hs index 8fa8fe50416bf05dadf26933cd9b98b98e85a3fe..157e32c158f3cb613184e8e01a0ba6d2e60a8549 100644 --- a/test/SpecCHK.hs +++ b/test/SpecCHK.hs @@ -33,6 +33,8 @@ import GHC.Generics (Generic) import Generators ( applyShareBitFlips, blockBitFlipper, + crypttextTreeLeafBitFlipper, + digests, fingerprintBitFlipper, genParameters, shareTreeLeafBitFlipper, @@ -52,7 +54,7 @@ import qualified Hedgehog.Range as Range import Tahoe.CHK (padCiphertext) import qualified Tahoe.CHK (decode, encode, segmentCiphertext) import Tahoe.CHK.Capability (Reader, dangerRealShow, pCapability, pReader, verifier) -import Tahoe.CHK.Crypto (convergenceSecretLength) +import Tahoe.CHK.Crypto (ciphertextSegmentHash', convergenceSecretLength) import Tahoe.CHK.Encrypt (encrypt) import Tahoe.CHK.Share ( Share ( @@ -72,7 +74,12 @@ import Tahoe.CHK.Upload ( memoryUploadableWithConvergence, store, ) -import Tahoe.CHK.Validate (matchingBlockHashRoot, validFingerprint, validShareRootHash) +import Tahoe.CHK.Validate ( + matchingBlockHashRoot, + validFingerprint, + validSegment, + validShareRootHash, + ) import Tahoe.Server ( nullStorageServer, ) @@ -138,6 +145,7 @@ tests = , testSizes , testOutOfBoundsShareNumbers , testProperty "decode signals error if the integrity of the shares is compromised" propIntegrity + , testProperty "validSegment returns False if called with a hash not related to a ciphertext by the ciphertext segment hash function" propInvalidSegment ] data Described descr b = Described descr b @@ -164,6 +172,7 @@ propIntegrity = property $ do [ fingerprintBitFlipper validCap , shareTreeLeafBitFlipper params validShares , blockBitFlipper params validShares + , crypttextTreeLeafBitFlipper params validShares ] munge <- forAll $ Gen.choice mungers @@ -475,3 +484,9 @@ prop_expand_template = checkTemplate template expanded = all (uncurry (==)) (B.zip template expanded) && checkTemplate template (B.drop (B.length template) expanded) + +propInvalidSegment :: Property +propInvalidSegment = property $ do + ciphertext <- forAll $ Gen.bytes (Range.linear 1 64) + expected <- forAll $ Gen.filterT (ciphertextSegmentHash' ciphertext /=) digests + diff Nothing (==) (validSegment expected ciphertext)