tahoe-chk 0.1.0.2 → 0.2.0.0

raw patch · 23 files changed

+1632/−571 lines, 23 filesdep +deepseqdep +lensdep −cerealdep −cipher-aes128dep −crypto-apidep ~base32dep ~bytestringdep ~cryptonitePVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, lens

Dependencies removed: cereal, cipher-aes128, crypto-api, monad-loops, tagged

Dependency ranges changed: base32, bytestring, cryptonite, hedgehog, memory, tasty-hedgehog, text

API changes (from Hackage documentation)

Files

• ChangeLog.md +26/−0
• README.md +3/−1
• src/Tahoe/CHK.hs +271/−97
• src/Tahoe/CHK/Capability.hs +77/−49
• src/Tahoe/CHK/Cipher.hs +53/−0
• src/Tahoe/CHK/Crypto.hs +48/−28
• src/Tahoe/CHK/Encrypt.hs +37/−7
• src/Tahoe/CHK/Merkle.hs +116/−76
• src/Tahoe/CHK/SHA256d.hs +100/−0
• src/Tahoe/CHK/Share.hs +52/−47
• src/Tahoe/CHK/Types.hs +6/−6
• src/Tahoe/CHK/URIExtension.hs +64/−30
• src/Tahoe/CHK/Upload.hs +28/−17
• src/Tahoe/CHK/Validate.hs +130/−0
• tahoe-chk.cabal +28/−25
• test/Generators.hs +210/−17
• test/Spec.hs +15/−0
• test/SpecCHK.hs +164/−110
• test/SpecCrypto.hs +54/−11
• test/SpecMerkle.hs +96/−45
• test/SpecUEB.hs +2/−1
• test/SpecUpload.hs +2/−4
• test/Vectors.hs +50/−0

@@ -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.

@@ -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? 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 ("   \\" <>)

@@ -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

@@ -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

@@ -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

@@ -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 ::

@@ -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

@@ -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

@@ -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 <https://whetstone.private.storage/privatestorage/tahoe-chk/-/blob/main/README.md>+  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

@@ -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

@@ -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 =

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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) 

@@ -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