diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,31 @@ # Changelog for tahoe-lafs-immutable-uploader +## 0.2.0.0 (2023-10-02) + +* `decode` now checks the fingerprint in the read capability against the URI + extension block in shares being decoded and signals an error instead of + performing decoding if there are not enough shares where they match. (#18) + +* `decode` now checks the consistency of the "share hash tree" information in + each share and signals an error instead of performing decoding if there are + not enough shares where it is consistent. (#19) + +* `decode` now checks the consistency of each share's "blocks" and signals an + 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. + +* The `cereal`, `cipher-aes128`, `crypto-api`, `tagged`, and `monad-loop` + direct dependencies have been dropped. `cryptonite` (already a dependency) + is now used for AES128 operations. (!54) + ## 0.1.0.2 * `taggedPairHash` now respects the size parameter passed to it. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,7 +14,9 @@ * 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. - * Authenticity of the decoded data is not yet verified. + * 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 --- a/src/Tahoe/CHK.hs +++ b/src/Tahoe/CHK.hs @@ -1,6 +1,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -- @@ -65,41 +67,35 @@ decode, padCiphertext, segmentCiphertext, + DecodeError (..), ) where import qualified Codec.FEC as ZFEC -import Crypto.Cipher.AES128 ( - AESKey128, - ) -import Data.Int (Int64) -import Data.Word (Word64) - --- import Debug.Trace - +import Control.Applicative (Alternative (empty)) +import Control.Lens (view) +import Crypto.Cipher.AES (AES128) import Crypto.Hash ( Context, - HashAlgorithm (hashDigestSize), - SHA256 (SHA256), + HashAlgorithm, hashFinalize, hashInit, hashUpdate, ) -import Data.Bifunctor (first, second) -import qualified Data.ByteArray as BA +import Data.Bifunctor (Bifunctor (bimap), first, second) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Foldable (foldlM) -import Data.List (sort, transpose) -import Data.List.Extra ( - snoc, - ) -import Data.Maybe (fromJust) +import Data.Int (Int64) +import Data.List (partition, sort, transpose) +import Data.List.Extra (snoc) +import Data.Maybe (fromJust, mapMaybe) +import Data.Word (Word64) import qualified Tahoe.CHK.Capability as Cap +import Tahoe.CHK.Cipher (Key) import Tahoe.CHK.Crypto ( - blockHash, - ciphertextSegmentHash, + blockHash', + ciphertextSegmentHash', ciphertextTag, - sha256, uriExtensionHash, ) import Tahoe.CHK.Merkle ( @@ -111,7 +107,8 @@ neededHashes, rootHash, ) -import Tahoe.CHK.Share (Share (..)) +import Tahoe.CHK.SHA256d (Digest' (Digest'), zero) +import Tahoe.CHK.Share (Share (..), crypttextHashTree, uriExtension) import Tahoe.CHK.Types ( BlockHash, CrypttextHash, @@ -122,7 +119,16 @@ ) import Tahoe.CHK.URIExtension ( URIExtension (..), + codecParams, ) +import Tahoe.CHK.Validate ( + matchingBlockHashRoot, + matchingCrypttextHashRoot, + shareValidBlocks, + validFingerprint, + validSegments, + validShareRootHash, + ) import Tahoe.Netstring ( netstring, ) @@ -202,22 +208,22 @@ carries along intermediate hash values used at the end to build extra self-authenticating fields into the share. -} -data EncodingState = CPState +data EncodingState hash = CPState { -- A single hash of all crypttext segments encoded so far. - cpCrypttextHash :: Crypto.Hash.Context Crypto.Hash.SHA256 + cpCrypttextHash :: Crypto.Hash.Context hash , -- A list of hashes of each ciphertext segment encoded so far - cpCrypttextHashes :: [CrypttextHash] + cpCrypttextHashes :: [CrypttextHash hash] , -- Hashes of blocks encoded so far. - cpBlockHashes :: [[BlockHash]] + cpBlockHashes :: [[BlockHash hash]] , -- Blocks encoded so far. cpBlocks :: [[LB.ByteString]] } -- | The initial state for CHK encoding. -initEncodingState :: EncodingState +initEncodingState :: forall hash. HashAlgorithm hash => EncodingState hash initEncodingState = CPState - { cpCrypttextHash = hashUpdate (hashInit :: Context SHA256) (netstring ciphertextTag) + { cpCrypttextHash = hashUpdate (hashInit @hash) (netstring ciphertextTag) , cpCrypttextHashes = mempty , cpBlockHashes = mempty , cpBlocks = mempty @@ -242,9 +248,9 @@ {- | Process ciphertext into blocks, carrying hashes computed along the way as state. -} -processCiphertext :: Parameters -> [LB.ByteString] -> IO EncodingState +processCiphertext :: forall hash. HashAlgorithm hash => Parameters -> [LB.ByteString] -> IO (EncodingState hash) processCiphertext Parameters{paramRequiredShares, paramTotalShares} = - foldlM processSegment initEncodingState + foldlM processSegment (initEncodingState @hash) where processSegment CPState{..} segment = do -- Produce the FEC blocks for this piece of ciphertext. @@ -256,8 +262,8 @@ pure $ CPState { cpCrypttextHash = hashUpdate cpCrypttextHash (LB.toStrict segment) - , cpCrypttextHashes = snoc cpCrypttextHashes (ciphertextSegmentHash (LB.toStrict segment)) - , cpBlockHashes = snoc cpBlockHashes (blockHash . LB.toStrict <$> blocks) + , cpCrypttextHashes = snoc cpCrypttextHashes (ciphertextSegmentHash' (LB.toStrict segment)) + , cpBlockHashes = snoc cpBlockHashes (blockHash' . LB.toStrict <$> blocks) , cpBlocks = snoc cpBlocks blocks } @@ -286,7 +292,7 @@ -} encode :: -- | The encryption/decryption key. - AESKey128 -> + Key AES128 -> -- | The ZFEC parameters for this encoding. This determines how many shares -- will come out of this function. Parameters -> @@ -325,10 +331,7 @@ -- can hold our number of segments. . replicate (2 * effectiveSegments - 1) -- And make every node all nul. - $ B.replicate (hashDigestSize SHA256) 0 - - -- The merkle tree of ciphertext segment hashes. - crypttextHashTree = makeTreePartial cpCrypttextHashes + $ zero -- shareTree is a MerkleTree of MerkleTree shareTree = @@ -338,40 +341,40 @@ shareTree' = makeShareTree . map makeTreePartial . transpose $ cpBlockHashes -- A bag of additional metadata about the share and encoded object. - uriExtension = + uriExt = URIExtension - { uriExtCodecName = "crs" - , uriExtCodecParams = p -- trace ("Params: " <> show p) p - , uriExtSize = fromIntegral $ LB.length ciphertext - , uriExtSegmentSize = segmentSize - , uriExtNeededShares = required - , uriExtTotalShares = total - , uriExtNumSegments = numSegments - , uriExtTailCodecParams = tailParams p (LB.length ciphertext) - , uriExtCrypttextHash = makeCrypttextHash cpCrypttextHash - , uriExtCrypttextRootHash = makeCrypttextRootHash cpCrypttextHashes - , uriExtShareRootHash = rootHash shareTree + { _codecName = "crs" + , _codecParams = p -- trace ("Params: " <> show p) p + , _size = fromIntegral $ LB.length ciphertext + , _segmentSize = segmentSize + , _neededShares = required + , _totalShares = total + , _numSegments = numSegments + , _tailCodecParams = tailParams p (LB.length ciphertext) + , _crypttextHash = makeCrypttextHash cpCrypttextHash + , _crypttextRootHash = makeCrypttextRootHash cpCrypttextHashes + , _shareRootHash = rootHash shareTree } -- The read capability for the encoded object. cap = Cap.makeReader readKey - (uriExtensionHash uriExtension) + (uriExtensionHash uriExt) required total (fromIntegral $ LB.length ciphertext) toShare sharenum blocks blockHashes = Share - { shareBlockSize = shareBlockSize p - , shareDataSize = fromIntegral $ LB.length ciphertext `ceilDiv` fromIntegral required - , shareBlocks = blocks - , sharePlaintextHashTree = plaintextHashTree - , shareCrypttextHashTree = crypttextHashTree - , shareBlockHashTree = makeTreePartial blockHashes - , shareNeededHashes = sort . fmap (first fromIntegral) $ computeNeededShares shareTree sharenum - , shareURIExtension = uriExtension + { _blockSize = shareBlockSize p + , _dataSize = fromIntegral $ LB.length ciphertext `ceilDiv` fromIntegral required + , _blocks = blocks + , _plaintextHashTree = plaintextHashTree + , _crypttextHashTree = makeTreePartial cpCrypttextHashes + , _blockHashTree = makeTreePartial blockHashes + , _neededHashes = sort . fmap (first fromIntegral) $ computeNeededHashes shareTree sharenum + , _uriExtension = uriExt } -- The size in bytes of one erasure-encoded block of data. @@ -395,6 +398,24 @@ { paramSegmentSize = nextMultipleOf required' $ min maximumSegmentSize (fromIntegral $ LB.length ciphertext) } +-- | A problem was encountered during decoding. +data DecodeError + = -- | The size of the data is greater than the limits imposed by this implementation. + SizeOverflow + | -- | There weren't enough shares supplied to attempt erasure decoding. + NotEnoughShares + | -- | After discarding shares for which the fingerprint from the read + -- | capability did not match the URI extension block, there weren't + -- | enough shares left to attempt erasure decoding. + IntegrityError + { integrityErrorInvalidShares :: [(Int, Share, InvalidShare)] + } + | -- | 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 the inverse of ``encode``. -} @@ -404,29 +425,56 @@ -- | At least as many shares as are required to erasure decode the -- ciphertext. [(Int, Share)] -> - -- | An action that results in the ciphertext contained by the shares if - -- it is possible to recover it, or Nothing. - IO (Maybe LB.ByteString) -decode Cap.Reader{verifier = Cap.Verifier{required, total, size}} shares - | size > fromIntegral @Int64 @Integer maxBound = pure Nothing - | length shares < fromIntegral required = pure Nothing + -- | An action that results in Right of the ciphertext contained by the + -- shares if it is possible to recover it, or Left with information about + -- why it is not. + IO (Either DecodeError LB.ByteString) +decode reader shares + | size reader > fromIntegral @Int64 @Integer maxBound = pure $ Left SizeOverflow + | length shares < fromIntegral (required reader) = pure $ Left NotEnoughShares + | length validShares < fromIntegral (required reader) = pure . Left . IntegrityError $ invalidShares | otherwise = do - let -- Enough shares to satisfy the ZFEC decoder. - enoughShares = take (fromIntegral required) shares + let -- The ZFEC decoder takes as input a list of (share number, block + -- bytes) tuples (and the encoding parameters). It wants the list + -- to contain *exactly* `k` distinct blocks. Our job is to give + -- it these such a list, then. If there were shares with metadata + -- that disqualified them from use we have already discarded them. + -- We have not yet verified the integrity of the actual blocks so + -- we will do so now. + -- + -- It could be that we initially appear to have some extra data + -- available (more than `k` shares) but then discover that *some* + -- blocks are invalid. If we can disqualify *blocks* for being + -- invalid rather than disqualifying entire shares then we will be + -- able to recover data in more situations so we will try to do + -- that. - -- A list of erasure encoded blocks and positional information. - -- The outer list gives a share number along with all of the - -- blocks held in that share. - blocks :: [(Int, [LB.ByteString])] - blocks = second shareBlocks <$> enoughShares + -- Start by annotating every block of every share with a boolean + -- of whether its hash matches the good hash from the block hash + -- tree. The outer list gives a share number along with that + -- share's data. Each inner list gives a validated block or + -- nothing if validation failed. + blocksWithValidity :: [[(Int, Maybe LB.ByteString)]] + blocksWithValidity = fixBlocks . second shareValidBlocks <$> validShares - -- The outer is corresponds to erasure-encoded segments. The - -- order corresponds to the order of the segments from the - -- original input. Each inner list contains enough blocks to be - -- erasure-decoded back to a segment. - explodedBlocks :: [[(Int, LB.ByteString)]] - explodedBlocks = transpose $ fixBlocks <$> blocks + -- Change the container structure. The outer list corresponds to + -- erasure-encoded segments. The order corresponds to the order + -- of the segments from the original input. Each inner list + -- contains the blocks we were able to validate for that segment. + explodedBlocks :: [[(Int, Maybe LB.ByteString)]] + explodedBlocks = transpose blocksWithValidity + -- Then filter down to only the validated blocks. + validBlocks :: [[(Int, LB.ByteString)]] + validBlocks = mapMaybe (\(num, mbs) -> (num,) <$> mbs) <$> explodedBlocks + + -- If we end up with fewer than `required` blocks for any + -- particular segment, we cannot decode that segment. Throw out + -- the data we cannot use and structure what's left so we can + -- easily skip over those segments if desired. + enoughBlocks :: [Maybe [(Int, LB.ByteString)]] + enoughBlocks = guarded ((fromIntegral (required reader) <=) . length) <$> validBlocks + -- Figure out how many bytes are expected to be in each segment. -- Depending on the ZFEC encoding parameters, it is possible that -- we will end up with blocks that are not completely "filled" @@ -434,37 +482,155 @@ -- 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 . uriExtCodecParams . shareURIExtension . snd . head $ enoughShares + 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) (fromIntegral total) + -- + -- 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)) - -- Decode every group of blocks back to the original segments. - segments <- mapM zunfec' explodedBlocks + -- Get ready to decode the groups of blocks back to the original + -- segments, where this is possible. We might have even more than + -- we need at this point so be sure to discard any extras so + -- zunfec doesn't grow angry. + getSegments :: [Maybe (IO LB.ByteString)] + getSegments = fmap (zunfec' . take (fromIntegral (required reader)) <$>) enoughBlocks - -- 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 $ Just . LB.take (fromIntegral size) . LB.concat $ segments + -- Actually do it + maybeSegments <- traverse sequence getSegments :: IO [Maybe LB.ByteString] + + 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. + -- + -- 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 -- decoding. - fixBlocks :: (Int, [LB.ByteString]) -> [(Int, LB.ByteString)] + fixBlocks :: (Int, [a]) -> [(Int, a)] fixBlocks (sharenum, bs) = zip (repeat sharenum) bs -makeShareTree :: [MerkleTree] -> MerkleTree -makeShareTree = makeTreePartial . map rootHash + size = view (Cap.verifier . Cap.size) + required = view (Cap.verifier . Cap.required) + total = view (Cap.verifier . Cap.total) -makeCrypttextHash :: Context SHA256 -> CrypttextHash -makeCrypttextHash = sha256 . toBytes . hashFinalize + -- 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. + FingerprintMismatch + | -- | The values in the share for the block hash tree root and the + -- share's own entry in "needed shares" do not match. + BlockHashRootMismatch + | -- | The "share root hash" in the share's URIExtension doesn't agree + -- 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 + and those which do not. +-} +partitionShares :: Cap.Verifier -> [(Int, Share)] -> ([(Int, Share)], [(Int, Share, InvalidShare)]) +partitionShares verifier shares = + ( validShares + , map (`err` FingerprintMismatch) haveInvalidFingerprint + ++ map (`err` BlockHashRootMismatch) haveInvalidBlockHashRoot + ++ map (`err` ShareRootHashInvalid) haveInvalidShareRootHash + ++ map (`err` CrypttextHashRootMismatch) haveMismatchingCrypttextHashRoot + ) where - toBytes = B.pack . BA.unpack + -- Helper to build our error structure + err = uncurry (,,) -makeCrypttextRootHash :: [CrypttextHash] -> CrypttextHash + -- The hash of the UEB must equal the fingerprint in the capability. + (haveValidFingerprint, haveInvalidFingerprint) = partition (validFingerprint verifier . snd) shares + + -- The root of the share block tree in the share body must equal the + -- 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 = haveMatchingCrypttextHashRoot + (haveValidShareRootHash, haveInvalidShareRootHash) = bimap (snd <$>) (snd <$>) $ partition fst shareRootValidations + + validShares = haveValidShareRootHash + +{- | Build a merkle tree where the leaves are the root hashes of the block + hash tree of each share. +-} +makeShareTree :: HashAlgorithm hash => [MerkleTree B.ByteString hash] -> MerkleTree (MerkleTree B.ByteString hash) hash +makeShareTree = makeTreePartial . map rootHash + +makeCrypttextHash :: HashAlgorithm hash => Context hash -> CrypttextHash hash +makeCrypttextHash = Digest' . hashFinalize + +makeCrypttextRootHash :: HashAlgorithm hash => [CrypttextHash hash] -> CrypttextHash hash makeCrypttextRootHash = rootHash . makeTreePartial -- Construct the encoding parameters for the final segment which may be @@ -485,8 +651,8 @@ the indicated share number. The indicated share number is included in the result, as are the corresponding hashes from the given tree. -} -computeNeededShares :: MerkleTree -> Int -> [(Int, B.ByteString)] -computeNeededShares shareTree sharenum = +computeNeededHashes :: MerkleTree (MerkleTree B.ByteString hash) hash -> Int -> [(Int, Digest' hash)] +computeNeededHashes shareTree sharenum = -- In addition to what neededHashes computes we also need to include this -- share's own block hash root in the result. Shove it on the front of -- the result here. This will place it out of order so we'll fix it up @@ -499,11 +665,19 @@ -- to our passing in some value it doesn't want to provide a result for). (leafNumberToNodeNumber shareTree sharenum - 1, blockHashRoot shareTree sharenum) : fromJust (neededHashes shareTree sharenum) --- | Find the nth leaf hash in the given tree. -blockHashRoot :: MerkleTree -> Int -> B.ByteString +{- | Find the block tree root hash for the nth share in the given share hash + tree. +-} +blockHashRoot :: MerkleTree (MerkleTree B.ByteString hash) hash -> Int -> Digest' hash blockHashRoot tree n | n < 0 = error "Cannot have a negative leaf number" | n >= length leafs = error "Leaf number goes past the end of the tree" | otherwise = leafs !! n where leafs = leafHashes tree + +-- | Conditionally lift a value into a context. +guarded :: Alternative f => (a -> Bool) -> a -> f a +guarded predicate value + | predicate value = pure value + | otherwise = empty diff --git a/src/Tahoe/CHK/Capability.hs b/src/Tahoe/CHK/Capability.hs --- a/src/Tahoe/CHK/Capability.hs +++ b/src/Tahoe/CHK/Capability.hs @@ -1,28 +1,49 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} -module Tahoe.CHK.Capability (CHK (..), Reader (..), Verifier (..), makeReader, pCapability, pVerifier, pReader, dangerRealShow) where +module Tahoe.CHK.Capability ( + CHK (..), + Reader, + readKey, + verifier, + Verifier, + storageIndex, + fingerprint, + required, + total, + size, + makeReader, + pCapability, + pVerifier, + pReader, + dangerRealShow, +) where +import Control.Lens (view) +import Control.Lens.TH (makeLenses) +import Crypto.Cipher.AES (AES128) +import Crypto.Cipher.Types (Cipher (cipherInit)) +import Crypto.Error (maybeCryptoError) +import Data.ByteArray (convert) import qualified Data.ByteString as B import qualified Data.ByteString.Base32 as B -import Data.Serialize ( - encode, - ) import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.TreeDiff.Class (ToExpr (..)) import Data.Void (Void) import Data.Word (Word16, Word64) +import GHC.Generics (Generic) +import Tahoe.CHK.Cipher (Key (..)) +import Tahoe.CHK.Crypto (storageIndexHash) +import qualified Tahoe.CHK.Parsing import Text.Megaparsec (ErrorFancy (ErrorFail), Parsec, count, fancyFailure, oneOf, try, (<|>)) import Text.Megaparsec.Char (char, string) import Text.Megaparsec.Char.Lexer (decimal) -import Crypto.Cipher.AES128 ( - AESKey128, - ) -import Crypto.Classes (buildKey) -import Tahoe.CHK.Crypto (storageIndexHash) -import qualified Tahoe.CHK.Parsing - {- | Define a type in which we will perform parsing. There is no custom error data (Void) and we are parsing T.Text. -} @@ -49,27 +70,29 @@ -- content-addressable storage system that is a storage server. It can be -- used to ask storage servers for "shares" (ciphertext plus some -- metadata) to download. - storageIndex :: B.ByteString + _storageIndex :: B.ByteString , -- | The fingerprint (aka "UEB hash" aka "URI extension block hash") is a -- cryptographic hash that covers the URI extension block at the end of a -- CHK share. The URI extension block itself contains various other -- cryptographic hashes. Altogether this allows for integrity checking so -- shares downloaded from storage servers can be checked for validity (ie, -- that they are the same as what was uploaded) before they are processed. - fingerprint :: B.ByteString + _fingerprint :: B.ByteString , -- | The number of shares required to ZFEC decode the contents of the -- shares. ZFEC calls this *K*. It must be that 1 <= required <= 256 and -- required <= total. ZFEC is not defined outside of these bounds. - required :: Word16 + _required :: Word16 , -- | The total number of shares produced by ZFEC encoding. ZFEC calls -- this *n*. It must be that 1 <= total <= 256 and required <= total. - total :: Word16 + _total :: Word16 , -- | The size (in bytes) of the plaintext encoded in the shares. It must -- be that size >= 0 and in practice it is usually true that size >= 56. - size :: Integer + _size :: Integer } - deriving (Ord, Eq) + deriving (Ord, Eq, Generic, ToExpr) +$(makeLenses ''Verifier) + {- | Replace most of the tail of a string with a short placeholder. If the string is not much longer than `n` then the result might not actually be shorter. @@ -90,17 +113,17 @@ bounded = Tahoe.CHK.Parsing.bounded decimal instance Show Verifier where - show Verifier{storageIndex, fingerprint, required, total, size} = + show v = T.unpack $ T.intercalate ":" [ "URI" , "CHK-Verifier" - , shorten 4 . showBase32 $ storageIndex - , shorten 4 . showBase32 $ fingerprint - , showT required - , showT total - , showT size + , shorten 4 . showBase32 $ view storageIndex v + , shorten 4 . showBase32 $ view fingerprint v + , showT $ view required v + , showT $ view total v + , showT $ view size v ] {- | Represent a CHK "read" capability. This capability type can be diminished @@ -114,11 +137,13 @@ -- key to turn the original plaintext into ciphertext and back again. The -- read key is also used to derive the verify key for the verify -- capability. See ``storageIndexHash``. - readKey :: AESKey128 + _readKey :: Key AES128 , -- | The verify capability for this read capability. - verifier :: Verifier + _verifier :: Verifier } +$(makeLenses ''Reader) + -- AESKey128 has no Eq or Ord instances so derive these for Reader manually. -- We do include the AESKey128 in our comparison by encoding it to bytes -- first. @@ -128,29 +153,32 @@ instance Ord Reader where compare left right = compare (readerKey left) (readerKey right) +instance ToExpr Reader where + toExpr = toExpr . readerKey + {- | Give it a Show instance that elides the sensitive material. This makes it easier to compose with other types and we can still learn a lot of useful things about a capability without being able to see the literal secret key. -} instance Show Reader where - show Reader{readKey, verifier} = + show reader = T.unpack $ T.intercalate ":" [ "URI" , "CHK" - , shorten 4 . showBase32 . encode $ readKey - , shorten 4 . showBase32 . fingerprint $ verifier - , showT . required $ verifier - , showT . total $ verifier - , showT . size $ verifier + , shorten 4 . showBase32 . convert . keyBytes $ view readKey reader + , shorten 4 . showBase32 $ view (verifier . fingerprint) reader + , showT $ view (verifier . required) reader + , showT $ view (verifier . total) reader + , showT $ view (verifier . size) reader ] -- Construct a key with Eq and Ord instances for the Reader Eq and Ord -- instances. readerKey :: Reader -> (B.ByteString, Verifier) -readerKey r = (encode . readKey $ r, verifier r) +readerKey r = (convert $ view readKey r, view verifier r) {- | A "Content-Hash-Key" (CHK) capability is small value that can be used to perform some operation on a (usually) larger value that may be stored @@ -170,27 +198,27 @@ implementation of Tahoe-LAFS. -} dangerRealShow :: CHK -> T.Text -dangerRealShow (CHKVerifier (Verifier{storageIndex, fingerprint, required, total, size})) = +dangerRealShow (CHKVerifier v) = T.intercalate ":" [ "URI" , "CHK-Verifier" - , showBase32 storageIndex - , showBase32 fingerprint - , showT required - , showT total - , showT size + , showBase32 $ view storageIndex v + , showBase32 $ view fingerprint v + , showT $ view required v + , showT $ view total v + , showT $ view size v ] -dangerRealShow (CHKReader (Reader{readKey, verifier})) = +dangerRealShow (CHKReader r) = T.intercalate ":" [ "URI" , "CHK" - , showBase32 . encode $ readKey - , showBase32 . fingerprint $ verifier - , showT . required $ verifier - , showT . total $ verifier - , showT . size $ verifier + , showBase32 . convert $ view readKey r + , showBase32 $ view (verifier . fingerprint) r + , showT $ view (verifier . required) r + , showT $ view (verifier . total) r + , showT $ view (verifier . size) r ] {- | A parser combinator for parsing either a verify or read CHK capability @@ -219,7 +247,7 @@ makeReader <$> ( string "URI:CHK:" *> pBase32 rfc3548Alphabet 128 - >>= maybe (fancyFailure . Set.singleton . ErrorFail . T.unpack $ "Failed to build AESKey128 from CHK read key bytes") pure . buildKey + >>= maybe (fancyFailure . Set.singleton . ErrorFail . T.unpack $ "Failed to build AESKey128 from CHK read key bytes") pure . maybeCryptoError . cipherInit ) <* char ':' <*> pBase32 rfc3548Alphabet 256 @@ -233,16 +261,16 @@ {- | Construct a CHK read capability from its components. This includes the correct derivation of the corresponding CHK verify capability. -} -makeReader :: AESKey128 -> B.ByteString -> Word16 -> Word16 -> Integer -> Reader -makeReader readKey fingerprint required total size = - Reader readKey (deriveVerifier readKey fingerprint required total size) +makeReader :: Key AES128 -> B.ByteString -> Word16 -> Word16 -> Integer -> Reader +makeReader readKey' fingerprint' required' total' size' = + Reader readKey' (deriveVerifier readKey' fingerprint' required' total' size') {- | Given all of the fields of a CHK read capability, derive and return the corresponding CHK verify capability. -} deriveVerifier :: -- | The read key - AESKey128 -> + Key AES128 -> -- | The fingerprint B.ByteString -> -- | The required number of shares diff --git a/src/Tahoe/CHK/Cipher.hs b/src/Tahoe/CHK/Cipher.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK/Cipher.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Tahoe.CHK.Cipher ( + Key (keyBytes, keyCipher), +) where + +import Control.DeepSeq (NFData) +import Crypto.Cipher.Types (AEAD, BlockCipher (..), Cipher (..)) +import Data.ByteArray (ScrubbedBytes) +import qualified Data.ByteArray as BA +import Data.Coerce (coerce) +import GHC.Generics (Generic) + +{- | A block cipher key which can be deserialized from or serialized to a + ByteArray. + + This is a wrapper around Crypto.Cipher.Types.Cipher which does not provide a + way to recover the original bytes of the key. We provide this by keeping the + original bytes around. +-} +data Key cipher = Key {keyBytes :: ScrubbedBytes, keyCipher :: cipher} + +deriving instance Generic (Key cipher) +deriving instance NFData cipher => NFData (Key cipher) + +instance forall cipher. Cipher cipher => Cipher (Key cipher) where + cipherInit bs = Key (BA.convert bs) <$> cipherInit bs + cipherName _ = cipherName @cipher undefined + cipherKeySize _ = cipherKeySize @cipher undefined + +instance forall cipher. BlockCipher cipher => BlockCipher (Key cipher) where + blockSize _ = blockSize @cipher undefined + ecbEncrypt = ecbEncrypt . keyCipher + ecbDecrypt = ecbDecrypt . keyCipher + cbcEncrypt (Key _ cipher) iv = cbcEncrypt cipher (coerce iv) + cbcDecrypt (Key _ cipher) iv = cbcDecrypt cipher (coerce iv) + + cfbEncrypt (Key _ cipher) iv = cfbEncrypt cipher (coerce iv) + cfbDecrypt (Key _ cipher) iv = cfbDecrypt cipher (coerce iv) + ctrCombine (Key _ cipher) iv = ctrCombine cipher (coerce iv) + + aeadInit mode (Key _ cipher) iv = wrap <$> aeadInit mode cipher iv + where + wrap = coerce @(AEAD cipher) @(AEAD (Key cipher)) + +instance BA.ByteArrayAccess (Key cipher) where + length (Key ba _) = BA.length ba + withByteArray (Key ba _) = BA.withByteArray ba diff --git a/src/Tahoe/CHK/Crypto.hs b/src/Tahoe/CHK/Crypto.hs --- a/src/Tahoe/CHK/Crypto.hs +++ b/src/Tahoe/CHK/Crypto.hs @@ -1,14 +1,21 @@ +{-# LANGUAGE TypeApplications #-} + module Tahoe.CHK.Crypto ( sha1, sha256, sha256d, storageIndexLength, + toBytes, taggedHash, + taggedHash', taggedPairHash, + taggedPairHash', blockHash, + blockHash', storageIndexHash, ciphertextTag, ciphertextSegmentHash, + ciphertextSegmentHash', uriExtensionHash, convergenceEncryptionTag, convergenceEncryptionHashLazy, @@ -18,43 +25,32 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteArray as BA - -import Data.Serialize ( - encode, - ) - import Crypto.Hash ( Digest, + HashAlgorithm, hash, hashDigestSize, hashlazy, ) -import Crypto.Types (ByteLength) +import Data.ByteArray (convert) +import Crypto.Cipher.AES (AES128) import Crypto.Hash.Algorithms ( SHA1, SHA256 (SHA256), ) -import Crypto.Cipher.AES128 ( - AESKey128, - ) - -import Tahoe.Netstring ( - netstring, - ) - +import Tahoe.CHK.Cipher (Key) +import Tahoe.CHK.SHA256d (Digest' (..), SHA256d, toBytes) +import Tahoe.CHK.Types (Parameters (Parameters), StorageIndex) import Tahoe.CHK.URIExtension ( URIExtension, showBytes, uriExtensionToBytes, ) - -import Tahoe.CHK.Types (Parameters (Parameters), StorageIndex) - -toBytes :: Digest a -> B.ByteString -toBytes = B.pack . BA.unpack +import Tahoe.Netstring ( + netstring, + ) sha1 :: B.ByteString -> B.ByteString sha1 xs = toBytes (hash xs :: Digest SHA1) @@ -63,14 +59,27 @@ sha256 xs = toBytes (hash xs :: Digest SHA256) sha256d :: B.ByteString -> B.ByteString -sha256d = sha256 . sha256 +sha256d = toBytes . (hash :: B.ByteString -> Digest SHA256d) taggedHash :: Int -> B.ByteString -> B.ByteString -> B.ByteString -taggedHash size tag bytes = B.take size . sha256d . B.concat $ [netstring tag, bytes] +taggedHash size tag bytes = B.take size . toBytes $ taggedHash' @SHA256d tag bytes +{- | Compute the "tagged hash" of a byte string: the hash of the concatenation + of the netstring encoding of a tag and the given bytes. +-} +taggedHash' :: HashAlgorithm hash => B.ByteString -> B.ByteString -> Digest' hash +taggedHash' tag bytes = Digest' . hash . B.concat $ [netstring tag, bytes] + taggedPairHash :: Int -> B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -taggedPairHash size tag left right = B.take size . sha256d . B.concat $ [netstring tag, netstring left, netstring right] +taggedPairHash size tag left right = B.take size . toBytes $ taggedPairHash' @SHA256d tag left right +{- | Compute the "tagged pair hash" of two byte strings: the hash of the + concatenation of the netstring encoding of a tag and each of two other byte + strings. +-} +taggedPairHash' :: HashAlgorithm hash => B.ByteString -> B.ByteString -> B.ByteString -> Digest' hash +taggedPairHash' tag left right = Digest' . hash . B.concat $ [netstring tag, netstring left, netstring right] + blockTag :: B.ByteString blockTag = "allmydata_encoded_subshare_v1" @@ -78,13 +87,19 @@ blockHash :: B.ByteString -> B.ByteString blockHash = taggedHash (hashDigestSize SHA256) blockTag +{- | Compute the hash of a share block. This is the same function as + allmydata.util.hashutil.block_hash. +-} +blockHash' :: HashAlgorithm hash => B.ByteString -> Digest' hash +blockHash' = taggedHash' blockTag + storageIndexTag :: B.ByteString storageIndexTag = "allmydata_immutable_key_to_storage_index_v1" -- Compute the storage index for a given encryption key -- allmydata.util.hashutil.storage_index_hash -storageIndexHash :: AESKey128 -> StorageIndex -storageIndexHash = taggedHash storageIndexLength storageIndexTag . encode +storageIndexHash :: Key AES128 -> StorageIndex +storageIndexHash = taggedHash storageIndexLength storageIndexTag . convert ciphertextTag :: B.ByteString ciphertextTag = "allmydata_crypttext_v1" @@ -93,8 +108,12 @@ ciphertextSegmentTag = "allmydata_crypttext_segment_v1" ciphertextSegmentHash :: B.ByteString -> B.ByteString -ciphertextSegmentHash = taggedHash (hashDigestSize SHA256) ciphertextSegmentTag +ciphertextSegmentHash = toBytes . ciphertextSegmentHash' @SHA256d +-- | Compute the hash of a segment of ciphertext. +ciphertextSegmentHash' :: HashAlgorithm hash => B.ByteString -> Digest' hash +ciphertextSegmentHash' = taggedHash' ciphertextSegmentTag + uriExtensionTag :: B.ByteString uriExtensionTag = "allmydata_uri_extension_v1" @@ -124,13 +143,14 @@ -- B.take convergenceSecretLength theSHA256d where - theSHA256d = toBytes (hash theSHA256 :: Digest SHA256) - theSHA256 = toBytes (hashlazy toHash :: Digest SHA256) + theSHA256d = toBytes (hashlazy toHash :: Digest SHA256d) toHash :: BL.ByteString toHash = BL.concat [tag, bytes] tag = BL.fromStrict . netstring $ convergenceEncryptionTag secret params + +type ByteLength = Int convergenceSecretLength :: ByteLength convergenceSecretLength = 16 diff --git a/src/Tahoe/CHK/Encrypt.hs b/src/Tahoe/CHK/Encrypt.hs --- a/src/Tahoe/CHK/Encrypt.hs +++ b/src/Tahoe/CHK/Encrypt.hs @@ -1,18 +1,48 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + -- | Support the encryption requirements of CHK. -module Tahoe.CHK.Encrypt (encrypt, decrypt) where +module Tahoe.CHK.Encrypt (encrypt, encryptLazy, decrypt, decryptLazy) where -import Crypto.Cipher.AES128 (AESKey128, BlockCipher (ctrLazy), zeroIV) -import qualified Data.ByteString.Lazy as LB +import Crypto.Cipher.Types (BlockCipher (blockSize, ctrCombine), ivAdd, nullIV) +import Data.ByteArray (ByteArray) +import qualified Data.ByteString.Lazy as LBS +import Data.List (unfoldr) -{- | AES128-CTR encrypt a byte string in the manner used by CHK. +{- | CTR-mode encrypt a byte string using some block cipher. + When used for CHKv1 or CHKv2 the block cipher should be AES128. + This replaces allmydata.immutable.upload.EncryptAnUploadable The only noteworthy piece here is that encryption starts with the zero IV. -} -encrypt :: AESKey128 -> LB.ByteString -> LB.ByteString -encrypt key plaintext = fst $ ctrLazy key zeroIV plaintext +encrypt :: (BlockCipher cipher, ByteArray ba) => cipher -> ba -> ba +encrypt key = ctrCombine key nullIV +-- | Like encrypt but operate on lazy bytestrings. +encryptLazy :: forall cipher. BlockCipher cipher => cipher -> LBS.ByteString -> LBS.ByteString +encryptLazy cipher lbs = LBS.concat . (LBS.fromStrict <$>) $ zipWith (ctrCombine cipher) ivs blocks + where + -- The underlying encryption function works on strict bytes. Here's the + -- number of *blocks* to feed to it (that is, to make strict) at a time. + -- This value here is a magic number that is meant to represent a good + -- compromise between performance and number of bytes forced at one time. + workingBlocks = 1024 * 16 + + -- The size of a block is determined by the cipher. + workingBytes = workingBlocks * blockSize @cipher undefined + + ivs = iterate (`ivAdd` workingBlocks) nullIV + blocks = LBS.toStrict <$> unfoldr takeChunk lbs + + takeChunk "" = Nothing + takeChunk xs = Just . LBS.splitAt (fromIntegral workingBytes) $ xs + -- | AES128-CTR decrypt a byte string in the manner used by CHK. -decrypt :: AESKey128 -> LB.ByteString -> LB.ByteString +decrypt :: (BlockCipher cipher, ByteArray ba) => cipher -> ba -> ba decrypt = encrypt + +-- | Like decrypt but operate on lazy bytestrings. +decryptLazy :: BlockCipher cipher => cipher -> LBS.ByteString -> LBS.ByteString +decryptLazy = encryptLazy diff --git a/src/Tahoe/CHK/Merkle.hs b/src/Tahoe/CHK/Merkle.hs --- a/src/Tahoe/CHK/Merkle.hs +++ b/src/Tahoe/CHK/Merkle.hs @@ -1,17 +1,21 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Tahoe.CHK.Merkle ( MerkleTree (MerkleNode, MerkleLeaf), Direction (..), - leaf, + leafNumberToNode, leafNumberToNodeNumber, breadthFirstList, merklePathLengthForSize, + heightForLeafCount, makeTree, makeTreePartial, merkleProof, + checkMerkleProof, neededHashes, firstLeafNum, rootHash, @@ -25,83 +29,75 @@ -- exported for testing in ghci treeFromRows, buildTreeOutOfAllTheNodes, + dumpTree, ) where +import Control.Monad ((>=>)) +import Crypto.Hash (HashAlgorithm (hashDigestSize), digestFromByteString) import Data.Binary (Binary (get, put)) import Data.Binary.Get (getRemainingLazyByteString) import Data.Binary.Put (putByteString) -import Data.TreeDiff.Class (ToExpr) -import GHC.Generics (Generic) - +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as LBS +import Data.Function (on) import Data.List.HT ( padLeft, ) +import Data.Text (Text) +import qualified Data.Text as T +import Data.TreeDiff.Class (ToExpr (..)) import Data.Tuple.HT ( mapFst, ) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LBS - -import Data.Text ( - pack, - ) -import qualified Data.Text as T -import Data.Text.Encoding ( - encodeUtf8, - ) - -import Data.ByteString.Base32 ( - encodeBase32Unpadded, - ) - +import GHC.Generics (Generic) import Tahoe.CHK.Crypto ( - taggedHash, - taggedPairHash, + taggedHash', + taggedPairHash', + toBytes, ) - -import Crypto.Hash (HashAlgorithm (hashDigestSize)) -import Crypto.Hash.Algorithms (SHA256 (SHA256)) +import Tahoe.CHK.SHA256d (Digest' (..), SHA256d) import Tahoe.Util ( chunkedBy, nextPowerOf, toBinary, ) -data MerkleTree - = MerkleLeaf B.ByteString - | MerkleNode B.ByteString MerkleTree MerkleTree - deriving (Eq, Ord, Generic, ToExpr) - -{- | A constructor for a MerkleLeaf that enforces correct byte string length - (error on incorrect length). +{- | A Merkle tree parameterized on a value type and hash algorithm. The value + type is phantom and is intended to help avoid mixing up opaque hashes from + Merkle trees used for different purposes. -} -leaf :: B.ByteString -> MerkleTree -leaf bs - | B.length bs == 32 = MerkleLeaf bs - | otherwise = error $ "Constructed MerkleLeaf with hash of length " <> show (B.length bs) +data MerkleTree value hash + = MerkleLeaf (Digest' hash) + | MerkleNode (Digest' hash) (MerkleTree value hash) (MerkleTree value hash) + deriving (Eq, Ord, Generic, ToExpr) -- | Count the number of nodes in a tree. -size :: MerkleTree -> Int +size :: MerkleTree v a -> Int size = sum . mapTree (const 1) -- | Measure the height of a tree. -height :: MerkleTree -> Int +height :: MerkleTree v a -> Int height (MerkleLeaf _) = 1 height (MerkleNode _ left _) = 1 + height left -mapTree :: (MerkleTree -> a) -> MerkleTree -> [a] +{- | Compute the minimum height for a tree that can hold the given number of + leaves. +-} +heightForLeafCount :: Integral n => n -> Int +heightForLeafCount num = ceiling $ logBase (2 :: Float) (fromIntegral num) + +mapTree :: (MerkleTree v a -> b) -> MerkleTree v a -> [b] mapTree f l@(MerkleLeaf _) = [f l] mapTree f n@(MerkleNode _ left right) = f n : mapTree f left ++ mapTree f right -instance Show MerkleTree where - show (MerkleLeaf value) = - T.unpack $ T.concat ["MerkleLeaf ", encodeBase32Unpadded value] +instance (HashAlgorithm hash) => Show (MerkleTree value hash) where + show (MerkleLeaf value) = "MerkleLeaf " <> show value show (MerkleNode value left right) = T.unpack $ T.concat [ "MerkleNode " :: T.Text - , encodeBase32Unpadded value + , T.pack $ show value , " (" , T.pack $ show left , ")" @@ -110,18 +106,18 @@ , ")" ] -emptyLeafHash :: Int -> B.ByteString -emptyLeafHash = taggedHash (hashDigestSize SHA256) "Merkle tree empty leaf" . encodeUtf8 . pack . show +emptyLeafHash :: HashAlgorithm hash => Int -> Digest' hash +emptyLeafHash = taggedHash' "Merkle tree empty leaf" . C8.pack . show -pairHash :: B.ByteString -> B.ByteString -> B.ByteString -pairHash = taggedPairHash (hashDigestSize SHA256) "Merkle tree internal node" +pairHash :: HashAlgorithm a => B.ByteString -> B.ByteString -> Digest' a +pairHash = taggedPairHash' "Merkle tree internal node" -rootHash :: MerkleTree -> B.ByteString +rootHash :: MerkleTree v a -> Digest' a rootHash (MerkleLeaf value) = value rootHash (MerkleNode value _ _) = value -- Like makeTree but error on empty list -makeTreePartial :: [B.ByteString] -> MerkleTree +makeTreePartial :: HashAlgorithm hash => [Digest' hash] -> MerkleTree value hash makeTreePartial = unJust . makeTree where unJust Nothing = error "Merkle.makeTreePartial failed to make a tree" @@ -130,13 +126,13 @@ -- Make a merkle tree for the given values. Extra values are generated to -- fill the tree if necessary. The given values are the values of the leaf -- nodes. -makeTree :: [B.ByteString] -> Maybe MerkleTree +makeTree :: forall hash value. HashAlgorithm hash => [Digest' hash] -> Maybe (MerkleTree value hash) makeTree [] = Nothing makeTree leaves = Just $ makeTree' (pad leaves) where -- Pad the leaves out to the next power of two so the tree is full. - pad :: [B.ByteString] -> [B.ByteString] + pad :: [Digest' hash] -> [Digest' hash] pad leaves' = leaves' ++ padding (length leaves') -- Create the padding for the pad function. The number of leaves in the @@ -150,12 +146,12 @@ -- half the number of total leaves. If it is fewer it will create less -- padding than necessary. This should be reasonable since if there fewer -- leaves then a smaller tree could hold them all. - padding :: Int -> [B.ByteString] + padding :: Int -> [Digest' hash] padding numLeaves = emptyLeafHash <$> [numLeaves .. nextPowerOf 2 numLeaves - 1] -- Turn a length-of-power-of-2 list into a tree - makeTree' :: [B.ByteString] -> MerkleTree - makeTree' [x] = leaf x + makeTree' :: [Digest' hash] -> MerkleTree value hash + makeTree' [x] = MerkleLeaf x makeTree' xs = makeNode (makeTree' left) (makeTree' right) where @@ -163,9 +159,8 @@ -- Make a parent node referencing two given child nodes, calculating the -- parent node's hash in the process. - makeNode :: MerkleTree -> MerkleTree -> MerkleTree - makeNode left right = - MerkleNode (pairHash (rootHash left) (rootHash right)) left right + makeNode :: MerkleTree value hash -> MerkleTree value hash -> MerkleTree value hash + makeNode left right = MerkleNode ((pairHash `on` toBytes . rootHash) left right) left right -- | Represent a direction to take when walking down a binary tree. data Direction = TurnLeft | TurnRight deriving (Show, Ord, Eq) @@ -175,9 +170,33 @@ root node is numbered 1, each node's left child is the node's number times two, and the node's right child is the node's number times two plus one. -} -merkleProof :: MerkleTree -> Int -> Maybe [(Int, B.ByteString)] +merkleProof :: MerkleTree v a -> Int -> Maybe [(Int, Digest' a)] merkleProof tree targetLeaf = merkleProof' 1 tree $ merklePath (height tree) targetLeaf +{- | Check a merkle proof for validity. The proof is valid if it represents + the correct hash chain from the given leaf to the given root. +-} +checkMerkleProof :: + forall n hash. + (Integral n, HashAlgorithm hash) => + -- | The proof to check. + [(n, Digest' hash)] -> + -- | The root hash of the merkle tree against which to check the proof. + Digest' hash -> + -- | The leaf hash against which to check the proof. + Digest' hash -> + -- | True if the proof checks out, False otherwise. + Bool +checkMerkleProof proof expectedRootHash leafHash = expectedRootHash == check proof + where + check :: [(n, Digest' hash)] -> Digest' hash + check [] = leafHash + check ((nodeNum, nodeHash) : more) + | even nodeNum = pairHashD nodeHash (check more) + | otherwise = pairHashD (check more) nodeHash + where + pairHashD = pairHash `on` toBytes + {- | Compute the path to a leaf from the root of a merkle tree of a certain height. -} @@ -189,10 +208,10 @@ merklePathLengthForSize size' = ceiling . logBase (2 :: Double) . fromIntegral $ nextPowerOf 2 size' -- Convert a tree to a breadth-first list of its hash values. -breadthFirstList :: MerkleTree -> [B.ByteString] +breadthFirstList :: forall v a. MerkleTree v a -> [Digest' a] breadthFirstList tree = traverse' [tree] where - traverse' :: [MerkleTree] -> [B.ByteString] + traverse' :: [MerkleTree v a] -> [Digest' a] traverse' [] = [] traverse' trees = [rootHash tree' | tree' <- trees] ++ traverse' (concat [children tree'' | tree'' <- trees]) @@ -203,7 +222,7 @@ {- | Construct Just a merkle proof along the pre-computed path or Nothing if the path runs past the leaves of the tree. -} -merkleProof' :: Int -> MerkleTree -> [Direction] -> Maybe [(Int, B.ByteString)] +merkleProof' :: Int -> MerkleTree v a -> [Direction] -> Maybe [(Int, Digest' a)] merkleProof' _ _ [] = Just [] merkleProof' thisNodeNum (MerkleNode _ left right) (d : ds) = case d of @@ -220,19 +239,32 @@ and identify leaves of a tree from left to right. Node numbers are one indexed and identify nodes of a tree from top to bottom, left to right. -} -leafNumberToNodeNumber :: MerkleTree -> Int -> Int +leafNumberToNodeNumber :: MerkleTree v a -> Int -> Int leafNumberToNodeNumber tree leafNum = 1 + leafNum + firstLeafNum tree +{- | Get a leaf node by its leaf number, if possible. Leaf numbers are zero indexed + and identify leaves of a tree from left to right. +-} +leafNumberToNode :: MerkleTree v a -> Int -> Maybe (MerkleTree v a) +leafNumberToNode tree leafNum = nodeAtPath tree path + where + path = merklePath (height tree) leafNum + + nodeAtPath node [] = Just node + nodeAtPath (MerkleNode _ left _) (TurnLeft : ds) = nodeAtPath left ds + nodeAtPath (MerkleNode _ _ right) (TurnRight : ds) = nodeAtPath right ds + nodeAtPath (MerkleLeaf _) _ = Nothing + {- | Get a merkle proof but re-number the node numbers to be zero-indexed instead of one-indexed. -} -neededHashes :: MerkleTree -> Int -> Maybe [(Int, B.ByteString)] +neededHashes :: MerkleTree v a -> Int -> Maybe [(Int, Digest' a)] neededHashes tree = fmap (map $ mapFst (subtract 1)) . merkleProof tree {- | Determine the smallest index into the breadth first list for the given tree where a leaf may be found. -} -firstLeafNum :: MerkleTree -> Int +firstLeafNum :: MerkleTree v a -> Int firstLeafNum tree = size tree `div` 2 {- | Serialize a MerkleTree to bytes by concatenating all of the leaf hashes @@ -242,17 +274,17 @@ consume all available input. Use this instance with `isolate` and bring your own framing mechanism to determine how many bytes to process. -} -instance Binary MerkleTree where - put = putByteString . B.concat . breadthFirstList +instance (Show hash, HashAlgorithm hash) => Binary (MerkleTree v hash) where + put = putByteString . B.concat . fmap toBytes . breadthFirstList get = getRemainingLazyByteString >>= maybe (fail "could not construct MerkleTree") pure - . buildTreeOutOfAllTheNodes - . chunkedBy (hashDigestSize SHA256) + . (mapM (fmap Digest' . digestFromByteString) >=> buildTreeOutOfAllTheNodes) + . chunkedBy (hashDigestSize (undefined :: SHA256d)) . LBS.toStrict -- | Get a list of all of the leaf hashes of a tree from left to right. -leafHashes :: MerkleTree -> [B.ByteString] +leafHashes :: MerkleTree v a -> [Digest' a] leafHashes (MerkleLeaf h) = [h] leafHashes (MerkleNode _ l r) = leafHashes l <> leafHashes r @@ -260,7 +292,7 @@ root, then first two children, etc .. [0, 1, 2] is a two-layer tree, [0, 1, 2, 3, 4, 5, 6] is three-layer, etc -} -buildTreeOutOfAllTheNodes :: [B.ByteString] -> Maybe MerkleTree +buildTreeOutOfAllTheNodes :: (Show hash, HashAlgorithm hash) => [Digest' hash] -> Maybe (MerkleTree value hash) buildTreeOutOfAllTheNodes nodes | validMerkleSize nodes = Just (head (treeFromRows [] (clumpRows powersOfTwo nodes))) | otherwise = Nothing @@ -293,23 +325,24 @@ -- head) and subsequent (the tail) clumps. [Int] -> -- | The values of the nodes themselves. - [B.ByteString] -> - [[B.ByteString]] + [a] -> + [[a]] clumpRows _ [] = [] clumpRows [] _ = error "Ran out of clump lengths (too many nodes!)" clumpRows (p : ps) rows = clumpRows ps (drop p rows) ++ [take p rows] -- | Given some children treeFromRows :: + (Show hash, HashAlgorithm hash) => -- | Some children to attach to a list of nodes representing the next -- shallowest level of the tree. - [MerkleTree] -> + [MerkleTree value hash] -> -- | The values of the nodes to create at the next shallowest level of the -- tree. - [[B.ByteString]] -> + [[Digest' hash]] -> -- | The nodes forming the shallowest level of the tree. If we built a -- full tree, there will be exactly one node here. - [MerkleTree] + [MerkleTree value hash] -- if we've processed nothing yet, we're on the "all leafs" children row treeFromRows [] (children : rest) = treeFromRows (MerkleLeaf <$> children) rest -- if we're out of other stuff then we're done @@ -323,7 +356,14 @@ -- this does the "second recursion"; see above -- building out a row -- of parents from children + parent node content -mTree :: [MerkleTree] -> [B.ByteString] -> [MerkleTree] +mTree :: HashAlgorithm hash => [MerkleTree value hash] -> [Digest' hash] -> [MerkleTree value hash] mTree [left, right] [head'] = [MerkleNode head' left right] mTree (left : right : more) row = MerkleNode (head row) left right : mTree more (tail row) mTree x y = error $ "mTree not sure what to do with " <> show x <> " " <> show y + +dumpTree :: HashAlgorithm hash => MerkleTree value hash -> [Text] +dumpTree (MerkleLeaf hash) = ["Leaf " <> (T.pack . show) hash] +dumpTree (MerkleNode hash left right) = + ("Node " <> (T.pack . show) hash) : indent (dumpTree left) ++ indent (dumpTree right) + where + indent = fmap (" \\" <>) diff --git a/src/Tahoe/CHK/SHA256d.hs b/src/Tahoe/CHK/SHA256d.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK/SHA256d.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Tahoe.CHK.SHA256d where + +import Crypto.Hash (Context, Digest, HashAlgorithm, SHA256, digestFromByteString, hash) +import Crypto.Hash.IO (HashAlgorithm (..)) +import qualified Data.ByteArray as BA +import Data.ByteString (packCStringLen, useAsCString) +import qualified Data.ByteString as B +import Data.ByteString.Base32 (decodeBase32Unpadded, encodeBase32Unpadded') +import qualified Data.ByteString.Char8 as C8 +import Data.Char (toLower) +import Data.Coerce (coerce) +import Data.Data (Data) +import Data.Maybe (fromJust, fromMaybe) +import Data.Primitive (Ptr) +import Data.Primitive.Ptr (copyPtr) +import Data.String (IsString (..)) +import Data.TreeDiff.Class (ToExpr (..)) +import Foreign.C (CString) + +{- | A newtype wrapper around Digest which comes with the string interpretation + Tahoe-LAFS is accustomed to (lowercase base32 rather than lowercase base16), + as well as a ToExpr instance for participation in nice diff computation. +-} +newtype Digest' a = Digest' (Digest a) deriving newtype (Eq, Ord) + +instance HashAlgorithm hash => Show (Digest' hash) where + show (Digest' digest) = fmap toLower . C8.unpack . encodeBase32Unpadded' . toBytes $ digest + +instance ToExpr (Digest' a) where + toExpr (Digest' d) = toExpr (toBytes d) + +deriving instance BA.ByteArrayAccess (Digest' hash) + +instance HashAlgorithm hash => IsString (Digest' hash) where + fromString = + Digest' + . fromMaybe (error "invalid base32-encoded digest") + . either (error "invalid base32-encoded digest") digestFromByteString + . decodeBase32Unpadded + . C8.pack + +-- | The all-zero digest value at a specific hash algorithm. +zero :: forall hash. HashAlgorithm hash => Digest' hash +zero = Digest' . fromJust . digestFromByteString @hash . B.replicate (hashDigestSize (undefined :: hash)) $ 0 + +{- | A hash algorithm which computes its digest using the parameterized hash + algorithm and then computes a digest of _that_ digest with the same hash + algorithm. +-} +data DoubleHash hash = DoubleHash + +-- | The double SHA256 hash algorithm. +type SHA256d = DoubleHash SHA256 + +deriving instance Show hash => Show (DoubleHash hash) +deriving instance Data hash => Data (DoubleHash hash) + +instance HashAlgorithm hash => HashAlgorithm (DoubleHash hash) where + type HashBlockSize (DoubleHash hash) = HashBlockSize hash + type HashDigestSize (DoubleHash hash) = HashDigestSize hash + type HashInternalContextSize (DoubleHash hash) = HashInternalContextSize hash + + -- cryptonite doesn't force the argument and neither will we, allowing the + -- pattern of passing `undefined` around as the value. + hashBlockSize _ = hashBlockSize @hash undefined + hashDigestSize _ = hashDigestSize @hash undefined + hashInternalContextSize _ = hashInternalContextSize @hash undefined + + -- We'll re-use a Context for the wrapped hash type. + hashInternalInit ctxPtr = hashInternalInit (coerce ctxPtr :: Ptr (Context hash)) + hashInternalUpdate ctxPtr = hashInternalUpdate (coerce ctxPtr :: Ptr (Context hash)) + hashInternalFinalize ctxPtr digestPtr = do + -- Do the first pass + hashInternalFinalize + (coerce ctxPtr :: Ptr (Context hash)) + (coerce digestPtr :: Ptr (Digest hash)) + -- And then a second pass over the result + firstHash <- digestPtrToByteString digestPtr + let secondHash = hash firstHash :: Digest hash + -- And shove the second result into the output + useAsCString (toBytes secondHash) $ \new -> copyPtr (coerce digestPtr :: CString) new (hashDigestSize @hash undefined) + +-- | Extract the bytes from a value like a `Digest' hash`. +toBytes :: BA.ByteArrayAccess a => a -> B.ByteString +toBytes = B.pack . BA.unpack + +{- | Read the digest bytes out of a pointer to a Digest. This uses some + coerce trickery. I hope it's not too broken. +-} +digestPtrToByteString :: forall hash. HashAlgorithm hash => Ptr (Digest hash) -> IO B.ByteString +digestPtrToByteString = packCStringLen . (,hashDigestSize @hash undefined) . coerce @(Ptr (Digest hash)) @CString diff --git a/src/Tahoe/CHK/Share.hs b/src/Tahoe/CHK/Share.hs --- a/src/Tahoe/CHK/Share.hs +++ b/src/Tahoe/CHK/Share.hs @@ -2,6 +2,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} -- To read all the plaintext of a CHK share which you have enough shares for: @@ -41,6 +43,9 @@ module Tahoe.CHK.Share where import Control.Exception (Exception, throw) +import Control.Lens (makeLenses) +import Crypto.Hash (HashAlgorithm (hashDigestSize), digestFromByteString) +import Data.Bifunctor (Bifunctor (bimap)) import Data.Binary ( Binary (get, put), Word32, @@ -62,12 +67,13 @@ import Data.Either (fromRight) import Data.Int (Int64) import Data.List.Extra (dropEnd, sumOn') +import Data.Maybe (fromMaybe) import Data.TreeDiff.Class (ToExpr) -import Data.Tuple.HT (mapFst) import Debug.Trace () import GHC.Generics (Generic) import Network.ByteOrder (bytestring32, bytestring64) import Tahoe.CHK.Merkle (MerkleTree) +import Tahoe.CHK.SHA256d (Digest' (Digest'), SHA256d, toBytes) import Tahoe.CHK.Types (ShareNum) import Tahoe.CHK.URIExtension ( URIExtension, @@ -77,27 +83,32 @@ 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. - shareBlockSize :: Word64 + _blockSize :: Word64 , -- | The share data length. Legacy value. Unused. - shareDataSize :: Word64 + _dataSize :: Word64 , -- | The ZFEC encoded ciphertext blocks. - shareBlocks :: [LBS.ByteString] + _blocks :: [LBS.ByteString] , -- | A merkle tree of plaintext segment hashes. Unimplemented. - sharePlaintextHashTree :: MerkleTree + _plaintextHashTree :: MerkleTree BS.ByteString SHA256d , -- | A merkle tree of ciphertext segment hashes. - shareCrypttextHashTree :: MerkleTree + _crypttextHashTree :: MerkleTree Crypttext SHA256d , -- | A merkle tree of hashes of `shareBlocks`. - shareBlockHashTree :: MerkleTree + _blockHashTree :: MerkleTree BS.ByteString SHA256d , -- | The information needed to complete a merkle proof for this share. - shareNeededHashes :: [(ShareNum, BS.ByteString)] + _neededHashes :: [(ShareNum, Digest' SHA256d)] , -- | Additional metadata about this share. - shareURIExtension :: URIExtension + _uriExtension :: URIExtension } deriving (Eq, Ord, Show, Generic, ToExpr) +$(makeLenses ''Share) + getWord32 :: Get Word64 getWord32 = do word32 <- get :: Get Word32 @@ -122,16 +133,7 @@ -- Serialize a share to its canonical byte representation. This replaces -- much of allmydata.immutable.layout. put - Share - { shareBlockSize - , shareDataSize - , shareBlocks - , sharePlaintextHashTree - , shareCrypttextHashTree - , shareBlockHashTree - , shareNeededHashes - , shareURIExtension - } = + Share{..} = let -- shareDataSize is supposedly unused. Avoid making any -- calculations based on its value. We'll serialize it into -- the output but otherwise we should ignore it. Instead, @@ -139,7 +141,7 @@ -- rest of our data. -- -- CRSEncoder.set_params - realSize = sumOn' LBS.length shareBlocks + realSize = sumOn' LBS.length _blocks -- Pick a share format version based on the size of our data, -- along with helpers to encoding our fields for that format @@ -151,13 +153,13 @@ -- -- Tahoe also checks blockSize < 2 ^ 32 but I don't see how it is -- possible for blockSize to be greater than dataSize. - (version, encodeWord, putWord) = chooseVersion $ max shareDataSize (int64ToWord64 realSize) + (version, encodeWord, putWord) = chooseVersion $ max _dataSize (int64ToWord64 realSize) -- This excludes the version but otherwise has all of the integer -- header fields we need to write. header = - [ shareBlockSize - , shareDataSize + [ _blockSize + , _dataSize , (fromIntegral :: Int -> Word64) headerSize ] <> trailerFieldOffsets @@ -188,26 +190,26 @@ -- trailer field which has an offset recorded in the header. -- That code will produce an incorrect header if this -- assumption is violated. - ueb = uriExtensionToBytes shareURIExtension + ueb = uriExtensionToBytes _uriExtension trailerFields = - [ encode sharePlaintextHashTree - , encode shareCrypttextHashTree - , encode shareBlockHashTree - , LBS.fromStrict $ serializeNeededShares shareNeededHashes + [ encode _plaintextHashTree + , encode _crypttextHashTree + , encode _blockHashTree + , LBS.fromStrict $ serializeNeededShares _neededHashes , LBS.fromStrict $ encodeWord (intToWord64 $ BS.length ueb) <> ueb ] in do put (fromIntegral version :: Word32) mapM_ putWord header - mapM_ putLazyByteString shareBlocks + mapM_ putLazyByteString _blocks mapM_ putLazyByteString trailerFields get = do -- Read the version marker to determine the size of certain following -- fields. (_version, getWord) <- getVersion -- 0, 1 - shareBlockSize <- getWord -- 4, 1 - shareDataSize <- getWord -- 8, 1 + _blockSize <- getWord -- 4, 1 + _dataSize <- getWord -- 8, 1 -- These offsets are all relative to the beginning of the share. dataOffset <- getWord -- 12, 36 @@ -224,19 +226,19 @@ -- we'll fail to load the share but at least we won't apply an invalid -- interpretation to any of the data. allShareBlocks <- getLazyByteStringInBoundsFrom "share blocks" dataOffset plaintextHashTreeOffset -- 36, <1 byte> - sharePlaintextHashTree <- isolateBetween "plaintext hash tree" plaintextHashTreeOffset crypttextHashTreeOffset (get :: Get MerkleTree) -- 37, <69 - 37 == 32 bytes> - shareCrypttextHashTree <- isolateBetween "crypttext hash tree" crypttextHashTreeOffset blockHashesOffset (get :: Get MerkleTree) -- 69, <101 - 69 == 32 bytes> - shareBlockHashTree <- isolateBetween "block hash tree" blockHashesOffset shareHashesOffset (get :: Get MerkleTree) -- 101, <133 - 101 == 32 bytes> - shareNeededHashes <- unserializeNeededShares . LBS.toStrict <$> getLazyByteStringInBoundsFrom "needed shares" shareHashesOffset uriExtensionLengthOffset -- 133, <167 - 133 == 34 bytes> + _plaintextHashTree <- isolateBetween "plaintext hash tree" plaintextHashTreeOffset crypttextHashTreeOffset get -- 37, <69 - 37 == 32 bytes> + _crypttextHashTree <- isolateBetween "crypttext hash tree" crypttextHashTreeOffset blockHashesOffset get -- 69, <101 - 69 == 32 bytes> + _blockHashTree <- isolateBetween "block hash tree" blockHashesOffset shareHashesOffset get -- 101, <133 - 101 == 32 bytes> + _neededHashes <- fromMaybe (fail "Could not parse `needed hashes`") . unserializeNeededShares . LBS.toStrict <$> getLazyByteStringInBoundsFrom "needed shares" shareHashesOffset uriExtensionLengthOffset -- 133, <167 - 133 == 34 bytes> uriExtensionLength <- getWord >>= getInt64FromWord64 "URI extension length" -- 167, uriExtensionBytes <- getLazyByteString uriExtensionLength - shareURIExtension <- + _uriExtension <- either (fail . show) pure (parse pURIExtension "URI extension" $ LBS.toStrict uriExtensionBytes) - let shareBlocks = segmentLazyBytes (fromIntegral shareBlockSize) allShareBlocks + let _blocks = segmentLazyBytes (fromIntegral _blockSize) allShareBlocks pure $ Share{..} @@ -281,23 +283,26 @@ maxWord32 :: Integral i => i maxWord32 = fromIntegral (maxBound :: Word32) -serializeNeededShares :: [(ShareNum, BS.ByteString)] -> BS.ByteString +{- | Serialize the list of (share number, block tree root hash) pairs for + inclusion in the serialized form of a Share. The inverse of + unserializeNeededShares. +-} +serializeNeededShares :: HashAlgorithm hash => [(ShareNum, Digest' hash)] -> BS.ByteString serializeNeededShares = BS.concat . pieces where pieces [] = [] - pieces ((sharenum, hash) : xs) - | BS.length hash == 32 = - (toStrictByteString . BS.int16BE . fromIntegral $ sharenum) : hash : pieces xs - | otherwise = - error $ "A 'needed shares' hash had length " <> show (BS.length hash) + pieces ((sharenum, hash) : xs) = (toStrictByteString . BS.int16BE . fromIntegral $ sharenum) : toBytes hash : pieces xs -unserializeNeededShares :: BS.ByteString -> [(ShareNum, BS.ByteString)] +{- | Unserialize a a list of (share number, block tree root hash) pairs from + their form in a serialized Share. The inverse of serializeNeededShares. +-} +unserializeNeededShares :: forall hash. HashAlgorithm hash => BS.ByteString -> Maybe [(ShareNum, Digest' hash)] unserializeNeededShares bs = - result + traverse sequenceA result where - chunks = chunkedBy (2 + 32) bs + chunks = chunkedBy (2 + hashDigestSize (undefined :: hash)) bs pairs = map (BS.splitAt 2) chunks - result = map (mapFst toShareNum) pairs + result = bimap toShareNum (fmap Digest' . digestFromByteString) <$> pairs toShareNum :: BS.ByteString -> ShareNum toShareNum x = fromIntegral $ fromEnum msb `shiftL` 8 .|. fromEnum lsb diff --git a/src/Tahoe/CHK/Types.hs b/src/Tahoe/CHK/Types.hs --- a/src/Tahoe/CHK/Types.hs +++ b/src/Tahoe/CHK/Types.hs @@ -5,12 +5,12 @@ import Data.Word ( Word16, - Word8, ) import qualified Data.ByteString as B import Data.TreeDiff.Class (ToExpr) import GHC.Generics (Generic) +import Tahoe.CHK.SHA256d (Digest') -- 16 bytes type StorageIndex = B.ByteString @@ -25,13 +25,13 @@ type SegmentNum = Int -- With respect to FEC encoding, the number of a share. -type ShareNum = Word8 +type ShareNum = Int --- The SHA256d hash of a FEC-encoded block -type BlockHash = B.ByteString +-- The hash of a FEC-encoded block, parameterized on the hash algorithm. +type BlockHash a = Digest' a --- The SHA256d hash of some ciphertext -type CrypttextHash = B.ByteString +-- The hash of some ciphertext, parameterized on the hash algorithm. +type CrypttextHash a = Digest' a -- Erasure encoding / placement parameters type Total = Word16 diff --git a/src/Tahoe/CHK/URIExtension.hs b/src/Tahoe/CHK/URIExtension.hs --- a/src/Tahoe/CHK/URIExtension.hs +++ b/src/Tahoe/CHK/URIExtension.hs @@ -2,9 +2,21 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Tahoe.CHK.URIExtension ( URIExtension (..), + codecName, + codecParams, + tailCodecParams, + size, + segmentSize, + numSegments, + neededShares, + totalShares, + crypttextHash, + crypttextRootHash, + shareRootHash, uriExtensionToBytes, showBytes, pURIExtension, @@ -12,10 +24,14 @@ import Control.Applicative.Combinators (count) import Control.Applicative.Permutations (runPermutation, toPermutation) -import Control.Monad (join, void) +import Control.Lens (view) +import Control.Lens.TH (makeLenses) +import Control.Monad (join, void, (>=>)) +import Crypto.Hash (HashAlgorithm, digestFromByteString) import Data.TreeDiff.Class (ToExpr) import Data.Void (Void) import GHC.Generics (Generic) +import Tahoe.CHK.SHA256d (Digest' (Digest'), SHA256d, toBytes) import Text.Megaparsec ( MonadParsec (takeP), @@ -49,7 +65,6 @@ Size, Total, ) - import Tahoe.Netstring ( netstring, ) @@ -57,37 +72,39 @@ -- | Represent additional metadata that appears at the end of each share. data URIExtension = URIExtension { -- | The name of the encoding function. Only "zfec" is implemented. - uriExtCodecName :: B.ByteString + _codecName :: B.ByteString , -- | The parameters for the encoding function for all except the final -- segment. - uriExtCodecParams :: Parameters + _codecParams :: Parameters , -- | The parameters for the encoding function for the final segment. - uriExtTailCodecParams :: Parameters + _tailCodecParams :: Parameters , -- | The application data size in bytes. - uriExtSize :: Size + _size :: Size , -- | The individual segment size in bytes. - uriExtSegmentSize :: Size + _segmentSize :: Size , -- | The number of segments of application data. Note the last segment -- may be short so it is not necessarily the case that uriExtSize == -- uriExtSegmentSize * uriExtNumSegments. - uriExtNumSegments :: SegmentNum + _numSegments :: SegmentNum , -- | The required (K) parameter to the encoding function. This is a -- duplicate of the values in uriExtCodecParams and uriExtTailCodecParams. - uriExtNeededShares :: Required + _neededShares :: Required , -- | The total (N) parameter to the encoding function. This too is a -- duplicate. - uriExtTotalShares :: Total + _totalShares :: Total , -- | A tagged sha256d hash of the complete ciphertext. - uriExtCrypttextHash :: CrypttextHash + _crypttextHash :: CrypttextHash SHA256d , -- | The root hash of a merkle tree where the leaf hashes are of segments of ciphertext. - uriExtCrypttextRootHash :: CrypttextHash + _crypttextRootHash :: CrypttextHash SHA256d , -- | The root hash of a merkle tree where leaf hashes are the root hashes of all of the block hash trees. - uriExtShareRootHash :: CrypttextHash + _shareRootHash :: CrypttextHash SHA256d } deriving (Eq, Ord, Generic, ToExpr) +$(makeLenses ''URIExtension) + instance Show URIExtension where - show (URIExtension name params tailParams size segSize numSegs needed total hash1 hash2 hash3) = + show (URIExtension name params tailParams sz segSize numSegs needed total hash1 hash2 hash3) = T.unpack . T.concat $ [ "URIExtension { " , "codec = " @@ -97,7 +114,7 @@ , "; tail-codec-params = " , showText tailParams , "; size = " - , showText size + , showText sz , "; segment-size = " , showText segSize , "; num-segments = " @@ -117,24 +134,24 @@ where showText :: Show s => s -> T.Text showText = T.pack . show - b32 = encodeBase32Unpadded + b32 = encodeBase32Unpadded . toBytes -- Serialize a URIExtension to bytes in the format it appears in a CHK share. uriExtensionToBytes :: URIExtension -> B.ByteString uriExtensionToBytes = toWeirdString -- all of the below values are authenticated by the capability you get when you store data in Tahoe - [ ("codec_name", uriExtCodecName) - , ("codec_params", paramsToBytes . uriExtCodecParams) - , ("tail_codec_params", paramsToBytes . uriExtTailCodecParams) - , ("size", showBytes . uriExtSize) - , ("segment_size", showBytes . uriExtSegmentSize) - , ("num_segments", showBytes . uriExtNumSegments) - , ("needed_shares", showBytes . uriExtNeededShares) - , ("total_shares", showBytes . uriExtTotalShares) - , ("crypttext_hash", uriExtCrypttextHash) -- hash of the *entire* cipher text - , ("crypttext_root_hash", uriExtCrypttextRootHash) -- root hash of the *cipher text* merkle tree - , ("share_root_hash", uriExtShareRootHash) -- root hash of the *share* merkle tree + [ ("codec_name", view codecName) + , ("codec_params", paramsToBytes . view codecParams) + , ("tail_codec_params", paramsToBytes . view tailCodecParams) + , ("size", showBytes . view size) + , ("segment_size", showBytes . view segmentSize) + , ("num_segments", showBytes . view numSegments) + , ("needed_shares", showBytes . view neededShares) + , ("total_shares", showBytes . view totalShares) + , ("crypttext_hash", toBytes . view crypttextHash) -- hash of the *entire* cipher text + , ("crypttext_root_hash", toBytes . view crypttextRootHash) -- root hash of the *cipher text* merkle tree + , ("share_root_hash", toBytes . view shareRootHash) -- root hash of the *share* merkle tree ] type Parser = Parsec Void B.ByteString @@ -158,10 +175,17 @@ <*> toPermutation (pField "num_segments" $ const (bounded 1 maxBound)) <*> toPermutation (pField "needed_shares" $ const (bounded 1 256)) <*> toPermutation (pField "total_shares" $ const (bounded 1 256)) - <*> toPermutation (pField "crypttext_hash" $ takeP Nothing) - <*> toPermutation (pField "crypttext_root_hash" $ takeP Nothing) - <*> toPermutation (pField "share_root_hash" $ takeP Nothing) + <*> toPermutation (pFieldM "crypttext_hash" pDigest) + <*> toPermutation (pFieldM "crypttext_root_hash" pDigest) + <*> toPermutation (pFieldM "share_root_hash" pDigest) +{- | Parse the raw bytes of a hash algorithm digest back into a Digest'. The + parser succeeds if exactly the size of the digest exactly matches the + specified number of tokens to parse. +-} +pDigest :: HashAlgorithm hash => Int -> Parser (Maybe (Digest' hash)) +pDigest = takeP Nothing >=> (pure . (Digest' <$>) . digestFromByteString) + -- | Parse one field of a serialized URIExtension. pField :: -- | The serialized label for the field. @@ -177,6 +201,16 @@ result <- pInner len void $ string "," pure result + +{- | Flatten a Parser for a value in Maybe to a Parser for just the value. A + Nothing result from the inner parser will trigger a Parser error. +-} +pFieldM :: B.ByteString -> (Int -> Parser (Maybe a)) -> Parser a +pFieldM label pInner = do + result <- pField label pInner + case result of + Nothing -> fail $ "parsing " <> show label <> " failed to produce a value" + Just r -> pure r -- | Serialize some named URIExtension fields to bytes. toWeirdString :: diff --git a/src/Tahoe/CHK/Upload.hs b/src/Tahoe/CHK/Upload.hs --- a/src/Tahoe/CHK/Upload.hs +++ b/src/Tahoe/CHK/Upload.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Tahoe.CHK.Upload ( UploadResult (uploadResultReadCap, uploadResultExistingShares, uploadResultShareMap), @@ -34,6 +36,7 @@ ) import qualified Data.Binary as Binary +import Data.ByteArray (ScrubbedBytes) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL @@ -48,11 +51,6 @@ import qualified Data.Map.Strict as Map -import Crypto.Classes ( - buildKey, - buildKeyIO, - ) - import qualified Tahoe.CHK.Capability as Cap import System.IO ( @@ -63,10 +61,11 @@ openFile, ) -import Crypto.Cipher.AES128 ( - AESKey128, - ) +import Crypto.Cipher.AES (AES128) +import Crypto.Cipher.Types (BlockCipher, Cipher (cipherInit, cipherKeySize), KeySizeSpecifier (..)) +import "cryptonite" Crypto.Random (getRandomBytes) +import Tahoe.CHK.Cipher (Key) import Tahoe.CHK.Crypto ( convergenceEncryptionHashLazy, storageIndexHash, @@ -85,15 +84,16 @@ import Tahoe.Util (nextMultipleOf) +import Crypto.Error (maybeCryptoError) import Data.Tuple.Extra (thd3) import Tahoe.CHK ( encode, ) -import Tahoe.CHK.Encrypt (encrypt) +import Tahoe.CHK.Encrypt (encryptLazy) -- Some data that can be uploaded. data Uploadable = Uploadable - { uploadableKey :: AESKey128 + { uploadableKey :: Key AES128 , uploadableSize :: Size , uploadableParameters :: Parameters , uploadableReadCleartext :: Integer -> IO B.ByteString @@ -189,7 +189,7 @@ IO ([BL.ByteString], Cap.Reader) encryptAndEncode (Uploadable readKey _ params read') = do plaintext <- readAll read' - let ciphertext = encrypt readKey plaintext + let ciphertext = encryptLazy readKey plaintext (shares, cap) <- encode readKey params ciphertext pure (map Binary.encode shares, cap) where @@ -210,7 +210,7 @@ -- | The servers to consider uploading shares to. [StorageServer] -> -- | The encryption key (to derive the storage index). - AESKey128 -> + Key AES128 -> -- | The encoding parameters (XXX only for happy, right?) Parameters -> -- | The share data to upload. @@ -278,7 +278,7 @@ nextMultipleOf required . min segmentSize -- Create an uploadable with the given key. -filesystemUploadable :: AESKey128 -> FilePath -> Parameters -> IO Uploadable +filesystemUploadable :: Key AES128 -> FilePath -> Parameters -> IO Uploadable filesystemUploadable key path params = do fhandle <- openBinaryFile path ReadMode fsize <- hFileSize fhandle @@ -315,7 +315,7 @@ let key = getConvergentKey secret (adjustSegmentSize params size) content in memoryUploadable key size content params -memoryUploadable :: AESKey128 -> Integer -> BL.ByteString -> Parameters -> IO Uploadable +memoryUploadable :: Key AES128 -> Integer -> BL.ByteString -> Parameters -> IO Uploadable memoryUploadable key size content params = let makeReader :: BL.ByteString -> IO (Integer -> IO BL.ByteString) makeReader allContent = @@ -335,14 +335,25 @@ } -- allmydata.immutable.upload.FileHandle._get_encryption_key_convergent -getConvergentKey :: B.ByteString -> Parameters -> BL.ByteString -> AESKey128 +getConvergentKey :: B.ByteString -> Parameters -> BL.ByteString -> Key AES128 getConvergentKey secret params content = - fromJust . buildKey $ convergenceEncryptionHashLazy secret params content + fromJust . maybeCryptoError . cipherInit $ convergenceEncryptionHashLazy secret params content +buildKeyIO :: forall cipher. BlockCipher cipher => IO (Key cipher) +buildKeyIO = do + keyBytes <- getRandomBytes @IO @ScrubbedBytes keySize + pure . fromJust . maybeCryptoError . cipherInit $ keyBytes + where + keySize = case cipherKeySize @cipher undefined of + KeySizeRange _ high -> high + KeySizeEnum [] -> error "no key sizes!" + KeySizeEnum (s : _) -> s + KeySizeFixed s -> s + -- Create an uploadable with a random key. filesystemUploadableRandomConvergence :: FilePath -> Parameters -> IO Uploadable filesystemUploadableRandomConvergence path params = do - key <- buildKeyIO :: IO AESKey128 + key <- buildKeyIO :: IO (Key AES128) filesystemUploadable key path params prettyFormatSharemap :: ShareMap -> Text diff --git a/src/Tahoe/CHK/Validate.hs b/src/Tahoe/CHK/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK/Validate.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Tahoe.CHK.Validate where + +import Control.Lens (view) +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', ciphertextSegmentHash', uriExtensionHash) +import Tahoe.CHK.Merkle (checkMerkleProof, heightForLeafCount, leafHashes, rootHash) +import Tahoe.CHK.SHA256d (Digest', SHA256d) +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. +-} +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. +-} +matchingBlockHashRoot :: Int -> Share -> Bool +matchingBlockHashRoot shareNum share = + -- We should find exactly one element with a share number matching our + -- share number and the associated hash should match our hash. If we find + -- none or more than one then the share is mis-encoded and we should fail + -- validation (though maybe we should do so with a distinct error value). + isMatching + where + isMatching = + checkMatch + . findOwnHash + $ view neededHashes share + + checkMatch = ([rootHash (view blockHashTree share)] ==) . map snd + + -- Note that shareNeededHashes contains "node numbers" while our + -- shareNum is a "leaf number". So, convert. + findOwnHash = filter ((== nodeNumber) . fst) + + nodeNumber :: Int + nodeNumber = toNodeNumber shareNum + + toNodeNumber num = num + (2 ^ treeHeight) - 1 + treeHeight = heightForLeafCount . view (uriExtension . totalShares) $ share + +{- | Determine the validity of each of the given shares' "share root hash" + values with respect to the other shares in the list. +-} +validShareRootHash :: [(Int, Share)] -> [Bool] +validShareRootHash [] = [] +validShareRootHash shares@((_, aShare) : _) = + isValid + where + isValid = zipWith (`checkMerkleProof` expected) proofs leafs + + -- You already validated the share fingerprint so the expected share root + -- hash from the UEB has also been validated and we can use it. The UEB + -- is the same for all shares so we can pull this value from an arbitrary + -- share. + expected = view (uriExtension . shareRootHash) aShare + + -- Extract the proof for each share in the given list. + proofs = uncurry oneProof <$> shares + + -- Also extract each share's leaf hash to supply to the proof checker. + leafs = rootHash . view blockHashTree . snd <$> shares + + oneProof :: Int -> Share -> [(Int, Digest' SHA256d)] + oneProof shareNum share = fmap (first (+ 1)) proof + where + -- The length of the proof equals the height of the tree. + treeHeight = length (view neededHashes share) + + -- Since inclusion of our block tree root hash is what the proof is + -- proving we don't want it. We need to take it out to use our proof + -- checker. That means we need to find it. The "needed hashes" are + -- labeled by tree _node number_ and our share number is effectively a + -- _leaf number_ so we need to convert for comparison. + + -- Nodes are numbered consecutively, starting at 0 for the root node + -- and proceeding left-to-right depth-first. + firstLeafNum = 2 ^ (treeHeight - 1) - 1 + nodeNum = firstLeafNum + shareNum + + -- The proof is all of the needed hashes except for this share's own + -- hash which we will feed into the proof checker separately. + proof = filter ((/= nodeNum) . fst) (first fromIntegral <$> view neededHashes share) + +showHashes :: (Show a, Show b) => [(a, b)] -> String +showHashes = unwords . fmap showHash + +showHash :: (Show a, Show b) => (a, b) -> String +showHash (n, bs) = unwords [show n, show bs] + +{- | Get only and all the blocks from the given share with hashes that match + the values in the Share's "block hash tree". +-} +shareValidBlocks :: Share -> [Maybe LB.ByteString] +shareValidBlocks share = + zipWith checkHash (view blocks share) (leafHashes (view blockHashTree share)) + where + checkHash :: forall hash. HashAlgorithm hash => LB.ByteString -> Digest' hash -> Maybe LB.ByteString + 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/tahoe-chk.cabal b/tahoe-chk.cabal --- a/tahoe-chk.cabal +++ b/tahoe-chk.cabal @@ -1,11 +1,13 @@ cabal-version: 1.12 name: tahoe-chk -version: 0.1.0.2 +version: 0.2.0.0 synopsis: The Tahoe-LAFS' Content-Hash-Key (CHK) cryptographic protocol. description: - Please see the README on GitHub at + Reversibly encrypt plaintext, encode ciphertext to shares, and serialize + shares to bytes such that confidentiality, integrity, and authenticity are + assured. homepage: https://whetstone.private.storage/privatestorage/tahoe-chk bug-reports: @@ -22,6 +24,9 @@ ChangeLog.md README.md +tested-with: + GHC ==8.6.5 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.3 + source-repository head type: git location: @@ -31,15 +36,18 @@ exposed-modules: Tahoe.CHK Tahoe.CHK.Capability + Tahoe.CHK.Cipher Tahoe.CHK.Crypto Tahoe.CHK.Encrypt Tahoe.CHK.Merkle Tahoe.CHK.Parsing Tahoe.CHK.Server + Tahoe.CHK.SHA256d Tahoe.CHK.Share Tahoe.CHK.Types Tahoe.CHK.Upload Tahoe.CHK.URIExtension + Tahoe.CHK.Validate Tahoe.Netstring Tahoe.Server Tahoe.Util @@ -52,28 +60,25 @@ aeson >=1.4.7 && <2.2 , async >=2.2.2 && <2.3 , base >=4.7 && <5 - , base32 >=0.2.1 && <0.3 + , base32 >=0.2.1 && <0.4 , base64-bytestring >=1.0.0.3 && <1.3 , binary >=0.8.6 && <0.9 - , bytestring >=0.10.8.2 && <0.11 - , cereal >=0.5.8.1 && <0.6 - , cipher-aes128 >=0.7.0.5 && <0.8 + , bytestring >=0.10.8.2 && <0.12 , concurrency >=1.11 && <2 , containers >=0.6.0.1 && <0.7 - , crypto-api >=0.13.3 && <0.14 - , cryptonite >=0.27 && <0.30 + , cryptonite >=0.27 && <0.31 + , deepseq >=1.1 && <1.6 , directory >=1.3.3 && <1.4 , extra >=1.7.7 && <1.8 , fec >=0.1.1 && <0.2 , filepath >=1.4.2 && <1.5 + , lens >=5.0 && <5.3 , megaparsec >=8.0 && <9.3 - , memory >=0.15 && <0.17 - , monad-loops >=0.4.3 && <0.5 + , memory >=0.15 && <0.19 , network-byte-order >=0.1.5 && <0.2 , parser-combinators >=1.2.1 && <1.4 , primitive >=0.7.0.1 && <0.8 - , tagged >=0.8.6 && <0.9 - , text >=1.2.3.1 && <1.3 + , text >=1.2.3.1 && <2.2 , tree-diff >=0.1 && <0.3 , utility-ht >=0.0.15 && <0.1 @@ -87,11 +92,11 @@ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 - , base32 >=0.2.1 && <0.3 - , bytestring >=0.10.8.2 && <0.11 + , base32 >=0.2.1 && <0.4 + , bytestring >=0.10.8.2 && <0.12 , optparse-applicative >=0.15.1.0 && <0.19 , tahoe-chk - , text >=1.2.3.1 && <1.3 + , text >=1.2.3.1 && <2.2 default-language: Haskell2010 @@ -120,28 +125,26 @@ build-depends: aeson >=1.4.7 && <2.2 , base >=4.7 && <5 - , base32 >=0.2.1 && <0.3 + , base32 >=0.2.1 && <0.4 , base64-bytestring >=1.0.0.3 && <1.3 , binary >=0.8.6 && <0.9 - , bytestring >=0.10.8.2 && <0.11 - , cereal >=0.5.8.1 && <0.6 - , cipher-aes128 >=0.7.0.5 && <0.8 + , bytestring >=0.10.8.2 && <0.12 , containers >=0.6.0.1 && <0.7 - , crypto-api >=0.13.3 && <0.14 - , cryptonite >=0.27 && <0.30 + , cryptonite >=0.27 && <0.31 , directory >=1.3.3 && <1.4 , fec >=0.1.1 && <0.2 , filepath >=1.4.2 && <1.5 - , hedgehog >=1.0.3 && <1.1 + , hedgehog >=1.0.3 && <1.5 + , lens >=5.0 && <5.3 , megaparsec >=8.0 && <9.3 + , memory >=0.15 && <0.19 , scientific >=0.3.6.2 && <0.4 - , tagged >=0.8.6 && <0.9 , tahoe-chk , tasty >=1.2.3 && <1.5 - , tasty-hedgehog >=1.0.0.2 && <1.2 + , tasty-hedgehog >=1.0.0.2 && <1.5 , tasty-hunit >=0.10.0.2 && <0.11 , temporary >=1.3 && <1.4 - , text >=1.2.3.1 && <1.3 + , text >=1.2.3.1 && <2.2 , tree-diff >=0.1 && <0.3 , vector >=0.12.1.2 && <0.13 , yaml >=0.11.5.0 && <0.11.9.0 || >=0.11.9.0.0 && <0.12 diff --git a/test/Generators.hs b/test/Generators.hs --- a/test/Generators.hs +++ b/test/Generators.hs @@ -1,26 +1,38 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Generators where +import Control.Lens (over, view) +import Control.Lens.Tuple (_2) +import Control.Monad (zipWithM) import Crypto.Hash ( + HashAlgorithm, + digestFromByteString, hashDigestSize, ) import Crypto.Hash.Algorithms ( SHA256 (SHA256), ) +import Data.Bifunctor (Bifunctor (first)) +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 (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.Merkle (MerkleTree, leafHashes, makeTreePartial) +import Tahoe.CHK.SHA256d (Digest' (..), SHA256d, zero) import Tahoe.CHK.Server (StorageServerAnnouncement (StorageServerAnnouncement)) -import Tahoe.CHK.Share (Share (..)) -import Tahoe.CHK.Types (Parameters (..), ShareNum, StorageIndex) +import Tahoe.CHK.Share (Crypttext, Share (..), blocks, crypttextHashTree, neededHashes) +import Tahoe.CHK.Types (Parameters (..), Required, ShareNum, StorageIndex, Total) import Tahoe.CHK.URIExtension (URIExtension (URIExtension)) -- | The maximum value an Int64 can represent. @@ -30,7 +42,12 @@ -- | Generate Parameters values for which all field invariants hold. genParameters :: MonadGen m => m Parameters genParameters = do - paramSegmentSize <- Gen.integral (Range.exponential 1 maxInt64) + -- The normal smallest amount of data for a CHK share is 56 bytes. We can + -- set the segment size smaller than this to break those 56 bytes into + -- multiple segments but we end up with a much simplified share if the + -- segment size equals the data set. So, set the origin - the value to + -- shrink towards - to 56. + paramSegmentSize <- Gen.integral (Range.exponentialFrom 56 1 maxInt64) paramTotalShares <- Gen.integral (Range.linear 1 256) paramRequiredShares <- Gen.integral (Range.linear 1 paramTotalShares) -- XXX We're going to get rid of "Happy" from this type. For now it's @@ -50,21 +67,30 @@ <*> Gen.integral (Range.exponential 1 (maxBound :: Int)) <*> Gen.integral (Range.linear 1 256) <*> Gen.integral (Range.linear 1 256) - <*> genHash - <*> genHash - <*> genHash + <*> digests + <*> digests + <*> digests +-- | Generate Digest' values for some hash algorithm. Shrinks toward "aaa..." +digests :: forall m hash. (MonadGen m, HashAlgorithm hash) => m (Digest' hash) +digests = + Digest' + . fromMaybe (error "Failed to interpret bytes as digest") + . digestFromByteString + <$> Gen.bytes (Range.singleton (hashDigestSize (undefined :: hash))) + -- | Generate ByteStrings which could be sha256d digests. genHash :: MonadGen m => m BS.ByteString genHash = Gen.bytes . Range.singleton . hashDigestSize $ SHA256 +-- | Generate share-shaped data without trying to make the data itself coherent. shares :: MonadGen m => m Share shares = do -- XXX It would be nice to explore the full space but the tests operate in -- memory (and even if they didn't, they would be constrained by disk -- space and speed) and maxBound :: Int64 is a lot of bytes... let maxSize = 65536 - shareBlockSize <- Gen.integral (Range.exponential 1 maxSize) + _blockSize <- Gen.integral (Range.exponential 1 maxSize) numBlocks <- Gen.integral (Range.exponential 1 32) -- We don't make shareDataSize agree with the rest of the share data @@ -73,26 +99,26 @@ -- -- We can go all the way up to an unreasonable maximum here because this -- doesn't influence how many bytes are actually in the share. - shareDataSize <- fromIntegral <$> Gen.integral (Range.linear 1 maxInt64) + _dataSize <- fromIntegral <$> Gen.integral (Range.linear 1 maxInt64) - shareBlocks <- Gen.list (Range.singleton numBlocks) (LBS.fromStrict <$> Gen.bytes (Range.singleton $ fromIntegral shareBlockSize)) + _blocks <- Gen.list (Range.singleton numBlocks) (LBS.fromStrict <$> Gen.bytes (Range.singleton $ fromIntegral _blockSize)) -- XXX These merkle trees and the "needed hashes" list all have a size -- that really needs to be dictated by the encoding parameters (k and n). - sharePlaintextHashTree <- merkleTrees (Range.exponential 1 256) - shareCrypttextHashTree <- merkleTrees (Range.exponential 1 256) - shareBlockHashTree <- merkleTrees (Range.exponential 1 256) - shareNeededHashes <- Gen.list (Range.exponential 1 100) ((,) <$> Gen.integral (Range.exponential 1 255) <*> Gen.bytes (Range.singleton 32)) + _plaintextHashTree <- merkleTrees (Range.exponential 1 256) + _crypttextHashTree <- merkleTrees (Range.exponential 1 256) + _blockHashTree <- merkleTrees (Range.exponential 1 256) + _neededHashes <- Gen.list (Range.exponential 1 100) ((,) <$> Gen.integral (Range.exponential 1 255) <*> digests) -- XXX A valid share will have a URI extension that agrees with some of -- the other fields we've just generated, which we're not even trying to -- do here. - shareURIExtension <- genURIExtension + _uriExtension <- genURIExtension pure $ Share{..} -merkleTrees :: MonadGen m => Range.Range Int -> m MerkleTree -merkleTrees r = makeTreePartial <$> Gen.list r genHash +merkleTrees :: (HashAlgorithm hash, MonadGen m) => Range.Range Int -> m (MerkleTree value hash) +merkleTrees r = makeTreePartial <$> Gen.list r digests storageIndexes :: MonadGen m => m StorageIndex storageIndexes = Gen.bytes (Range.singleton storageIndexLength) @@ -129,3 +155,170 @@ swissnum <- encodeBase32Unpadded <$> Gen.bytes (Range.singleton 32) let location = "@tcp:" pure $ "pb://" <> tubid <> location <> "/" <> swissnum + +-- | Generate ByteStrings where at least one bit is non-zero. +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 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 hash) +fingerprintBitFlipper reader = do + FingerprintBitFlips <$> (Gen.bytes . Range.singleton . BS.length) (view (verifier . fingerprint) reader) + +-- | Choose a function to run on a value based on a boolean. +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 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 + + -- Make up some masks to do the block modification. + masks <- zipWithM (conditionally maskForShare (pure . zerosForShare)) whichShares shares' + pure $ BlockBitFlips masks + where + -- Replace all the Word8s in the share blocks with 0s. + zerosForShare :: Share -> [BS.ByteString] + zerosForShare = (LBS.toStrict <$>) . (LBS.map (const 0) <$>) . view blocks + + maskForShare :: Share -> m [BS.ByteString] + maskForShare = go . view blocks + where + go :: [LBS.ByteString] -> m [BS.ByteString] + go = mapM (nonZeroBytes . Range.singleton . fromIntegral @Int64 @Int . LBS.length) + +{- | Generate flags indicating which shares should be modified in order to + make the whole set unusable. +-} +enoughModifiedShares :: MonadGen m => Required -> Total -> m [Bool] +enoughModifiedShares required total = do + -- How many will we actually flip bits in? + numSharesToModify <- Gen.integral $ Range.linear minSharesToModify maxSharesToModify + + -- Which shares will we flip bits in? Each element corresponds to a share + -- and tells us whether to modify it or not. + Gen.shuffle $ (< numSharesToModify) <$> [0 .. total - 1] + where + -- What is the fewest number of shares we need to flip bits in? + minSharesToModify = total - required + 1 + -- And the most? + maxSharesToModify = total + +-- | Execute the ShareTreeLeafBitFlips instruction on a list of shares. +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, 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 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 hash) +shareTreeLeafBitFlipper Parameters{paramRequiredShares, paramTotalShares} shares' = do + modifyShare <- enoughModifiedShares paramRequiredShares paramTotalShares + + -- Modify the shares to modify, leave the rest alone. + ShareTreeLeafBitFlips <$> zipWithM modifiedShare modifyShare shares' + where + bytesInMask = fromIntegral $ hashDigestSize (undefined :: SHA256d) + zeroMask = BS.replicate bytesInMask 0 + + modifiedShare :: MonadGen m => Bool -> Share -> m [BS.ByteString] + modifiedShare False Share{_neededHashes} = pure $ replicate (length _neededHashes) zeroMask + modifiedShare True Share{_neededHashes} = do + let -- We have to change *something* + minHashesToModify = 1 + -- We might change everything + maxHashesToModify = length _neededHashes + + -- Now choose how many we will change. + numHashesToModify <- Gen.integral $ Range.linear minHashesToModify (maxHashesToModify - 1) + -- And which ones + modifyHash <- Gen.shuffle $ (< numHashesToModify) <$> [0 .. length _neededHashes - 1] + + mapM modifiedHash modifyHash + + modifiedHash :: MonadGen m => Bool -> m BS.ByteString + modifiedHash False = pure zeroMask + modifiedHash True = nonZeroFlips + where + -- Flip up to and including every bit of the input. + 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/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,6 +4,9 @@ import System.IO (hSetEncoding, stderr, stdout, utf8) +import qualified Codec.FEC as FEC +import Control.Exception (evaluate) +import Control.Monad (void) import qualified SpecCHK import qualified SpecCrypto import qualified SpecMerkle @@ -38,6 +41,18 @@ -- choice normally made). hSetEncoding stdout utf8 hSetEncoding stderr utf8 + + -- fec <= 0.1.1 has a bug under multithreaded usage where concurrent + -- implicit initialization from different threads corrupts some of its + -- internal state. fec > 0.1.1 exposes an `initialize` function to allow + -- this to be avoided but for now we can just do any initialization prior + -- to multithreaded work to avoid this. + -- + -- Use evaluate to force evaluation at this position in the IO, otherwise + -- we have no idea when `FEC.fec ...` will actually cause initialization + -- of the underlying lib. Replace this with `FEC.initialize` when + -- possible. + void $ evaluate $ FEC.fec 2 3 testVectors <- loadTestVectorData let testVectorsTree = diff --git a/test/SpecCHK.hs b/test/SpecCHK.hs --- a/test/SpecCHK.hs +++ b/test/SpecCHK.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module SpecCHK ( tests, @@ -8,33 +9,36 @@ import Control.Arrow ( (&&&), ) -import Crypto.Cipher.AES128 ( - AESKey128, - ) -import Crypto.Classes ( - encode, - ) +import Control.Lens (view) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Crypto.Cipher.AES (AES128) import qualified Data.Binary as Binary +import Data.ByteArray (convert) import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Lazy as BL import Data.Coerce (coerce) +import Data.Either (isLeft) import Data.Text ( - Text, concat, unpack, ) import Data.TreeDiff.Class (ToExpr, ediff) import Data.TreeDiff.Pretty (prettyEditExpr) import GHC.Generics (Generic) -import Tahoe.CHK.URIExtension (uriExtCodecParams) - -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.ByteString.Base32 (decodeBase32Unpadded) -import Data.Word (Word32) -import Generators (genParameters, shares) +import Generators ( + applyShareBitFlips, + blockBitFlipper, + crypttextTreeLeafBitFlipper, + digests, + fingerprintBitFlipper, + genParameters, + shareTreeLeafBitFlipper, + shares, + ) import Hedgehog ( Property, + annotateShow, assert, diff, forAll, @@ -45,27 +49,34 @@ import qualified Hedgehog.Range as Range import Tahoe.CHK (padCiphertext) import qualified Tahoe.CHK (decode, encode, segmentCiphertext) -import Tahoe.CHK.Capability (CHK (CHKReader), dangerRealShow, pCapability, pReader) -import Tahoe.CHK.Crypto (convergenceSecretLength) -import Tahoe.CHK.Encrypt (encrypt) +import Tahoe.CHK.Capability (Reader, dangerRealShow, pCapability, pReader, verifier) +import Tahoe.CHK.Cipher (Key) +import Tahoe.CHK.Crypto (ciphertextSegmentHash', convergenceSecretLength) +import Tahoe.CHK.Encrypt (encryptLazy) import Tahoe.CHK.Share ( Share ( - shareBlockSize, - shareURIExtension + _blockSize ), + uriExtension, ) import Tahoe.CHK.Types ( Parameters (..), ) +import Tahoe.CHK.URIExtension (codecParams) import Tahoe.CHK.Upload ( UploadResult (..), Uploadable (..), adjustSegmentSize, - encryptAndEncode, getConvergentKey, memoryUploadableWithConvergence, store, ) +import Tahoe.CHK.Validate ( + matchingBlockHashRoot, + validFingerprint, + validSegment, + validShareRootHash, + ) import Tahoe.Server ( nullStorageServer, ) @@ -88,8 +99,20 @@ Sample (..), TestCase (..), VectorSpec (..), + WellKnown (..), + loadWellKnownCase, ) +{- | Encrypt and encode some plaintext using some parameters, producing some + shares and a read capability. + + A hard-coded convergence secret is used for simplicity and reproducibility. +-} +makeValidShares :: Parameters -> BL.ByteString -> IO ([Share], Reader) +makeValidShares params plaintext = Tahoe.CHK.encode key params (encryptLazy key plaintext) + where + key = getConvergentKey "secret" params plaintext + assertEqual' :: (Generic a, ToExpr a, Eq a) => a -> a -> Assertion assertEqual' a b = assertBool (show . prettyEditExpr $ ediff a b) (a == b) @@ -118,17 +141,65 @@ , testProperty "ciphertext round-trips through decode . encode" prop_share_encoding_roundtrip , 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 + +instance Show descr => Show (Described descr b) where + show (Described descr _) = show descr + +{- | Tahoe.CHK.decode returns a Left value if the capability fingerprint does + not equal the URI extension block hash for any share to be decoded. +-} +propIntegrity :: Property +propIntegrity = property $ do + -- First synthesize some intact shares and the associated read capability. + plaintext <- forAll $ BL.fromStrict <$> Gen.bytes (Range.linear 1 1024) + params <- forAll $ fixParams <$> genParameters + + valid@(validShares, validCap) <- liftIO $ makeValidShares params plaintext + annotateShow validShares + annotateShow validCap + + -- Pick a function to use to screw them up somehow. Wrap them in + -- something Showable for the sake of `forAll`. + let mungers = + [ fingerprintBitFlipper validCap + , shareTreeLeafBitFlipper params validShares + , blockBitFlipper params validShares + , crypttextTreeLeafBitFlipper params validShares + ] + munge <- forAll $ Gen.choice mungers + + -- Verify that decoding with the screwed up values signals a lack of + -- integrity. + let munged@(mungedShares, mungedCap) = applyShareBitFlips munge valid + annotateShow mungedShares + annotateShow mungedCap + + -- Sanity check - something must have changed or the decode _should_ + -- succeed (not what we want to test here). + diff valid (/=) munged + + -- Show us the difference + annotateShow $ prettyEditExpr (ediff valid munged) + + let taggedShares = zip [0 ..] mungedShares + shuffledShares <- forAll $ Gen.shuffle taggedShares + result <- liftIO $ Tahoe.CHK.decode mungedCap shuffledShares + diff True (==) (isLeft result) + testSizes :: TestTree testSizes = testCase "the maximum segment size encoded in the UEB equals the actual segment size" $ do uploadable <- memoryUploadableWithConvergence (B.replicate 32 0x00) (fromIntegral $ BL.length ciphertext) ciphertext params (shares', _cap) <- Tahoe.CHK.encode (uploadableKey uploadable) params ciphertext - mapM_ (assertEqual "The shareBlockSize reflects the parameters and real ciphertext size" (fromIntegral $ BL.length ciphertext `div` 2) . shareBlockSize) shares' + mapM_ (assertEqual "The shareBlockSize reflects the parameters and real ciphertext size" (fromIntegral $ BL.length ciphertext `div` 2) . _blockSize) shares' mapM_ (assertEqual "The segment size is reduced to the ciphertext size" (fromIntegral $ BL.length ciphertext) . getSegmentSize) shares' where - getSegmentSize = paramSegmentSize . uriExtCodecParams . shareURIExtension + getSegmentSize = paramSegmentSize . view (uriExtension . codecParams) params = Parameters { paramSegmentSize = 100000 @@ -160,92 +231,68 @@ diff (BL.length padded `mod` fromIntegral paramRequiredShares) (==) 0 -wellKnownCase :: Parameters -> (Int -> FilePath) -> Text -> Assertion -wellKnownCase params pathToExpected expectedCap = - let -- Must be at least 56 bytes or we cannot get shares for - -- comparison out of Tahoe-LAFS (instead, it emits a LIT cap). - plaintext = - "abcdefghijklmnopqrstuvwxyz\ - \ZYXWVUTSRQPONMLKJIJHGRFCBA\ - \1357" - - -- Hard-code the particular convergence secret used to generated - -- the expected value. - Right convergenceSecret = decodeBase32Unpadded "lcngfrvgaksfwrelc6ae5kucb3zufssoe6cj74rozcqibnl6uy2a" +{- | Assert that: - extractShareData :: BL.ByteString -> BL.ByteString - extractShareData container = shareData - where - shareData = BL.take (fromIntegral shareDataLength) . BL.drop 0x0c $ container - shareDataLength = Binary.decode . BL.take 4 . BL.drop 4 $ container :: Word32 - in do - uploadable <- memoryUploadableWithConvergence convergenceSecret (fromIntegral $ BL.length plaintext) plaintext params - let ciphertext = encrypt (uploadableKey uploadable) plaintext - (shares', cap) <- Tahoe.CHK.encode (uploadableKey uploadable) params ciphertext + * shares of a certain well-known case can be decoded and re-encoded to the same byte sequences + * we can create those same shares and the corresponding capability by re-encoding the same inputs + * we can validate the UEB fingerprint for each share + * we can validate the share tree root hash included in each share +-} +wellKnownCase :: WellKnown -> Assertion +wellKnownCase WellKnown{..} = + do + uploadable <- memoryUploadableWithConvergence wellKnownConvergenceSecret (fromIntegral $ BL.length wellKnownPlaintext) wellKnownPlaintext wellKnownParameters + let ciphertext = encryptLazy (uploadableKey uploadable) wellKnownPlaintext + (shares', cap) <- Tahoe.CHK.encode (uploadableKey uploadable) wellKnownParameters ciphertext - -- Encoded by Tahoe-LAFS itself, hacked to use an 8 byte - -- maximum segment size. - shareContainers <- mapM BL.readFile (pathToExpected <$> [0 .. length shares' - 1]) + let allValid = replicate (fromIntegral $ paramTotalShares wellKnownParameters) True - -- Find the real share data admist the storage server framing - -- and metadata. encode only produces the share data so we - -- must scrape it out of the server storage format files we - -- have as test data. what encryptAndEncode is expected to - -- produce. - let expectedEncoded = extractShareData <$> shareContainers - expectedShares = Binary.decode <$> expectedEncoded - encodedShares = Binary.encode <$> shares' + let expectedShares = Binary.decode <$> wellKnownShares + encodedShares = Binary.encode <$> shares' - assertEqual' expectedShares shares' - assertEqual' expectedEncoded encodedShares - assertEqual "The cap matches" (dangerRealShow $ CHKReader cap) expectedCap + assertEqual' expectedShares shares' + assertEqual' wellKnownShares encodedShares + assertEqual "The cap matches" cap wellKnownCapability + assertEqual "The fingerprint matches" allValid ((validFingerprint . view verifier $ wellKnownCapability) <$> expectedShares) + assertEqual "The block tree root hash matches the proof" allValid (zipWith matchingBlockHashRoot [0 ..] expectedShares) + assertEqual "The share tree root hash is consistent" allValid (validShareRootHash $ zip [0 ..] expectedShares) + pure () -testWellKnownShare3of10 :: TestTree -testWellKnownShare3of10 = - testCase - "a known 3-of-10 case encodes as expected" - ( wellKnownCase - Parameters - { paramSegmentSize = 8 - , paramTotalShares = 10 - , paramHappyShares = 1 - , paramRequiredShares = 3 - } - (("test/3of10." <>) . show) - "URI:CHK:o4lpfdvt7ib5xei2qhz6ovkz34:uvhgccbgigj4gfqfeyh5g5uogyt7etmlmqnvswqxumm7q3rqh7uq:3:10:56" - ) +testWellKnownShare1of2 :: TestTree +testWellKnownShare1of2 = testCase "a known 1-of-2 case encodes as expected" (loadWellKnownCase params cap >>= wellKnownCase) + where + params = + Parameters + { paramSegmentSize = 8 + , paramHappyShares = 1 + , paramRequiredShares = 1 + , paramTotalShares = 2 + } + cap = "URI:CHK:pyv3qypbpk6knq5ozeibenuubq:jh3twlgmxtytwqtzn6jtbsfy2w574ybkcnalurlnlq2snuu3j5da:1:2:56" testWellKnownShare2of3 :: TestTree -testWellKnownShare2of3 = - testCase - "a known 2-of-3 case encodes as expected" - -- Just match the parameters given to Tahoe-LAFS when the test value - -- was generated. - ( wellKnownCase - Parameters - { paramSegmentSize = 8 - , paramTotalShares = 3 - , paramHappyShares = 1 - , paramRequiredShares = 2 - } - (("test/2of3." <>) . show) - "URI:CHK:co4s2wzrwos726nu24ervz2ffu:orrq3znudwnwgcazuc7qbm3prf4a46c3gmboecbror4l2k62jtkq:2:3:56" - ) +testWellKnownShare2of3 = testCase "a known 2-of-3 case encodes as expected" (loadWellKnownCase params cap >>= wellKnownCase) + where + params = + Parameters + { paramSegmentSize = 8 + , paramHappyShares = 1 + , paramRequiredShares = 2 + , paramTotalShares = 3 + } + cap = "URI:CHK:co4s2wzrwos726nu24ervz2ffu:orrq3znudwnwgcazuc7qbm3prf4a46c3gmboecbror4l2k62jtkq:2:3:56" -testWellKnownShare1of2 :: TestTree -testWellKnownShare1of2 = - testCase - "a known 1-of-2 case encodes as expected" - ( wellKnownCase - Parameters - { paramSegmentSize = 8 - , paramTotalShares = 2 - , paramHappyShares = 1 - , paramRequiredShares = 1 - } - (("test/1of2." <>) . show) - "URI:CHK:pyv3qypbpk6knq5ozeibenuubq:jh3twlgmxtytwqtzn6jtbsfy2w574ybkcnalurlnlq2snuu3j5da:1:2:56" - ) +testWellKnownShare3of10 :: TestTree +testWellKnownShare3of10 = testCase "a known 3-of-10 case encodes as expected" (loadWellKnownCase params cap >>= wellKnownCase) + where + params = + Parameters + { paramSegmentSize = 8 + , paramHappyShares = 1 + , paramRequiredShares = 3 + , paramTotalShares = 10 + } + cap = "URI:CHK:o4lpfdvt7ib5xei2qhz6ovkz34:uvhgccbgigj4gfqfeyh5g5uogyt7etmlmqnvswqxumm7q3rqh7uq:3:10:56" prop_share_encoding_roundtrip :: Property prop_share_encoding_roundtrip = property $ do @@ -256,15 +303,16 @@ (shares', cap) <- liftIO $ Tahoe.CHK.encode key params ciphertext recovered <- liftIO $ Tahoe.CHK.decode cap (zip [0 ..] shares') - diff (Just ciphertext) (==) recovered - where - -- XXX Our ZFEC bindings are unhappy with k == n. genParameters will - -- happily give us that so adjust k or n if we happen to hit such a case. - fixParams p@Parameters{paramRequiredShares = 256, paramTotalShares = 256} = p{paramRequiredShares = 255} - fixParams p@Parameters{paramRequiredShares, paramTotalShares} - | paramRequiredShares == paramRequiredShares = p{paramTotalShares = paramTotalShares + 1} - | otherwise = p + diff (Right ciphertext) (==) recovered +-- XXX Our ZFEC bindings are unhappy with k == n. genParameters will +-- happily give us that so adjust k or n if we happen to hit such a case. +fixParams :: Parameters -> Parameters +fixParams p@Parameters{paramRequiredShares = 256, paramTotalShares = 256} = p{paramRequiredShares = 255} +fixParams p@Parameters{paramRequiredShares, paramTotalShares} + | paramRequiredShares == paramRequiredShares = p{paramTotalShares = paramTotalShares + 1} + | otherwise = p + prop_share_roundtrip :: Property prop_share_roundtrip = let decode' = ((\(_, _, sh) -> sh) <$>) . Binary.decodeOrFail @@ -280,7 +328,7 @@ assertEqual "expected convergence key" "oBcuR/wKdCgCV2GKKXqiNg==" - (Base64.encode $ encode convergenceKey) + (Base64.encode $ convert convergenceKey) let b64ciphertext = Base64.encode (BL.toStrict ciphertext) assertEqual "known result" knownCorrect b64ciphertext ] @@ -294,9 +342,9 @@ plaintext = "hello world" ciphertext :: BL.ByteString - ciphertext = encrypt convergenceKey plaintext + ciphertext = encryptLazy convergenceKey plaintext - convergenceKey :: AESKey128 + convergenceKey :: Key AES128 convergenceKey = getConvergentKey convergenceSecret params plaintext convergenceSecret = B.replicate convergenceSecretLength 0x42 @@ -433,3 +481,9 @@ 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) diff --git a/test/SpecCrypto.hs b/test/SpecCrypto.hs --- a/test/SpecCrypto.hs +++ b/test/SpecCrypto.hs @@ -1,31 +1,32 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module SpecCrypto ( tests, ) where -import Crypto.Cipher.AES128 ( - AESKey128, - ) -import Crypto.Classes ( - buildKey, - keyLength, - ) -import Crypto.Types (ByteLength) +import Crypto.Cipher.AES (AES128) +import Crypto.Cipher.Types (Cipher (..), KeySizeSpecifier (..)) +import Crypto.Error (CryptoFailable (CryptoPassed)) import qualified Data.ByteString as B import Data.Char ( ord, ) -import Data.Tagged (Tagged, untag) +import Tahoe.CHK.Cipher (Key) import Tahoe.CHK.Crypto ( + blockHash', + ciphertextSegmentHash', convergenceEncryptionTag, convergenceSecretLength, sha256, sha256d, storageIndexHash, taggedHash, + taggedHash', taggedPairHash, + taggedPairHash', ) +import Tahoe.CHK.SHA256d (SHA256d) import Tahoe.CHK.Types ( Parameters (..), ) @@ -58,13 +59,49 @@ -- Adapted from allmydata.test.test_hashutil.HashUtilTests.test_known_answers assertEqual "known value" - (Just "\xb5\x4c\x60\xc5\xb1\x26\x46\xf0\x77\x0\xc4\x4c\x8b\x75\xb9\x48") + (CryptoPassed "\xb5\x4c\x60\xc5\xb1\x26\x46\xf0\x77\x0\xc4\x4c\x8b\x75\xb9\x48") (storageIndexHash <$> xKey) , testCase "tagged hash length" $ do -- The length of the result equals the given size. let expected = 17 assertEqual "taggedHash result length /= expected" expected (B.length $ taggedHash expected "tag" "hello world") assertEqual "taggedPairHash result length /= expected" expected (B.length $ taggedPairHash expected "tag" "hello" "world") + , testCase "well-known tagged hashes" $ do + assertEqual + "taggedHash' result /= expected" + "yra322btzoqjp4ts2jon5dztgnilcdg6jgztgk7joi6qpjkitg2q" + (taggedHash' @SHA256d "tag" "hello world") + assertEqual + "taggedHash' result /= expected" + "kfbsfssrv2bvtp3regne6j7gpdjcdjwncewriyfdtt764o5oa7ta" + (taggedHash' @SHA256d "different" "hello world") + assertEqual + "taggedHash' result /= expected" + "z34pzkgo36chbjz2qykonlxthc4zdqqquapw4bcaoogzvmmcr3zq" + (taggedHash' @SHA256d "different" "goodbye world") + , testCase "well-known tagged pair hashes" $ do + assertEqual + "taggedPairHash' result /= expected" + "wmto44q3shtezwggku2fxztfkwibvznkfu6clatnvfog527sb6dq" + (taggedPairHash' @SHA256d "tag" "hello" "world") + assertEqual + "taggedPairHash' result /= expected" + "lzn27njx246jhijpendqrxlk4yb23nznbcrihommbymg5e7quh4a" + (taggedPairHash' @SHA256d "different" "hello" "world") + assertEqual + "taggedPairHash' result /= expected" + "qnehpoypxxdhjheqq7dayloghtu42yr55uylc776zt23ii73o3oq" + (taggedPairHash' @SHA256d "different" "goodbye" "world") + , testCase "well-known ciphertext segment hashes" $ do + assertEqual + "ciphertextSegmentHash' result /= expected" + "aovy5aa7jej6ym5ikgwyoi4pxawnoj3wtaludjz7e2nb5xijb7aa" + (ciphertextSegmentHash' @SHA256d "") + , testCase "well-known block hashes" $ do + assertEqual + "blockHash' result /= expected" + "msjr5bh4evuh7fa3zw7uovixfbvlnstr5b65mrerwfnvjxig2jvq" + (blockHash' @SHA256d "") , testCase "convergence hasher tag" $ -- See allmydata.test.test_hashutil.HashUtilTests.test_convergence_hasher_tag let convergenceSecret = B.replicate convergenceSecretLength 0x42 @@ -87,4 +124,10 @@ ] ] where - xKey = buildKey (B.replicate (untag (keyLength :: Tagged AESKey128 ByteLength)) . fromIntegral . ord $ 'x') :: Maybe AESKey128 + xKey = cipherInit keyBytes :: CryptoFailable (Key AES128) + keyBytes = B.replicate keySize (fromIntegral $ ord 'x') + keySize = case cipherKeySize @(Key AES128) undefined of + KeySizeRange _ high -> high + KeySizeEnum [] -> error "no key sizes!" + KeySizeEnum (s : _) -> s + KeySizeFixed s -> s diff --git a/test/SpecMerkle.hs b/test/SpecMerkle.hs --- a/test/SpecMerkle.hs +++ b/test/SpecMerkle.hs @@ -1,50 +1,48 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module SpecMerkle ( tests, ) where -import Crypto.Hash (HashAlgorithm (hashDigestSize), SHA256 (SHA256)) +import Crypto.Hash (hash) import Data.Binary (decodeOrFail, encode) -import Data.ByteString.Base32 ( - encodeBase32Unpadded, - ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C8 import Data.List ( sort, ) import Data.Maybe ( isJust, ) -import Data.Text ( - pack, - ) -import Data.Text.Encoding ( - encodeUtf8, - ) +import Data.String (fromString) +import Generators (digests, merkleTrees) import Hedgehog ( - Gen, + MonadTest, Property, annotateShow, assert, diff, failure, forAll, + label, property, tripping, ) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Tahoe.CHK.Crypto ( - sha256, - taggedHash, + taggedHash', ) import Tahoe.CHK.Merkle ( Direction (..), MerkleTree (MerkleLeaf, MerkleNode), breadthFirstList, buildTreeOutOfAllTheNodes, + checkMerkleProof, emptyLeafHash, height, + leafNumberToNode, leafNumberToNodeNumber, makeTree, mapTree, @@ -54,8 +52,8 @@ pairHash, rootHash, size, - treeFromRows, ) +import Tahoe.CHK.SHA256d (Digest' (Digest'), SHA256d, toBytes) import Test.Tasty ( TestTree, testGroup, @@ -67,6 +65,15 @@ ) import Test.Tasty.Hedgehog (testProperty) +sha256d :: B.ByteString -> Digest' SHA256d +sha256d = Digest' . hash + +sha256dBytes :: B.ByteString -> B.ByteString +sha256dBytes = toBytes . sha256d + +pairSHA256d :: B.ByteString -> B.ByteString -> Digest' SHA256d +pairSHA256d = pairHash + tests :: TestTree tests = testGroup @@ -74,33 +81,33 @@ [ testCase "pairHash" $ assertEqual "simple test vector" - "MNP3F5B64GHVUPQ3U7ZT76D7ZP6NVHHV5KMFLT2IPORIGI5EL57Q" - (encodeBase32Unpadded $ pairHash "abc" "xyz") + "mnp3f5b64ghvupq3u7zt76d7zp6nvhhv5kmflt2iporigi5el57q" + (pairHash @SHA256d "abc" "xyz") , testCase "emptyLeafHash" $ assertEqual "simple test vector" - "T3KZA5VWX3TLOWDEMMGDYIGP62JU57QDUYFH7UULNFKC7MJ2NCRQ" - (encodeBase32Unpadded $ emptyLeafHash 3) + "t3kza5vwx3tlowdemmgdyigp62ju57qduyfh7uulnfkc7mj2ncrq" + (emptyLeafHash @SHA256d 3) , testCase "two leaf tree" $ assertEqual "root hash is leaf pair hash" - (Just "NFOM5H52FQH5A4F3OL3JCPGAUECQJEW6FUWKW5HWVQDIFSKPM6DQ") - (encodeBase32Unpadded . rootHash <$> makeTree [sha256 "abc", sha256 "xyz"]) + (Just "mdopl4owpdikpfqxeigeqlrqlzbecz42fslvszbhsa5kdsxb4xpa") + (rootHash <$> makeTree (sha256d <$> ["abc", "xyz"])) , testCase "three leaf tree" $ assertEqual "root hash of three leaf tree includes empty node hash" - (Just $ encodeBase32Unpadded $ pairHash (pairHash (sha256 "abc") (sha256 "xyz")) (pairHash (sha256 "mno") $ emptyLeafHash 3)) - (encodeBase32Unpadded . rootHash <$> makeTree [sha256 "abc", sha256 "xyz", sha256 "mno"]) + (Just $ pairSHA256d (toBytes $ pairSHA256d (sha256dBytes "abc") (sha256dBytes "xyz")) (toBytes $ pairSHA256d (sha256dBytes "mno") $ toBytes (emptyLeafHash @SHA256d 3))) + (rootHash <$> makeTree (sha256d <$> ["abc", "xyz", "mno"])) , testCase "empty tree" $ assertEqual "empty list results in no tree" Nothing - (makeTree []) + (makeTree @SHA256d []) , testCase "tiny tree" $ assertEqual "a two leaf tree can be constructed" - (Just (MerkleNode "\162a\224\215\DEL_\204[u-\134\200\245\&8_\210\177=\DELM\217\203V\157\220\169\224tE\145F\145" (MerkleLeaf (sha256 "bar")) (MerkleLeaf (sha256 "baz")))) - (makeTree [sha256 "bar", sha256 "baz"]) + (Just (MerkleNode "rja6pertnjkplyb36vhkfmjdcjyrwyavc77nrfgnanxftv2d7tyq" (MerkleLeaf (sha256d "bar")) (MerkleLeaf (sha256d "baz")))) + (makeTree (sha256d <$> ["bar", "baz"])) , testCase "make 6 leaf tree" $ assertBool "it can be made" $ isJust (makeTestTree 6) @@ -117,6 +124,24 @@ , testCase "show it" $ do print $ makeTestTree 2 return () + , testCase "well-known tree" $ + assertEqual + "built tree does not equal well-known correct tree" + (makeTestTree 3) + ( Just $ + MerkleNode + "vxuqudnucceja4pqkdqy5txapagxubm5moupzqywkbg2jrjkaola" + ( MerkleNode + "weycjri4jlcaunca2jyx2kr7sbtb7qdriog3f26g5jpc5awfeazq" + (MerkleLeaf "esd34nbzri75l3j2vwetpk3dvlvsxstkbaktomonrulpks3df3sq") + (MerkleLeaf "jkxbwa2tppyfax35o72tbjecxvaa4xphma6zbyfbkkku3ed2657a") + ) + ( MerkleNode + "5ovy3g2wwjnxoqtja4licckxkbqjef4xsjtclk6gxnsl66kvow6a" + (MerkleLeaf "wfisavaqgab2raihe7dld2qjps4rtxyiubgfs5enziokey2msjwa") + (MerkleLeaf "t3kza5vwx3tlowdemmgdyigp62ju57qduyfh7uulnfkc7mj2ncrq") + ) + ) , testCase "neededHashes test vectors" $ let Just tree = makeTestTree 8 needed = (sort . map fst <$>) . neededHashes tree @@ -132,28 +157,56 @@ , testProperty "node numbering round trips through the converters" spec_numberConversion_tripping , testProperty "merkle tree block construction" spec_merkleFromRows , testProperty "invalid merkle trees fail" spec_invalidMerkle + , testProperty "checkMerkleProof accepts all merkleProof results" prop_checkMerkleProof_accept + , testProperty "checkMerkleProof rejects proofs that do not prove the inclusion of the given leaf hash" prop_checkMerkleProof_reject , testProperty "merkle trees round-trip through encode / decode" prop_binary_tripping ] +heightLabel :: MonadTest m => MerkleTree value hash -> m () +heightLabel = label . fromString . ("tree height == " <>) . show . height + +prop_checkMerkleProof_accept :: Property +prop_checkMerkleProof_accept = property $ do + someTree <- forAll $ merkleTrees @SHA256d (Range.linear 1 256) + heightLabel someTree + someLeafNum <- forAll $ Gen.integral (Range.linear 0 $ height someTree - 1) + let Just proof = merkleProof someTree someLeafNum + Just someLeaf = leafNumberToNode someTree someLeafNum + annotateShow proof + annotateShow someLeaf + diff True (==) (checkMerkleProof proof (rootHash someTree) (rootHash someLeaf)) + +prop_checkMerkleProof_reject :: Property +prop_checkMerkleProof_reject = property $ do + someTree <- forAll $ merkleTrees @SHA256d (Range.linear 1 256) + heightLabel someTree + someLeafNum <- forAll $ Gen.integral (Range.linear 0 $ height someTree - 1) + let Just proof = merkleProof someTree someLeafNum + Just someLeaf = leafNumberToNode someTree someLeafNum + annotateShow proof + annotateShow someLeaf + anotherHash <- forAll $ Gen.filterT (/= rootHash someLeaf) digests + diff False (==) $ checkMerkleProof proof (rootHash someTree) anotherHash + prop_binary_tripping :: Property prop_binary_tripping = property $ do - (Just someTree) <- forAll genMerkleTree + someTree <- forAll $ merkleTrees @SHA256d (Range.linear 1 256) let third (_, _, x) = x tripping someTree encode ((third <$>) . decodeOrFail) prop_merkleProof_length :: Property prop_merkleProof_length = property $ do - (Just someTree) <- forAll genMerkleTree + someTree <- forAll $ merkleTrees @SHA256d (Range.linear 1 256) someLeaf <- forAll $ Gen.integral (Range.linear 0 $ height someTree - 1) diff (Just $ height someTree - 1) (==) (length <$> merkleProof someTree someLeaf) prop_makeTree_hashes :: Property prop_makeTree_hashes = property $ do - (Just some_tree) <- forAll genMerkleTree - assert (and $ mapTree checkMerkleProperty some_tree) + someTree <- forAll $ merkleTrees @SHA256d (Range.linear 1 256) + assert (and $ mapTree checkMerkleProperty someTree) where checkMerkleProperty (MerkleLeaf _) = True - checkMerkleProperty (MerkleNode h l r) = h == pairHash (rootHash l) (rootHash r) + checkMerkleProperty (MerkleNode h l r) = h == pairHash (toBytes $ rootHash l) (toBytes $ rootHash r) {- | Convert a set of directions to a node to that node's number. The first argument is the node number of the root node from which to follow the @@ -188,12 +241,12 @@ -} spec_merkleProof_hashes :: Property spec_merkleProof_hashes = property $ do - (Just someTree) <- forAll genMerkleTree + someTree <- forAll $ merkleTrees @SHA256d (Range.linear 1 256) someLeafNum <- forAll $ Gen.integral (Range.linear 0 $ height someTree - 1) let proof = merkleProof someTree someLeafNum -- Brute force search the tree for a matching node. - getNode :: Int -> MerkleTree -> Int -> [MerkleTree] + getNode :: Int -> MerkleTree value hash -> Int -> [MerkleTree value hash] getNode thisNodeNum n@(MerkleLeaf _) targetNodeNum | thisNodeNum == targetNodeNum = [n] | otherwise = [] @@ -214,7 +267,7 @@ -} spec_merkleProof_nodeNumbers :: Property spec_merkleProof_nodeNumbers = property $ do - (Just someTree) <- forAll genMerkleTree + someTree <- forAll $ merkleTrees @SHA256d (Range.linear 1 256) -- Choose an arbitrary path through the tree. somePath <- @@ -222,7 +275,8 @@ Gen.list (Range.singleton $ height someTree - 1) $ Gen.element [TurnLeft, TurnRight] - let -- Identify the node at the end of the path + let + -- Identify the node at the end of the path nodeNum = pathToNumber 1 somePath leafNum = nodeNumberToLeafNumber someTree nodeNum @@ -239,27 +293,27 @@ spec_numberConversion_tripping :: Property spec_numberConversion_tripping = property $ do - (Just someTree) <- forAll genMerkleTree + someTree <- forAll $ merkleTrees @SHA256d (Range.linear 1 256) someNum <- forAll $ Gen.integral (Range.linear 1 $ size someTree - 1) tripping someNum (leafNumberToNodeNumber someTree) (pure . nodeNumberToLeafNumber someTree :: Int -> Maybe Int) -- | We can build a Merkle tree from its flattened form spec_merkleFromRows :: Property spec_merkleFromRows = property $ do - (Just validTree) <- forAll genMerkleTree + validTree <- forAll $ merkleTrees (Range.linear 1 256) let nodes = breadthFirstList validTree - let (Just alleged) = buildTreeOutOfAllTheNodes nodes + let (Just alleged) = buildTreeOutOfAllTheNodes @SHA256d nodes diff alleged (==) validTree -- | Invalid flattened trees produce errors spec_invalidMerkle :: Property spec_invalidMerkle = property $ do - (Just validTree) <- forAll genMerkleTree + validTree <- forAll $ merkleTrees (Range.linear 1 256) -- it's a valid list, missing one of the elements let nodes = tail (breadthFirstList validTree) - let maybeTree = buildTreeOutOfAllTheNodes nodes + let maybeTree = buildTreeOutOfAllTheNodes @SHA256d nodes diff maybeTree (==) Nothing -- | The length of all merkle paths equals one less than the given height. @@ -270,11 +324,8 @@ let path = merklePath height' leafNum diff (length path) (==) (height' - 1) -genMerkleTree :: Gen (Maybe MerkleTree) -genMerkleTree = makeTestTree <$> Gen.integral (Range.linear 1 256) - -makeTestTree :: Int -> Maybe MerkleTree -makeTestTree numleaves = makeTree [taggedHash (hashDigestSize SHA256) "tag" (encodeUtf8 . pack . show $ n) | n <- [0 .. numleaves - 1]] +makeTestTree :: Int -> Maybe (MerkleTree B.ByteString SHA256d) +makeTestTree numleaves = makeTree $ taggedHash' "tag" . C8.pack . show <$> [0 .. numleaves - 1] -nodeNumberToLeafNumber :: MerkleTree -> Int -> Int +nodeNumberToLeafNumber :: MerkleTree value hash -> Int -> Int nodeNumberToLeafNumber tree nodeNum = nodeNum - 1 - size tree `div` 2 diff --git a/test/SpecUEB.hs b/test/SpecUEB.hs --- a/test/SpecUEB.hs +++ b/test/SpecUEB.hs @@ -8,6 +8,7 @@ import qualified Data.Text as T import Generators import Hedgehog +import Tahoe.CHK.SHA256d (zero) import Tahoe.CHK.Types import Tahoe.CHK.URIExtension import Tahoe.Netstring @@ -24,7 +25,7 @@ , testCase "numeric overflow results in parse error" $ do let -- Get something we know is a valid serialized URI extension as -- a starting point for constructing something that isn't. - validBytes = uriExtensionToBytes $ URIExtension "csr" (Parameters 1 2 3 4) (Parameters 5 6 7 8) 9 10 11 12 13 "crypttexthash" "ciphertextroothash" "shareroothash" + validBytes = uriExtensionToBytes $ URIExtension "csr" (Parameters 1 2 3 4) (Parameters 5 6 7 8) 9 10 11 12 13 zero zero zero -- Replace the legitimate value of 11 for num_segments with a -- value that overflows Int. invalidBytes :: BS.ByteString diff --git a/test/SpecUpload.hs b/test/SpecUpload.hs --- a/test/SpecUpload.hs +++ b/test/SpecUpload.hs @@ -2,13 +2,11 @@ tests, ) where +import Data.ByteArray (convert) import Data.ByteString.Base32 ( encodeBase32Unpadded, ) import Data.Maybe (mapMaybe) -import Data.Serialize ( - encode, - ) import Test.Tasty ( TestTree, @@ -153,7 +151,7 @@ assertEqual "The key matches the known correct result" expectedKeyBytes - (encodeBase32Unpadded . encode $ key) + (encodeBase32Unpadded . convert $ key) where key = getConvergentKey secret params (BL.fromStrict dataContent) diff --git a/test/Vectors.hs b/test/Vectors.hs --- a/test/Vectors.hs +++ b/test/Vectors.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -20,17 +21,23 @@ parseFail, withObject, ) +import qualified Data.Binary as Binary import qualified Data.ByteString as B +import Data.ByteString.Base32 (decodeBase32Unpadded) import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.Word (Word32) import Data.Yaml (ParseException, decodeEither') import GHC.Generics ( Generic, ) +import Tahoe.CHK.Capability (Reader, pReader) import Tahoe.CHK.Types ( Parameters (..), ) +import qualified Text.Megaparsec as M newtype JSONByteString = JSONByteString B.ByteString deriving newtype (Ord, Eq) @@ -127,3 +134,46 @@ parse :: B.ByteString -> Either LoadError VectorSpec parse = either (Left . ParseError) pure . decodeEither' + +data WellKnown = WellKnown + { wellKnownPlaintext :: BL.ByteString + , wellKnownConvergenceSecret :: B.ByteString + , wellKnownParameters :: Parameters + , wellKnownShares :: [BL.ByteString] + , wellKnownCapability :: Reader + } + +{- | Load one "well-known" (that is: hard-coded and generated by Tahoe-LAFS) + cases of CHK shares. +-} +loadWellKnownCase :: Parameters -> T.Text -> IO WellKnown +loadWellKnownCase wellKnownParameters@Parameters{paramRequiredShares, paramTotalShares} capText = + do + wellKnownShares <- mapM (fmap extractShareData . BL.readFile . sharePath) [0 .. paramTotalShares - 1] + pure WellKnown{..} + where + -- Must be at least 56 bytes or we cannot get shares for comparison out of + -- Tahoe-LAFS (instead, it emits a LIT cap). + wellKnownPlaintext = + "abcdefghijklmnopqrstuvwxyz\ + \ZYXWVUTSRQPONMLKJIJHGRFCBA\ + \1357" + + -- Hard-code the particular convergence secret used to generated the + -- expected value. + Right wellKnownConvergenceSecret = decodeBase32Unpadded "lcngfrvgaksfwrelc6ae5kucb3zufssoe6cj74rozcqibnl6uy2a" + + Right wellKnownCapability = M.parse pReader "" capText + + -- Find the share data in the source tree. + sharePath n = concat ["test/", show paramRequiredShares, "of", show paramTotalShares, "." <> show n] + + -- Strip the share "container" bytes that is wrapped around the share data + -- "proper" in our test data files. These are the server-side bookkeeping + -- bytes written by the Tahoe-LAFS storage server which generated our test + -- data. + extractShareData :: BL.ByteString -> BL.ByteString + extractShareData container = shareData + where + shareData = BL.take (fromIntegral shareDataLength) . BL.drop 0x0c $ container + shareDataLength = Binary.decode . BL.take 4 . BL.drop 4 $ container :: Word32