diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,19 @@ +# Changelog for tahoe-lafs-immutable-uploader + +## 0.1.0.2 + +* `taggedPairHash` now respects the size parameter passed to it. +* The CHK capability parsers now signal error on overflow for the `n`, `k`, and `size` parameters. +* The UEB parser now signals error on overflow for `num_segments`, + `needed_shares`, `total_shares`, and `n` and `k` in the codec parameter + fields. + +## 0.1.0.1 + +* Switch from `base64` to `base64-bytestring` to avoid an encoding bug on ARM + with GHC 8.6.5. + +## 0.1.0.0 + +* Initial release. +* Support for encoding and decoding data using Tahoe-LAFS' CHK protocol. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,33 @@ +Copyright 2020-2023 +Jean-Paul Calderone +Shae Erisson +meejah + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the names of The Authors here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,27 @@ +# Tahoe-CHK + +## What is it? + +Tahoe-CHK is a Haskell implementation of the [Tahoe-LAFS](https://tahoe-lafs.org/) CHK crytographic protocol. +It aims for bit-for-bit compatibility with the original Python implementation. + +It will not include an implementation of any network protocol for transferring CHK shares. +However, its APIs are intended to be easy to integrate with such an implementation. + +### What is the current state? + +* Convergent encryption is supported and compatible with Tahoe-LAFS. +* 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. + +## Why does it exist? + +A Haskell implementation can be used in places the original Python implementation cannot be +(for example, runtime environments where it is difficult to have a Python interpreter). +Additionally, +with the benefit of the experience gained from creating and maintaining the Python implementation, +a number of implementation decisions can be made differently to produce a more efficient, more flexible, simpler implementation and API. +Also, +the Python implementation claims no public library API for users outside of the Tahoe-LAFS project itself. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,132 @@ +module Main where + +import qualified Data.ByteString as B +import qualified Data.Text as Text +import qualified Data.Text.IO as Text + +import Options.Applicative ( + Parser, + ParserInfo, + argument, + auto, + execParser, + fullDesc, + header, + help, + helper, + info, + long, + metavar, + option, + optional, + progDesc, + str, + strOption, + value, + (<**>), + ) + +import Data.ByteString.Base32 ( + decodeBase32Unpadded, + ) +import Tahoe.CHK.Types ( + Parameters (..), + Required, + Total, + ) + +import Tahoe.Server ( + directoryStorageServer', + ) + +import Tahoe.CHK.Upload ( + UploadResult (uploadResultReadCap, uploadResultShareMap), + defaultParameters, + filesystemUploadableRandomConvergence, + filesystemUploadableWithConvergence, + prettyFormatSharemap, + store, + ) + +import Tahoe.CHK.Capability ( + CHK (CHKReader), + dangerRealShow, + ) + +data Config = UploadConfig + { uploadConfigPath :: FilePath + , uploadConfigConvergence :: Maybe B.ByteString + , uploadConfigTotalShares :: Total + , uploadConfigRequiredShares :: Required + } + deriving (Show, Eq) + +uploadConfig :: Parser Config +uploadConfig = + UploadConfig + <$> argument str (metavar "PATH") + <*> optional + ( strOption + ( long "convergence-secret" + <> metavar "BASE32" + <> help "A convergence secret to use for deriving capabilities. The equivalent of a random convergence secret is used if not given." + ) + ) + <*> option + auto + ( long "shares-total" + <> metavar "COUNT" + <> help "The total number of shares into which the data will be encoded." + <> value 10 + ) + <*> option + auto + ( long "shares-required" + <> metavar "COUNT" + <> help "The minimum number of shares required to re-assemble the original data." + <> value 3 + ) + +opts :: ParserInfo Config +opts = + info + (uploadConfig <**> helper) + ( fullDesc + <> progDesc "Upload some data as an immutable object and report the capability." + <> header "tahoe-lafs-encrypt-chk" + ) + +main :: IO () +main = do + (UploadConfig path secret total required) <- execParser opts + let params = + defaultParameters + { paramTotalShares = total + , paramRequiredShares = required + } + uploadable <- case secret of + Nothing -> filesystemUploadableRandomConvergence path params + Just b32Secret -> + case decodeBase32Unpadded b32Secret of + Left _err -> error "base32 decoding convergence secret failed" + Right bytesSecret -> + filesystemUploadableWithConvergence bytesSecret path params + + servers <- getServers + result <- store servers uploadable + report_upload result + where + getServers = + mapM + directoryStorageServer' + [ "storage001" + , "storage002" + , "storage003" + , "storage004" + , "storage005" + ] + + report_upload :: UploadResult -> IO () + report_upload result = do + Text.putStrLn . prettyFormatSharemap . uploadResultShareMap $ result + Text.putStrLn . Text.append "Read cap: " . dangerRealShow . CHKReader . uploadResultReadCap $ result diff --git a/src/Tahoe/CHK.hs b/src/Tahoe/CHK.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK.hs @@ -0,0 +1,509 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +-- +-- Glossary +-- +-- CHK - An encryption and encoding scheme for storing immutable data. +-- +-- Data - The plaintext used to construct CHK. +-- +-- Share - One complete unit of encrypted and FEC encoded data. +-- +-- Segment - One piece of ciphertext used to construct CHK. All segments +-- belonging to a CHK are the same size except the last one may be short. +-- +-- k, required - The number of "primary" erasure-encoding outputs. Equal to +-- the minimum number of erasure-encoding outputs needed to reconstruct +-- the erasure-encoding input. +-- +-- n, total - The total number of erasure-encoding outputs. Always greater +-- than or equal to required. +-- +-- Block - One output resulting from erasure-encoding one segment using +-- required, total. If necessary, the input segment is nul-padded so its +-- size is a multiple of required. +-- +-- Plaintext Hash Tree - Not actually implemented by Tahoe so I'm not really +-- sure. Probably something like a sha256d merkle tree where the leaves +-- are hashes of the plaintext corresponding to each ciphertext segment. +-- Since all shares for a CHK are derived from the same plaintext, every +-- share has the same plaintext hash tree. +-- +-- Crypttext Hash Tree - A sha256d merkle tree where the leaves are hashes of +-- the ciphertext segments. Since all shares for a CHK are derived from +-- the same ciphertext, every share has the same ciphertext hash tree. +-- +-- Crypttext Root Hash - The hash at the root of Crypttext Hash Tree. +-- +-- Block Hash Tree - A sha256d merkle tree where the leaves are hashes of the +-- blocks. Since the erasure-encoding output is different for each share, +-- every share has a different block hash tree. +-- +-- Share Hash Tree - A sha256d merkle tree where the leaves are the root +-- hashes of the block hash trees for all shares. +-- +-- Share Hashes - A list of hashes from the Share Hash Tree which are required +-- to verify one block hash tree. Each share includes the Share Hashes +-- required to verify the Block Hash Tree contained within that share. +-- Since every share contains a different Block Hash Tree, every share +-- contains a different list of Share Hashes. Each Share Hash in this +-- list is accompanied by information about its position in the Share Hash +-- Tree though it may not be strictly required (since it could be inferred +-- from position in the list). +-- +-- URI Extension - A collection of metadata describing the encryption and +-- encoding used to create the CHK and (largely) necessary for either +-- decoding or verifying the integrity of the contained data. + +module Tahoe.CHK ( + zfec, + zunfec, + encode, + decode, + padCiphertext, + segmentCiphertext, +) where + +import qualified Codec.FEC as ZFEC +import Crypto.Cipher.AES128 ( + AESKey128, + ) +import Data.Int (Int64) +import Data.Word (Word64) + +-- import Debug.Trace + +import Crypto.Hash ( + Context, + HashAlgorithm (hashDigestSize), + SHA256 (SHA256), + hashFinalize, + hashInit, + hashUpdate, + ) +import Data.Bifunctor (first, second) +import qualified Data.ByteArray as BA +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 qualified Tahoe.CHK.Capability as Cap +import Tahoe.CHK.Crypto ( + blockHash, + ciphertextSegmentHash, + ciphertextTag, + sha256, + uriExtensionHash, + ) +import Tahoe.CHK.Merkle ( + MerkleTree, + buildTreeOutOfAllTheNodes, + leafHashes, + leafNumberToNodeNumber, + makeTreePartial, + neededHashes, + rootHash, + ) +import Tahoe.CHK.Share (Share (..)) +import Tahoe.CHK.Types ( + BlockHash, + CrypttextHash, + Parameters (..), + Required, + requiredToInt, + totalToInt, + ) +import Tahoe.CHK.URIExtension ( + URIExtension (..), + ) +import Tahoe.Netstring ( + netstring, + ) +import Tahoe.Util ( + ceilDiv, + chunkedBy, + nextMultipleOf, + nextPowerOf, + ) + +-- | Erasure encode some bytes using ZFEC. +zfec :: + -- | The number of outputs that will be required to reverse the encoding. + -- Also known as `k`. + Int -> + -- | The total number of outputs to produce. Also known as `n`. + Int -> + -- | Application data to divide into encoding inputs. + B.ByteString -> + -- | `n` encoding outputs. + IO [B.ByteString] +zfec k n segment = + pure $ chunks ++ ZFEC.encode (ZFEC.fec k n) chunks + where + chunks_ = chunkedBy (B.length segment `div` k) segment + _msg = + "zfec" + <> " k=" + <> show k + <> " n=" + <> show n + <> ", segment len " + <> show (B.length segment) + <> ", chunk lengths " + <> show (map B.length chunks_) + <> ", segment " + <> show segment + <> "-> chunks " + <> show chunks_ + chunks = {- trace _msg -} chunks_ + +-- | Version of `zfec` that operates on lazy ByteStrings. +zfecLazy :: Int -> Int -> LB.ByteString -> IO [LB.ByteString] +zfecLazy k n segment = (LB.fromStrict <$>) <$> zfec k n (LB.toStrict segment) + +-- | Erasure decode some bytes using ZFEC. +zunfec :: + -- | The `k` parameter used when encoding the data to decode. + Int -> + -- | The `n` parameter used when encoding the data to decode. + Int -> + -- | The encoding outputs annotated with their position (or "share number"). + [(Int, B.ByteString)] -> + -- | The bytes which were originally encoded. + IO B.ByteString +zunfec k n blocks = pure $ B.concat (ZFEC.decode (ZFEC.fec k n) blocks) + +-- | Version of `zunfec` that operates on lazy ByteStrings. +zunfecLazy :: Int -> Int -> [(Int, LB.ByteString)] -> IO LB.ByteString +zunfecLazy k n blocks = do + segment_ <- LB.fromStrict <$> zunfec k n (second LB.toStrict <$> blocks) + let _msg = + "zunfec" + <> " k=" + <> show k + <> " n=" + <> show n + <> " blocks=" + <> show blocks + <> " -> segment " + <> show segment_ + + -- pure (trace _msg) segment_ + pure segment_ + +{- | Represent progress encoding some ciphertext into a CHK share. This + carries along intermediate hash values used at the end to build extra + self-authenticating fields into the share. +-} +data EncodingState = CPState + { -- A single hash of all crypttext segments encoded so far. + cpCrypttextHash :: Crypto.Hash.Context Crypto.Hash.SHA256 + , -- A list of hashes of each ciphertext segment encoded so far + cpCrypttextHashes :: [CrypttextHash] + , -- Hashes of blocks encoded so far. + cpBlockHashes :: [[BlockHash]] + , -- Blocks encoded so far. + cpBlocks :: [[LB.ByteString]] + } + +-- | The initial state for CHK encoding. +initEncodingState :: EncodingState +initEncodingState = + CPState + { cpCrypttextHash = hashUpdate (hashInit :: Context SHA256) (netstring ciphertextTag) + , cpCrypttextHashes = mempty + , cpBlockHashes = mempty + , cpBlocks = mempty + } + +{- | Split a full ciphertext string into the separate ciphertext segments + required by most of CHK encoding. +-} +segmentCiphertext :: + -- | The encoding parameters which determine how to split the ciphertext. + Parameters -> + -- | The ciphertext. + LB.ByteString -> + -- | The segments. + [LB.ByteString] +segmentCiphertext Parameters{paramSegmentSize} ciphertext = + result + where + result = {- trace ("segmentCiphertext: " <> show ciphertext) -} result_ + result_ = LB.fromStrict <$> chunkedBy (fromIntegral paramSegmentSize) (LB.toStrict ciphertext) + +{- | Process ciphertext into blocks, carrying hashes computed along the way as + state. +-} +processCiphertext :: Parameters -> [LB.ByteString] -> IO EncodingState +processCiphertext Parameters{paramRequiredShares, paramTotalShares} = + foldlM processSegment initEncodingState + where + processSegment CPState{..} segment = do + -- Produce the FEC blocks for this piece of ciphertext. + blocks <- + zfecLazy + (requiredToInt paramRequiredShares) + (totalToInt paramTotalShares) + (padCiphertext paramRequiredShares segment) + pure $ + CPState + { cpCrypttextHash = hashUpdate cpCrypttextHash (LB.toStrict segment) + , cpCrypttextHashes = snoc cpCrypttextHashes (ciphertextSegmentHash (LB.toStrict segment)) + , cpBlockHashes = snoc cpBlockHashes (blockHash . LB.toStrict <$> blocks) + , cpBlocks = snoc cpBlocks blocks + } + +-- Compute the correctly padded ciphertext. The only ciphertext which is +-- expected to require padding is the final segment - in case the original +-- ciphertext did not have a length that was a multiple of the `required` +-- parameter. +-- +-- allmydata.immutable.encode.Encoder._gather_data NUL pads up to num_chunks +-- times input_chunk_size. num_chunks is our requiredShares. +-- input_chunk_size is taken from codec.get_block_size() which returns +-- codec.share_size. share_size is div_ceil(data_size, required_shares). +-- data_size is our segmentSize and required_shares is our requiredShares. +padCiphertext :: Required -> LB.ByteString -> LB.ByteString +padCiphertext requiredShares bs + | paddingLength > 0 = bs <> LB.replicate paddingLength 0x00 + | otherwise = bs + where + desiredLength = nextMultipleOf requiredShares (LB.length bs) + paddingLength = desiredLength - LB.length bs + +{- | Encode some application data (typically ciphertext, but this function only + weakly assumes this is the case) into some CHK shares. + + This replaces much of allmydata.immutable.encode. +-} +encode :: + -- | The encryption/decryption key. + AESKey128 -> + -- | The ZFEC parameters for this encoding. This determines how many shares + -- will come out of this function. + Parameters -> + -- | The data to encode. This is typically ciphertext. + LB.ByteString -> + -- | An IO which can be evaluated to get the encoded share data and the + -- read capability. The number of Shares will equal the `total` value + -- from the given Parameters. + IO ([Share], Cap.Reader) +encode readKey initParams@(Parameters maximumSegmentSize total _ required) ciphertext = + processCiphertext p (segmentCiphertext p ciphertext) >>= \CPState{..} -> + let -- The number of segments encoded in the share. There are the same number + -- of plaintext and ciphertext segments and this is also the number of + -- blocks in each share (though each share may have a different _value_ + -- for each block). + -- + -- allmydata.immutable.encode.Encoder._got_all_encoding_parameters + numSegments = length cpBlocks + + -- Our merkle trees need a number of leaves equal to a power of 2. + -- Compute that here so we can pad as necessary. + -- + -- allmydata.immutable.layout.WriteBucketProxy + effectiveSegments = nextPowerOf 2 numSegments + + -- XXX Unused by Tahoe so we don't even try for a sensible value right + -- now. Just fill it with zeros. + -- + -- As long as we calculate a valid number of nodes for a tree + -- buildTreeOutOfAllTheNodes won't give us a Nothing back ... cross + -- your fingers. + Just plaintextHashTree = + buildTreeOutOfAllTheNodes + -- We have to fill the *whole* tree with nul, not just the + -- leaves. Compute the total number of nodes in a tree that + -- 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 + + -- shareTree is a MerkleTree of MerkleTree + shareTree = + -- trace ("shareTree: " <> show shareTree') + shareTree' + where + shareTree' = makeShareTree . map makeTreePartial . transpose $ cpBlockHashes + + -- A bag of additional metadata about the share and encoded object. + uriExtension = + 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 + } + + -- The read capability for the encoded object. + cap = + Cap.makeReader + readKey + (uriExtensionHash uriExtension) + 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 + } + + -- The size in bytes of one erasure-encoded block of data. + -- allmydata.immutable.encode.Encoder._got_all_encoding_parameters + + -- allmydata.codec.CRSEncoder.set_params + shareBlockSize :: Parameters -> Word64 + shareBlockSize Parameters{paramSegmentSize, paramRequiredShares} = + fromIntegral paramSegmentSize `ceilDiv` fromIntegral paramRequiredShares + in pure + ( zipWith3 toShare [0 ..] (transpose cpBlocks) (transpose cpBlockHashes) + , cap + ) + where + -- If we have little enough ciphertext, the maximum configured segment + -- size may be greater than the length of the single segment we produce. + -- Segment size is also required to be a multiple of the number of + -- required shares so that segments can be evenly divided across the + -- shares. + p@(Parameters segmentSize _ _ required') = + initParams + { paramSegmentSize = nextMultipleOf required' $ min maximumSegmentSize (fromIntegral $ LB.length ciphertext) + } + +{- | Decode some CHK shares to recover some application data. This is roughly + the inverse of ``encode``. +-} +decode :: + -- | The read capability for the application data. + Cap.Reader -> + -- | 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 + | otherwise = do + let -- Enough shares to satisfy the ZFEC decoder. + enoughShares = take (fromIntegral required) shares + + -- 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 + + -- 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 + + -- 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" + -- with real data. When these are decoded, we will get _extra_ + -- 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 + + -- A helper that knows the correct parameters to do ZFEC decoding + -- for us. + zunfec' = (LB.take segSize <$>) . zunfecLazy (fromIntegral required) (fromIntegral total) + + -- Decode every group of blocks back to the original segments. + segments <- mapM zunfec' explodedBlocks + + -- 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 + where + -- 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 (sharenum, bs) = zip (repeat sharenum) bs + +makeShareTree :: [MerkleTree] -> MerkleTree +makeShareTree = makeTreePartial . map rootHash + +makeCrypttextHash :: Context SHA256 -> CrypttextHash +makeCrypttextHash = sha256 . toBytes . hashFinalize + where + toBytes = B.pack . BA.unpack + +makeCrypttextRootHash :: [CrypttextHash] -> CrypttextHash +makeCrypttextRootHash = rootHash . makeTreePartial + +-- Construct the encoding parameters for the final segment which may be +-- smaller than the earlier segments (if the size of the data to be encoded is +-- not a multiple of the segment size). +-- allmydata.immutable.encode.Encoder._got_all_encoding_parameters +tailParams :: Integral a => Parameters -> a -> Parameters +tailParams p@Parameters{paramSegmentSize, paramRequiredShares} dataSize = + p{paramSegmentSize = nextMultipleOf paramRequiredShares tailSize'} + where + tailSize' = + if tailSize == 0 + then paramSegmentSize + else tailSize + tailSize = fromIntegral dataSize `mod` paramSegmentSize + +{- | Determine the node numbers of the share tree which are required to verify + 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 = + -- 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 + -- below when we construct the Share. We also have to translate between + -- zero-indexed share numbers and 1-indexed leaf numbers. + -- + -- Is fromJust here safe? neededHashes returns Nothing when it fails to + -- compute a merkle proof. Given the way we're using it, that can + -- probably only happen if there's a bug inside neededHashes (as opposed + -- 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 +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 diff --git a/src/Tahoe/CHK/Capability.hs b/src/Tahoe/CHK/Capability.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK/Capability.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Tahoe.CHK.Capability (CHK (..), Reader (..), Verifier (..), makeReader, pCapability, pVerifier, pReader, dangerRealShow) where + +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.Void (Void) +import Data.Word (Word16, Word64) +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. +-} +type Parser = Parsec Void T.Text + +{- | The maximum number of shares it is possible for CHK-encoded data to be + divided in to. +-} +maxShares :: Word16 +maxShares = 256 + +-- | The maximum size of the application data represented by a set of shares. +maxDataSize :: Integer +maxDataSize = fromIntegral (maxBound :: Word64) + +{- | Represent a CHK "verify" capability. This capability type can be used to + verify the existence and validity (bit-level) of shares for the associated + piece of plaintext. + + It can also be used to repair unhealthy data (I think?) +-} +data Verifier = Verifier + { -- | The storage index of a verify capability is used as the key into the + -- 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 + , -- | 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 + , -- | 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 + , -- | 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 + , -- | 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 + } + deriving (Ord, Eq) + +{- | 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. +-} +shorten :: Int -> T.Text -> T.Text +shorten n = (<> "...") . T.take n + +-- | Show a value as Text. +showT :: Show s => s -> T.Text +showT = T.pack . show + +-- | Show a ByteString using a base32-encoded representation. +showBase32 :: B.ByteString -> T.Text +showBase32 = T.toLower . B.encodeBase32Unpadded + +-- | A version of bounded specialized to parsing text. +bounded :: (Ord n, Integral n) => n -> n -> Parser n +bounded = Tahoe.CHK.Parsing.bounded decimal + +instance Show Verifier where + show Verifier{storageIndex, fingerprint, required, total, size} = + T.unpack $ + T.intercalate + ":" + [ "URI" + , "CHK-Verifier" + , shorten 4 . showBase32 $ storageIndex + , shorten 4 . showBase32 $ fingerprint + , showT required + , showT total + , showT size + ] + +{- | Represent a CHK "read" capability. This capability type can be diminished + to a verify capability so it confers all of the abilities of a verify + capability. It can also be used to decrypt shares to reconstruct the + original plaintext. See makeReader for a safe constructor that correctly + derives the verify capability. +-} +data Reader = Reader + { -- | The read key of a read capability is used as the symmetric encryption + -- 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 + , -- | The verify capability for this read capability. + verifier :: Verifier + } + +-- 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. +instance Eq Reader where + left == right = readerKey left == readerKey right + +instance Ord Reader where + compare left right = compare (readerKey left) (readerKey right) + +{- | 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} = + 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 + ] + +-- 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) + +{- | 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 + somewhere else. There are two forms of CHK capabilities: verify and read. + See *Verifier* and *Reader* for details. +-} +data CHK = CHKVerifier Verifier | CHKReader Reader deriving (Ord, Eq) + +{- | Serialize a CHK capability to text. This operation is "dangerous" in + that it will serialize the encryption key of a read capability into the + text. Since the encryption key is necessary and (practically) sufficient + to recover the original plaintext associated with the capability, it must + be handled carefully to avoid unintentional disclosure. Serializing the + key to a string is a good way to accidentally disclose it! Be warned. + + The text is in the canonical form, originally used by the Python + implementation of Tahoe-LAFS. +-} +dangerRealShow :: CHK -> T.Text +dangerRealShow (CHKVerifier (Verifier{storageIndex, fingerprint, required, total, size})) = + T.intercalate + ":" + [ "URI" + , "CHK-Verifier" + , showBase32 storageIndex + , showBase32 fingerprint + , showT required + , showT total + , showT size + ] +dangerRealShow (CHKReader (Reader{readKey, verifier})) = + T.intercalate + ":" + [ "URI" + , "CHK" + , showBase32 . encode $ readKey + , showBase32 . fingerprint $ verifier + , showT . required $ verifier + , showT . total $ verifier + , showT . size $ verifier + ] + +{- | A parser combinator for parsing either a verify or read CHK capability + from the canonical format. This is the moral inverse of dangerRealShow. +-} +pCapability :: Parser CHK +pCapability = try (CHKVerifier <$> pVerifier) <|> (CHKReader <$> pReader) + +-- | A parser combinator for parsing a CHK verify capability. +pVerifier :: Parser Verifier +pVerifier = + Verifier + <$> (string "URI:CHK-Verifier:" *> pBase32 rfc3548Alphabet 128) + <* char ':' + <*> pBase32 rfc3548Alphabet 256 + <* char ':' + <*> bounded 1 maxShares + <* char ':' + <*> bounded 1 maxShares + <* char ':' + <*> bounded 1 maxDataSize + +-- | A parser combinator for parsing a CHK read capability. +pReader :: Parser Reader +pReader = + 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 + ) + <* char ':' + <*> pBase32 rfc3548Alphabet 256 + <* char ':' + <*> bounded 1 256 + <* char ':' + <*> bounded 1 256 + <* char ':' + <*> bounded 1 maxDataSize + +{- | 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) + +{- | Given all of the fields of a CHK read capability, derive and return the + corresponding CHK verify capability. +-} +deriveVerifier :: + -- | The read key + AESKey128 -> + -- | The fingerprint + B.ByteString -> + -- | The required number of shares + Word16 -> + -- | The total number of shares + Word16 -> + -- | The plaintext size + Integer -> + Verifier +deriveVerifier = Verifier . storageIndexHash + +{- | A parser combinator for an arbitrary byte string of a fixed length, + encoded using base32. +-} +pBase32 :: + -- | The alphabet to use. For example, *rfc3548Alphabet*. + [Char] -> + -- | The number of bits in the encoded byte string. + Word16 -> + -- | A parser for the byte string. Strings that are not valid base32 will + -- be rejected. Strings that are the wrong length are *not necessarily* + -- currently rejected! Please fix that, somebody. + Parser B.ByteString +pBase32 alpha bits = do + b32Text <- pBase32Text + either (fancyFailure . Set.singleton . ErrorFail . T.unpack) pure (decodeBase32Text b32Text) + where + decodeBase32Text = B.decodeBase32Unpadded . T.encodeUtf8 + pBase32Text = T.snoc <$> stem <*> trailer + + -- Determine how many full characters to expect along with how many bits + -- are left to expect encoded in the final character. + (full, extra) = bits `divMod` 5 + + -- Match the base32 characters that represent the full 5 bits + -- possible. fromIntegral is okay here because `full` is only a + -- Word16 and will definitely fit safely into the Int count wants. + stem :: Parser T.Text + stem = T.pack <$> count (fromIntegral full) (oneOf alpha) + + -- Match the final character that represents fewer than 5 bits. + trailer :: Parser Char + trailer = oneOf $ trailingChars alpha extra + + -- XXX The real trailing character set is smaller than this. This + -- parser will let through invalid characters that result in giving us + -- possibly too many bits. + trailingChars :: [Char] -> Word16 -> [Char] + trailingChars alpha' _ = alpha' + +{- | The RFC3548 standard alphabet used by Gnutella, Content-Addressable Web, + THEX, Bitzi, Web-Calculus... +-} +rfc3548Alphabet :: [Char] +rfc3548Alphabet = "abcdefghijklmnopqrstuvwxyz234567" diff --git a/src/Tahoe/CHK/Crypto.hs b/src/Tahoe/CHK/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK/Crypto.hs @@ -0,0 +1,139 @@ +module Tahoe.CHK.Crypto ( + sha1, + sha256, + sha256d, + storageIndexLength, + taggedHash, + taggedPairHash, + blockHash, + storageIndexHash, + ciphertextTag, + ciphertextSegmentHash, + uriExtensionHash, + convergenceEncryptionTag, + convergenceEncryptionHashLazy, + convergenceSecretLength, +) where + +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, + hash, + hashDigestSize, + hashlazy, + ) +import Crypto.Types (ByteLength) + +import Crypto.Hash.Algorithms ( + SHA1, + SHA256 (SHA256), + ) + +import Crypto.Cipher.AES128 ( + AESKey128, + ) + +import Tahoe.Netstring ( + netstring, + ) + +import Tahoe.CHK.URIExtension ( + URIExtension, + showBytes, + uriExtensionToBytes, + ) + +import Tahoe.CHK.Types (Parameters (Parameters), StorageIndex) + +toBytes :: Digest a -> B.ByteString +toBytes = B.pack . BA.unpack + +sha1 :: B.ByteString -> B.ByteString +sha1 xs = toBytes (hash xs :: Digest SHA1) + +sha256 :: B.ByteString -> B.ByteString +sha256 xs = toBytes (hash xs :: Digest SHA256) + +sha256d :: B.ByteString -> B.ByteString +sha256d = sha256 . sha256 + +taggedHash :: Int -> B.ByteString -> B.ByteString -> B.ByteString +taggedHash size tag bytes = B.take size . sha256d . 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] + +blockTag :: B.ByteString +blockTag = "allmydata_encoded_subshare_v1" + +-- allmydata.util.hashutil.block_hash +blockHash :: B.ByteString -> B.ByteString +blockHash = taggedHash (hashDigestSize SHA256) 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 + +ciphertextTag :: B.ByteString +ciphertextTag = "allmydata_crypttext_v1" + +ciphertextSegmentTag :: B.ByteString +ciphertextSegmentTag = "allmydata_crypttext_segment_v1" + +ciphertextSegmentHash :: B.ByteString -> B.ByteString +ciphertextSegmentHash = taggedHash (hashDigestSize SHA256) ciphertextSegmentTag + +uriExtensionTag :: B.ByteString +uriExtensionTag = "allmydata_uri_extension_v1" + +uriExtensionHash :: URIExtension -> B.ByteString +uriExtensionHash = taggedHash (hashDigestSize SHA256) uriExtensionTag . uriExtensionToBytes + +convergenceEncryptionTagPrefix :: B.ByteString +convergenceEncryptionTagPrefix = "allmydata_immutable_content_to_key_with_added_secret_v1+" + +convergenceEncryptionTag :: B.ByteString -> Parameters -> B.ByteString +convergenceEncryptionTag secret (Parameters segmentSize total _ required) = + tag + where + tag = B.concat [convergenceEncryptionTagPrefix, netstring secret, netstring paramTag] + paramTag = B.intercalate "," . map showBytes $ [requiredI, totalI, segmentSizeI] + requiredI = toInteger required + totalI = toInteger total + segmentSizeI = toInteger segmentSize + +-- Compute the strict convergence encryption hash on a lazy data parameter. +convergenceEncryptionHashLazy :: B.ByteString -> Parameters -> BL.ByteString -> B.ByteString +convergenceEncryptionHashLazy secret params bytes = + -- It was somewhat helpful during development/debugging to make this + -- function return this instead: + -- + -- BL.toStrict toHash + -- + B.take convergenceSecretLength theSHA256d + where + theSHA256d = toBytes (hash theSHA256 :: Digest SHA256) + theSHA256 = toBytes (hashlazy toHash :: Digest SHA256) + + toHash :: BL.ByteString + toHash = BL.concat [tag, bytes] + + tag = BL.fromStrict . netstring $ convergenceEncryptionTag secret params + +convergenceSecretLength :: ByteLength +convergenceSecretLength = 16 + +storageIndexLength :: ByteLength +storageIndexLength = 16 diff --git a/src/Tahoe/CHK/Encrypt.hs b/src/Tahoe/CHK/Encrypt.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK/Encrypt.hs @@ -0,0 +1,18 @@ +-- | Support the encryption requirements of CHK. +module Tahoe.CHK.Encrypt (encrypt, decrypt) where + +import Crypto.Cipher.AES128 (AESKey128, BlockCipher (ctrLazy), zeroIV) +import qualified Data.ByteString.Lazy as LB + +{- | AES128-CTR encrypt a byte string in the manner used by CHK. + + 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 + +-- | AES128-CTR decrypt a byte string in the manner used by CHK. +decrypt :: AESKey128 -> LB.ByteString -> LB.ByteString +decrypt = encrypt diff --git a/src/Tahoe/CHK/Merkle.hs b/src/Tahoe/CHK/Merkle.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK/Merkle.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Tahoe.CHK.Merkle ( + MerkleTree (MerkleNode, MerkleLeaf), + Direction (..), + leaf, + leafNumberToNodeNumber, + breadthFirstList, + merklePathLengthForSize, + makeTree, + makeTreePartial, + merkleProof, + neededHashes, + firstLeafNum, + rootHash, + pairHash, + emptyLeafHash, + size, + height, + mapTree, + merklePath, + leafHashes, + -- exported for testing in ghci + treeFromRows, + buildTreeOutOfAllTheNodes, +) where + +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 Data.List.HT ( + padLeft, + ) +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 Tahoe.CHK.Crypto ( + taggedHash, + taggedPairHash, + ) + +import Crypto.Hash (HashAlgorithm (hashDigestSize)) +import Crypto.Hash.Algorithms (SHA256 (SHA256)) +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). +-} +leaf :: B.ByteString -> MerkleTree +leaf bs + | B.length bs == 32 = MerkleLeaf bs + | otherwise = error $ "Constructed MerkleLeaf with hash of length " <> show (B.length bs) + +-- | Count the number of nodes in a tree. +size :: MerkleTree -> Int +size = sum . mapTree (const 1) + +-- | Measure the height of a tree. +height :: MerkleTree -> Int +height (MerkleLeaf _) = 1 +height (MerkleNode _ left _) = 1 + height left + +mapTree :: (MerkleTree -> a) -> MerkleTree -> [a] +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] + show (MerkleNode value left right) = + T.unpack $ + T.concat + [ "MerkleNode " :: T.Text + , encodeBase32Unpadded value + , " (" + , T.pack $ show left + , ")" + , " (" + , T.pack $ show right + , ")" + ] + +emptyLeafHash :: Int -> B.ByteString +emptyLeafHash = taggedHash (hashDigestSize SHA256) "Merkle tree empty leaf" . encodeUtf8 . pack . show + +pairHash :: B.ByteString -> B.ByteString -> B.ByteString +pairHash = taggedPairHash (hashDigestSize SHA256) "Merkle tree internal node" + +rootHash :: MerkleTree -> B.ByteString +rootHash (MerkleLeaf value) = value +rootHash (MerkleNode value _ _) = value + +-- Like makeTree but error on empty list +makeTreePartial :: [B.ByteString] -> MerkleTree +makeTreePartial = unJust . makeTree + where + unJust Nothing = error "Merkle.makeTreePartial failed to make a tree" + unJust (Just t) = t + +-- 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 [] = 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 leaves' = leaves' ++ padding (length leaves') + + -- Create the padding for the pad function. The number of leaves in the + -- tree must be a power of 2 (a height zero tree has 2 ^ 0 leaves, a + -- height one tree has 2 ^ 1 leaves, etc) so compute a number of empty + -- leaves that when added to the non-empty leaves gives us a power of 2. + -- This could be none if we happened to already have a number of leaves + -- that is a power of 2. + -- + -- This function assumes that the number of non-empty leaves is at least + -- 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 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' xs = + makeNode (makeTree' left) (makeTree' right) + where + (left, right) = splitAt (length xs `div` 2) xs + + -- 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 + +-- | Represent a direction to take when walking down a binary tree. +data Direction = TurnLeft | TurnRight deriving (Show, Ord, Eq) + +{- | Return a list of tuples of node numbers and corresponding merkle hashes. + The node numbers correspond to a numbering of the nodes in the tree where the + 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 tree targetLeaf = merkleProof' 1 tree $ merklePath (height tree) targetLeaf + +{- | Compute the path to a leaf from the root of a merkle tree of a certain + height. +-} +merklePath :: Int -> Int -> [Direction] +merklePath height' leafNum = padLeft TurnLeft (height' - 1) (toBinary TurnLeft TurnRight leafNum) + +-- | Compute the length of a merkle path through a tree of the given height. +merklePathLengthForSize :: Int -> Int +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 tree = traverse' [tree] + where + traverse' :: [MerkleTree] -> [B.ByteString] + traverse' [] = [] + traverse' trees = + [rootHash tree' | tree' <- trees] ++ traverse' (concat [children tree'' | tree'' <- trees]) + + children (MerkleLeaf _) = [] + children (MerkleNode _ left right) = [left, right] + +{- | 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' _ _ [] = Just [] +merkleProof' thisNodeNum (MerkleNode _ left right) (d : ds) = + case d of + TurnLeft -> + ((rightChildNum, rootHash right) :) <$> merkleProof' leftChildNum left ds + TurnRight -> + ((leftChildNum, rootHash left) :) <$> merkleProof' rightChildNum right ds + where + leftChildNum = thisNodeNum * 2 + rightChildNum = thisNodeNum * 2 + 1 +merkleProof' _ (MerkleLeaf _) ds = error $ show ds + +{- | Translate a leaf number to a node number. Leaf numbers are zero indexed + 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 tree leafNum = 1 + leafNum + firstLeafNum tree + +{- | 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 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 tree = size tree `div` 2 + +{- | Serialize a MerkleTree to bytes by concatenating all of the leaf hashes + left to right. + + This serialization includes no framing so the only thing we can do is + 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 + get = + getRemainingLazyByteString + >>= maybe (fail "could not construct MerkleTree") pure + . buildTreeOutOfAllTheNodes + . chunkedBy (hashDigestSize SHA256) + . LBS.toStrict + +-- | Get a list of all of the leaf hashes of a tree from left to right. +leafHashes :: MerkleTree -> [B.ByteString] +leafHashes (MerkleLeaf h) = [h] +leafHashes (MerkleNode _ l r) = leafHashes l <> leafHashes r + +{- | Make a merkle tree out of a flat list of all nodes (start from + 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 nodes + | validMerkleSize nodes = Just (head (treeFromRows [] (clumpRows powersOfTwo nodes))) + | otherwise = Nothing + +{- | Increasing consecutive powers of 2 from 2 ^ 0 to the maximum value + representable in `Int`. +-} +powersOfTwo :: [Int] +powersOfTwo = (2 ^) <$> [0 :: Int .. 62] + +{- | Determine whether a list of nodes is a possible representation of a + merkle tree. + + It is possible if the number of elements in the list is one less than a + positive power of 2. +-} +validMerkleSize :: [a] -> Bool +validMerkleSize nodes = + head (dropWhile (< size') (tail powersOfTwo)) == size' + where + size' = length nodes + 1 + +{- | Reorganize a flat list of merkle tree node values into a list of lists of + merkle tree node values. Each inner list gives the values from left to right + at a particular height in the tree. The head of the outer list gives the + leaves. +-} +clumpRows :: + -- | The numbers of elements of the flat list to take to make this (the + -- head) and subsequent (the tail) clumps. + [Int] -> + -- | The values of the nodes themselves. + [B.ByteString] -> + [[B.ByteString]] +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 :: + -- | Some children to attach to a list of nodes representing the next + -- shallowest level of the tree. + [MerkleTree] -> + -- | The values of the nodes to create at the next shallowest level of the + -- tree. + [[B.ByteString]] -> + -- | The nodes forming the shallowest level of the tree. If we built a + -- full tree, there will be exactly one node here. + [MerkleTree] +-- 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 +treeFromRows children [] = children +-- with only a single thing in the "rest", we're at the root +treeFromRows [left, right] [[root]] = [MerkleNode root left right] +-- this recursion is harder to think about: we want to "collect" done +-- stuff from the first argument and build it up into a tree. kind of. +treeFromRows (left : right : children) (row : rest) = treeFromRows (mTree (left : right : children) row) rest +treeFromRows x y = error $ "treeFromRows not sure what to do with " <> show x <> " " <> show y + +-- this does the "second recursion"; see above -- building out a row +-- of parents from children + parent node content +mTree :: [MerkleTree] -> [B.ByteString] -> [MerkleTree] +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 diff --git a/src/Tahoe/CHK/Parsing.hs b/src/Tahoe/CHK/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK/Parsing.hs @@ -0,0 +1,25 @@ +module Tahoe.CHK.Parsing where + +import qualified Data.Set as Set +import Text.Megaparsec (ErrorFancy (ErrorFail), MonadParsec, fancyFailure) + +-- | Parse an integral with lower and upper value constraints. +bounded :: + (MonadParsec e s m, Ord n, Integral n) => + -- | A parser for an arbitrarily large integral value. + m Integer -> + -- | The smallest allowed value. + n -> + -- | The largest allowed value. + n -> + -- | A parser that succeeds only for integers within the given bounds. + m n +bounded decimal low high = do + -- Parse into an integer so there's no wrap-around + v <- decimal + if v < fromIntegral low + then fancyFailure (Set.singleton (ErrorFail "below minimum allowed value")) + else + if v > fromIntegral high + then fancyFailure (Set.singleton (ErrorFail "above maximum allowed value")) + else pure (fromIntegral v) diff --git a/src/Tahoe/CHK/Server.hs b/src/Tahoe/CHK/Server.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK/Server.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE RecordWildCards #-} + +module Tahoe.CHK.Server where + +import Data.Aeson ( + FromJSON (..), + ToJSON (..), + object, + withObject, + (.:), + (.:?), + (.=), + ) +import qualified Data.ByteString as B +import Data.ByteString.Base32 (decodeBase32Unpadded, encodeBase32Unpadded) +import Data.List (sortOn) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Tahoe.CHK.Crypto (sha1, sha256) +import Tahoe.CHK.Types (Offset, ShareNum, StorageIndex) + +-- Where can a server be found +type URL = T.Text + +-- The unique identifier for a particular storage server, conventionally the +-- lowercase base32 encoding of some public key controlled by the server. +type StorageServerID = T.Text + +-- | An announcement from a storage server about its storage service. +data StorageServerAnnouncement = StorageServerAnnouncement + { storageServerAnnouncementFURL :: Maybe URL + , storageServerAnnouncementNick :: Maybe T.Text + , storageServerAnnouncementPermutationSeed :: Maybe B.ByteString + } + deriving (Eq, Ord, Show) + +-- A server that can have some data uploaded to it. +data StorageServer = StorageServer + { storageServerID :: StorageServerID + , -- TODO Strict byte strings here are unfortunate. They will force whole + -- chunks of data into memory at once. + storageServerWrite :: StorageIndex -> ShareNum -> Offset -> B.ByteString -> IO () + , storageServerRead :: StorageIndex -> ShareNum -> IO B.ByteString + , storageServerGetBuckets :: StorageIndex -> IO (Set.Set ShareNum) + } + +instance Eq StorageServer where + a == b = storageServerID a == storageServerID b + +instance Ord StorageServer where + a <= b = storageServerID a <= storageServerID b + +instance Show StorageServer where + show ss = show $ storageServerID ss + +type ShareMap = Map.Map ShareNum (Set.Set StorageServer) + +instance FromJSON StorageServerAnnouncement where + parseJSON = withObject "StorageServerAnnouncement" $ \ann -> do + v <- ann .: "ann" + storageServerAnnouncementFURL <- v .:? "anonymous-storage-FURL" + storageServerAnnouncementNick <- v .:? "nickname" + permutationSeed <- v .:? "permutation-seed-base32" + let storageServerAnnouncementPermutationSeed = + case permutationSeed of + Nothing -> Nothing + Just txt -> case decodeBase32Unpadded . encodeUtf8 $ txt of + Left _ -> Nothing + Right ps -> Just ps + + pure StorageServerAnnouncement{..} + +instance ToJSON StorageServerAnnouncement where + toJSON StorageServerAnnouncement{..} = + object + [ "ann" + .= object + [ "anonymous-storage-FURL" .= storageServerAnnouncementFURL + , "nickname" .= storageServerAnnouncementNick + , "permutation-seed-base32" + .= (encodeBase32Unpadded <$> storageServerAnnouncementPermutationSeed) + ] + ] + +{- | Find the preferred order of servers for an object with the given index. + + This is like allmydata.storage_client.StorageFarmBroker.get_servers_for_psi +-} +preferredServers :: StorageIndex -> Map.Map T.Text StorageServerAnnouncement -> [(StorageServerID, StorageServerAnnouncement)] +preferredServers storageIndex = sortOn permutedServerHash . Map.toList + where + permutedServerHash = + -- allmydata.util.hashutil.permute_server_hash + sha1 . (storageIndex <>) . uncurry storageServerPermutationSeed + +{- | Compute a sort key for a storage server given its identifier and storage + service announcement. + + This is like pieces of allmydata.storage_client._parse_announcement +-} +storageServerPermutationSeed :: StorageServerID -> StorageServerAnnouncement -> B.ByteString +storageServerPermutationSeed serverId ann = + case storageServerAnnouncementPermutationSeed ann of + Just bs -> bs + Nothing -> + case decodeBase32Unpadded . encodeUtf8 . T.drop 3 $ serverId of + Right bs -> bs + Left _ -> sha256 . encodeUtf8 $ serverId diff --git a/src/Tahoe/CHK/Share.hs b/src/Tahoe/CHK/Share.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK/Share.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +-- To read all the plaintext of a CHK share which you have enough shares for: + +-- (-1). Find and download the shares +-- ( 0). Parse the share bytes into the various fields + +-- 1. Check the UEB (URI Extension Block) hash +-- 2. Decode the UEB to find the share root hash +-- 3. Build the block hash tree for all shares you have +-- 4. Build the share hash tree out of those block hash tree roots combined with all of the "needed hashes" you pulled out of the shares you have +-- 5. Check the root of the share hash tree against the value in the UEB +-- 6. ZFEC decode the blocks into ciphertext ** +-- 7. Check the "crypttext hash" against the hash of the ciphertext +-- (maybe helps catch a ZFEC implementation bug?) +-- 8. Decrypt the ciphertext ** + +-- 3 of 4 +-- Have 4, 5, 6 +-- neededHashes a == [ 5, 6, 7 ] + +-- 1 +-- 2 3 +-- 4 5 6 7 +-- a b c d +-- ^ +-- 5+"5s hash"+6+"6s hash"+7+"7s hash" + +{- | +A share is a single data object comprising some erasure-encoded data and some +cryptographic hashes which allow certain determinations to be made about that +that data. One or more shares can be interpreted together, typically to +recover a particular ciphertext object. + +This modules exposes a structured representation of the share object along +with an encoder to and decoder from the canonical serialized representation. +-} +module Tahoe.CHK.Share where + +import Control.Exception (Exception, throw) +import Data.Binary ( + Binary (get, put), + Word32, + Word64, + Word8, + encode, + ) +import Data.Binary.Get ( + Get, + bytesRead, + getLazyByteString, + isolate, + ) +import Data.Binary.Put (Put, putLazyByteString) +import Data.Bits (shiftL, (.|.)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Either (fromRight) +import Data.Int (Int64) +import Data.List.Extra (dropEnd, sumOn') +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.Types (ShareNum) +import Tahoe.CHK.URIExtension ( + URIExtension, + pURIExtension, + uriExtensionToBytes, + ) +import Tahoe.Util (chunkedBy, toStrictByteString) +import Text.Megaparsec (parse) + +-- | Structured representation of a single CHK share. +data Share = Share + { -- | The ZFEC block size. Legacy value. Unused. + shareBlockSize :: Word64 + , -- | The share data length. Legacy value. Unused. + shareDataSize :: Word64 + , -- | The ZFEC encoded ciphertext blocks. + shareBlocks :: [LBS.ByteString] + , -- | A merkle tree of plaintext segment hashes. Unimplemented. + sharePlaintextHashTree :: MerkleTree + , -- | A merkle tree of ciphertext segment hashes. + shareCrypttextHashTree :: MerkleTree + , -- | A merkle tree of hashes of `shareBlocks`. + shareBlockHashTree :: MerkleTree + , -- | The information needed to complete a merkle proof for this share. + shareNeededHashes :: [(ShareNum, BS.ByteString)] + , -- | Additional metadata about this share. + shareURIExtension :: URIExtension + } + deriving (Eq, Ord, Show, Generic, ToExpr) + +getWord32 :: Get Word64 +getWord32 = do + word32 <- get :: Get Word32 + pure $ fromIntegral word32 + +getWord64 :: Get Word64 +getWord64 = get + +word64To4Bytes :: Word64 -> Maybe BS.ByteString +word64To4Bytes = (bytestring32 <$>) . word64ToWord32 + +word64To4Bytes' :: Word64 -> Either String BS.ByteString +word64To4Bytes' w = + case word64To4Bytes w of + Nothing -> Left "Word64 out of bounds in conversion to Word32" + Just bs -> pure bs + +word64To8Bytes :: Word64 -> BS.ByteString +word64To8Bytes = bytestring64 + +instance Binary Share where + -- 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 + } = + 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, + -- we'll use this computed value that's consistent with the + -- rest of our data. + -- + -- CRSEncoder.set_params + realSize = sumOn' LBS.length shareBlocks + + -- Pick a share format version based on the size of our data, + -- along with helpers to encoding our fields for that format + -- version. + -- + -- Okay we won't completely ignore shareDataSize. We can't + -- encode sufficiently large values into a v1 format share so + -- switch to v2 format if shareDataSize needs it. + -- + -- 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) + + -- This excludes the version but otherwise has all of the integer + -- header fields we need to write. + header = + [ shareBlockSize + , shareDataSize + , (fromIntegral :: Int -> Word64) headerSize + ] + <> trailerFieldOffsets + + -- Compute the header size so we can include it in the offset + -- calculation. The header is the 4 byte version field and then some + -- additional number of integer fields. Each subsequent integer field + -- is either 4 or 8 bytes depending on the share version. + headerSize = 4 + fieldSizeForVersion version * length header + + -- Then compute the offset of each piece of the trailer. They all + -- follow the header and all of the share blocks so start there and + -- advance by the size of each trailer piece. + trailerOffset = (fromIntegral :: Int -> Word64) headerSize + int64ToWord64 realSize + + -- The scanl would calculate the offset of the field following the + -- last field - which we don't need or want. So drop the last size. + trailerFieldOffsets = scanl (+) trailerOffset (dropEnd 1 trailerFieldSizes) + + -- We need to write offets to trailer fields into the header. Compute + -- the size of each trailer piece so we know how they'll be laid out. + trailerFieldSizes = map (int64ToWord64 . LBS.length) trailerFields + + -- Construct all of the trailing metadata here so we know how + -- big each piece of it is. We need to put offsets pointing + -- at this data into the header. Keep in mind that nearby + -- code assumes this list contains one element for each + -- 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 + trailerFields = + [ encode sharePlaintextHashTree + , encode shareCrypttextHashTree + , encode shareBlockHashTree + , LBS.fromStrict $ serializeNeededShares shareNeededHashes + , LBS.fromStrict $ encodeWord (intToWord64 $ BS.length ueb) <> ueb + ] + in do + put (fromIntegral version :: Word32) + mapM_ putWord header + mapM_ putLazyByteString shareBlocks + 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 + + -- These offsets are all relative to the beginning of the share. + dataOffset <- getWord -- 12, 36 + plaintextHashTreeOffset <- getWord -- 16, 37 + crypttextHashTreeOffset <- getWord -- 20, 69 + blockHashesOffset <- getWord -- 24, 101 + shareHashesOffset <- getWord -- 28, 133 + uriExtensionLengthOffset <- getWord -- 32, 167 + + -- Load the rest of the fields in the typical order. The offsets + -- might place these fields in a different order but they really + -- shouldn't. We'll fail with an explicit error in that case thanks + -- to position checking done in getLazyByteStringInBoundsFrom. Then + -- 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> + uriExtensionLength <- getWord >>= getInt64FromWord64 "URI extension length" -- 167, + uriExtensionBytes <- getLazyByteString uriExtensionLength + shareURIExtension <- + either + (fail . show) + pure + (parse pURIExtension "URI extension" $ LBS.toStrict uriExtensionBytes) + + let shareBlocks = segmentLazyBytes (fromIntegral shareBlockSize) allShareBlocks + + pure $ Share{..} + +segmentLazyBytes :: Int64 -> LBS.ByteString -> [LBS.ByteString] +segmentLazyBytes _segmentSize "" = [] +segmentLazyBytes segmentSize bs = nextSegment : segmentLazyBytes segmentSize theRest + where + (nextSegment, theRest) = LBS.splitAt segmentSize bs + +isolateBetween :: String -> Word64 -> Word64 -> Get a -> Get a +isolateBetween name start end g = do + pos <- bytesRead + if (fromIntegral :: Int64 -> Word64) pos /= start + then fail $ "expected to read from " <> show start <> " to get " <> name <> " but position is " <> show pos + else isolate (fromIntegral (end - start)) g + +getLazyByteStringInBoundsFrom :: String -> Word64 -> Word64 -> Get LBS.ByteString +getLazyByteStringInBoundsFrom name expectedPosition offset = do + pos <- bytesRead + if (fromIntegral :: Int64 -> Word64) pos /= expectedPosition + then fail $ "expected to read from " <> show expectedPosition <> " to get " <> name <> " but position is " <> show pos + else do + offsetInt64 <- getInt64FromWord64 name offset + getLazyByteString (offsetInt64 - pos) + +getInt64FromWord64 :: String -> Word64 -> Get Int64 +getInt64FromWord64 name = maybe (fail $ name <> " out of bounds") pure . word64ToInt64 + +word64ToInt64 :: Word64 -> Maybe Int64 +word64ToInt64 w + | w > maxInt64 = Nothing + | otherwise = Just (fromIntegral w) + where + maxInt64 :: Word64 + maxInt64 = fromIntegral (maxBound :: Int64) + +word64ToWord32 :: Word64 -> Maybe Word32 +word64ToWord32 w + | w > maxWord32 = Nothing + | otherwise = Just (fromIntegral w) + +maxWord32 :: Integral i => i +maxWord32 = fromIntegral (maxBound :: Word32) + +serializeNeededShares :: [(ShareNum, BS.ByteString)] -> 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) + +unserializeNeededShares :: BS.ByteString -> [(ShareNum, BS.ByteString)] +unserializeNeededShares bs = + result + where + chunks = chunkedBy (2 + 32) bs + pairs = map (BS.splitAt 2) chunks + result = map (mapFst toShareNum) pairs + + toShareNum :: BS.ByteString -> ShareNum + toShareNum x = fromIntegral $ fromEnum msb `shiftL` 8 .|. fromEnum lsb + where + msb = BS.head x + lsb = BS.last x + +intToWord64 :: Int -> Word64 +intToWord64 x + | x < 0 = error "Negative Int cannot be converted to Word64" + | otherwise = fromIntegral x + +int64ToWord64 :: Int64 -> Word64 +int64ToWord64 x + | x < 0 = error "Negative Int64 cannot be converted to Word64" + | otherwise = fromIntegral x + +getVersion :: Get (Word8, Get Word64) +getVersion = do + version <- getWord32 + pure + ( fromIntegral version + , case version of + 1 -> getWord32 + 2 -> getWord64 + _ -> fail $ "unsupported version: " <> show version + ) + +chooseVersion :: Word64 -> (Word8, Word64 -> BS.ByteString, Word64 -> Put) +chooseVersion shareDataSize = + (version, encodeWord, putWord) + where + -- Version 1 can encode sizes up to 2^32 bytes. Version 2 can encode + -- sizes up to 2^64 bytes. Choose a version based on the actual data + -- size. We only save a handful bytes of header this way so the extra + -- complexity may not be worth it just for that but it's convenient to + -- be able to emit either share version for testing. + version = if shareDataSize <= maxWord32 then 1 else 2 + + -- Here's where the version makes a difference to the header size. + -- Choose an integer encoding that uses the right number of bytes. + encodeWord + -- word64To4Bytes can't always succeed but if we're picking version 1 then + -- we believe it will succeed. If it fails, we'll have to have a hard + -- error :/ This is not ideal but ... I dunno what to do. + | version == 1 = word64To4BytesPartial + | version == 2 = word64To8Bytes + | otherwise = error $ "unsupported version: " <> show version + putWord = putLazyByteString . LBS.fromStrict . encodeWord + +fieldSizeForVersion :: Word8 -> Int +fieldSizeForVersion 1 = 4 +fieldSizeForVersion 2 = 8 +fieldSizeForVersion n = error $ "Unsupported version number: " <> show n + +{- | Serialize a Word64 to 4 bytes or throw an exception if the value can not + fit. +-} +word64To4BytesPartial :: Word64 -> BS.ByteString +word64To4BytesPartial i = fromRight (throw $ Word64OutOfBounds i) (word64To4Bytes' i) + +newtype EncodingError = Word64OutOfBounds Word64 deriving (Eq, Ord, Show) + +instance Exception EncodingError diff --git a/src/Tahoe/CHK/Types.hs b/src/Tahoe/CHK/Types.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK/Types.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module Tahoe.CHK.Types where + +import Data.Word ( + Word16, + Word8, + ) + +import qualified Data.ByteString as B +import Data.TreeDiff.Class (ToExpr) +import GHC.Generics (Generic) + +-- 16 bytes +type StorageIndex = B.ByteString + +-- How much data is there +type Size = Integer + +-- Byte-based position into a share +type Offset = Integer + +-- Segment-based position into a share +type SegmentNum = Int + +-- With respect to FEC encoding, the number of a share. +type ShareNum = Word8 + +-- The SHA256d hash of a FEC-encoded block +type BlockHash = B.ByteString + +-- The SHA256d hash of some ciphertext +type CrypttextHash = B.ByteString + +-- Erasure encoding / placement parameters +type Total = Word16 +type Happy = ShareNum -- This is not like the others. +type Required = Word16 +type SegmentSize = Size +data Parameters = Parameters + { paramSegmentSize :: SegmentSize + , paramTotalShares :: Total + , paramHappyShares :: Happy + , paramRequiredShares :: Required + } + deriving (Show, Ord, Eq, Generic, ToExpr) + +requiredToInt :: Required -> Int +requiredToInt = fromIntegral + +totalToInt :: Total -> Int +totalToInt = fromIntegral diff --git a/src/Tahoe/CHK/URIExtension.hs b/src/Tahoe/CHK/URIExtension.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK/URIExtension.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Tahoe.CHK.URIExtension ( + URIExtension (..), + uriExtensionToBytes, + showBytes, + pURIExtension, +) where + +import Control.Applicative.Combinators (count) +import Control.Applicative.Permutations (runPermutation, toPermutation) +import Control.Monad (join, void) +import Data.TreeDiff.Class (ToExpr) +import Data.Void (Void) +import GHC.Generics (Generic) + +import Text.Megaparsec ( + MonadParsec (takeP), + Parsec, + anySingle, + ) +import Text.Megaparsec.Byte (string) +import Text.Megaparsec.Byte.Lexer (decimal) + +import Data.ByteString.Base32 ( + encodeBase32Unpadded, + ) + +import qualified Data.ByteString as B +import qualified Data.Text as T +import Data.Text.Encoding ( + decodeLatin1, + encodeUtf8, + ) + +import Data.List ( + sort, + ) + +import qualified Tahoe.CHK.Parsing +import Tahoe.CHK.Types ( + CrypttextHash, + Parameters (..), + Required, + SegmentNum, + Size, + Total, + ) + +import Tahoe.Netstring ( + netstring, + ) + +-- | 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 + , -- | The parameters for the encoding function for all except the final + -- segment. + uriExtCodecParams :: Parameters + , -- | The parameters for the encoding function for the final segment. + uriExtTailCodecParams :: Parameters + , -- | The application data size in bytes. + uriExtSize :: Size + , -- | The individual segment size in bytes. + uriExtSegmentSize :: 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 + , -- | The required (K) parameter to the encoding function. This is a + -- duplicate of the values in uriExtCodecParams and uriExtTailCodecParams. + uriExtNeededShares :: Required + , -- | The total (N) parameter to the encoding function. This too is a + -- duplicate. + uriExtTotalShares :: Total + , -- | A tagged sha256d hash of the complete ciphertext. + uriExtCrypttextHash :: CrypttextHash + , -- | The root hash of a merkle tree where the leaf hashes are of segments of ciphertext. + uriExtCrypttextRootHash :: CrypttextHash + , -- | The root hash of a merkle tree where leaf hashes are the root hashes of all of the block hash trees. + uriExtShareRootHash :: CrypttextHash + } + deriving (Eq, Ord, Generic, ToExpr) + +instance Show URIExtension where + show (URIExtension name params tailParams size segSize numSegs needed total hash1 hash2 hash3) = + T.unpack . T.concat $ + [ "URIExtension { " + , "codec = " + , decodeLatin1 name + , "; codec-params = " + , showText params + , "; tail-codec-params = " + , showText tailParams + , "; size = " + , showText size + , "; segment-size = " + , showText segSize + , "; num-segments = " + , showText numSegs + , "; needed-shares = " + , showText needed + , "; total-shares = " + , showText total + , "; crypttext-hash = " + , showText $ b32 hash1 + , "; crypttext-root-hash = " + , showText $ b32 hash2 + , "; share-root-hash = " + , showText $ b32 hash3 + , " }" + ] + where + showText :: Show s => s -> T.Text + showText = T.pack . show + b32 = encodeBase32Unpadded + +-- 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 + ] + +type Parser = Parsec Void B.ByteString + +-- | A version of bounded specialized to parsing bytestrings. +bounded :: (Ord n, Integral n) => n -> n -> Parser n +bounded = Tahoe.CHK.Parsing.bounded decimal + +{- | Parse the representation of a URIExtension which appears in CHK shares + back into a URIExtension. +-} +pURIExtension :: Parser URIExtension +pURIExtension = + runPermutation $ + URIExtension + <$> toPermutation (B.pack <$> pField "codec_name" (`count` anySingle)) + <*> toPermutation (pField "codec_params" $ const pParameters) + <*> toPermutation (pField "tail_codec_params" $ const pParameters) + <*> toPermutation (pField "size" $ const decimal) + <*> toPermutation (pField "segment_size" $ const decimal) + <*> 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) + +-- | Parse one field of a serialized URIExtension. +pField :: + -- | The serialized label for the field. + B.ByteString -> + -- | A function that takes the length of the field value and returns a parser for the field value. + (Int -> Parser a) -> + -- | A parser for the field. + Parser a +pField label pInner = do + void $ string (label <> ":") + len <- decimal -- XXX Could overflow + void $ string ":" + result <- pInner len + void $ string "," + pure result + +-- | Serialize some named URIExtension fields to bytes. +toWeirdString :: + -- | A list of pairs of field names and functions to get serialized + -- field values. + [(B.ByteString, URIExtension -> B.ByteString)] -> + -- | The URIExtension to get the field values from. + URIExtension -> + -- | The concatenation of all of the serialized fields. + B.ByteString +toWeirdString fields ext = + B.concat . join . sort $ map (encodedField ext) fields + where + encodedField ext' (name, extract) = + [name, ":", netstring (extract ext')] + +-- | Show a value as a UTF-8-encoded byte string. +showBytes :: (Show s) => s -> B.ByteString +showBytes = encodeUtf8 . T.pack . show + +{- | Serialize Parameters to a byte string in the format it appears within the + URI extension block in a CHK share. +-} +paramsToBytes :: Parameters -> B.ByteString +paramsToBytes Parameters{paramSegmentSize, paramTotalShares, paramRequiredShares} = + B.concat [showBytes paramSegmentSize, "-", showBytes paramRequiredShares, "-", showBytes paramTotalShares] + +{- | Parse a serialized Parameters value in the format produced by + paramsToBytes. +-} +pParameters :: Parser Parameters +pParameters = + (\segSize required total -> Parameters{paramSegmentSize = segSize, paramRequiredShares = required, paramHappyShares = 1, paramTotalShares = total}) + <$> decimal + <* string "-" + <*> bounded 1 maxShares + <* string "-" + <*> bounded 1 maxShares + where + maxShares = 256 diff --git a/src/Tahoe/CHK/Upload.hs b/src/Tahoe/CHK/Upload.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/CHK/Upload.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Tahoe.CHK.Upload ( + UploadResult (uploadResultReadCap, uploadResultExistingShares, uploadResultShareMap), + Uploadable (..), + Parameters (Parameters), + defaultParameters, + filesystemUploadable, + filesystemUploadableWithConvergence, + filesystemUploadableRandomConvergence, + memoryUploadableWithConvergence, + getConvergentKey, + upload, + store, + prettyFormatSharemap, + adjustSegmentSize, + encryptAndEncode, +) where + +import Control.Monad.Conc.Class ( + modifyIORefCAS, + ) + +import Data.Maybe ( + fromJust, + ) + +import Data.List ( + intersperse, + ) + +import Data.IORef ( + newIORef, + ) + +import qualified Data.Binary as Binary +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL + +import Data.Text ( + Text, + intercalate, + pack, + ) +import qualified Data.Text as Text + +import qualified Data.Set as Set + +import qualified Data.Map.Strict as Map + +import Crypto.Classes ( + buildKey, + buildKeyIO, + ) + +import qualified Tahoe.CHK.Capability as Cap + +import System.IO ( + IOMode (ReadMode), + hFileSize, + hSetBinaryMode, + openBinaryFile, + openFile, + ) + +import Crypto.Cipher.AES128 ( + AESKey128, + ) + +import Tahoe.CHK.Crypto ( + convergenceEncryptionHashLazy, + storageIndexHash, + ) + +import Tahoe.CHK.Server ( + ShareMap, + StorageServer (..), + ) +import Tahoe.CHK.Types ( + Parameters (Parameters), + ShareNum, + Size, + StorageIndex, + ) + +import Tahoe.Util (nextMultipleOf) + +import Data.Tuple.Extra (thd3) +import Tahoe.CHK ( + encode, + ) +import Tahoe.CHK.Encrypt (encrypt) + +-- Some data that can be uploaded. +data Uploadable = Uploadable + { uploadableKey :: AESKey128 + , uploadableSize :: Size + , uploadableParameters :: Parameters + , uploadableReadCleartext :: Integer -> IO B.ByteString + } + +-- The outcome of an attempt to upload an immutable. +data UploadResult = UploadResult + { uploadResultReadCap :: Cap.Reader + , uploadResultExistingShares :: Integer + , uploadResultShareMap :: ShareMap + } + deriving (Show) + +-- Find shares that already exist on servers. +locateAllShareholders :: StorageIndex -> [StorageServer] -> IO ShareMap +locateAllShareholders storageIndex servers = + Map.unionsWith Set.union <$> mapM getBuckets servers + where + getBuckets :: StorageServer -> IO ShareMap + getBuckets s = do + buckets <- storageServerGetBuckets s storageIndex + return $ Map.fromSet (const $ Set.singleton s) buckets + +planSharePlacement :: Parameters -> StorageIndex -> ShareMap -> [StorageServer] -> ShareMap +planSharePlacement (Parameters _ total _ _) _storageIndex _currentShares servers = + Map.fromList + [ (shareNum, Set.singleton server) + | (shareNum, server) <- zip [0 .. (fromIntegral total - 1)] (cycle servers) + ] + +-- Upload some immutable share data to some buckets on some servers. +-- +-- XXX TODO This writes the raw share data to a file with no server-side +-- bookkeeping. This may not be intrinsically bad but it makes the share +-- files incompatible with the Tahoe-LAFS storage server on-disk state. This +-- may not be intrinsically bad either but interop testing would be much +-- easier if the on-disk state were compatible. +uploadImmutableShares :: + StorageIndex -> + [(ShareNum, StorageServer, BL.ByteString)] -> + IO () +uploadImmutableShares storageIndex uploads = + uploadChunks 0 + where + -- How much data to upload to each server per request. + chunkSize = 1024 * 1024 + + -- Upload the chunk of each share at `offset` to the corresponding server + -- and then proceed to the chunks at the next offset. + uploadChunks offset = do + res <- uploadChunk chunkSize storageIndex offset + if res + then uploadChunks (offset + chunkSize) + else pure () + + uploadChunk :: + Integer -> + StorageIndex -> + Integer -> + IO Bool + uploadChunk size storageIndex' offset = + if any ("" /=) chunks + then mapM_ (uploadOneChunk offset storageIndex') uploads >> pure True + else pure False + where + chunks = map (BL.take (fromIntegral size) . BL.drop (fromIntegral offset) . thd3) uploads + + uploadOneChunk offset storageIndex' (shareNum, server, shareData) = + storageServerWrite server storageIndex' shareNum offset (BL.toStrict shareData) + +{- | Encrypt and encode some application data to some ZFEC shares and upload + them to some servers. +-} +store :: + -- | The servers to consider using. + [StorageServer] -> + -- | The application data to operate on. + Uploadable -> + -- | The result of the attempt. + IO UploadResult +store servers uploadable@(Uploadable key _ params _) = + encryptAndEncode uploadable >>= upload servers key params + +{- | Given some cleartext and some encoding parameters: encrypt and encode some + shares that can later be used to reconstruct the cleartext. +-} +encryptAndEncode :: + -- | The application data to encrypt and encode. + Uploadable -> + -- | An action to get an action that can be repeatedly evaluated to get + -- share data. As long as there is more share data, it evaluates to Left. + -- When shares are done, it evaluates to Right. + IO ([BL.ByteString], Cap.Reader) +encryptAndEncode (Uploadable readKey _ params read') = do + plaintext <- readAll read' + let ciphertext = encrypt readKey plaintext + (shares, cap) <- encode readKey params ciphertext + pure (map Binary.encode shares, cap) + where + readAll :: (Integer -> IO B.ByteString) -> IO BL.ByteString + readAll f = do + bs <- BL.fromStrict <$> f (1024 * 32) + if bs == "" + then pure "" + else (bs <>) <$> readAll f + +{- | Given some cleartext, some encoding parameters, and some servers: + encrypt, encode, and upload some shares that can later be used to + reconstruct the cleartext. + + This replaces allmydata.immutable.upload.Uploader.upload. +-} +upload :: + -- | The servers to consider uploading shares to. + [StorageServer] -> + -- | The encryption key (to derive the storage index). + AESKey128 -> + -- | The encoding parameters (XXX only for happy, right?) + Parameters -> + -- | The share data to upload. + ([BL.ByteString], Cap.Reader) -> + -- | Describe the outcome of the upload. + IO UploadResult +upload servers key params encoded = do + -- Decide where to put it + existingShares <- locateAllShareholders storageIndex servers + let targets = targetServers params existingShares + + -- Go + let (streams, cap) = encoded + uploadImmutableShares storageIndex (uploads targets streams) + + return $ + UploadResult + { uploadResultReadCap = cap + , uploadResultExistingShares = fromIntegral $ length existingShares + , uploadResultShareMap = targets + } + where + storageIndex :: StorageIndex + storageIndex = storageIndexHash key + + targetServers :: Parameters -> ShareMap -> ShareMap + targetServers parameters existingShares = planSharePlacement parameters storageIndex existingShares servers + + -- Adapt a stream of share data to a stream of share data annotated with + -- server placement decision. + uploads :: + ShareMap -> + [BL.ByteString] -> + [(ShareNum, StorageServer, BL.ByteString)] + uploads goal shareDatav = Map.foldrWithKey (makeUpload shareDatav) [] goal + where + makeUpload :: + [BL.ByteString] -> + ShareNum -> + Set.Set StorageServer -> + [(ShareNum, StorageServer, BL.ByteString)] -> + [(ShareNum, StorageServer, BL.ByteString)] + makeUpload shareDatav' num servers' soFar = + [ ( num + , server + , shareDatav' !! fromIntegral num + ) + | server <- Set.elems servers' + ] + ++ soFar + +defaultParameters :: Parameters +defaultParameters = Parameters (128 * 1024) 10 7 3 + +-- The adjustment implemented in +-- allmydata.immutable.upload.BaseUploadable.get_all_encoding_parameters +adjustSegmentSize :: Parameters -> Size -> Parameters +adjustSegmentSize (Parameters segmentSize total happy required) dataSize = + Parameters (effectiveSegmentSize dataSize) total happy required + where + effectiveSegmentSize = + -- For small files, shrink the segment size to avoid wasting space. + -- Also make the shrunk value a multiple of required shares or the + -- encoding doesn't work. + nextMultipleOf required . min segmentSize + +-- Create an uploadable with the given key. +filesystemUploadable :: AESKey128 -> FilePath -> Parameters -> IO Uploadable +filesystemUploadable key path params = do + fhandle <- openBinaryFile path ReadMode + fsize <- hFileSize fhandle + return $ + Uploadable + { uploadableKey = key + , uploadableSize = fsize + , uploadableParameters = adjustSegmentSize params fsize + , -- TODO Consider replacing this with a lazy bytestring or a list of bytestrings + uploadableReadCleartext = B.hGet fhandle . fromIntegral + } + +filesystemUploadableWithConvergence :: B.ByteString -> FilePath -> Parameters -> IO Uploadable +filesystemUploadableWithConvergence secret uploadablePath params = do + -- Allow getConvergentKey to use lazy ByteString to read and hash the + -- uploadable by letting the handle remain open past the end of this + -- function. lazy ByteString will close the handle. + uploadableHandle <- openFile uploadablePath ReadMode + hSetBinaryMode uploadableHandle True + + -- Annoyingly, adjust the segment size here so that the convergence secret + -- is computed based on the adjusted value. This is what Tahoe-LAFS does so + -- it is necessary to arrive at the same converged key. Whether this part + -- of the construction is actually important aside from interop, I don't + -- know. + size <- hFileSize uploadableHandle + content <- BL.hGetContents uploadableHandle + + memoryUploadableWithConvergence secret size content params + +-- TODO Consider lazy bytestring here instead +memoryUploadableWithConvergence :: B.ByteString -> Integer -> BL.ByteString -> Parameters -> IO Uploadable +memoryUploadableWithConvergence secret size content params = + let key = getConvergentKey secret (adjustSegmentSize params size) content + in memoryUploadable key size content params + +memoryUploadable :: AESKey128 -> Integer -> BL.ByteString -> Parameters -> IO Uploadable +memoryUploadable key size content params = + let makeReader :: BL.ByteString -> IO (Integer -> IO BL.ByteString) + makeReader allContent = + let cas len content' = (BL.drop len content', BL.take len content') + in do + contentRef <- newIORef allContent + return $ (modifyIORefCAS contentRef . cas) . fromIntegral + in do + reader <- makeReader content + return $ + Uploadable + { uploadableKey = key + , uploadableSize = size + , uploadableParameters = adjustSegmentSize params size + , -- TODO Consider replacing this with a lazy bytestring or a list of bytestrings + uploadableReadCleartext = (BL.toStrict <$>) . reader + } + +-- allmydata.immutable.upload.FileHandle._get_encryption_key_convergent +getConvergentKey :: B.ByteString -> Parameters -> BL.ByteString -> AESKey128 +getConvergentKey secret params content = + fromJust . buildKey $ convergenceEncryptionHashLazy secret params content + +-- Create an uploadable with a random key. +filesystemUploadableRandomConvergence :: FilePath -> Parameters -> IO Uploadable +filesystemUploadableRandomConvergence path params = do + key <- buildKeyIO :: IO AESKey128 + filesystemUploadable key path params + +prettyFormatSharemap :: ShareMap -> Text +prettyFormatSharemap sharemap = + intercalate + "\n" + [ Text.concat ["\t", showElem elem'] + | elem' <- Map.toList sharemap + ] + where + showElem :: (ShareNum, Set.Set StorageServer) -> Text + showElem (shareNum, servers) = + Text.concat $ + [ pack $ show shareNum + , ":" + ] + ++ intersperse ", " (map storageServerID (Set.toList servers)) diff --git a/src/Tahoe/Netstring.hs b/src/Tahoe/Netstring.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/Netstring.hs @@ -0,0 +1,16 @@ +module Tahoe.Netstring ( + netstring, +) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C8 + +-- | Encode a bytestring as a netstring. +netstring :: B.ByteString -> B.ByteString +netstring xs = + B.concat + [ C8.pack . show . B.length $ xs + , ":" + , xs + , "," + ] diff --git a/src/Tahoe/Server.hs b/src/Tahoe/Server.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/Server.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Tahoe.Server ( + nullStorageServer, + memoryStorageServer, + directoryStorageServer, + directoryStorageServer', +) where + +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set + +import Control.Exception ( + Exception, + catch, + throwIO, + ) +import Tahoe.CHK.Server ( + StorageServer (..), + ) +import Tahoe.CHK.Types ( + Offset, + ShareNum, + StorageIndex, + ) + +import Data.IORef ( + IORef, + modifyIORef', + newIORef, + readIORef, + ) + +import System.Directory ( + createDirectoryIfMissing, + listDirectory, + ) +import System.FilePath ( + (), + ) + +import qualified Data.ByteString as BS +import Data.ByteString.Base32 (encodeBase32Unpadded) +import qualified Data.Text as T +import System.IO ( + IOMode (..), + SeekMode (..), + hSeek, + withBinaryFile, + ) +import System.IO.Error ( + isDoesNotExistError, + ) + +{- | Create a storage server backed by a certain directory which already + exists. +-} +directoryStorageServer :: FilePath -> StorageServer +directoryStorageServer serverRoot = + StorageServer + { storageServerID = T.pack serverRoot + , storageServerWrite = writeShareDataAt serverRoot + , storageServerRead = \index sharenum -> + withBinaryFile (sharePath serverRoot index sharenum) ReadMode BS.hGetContents + , storageServerGetBuckets = getBuckets + } + where + writeShareDataAt :: FilePath -> StorageIndex -> ShareNum -> Offset -> BS.ByteString -> IO () + writeShareDataAt shareRoot' storageIndex shareNum offset xs = do + createDirectoryIfMissing True (bucketPath shareRoot' storageIndex) + withBinaryFile (sharePath shareRoot' storageIndex shareNum) ReadWriteMode $ \f -> + hSeek f AbsoluteSeek offset >> BS.hPut f xs + + -- Get the path to the directory where shares for the given storage + -- index should be written. + bucketPath :: FilePath -> StorageIndex -> FilePath + bucketPath root storageIndex = root bucketName + where + bucketName = "shares" shortPiece fullName + fullName = T.unpack . T.toLower . encodeBase32Unpadded $ storageIndex + shortPiece = take 2 fullName + + -- Get the path to the file where data for the given share of the given + -- storage index should be written. + sharePath :: FilePath -> StorageIndex -> ShareNum -> FilePath + sharePath root storageIndex shareNum = + bucketPath root storageIndex show shareNum + + getBuckets :: StorageIndex -> IO (Set.Set ShareNum) + getBuckets storageIndex = + readShareFilenames `catch` doesNotExist + where + readShareFilenames = + Set.fromList . map read <$> listDirectory (bucketPath serverRoot storageIndex) + + doesNotExist e = + if isDoesNotExistError e + then return Set.empty + else ioError e + +{- | Create a storage server backed by a certain directory which may or may + not already exist. +-} +directoryStorageServer' :: FilePath -> IO StorageServer +directoryStorageServer' shareRoot = do + createDirectoryIfMissing True shareRoot + pure $ directoryStorageServer shareRoot + +-- | Create a storage server backed only by in-memory data. +memoryStorageServer :: IO StorageServer +memoryStorageServer = do + shares :: IORef (M.Map (StorageIndex, ShareNum) BS.ByteString) <- newIORef mempty + + let storageServerID = "memory" + + storageServerWrite index sharenum offset sharedata = + modifyIORef' shares $ M.alter (appendBytes offset sharedata) (index, sharenum) + + appendBytes :: Offset -> BS.ByteString -> Maybe BS.ByteString -> Maybe BS.ByteString + appendBytes 0 sharedata Nothing = Just sharedata + appendBytes n _sharedata Nothing = + error $ + "memoryStorageServer appendBytes requires append-only usage; 0 bytes written but offset is " + <> show n + appendBytes n sharedata (Just existing) + | fromIntegral (BS.length existing) /= n = + error $ + "memoryStorageServer appendBytes requires append-only usage; " + <> show (BS.length existing) + <> " bytes written but offset is " + <> show n + | otherwise = Just (existing <> sharedata) + + storageServerRead :: StorageIndex -> ShareNum -> IO BS.ByteString + storageServerRead index sharenum = + fromMaybe "" . M.lookup (index, sharenum) <$> readIORef shares + + storageServerGetBuckets :: StorageIndex -> IO (Set.Set ShareNum) + storageServerGetBuckets index = + Set.fromList . map snd . filter ((== index) . fst) . M.keys <$> readIORef shares + + pure $ StorageServer{..} + +{- | Create a StorageServer that discards writes to it and throws errors on + reads. +-} +nullStorageServer :: StorageServer +nullStorageServer = + StorageServer + { storageServerID = "null-server" + , storageServerWrite = \_index _sharenum _offset _data -> return () + , storageServerRead = \_index _sharenum -> throwIO IThrewYourDataAway + , storageServerGetBuckets = \_index -> return mempty + } + +data ReadError = IThrewYourDataAway deriving (Show) +instance Exception ReadError diff --git a/src/Tahoe/Util.hs b/src/Tahoe/Util.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/Util.hs @@ -0,0 +1,62 @@ +module Tahoe.Util where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BS +import qualified Data.ByteString.Lazy as LBS + +-- | The smallest multiple of `multiplier` which is >= `value`. +nextMultipleOf :: (Integral m, Integral v) => m -> v -> v +nextMultipleOf multiplier value = factor * fromIntegral multiplier + where + factor = factor' + (if remainder == 0 then 0 else 1) + (factor', remainder) = value `divMod` fromIntegral multiplier + +{- | Return the smallest integer which is a power of k and greater than or + equal to n +-} +nextPowerOf :: (Ord p, Num p) => p -> p -> p +nextPowerOf k n = + nextPowerOf' k n 1 + where + nextPowerOf' k' n' p' = + if p' < n' + then nextPowerOf' k' n' (p' * k') + else p' + +{- | Construct a binary representation of the given integer. The first + argument represents a zero bit. The second argument represents a one bit. + The result is ordered from most to least significant bit. +-} +toBinary :: a -> a -> Int -> [a] +toBinary off on i = reverse $ toBinaryRev i + where + toBinaryRev 0 = [] + toBinaryRev n + | n `mod` 2 == (0 :: Int) = off : toBinaryRev (n `div` 2) + | otherwise = on : toBinaryRev (n `div` 2) + +{- | Break up a byte string into equal sized pieces, except the last piece + which might be short. *BS.concat . chunkedBy n == id* +-} +chunkedBy :: + -- | The number of bytes in each piece. + Int -> + -- | The byte string to break up. + BS.ByteString -> + [BS.ByteString] +chunkedBy _n "" = [] +chunkedBy n xs = nextChunk : chunkedBy n theRest + where + (nextChunk, theRest) = BS.splitAt n xs + +toStrictByteString :: BS.Builder -> BS.ByteString +toStrictByteString = LBS.toStrict . BS.toLazyByteString + +-- | Integer division rounded towards positive infinity. +ceilDiv :: Integral i => i -> i -> i +ceilDiv a b = q + adjustment + where + (q, r) = a `divMod` b + adjustment = case r of + 0 -> 0 + _ -> 1 diff --git a/tahoe-chk.cabal b/tahoe-chk.cabal new file mode 100644 --- /dev/null +++ b/tahoe-chk.cabal @@ -0,0 +1,149 @@ +cabal-version: 1.12 +name: tahoe-chk +version: 0.1.0.2 +synopsis: + The Tahoe-LAFS' Content-Hash-Key (CHK) cryptographic protocol. + +description: + Please see the README on GitHub at + +homepage: https://whetstone.private.storage/privatestorage/tahoe-chk +bug-reports: + https://whetstone.private.storage/privatestorage/tahoe-chk/-/issues + +author: Jean-Paul Calderone and others +maintainer: PrivateStorage.io, Inc. +copyright: 2020-2023 The Authors +license: BSD3 +license-file: LICENSE +category: Cryptography,Library,Parsers,Security +build-type: Simple +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: + gitlab@whetstone.private.storage:privatestorage/tahoe-chk.git + +library + exposed-modules: + Tahoe.CHK + Tahoe.CHK.Capability + Tahoe.CHK.Crypto + Tahoe.CHK.Encrypt + Tahoe.CHK.Merkle + Tahoe.CHK.Parsing + Tahoe.CHK.Server + Tahoe.CHK.Share + Tahoe.CHK.Types + Tahoe.CHK.Upload + Tahoe.CHK.URIExtension + Tahoe.Netstring + Tahoe.Server + Tahoe.Util + + other-modules: Paths_tahoe_chk + ghc-options: -Wall + hs-source-dirs: src + default-extensions: OverloadedStrings + build-depends: + aeson >=1.4.7 && <2.2 + , async >=2.2.2 && <2.3 + , base >=4.7 && <5 + , base32 >=0.2.1 && <0.3 + , 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 + , concurrency >=1.11 && <2 + , containers >=0.6.0.1 && <0.7 + , crypto-api >=0.13.3 && <0.14 + , cryptonite >=0.27 && <0.30 + , directory >=1.3.3 && <1.4 + , extra >=1.7.7 && <1.8 + , fec >=0.1.1 && <0.2 + , filepath >=1.4.2 && <1.5 + , megaparsec >=8.0 && <9.3 + , memory >=0.15 && <0.17 + , monad-loops >=0.4.3 && <0.5 + , 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 + , tree-diff >=0.1 && <0.3 + , utility-ht >=0.0.15 && <0.1 + + default-language: Haskell2010 + +executable tahoe-chk-encrypt + main-is: Main.hs + other-modules: Paths_tahoe_chk + hs-source-dirs: app + default-extensions: OverloadedStrings + 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 + , optparse-applicative >=0.15.1.0 && <0.19 + , tahoe-chk + , text >=1.2.3.1 && <1.3 + + default-language: Haskell2010 + +test-suite tahoe-chk-tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Generators + Paths_tahoe_chk + SpecCHK + SpecCrypto + SpecMerkle + SpecServer + SpecUEB + SpecUpload + SpecUtil + SpecZFEC + Vectors + + hs-source-dirs: test + default-extensions: + NamedFieldPuns + OverloadedStrings + + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=1.4.7 && <2.2 + , base >=4.7 && <5 + , base32 >=0.2.1 && <0.3 + , 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 + , containers >=0.6.0.1 && <0.7 + , crypto-api >=0.13.3 && <0.14 + , cryptonite >=0.27 && <0.30 + , directory >=1.3.3 && <1.4 + , fec >=0.1.1 && <0.2 + , filepath >=1.4.2 && <1.5 + , hedgehog >=1.0.3 && <1.1 + , megaparsec >=8.0 && <9.3 + , 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-hunit >=0.10.0.2 && <0.11 + , temporary >=1.3 && <1.4 + , text >=1.2.3.1 && <1.3 + , 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 + + default-language: Haskell2010 diff --git a/test/Generators.hs b/test/Generators.hs new file mode 100644 --- /dev/null +++ b/test/Generators.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE RecordWildCards #-} + +module Generators where + +import Crypto.Hash ( + hashDigestSize, + ) +import Crypto.Hash.Algorithms ( + SHA256 (SHA256), + ) +import qualified Data.ByteString as BS +import Data.ByteString.Base32 (encodeBase32Unpadded) +import qualified Data.ByteString.Lazy as LBS +import Data.Int (Int64) +import qualified Data.Text as T +import Hedgehog (MonadGen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Tahoe.CHK.Crypto (storageIndexLength) +import Tahoe.CHK.Merkle (MerkleTree, makeTreePartial) +import Tahoe.CHK.Server (StorageServerAnnouncement (StorageServerAnnouncement)) +import Tahoe.CHK.Share (Share (..)) +import Tahoe.CHK.Types (Parameters (..), ShareNum, StorageIndex) +import Tahoe.CHK.URIExtension (URIExtension (URIExtension)) + +-- | The maximum value an Int64 can represent. +maxInt64 :: Integer +maxInt64 = fromIntegral (maxBound :: Int64) + +-- | Generate Parameters values for which all field invariants hold. +genParameters :: MonadGen m => m Parameters +genParameters = do + paramSegmentSize <- Gen.integral (Range.exponential 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 + -- easier not to let this value vary and it doesn't hurt anything. + let paramHappyShares = 1 + pure $ Parameters{paramSegmentSize, paramTotalShares, paramHappyShares, paramRequiredShares} + +-- | Generate URIExtension values which are not necessarily well-formed. +genURIExtension :: MonadGen m => m URIExtension +genURIExtension = + URIExtension + <$> Gen.bytes (Range.linear 1 32) + <*> genParameters + <*> genParameters + <*> Gen.integral (Range.exponential 1 maxInt64) + <*> Gen.integral (Range.exponential 1 maxInt64) + <*> Gen.integral (Range.exponential 1 (maxBound :: Int)) + <*> Gen.integral (Range.linear 1 256) + <*> Gen.integral (Range.linear 1 256) + <*> genHash + <*> genHash + <*> genHash + +-- | Generate ByteStrings which could be sha256d digests. +genHash :: MonadGen m => m BS.ByteString +genHash = Gen.bytes . Range.singleton . hashDigestSize $ SHA256 + +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) + numBlocks <- Gen.integral (Range.exponential 1 32) + + -- We don't make shareDataSize agree with the rest of the share data + -- because the field is supposedly unused so everyone should just ignore + -- it and not mind if we put garbage there. + -- + -- 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) + + shareBlocks <- Gen.list (Range.singleton numBlocks) (LBS.fromStrict <$> Gen.bytes (Range.singleton $ fromIntegral shareBlockSize)) + + -- 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)) + + -- 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 + + pure $ Share{..} + +merkleTrees :: MonadGen m => Range.Range Int -> m MerkleTree +merkleTrees r = makeTreePartial <$> Gen.list r genHash + +storageIndexes :: MonadGen m => m StorageIndex +storageIndexes = Gen.bytes (Range.singleton storageIndexLength) + +shareNumbers :: MonadGen m => m ShareNum +shareNumbers = Gen.integral Range.linearBounded + +storageServerIdentifiers :: MonadGen m => m T.Text +storageServerIdentifiers = + Gen.choice + -- XXX Maybe more than alpha? + [ Gen.text (Range.linear 1 64) Gen.alpha + , encodeBase32Unpadded <$> Gen.bytes (Range.linear 1 64) + ] + +-- | Generate storage server anonymous storage service announcements. +storageServerAnnouncements :: MonadGen m => m StorageServerAnnouncement +storageServerAnnouncements = + StorageServerAnnouncement + <$> Gen.maybe storageServiceFURLs + -- XXX Maybe more than alpha? + <*> Gen.maybe (Gen.text (Range.linear 1 32) Gen.alpha) + -- XXX 32 bytes? + <*> Gen.maybe (Gen.bytes (Range.singleton 32)) + +{- | Generate text that could be a storage server fURL. TODO: Represent fURLs + _and NURLs_ in a structured way instead of with Text. +-} +storageServiceFURLs :: MonadGen m => m T.Text +storageServiceFURLs = do + -- XXX 32 bytes? + tubid <- encodeBase32Unpadded <$> Gen.bytes (Range.singleton 32) + -- XXX 32 bytes? + swissnum <- encodeBase32Unpadded <$> Gen.bytes (Range.singleton 32) + let location = "@tcp:" + pure $ "pb://" <> tubid <> location <> "/" <> swissnum diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,48 @@ +module Main where + +import Test.Tasty (TestTree, defaultMain, testGroup) + +import System.IO (hSetEncoding, stderr, stdout, utf8) + +import qualified SpecCHK +import qualified SpecCrypto +import qualified SpecMerkle +import qualified SpecServer +import qualified SpecUEB +import qualified SpecUpload +import qualified SpecUtil +import qualified SpecZFEC +import Test.Tasty.HUnit (assertBool, testCase) +import Vectors (loadTestVectorData) + +tests :: [TestTree] +tests = + [ SpecUpload.tests + , SpecCrypto.tests + , SpecMerkle.tests + , SpecZFEC.tests + , SpecUtil.tests + , SpecUEB.tests + , SpecServer.tests + , SpecCHK.tests + ] + +failurePlaceholder :: String -> String -> TestTree +failurePlaceholder name msg = testCase name $ assertBool msg False + +main :: IO () +main = do + -- Hedgehog writes some non-ASCII and the whole test process will die if + -- it can't be encoded. Increase the chances that all of the output can + -- be encoded by forcing the use of UTF-8 (overriding the LANG-based + -- choice normally made). + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + + testVectors <- loadTestVectorData + let testVectorsTree = + either + (failurePlaceholder "CHK" . ("Test vectors: " ++) . show) + SpecCHK.testsFromVectors + testVectors + defaultMain (testGroup "CHK" $ testVectorsTree : tests) diff --git a/test/SpecCHK.hs b/test/SpecCHK.hs new file mode 100644 --- /dev/null +++ b/test/SpecCHK.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SpecCHK ( + tests, + testsFromVectors, +) where + +import Control.Arrow ( + (&&&), + ) +import Crypto.Cipher.AES128 ( + AESKey128, + ) +import Crypto.Classes ( + encode, + ) +import qualified Data.Binary as Binary +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.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 Hedgehog ( + Property, + assert, + diff, + forAll, + property, + tripping, + ) +import qualified Hedgehog.Gen as Gen +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.Share ( + Share ( + shareBlockSize, + shareURIExtension + ), + ) +import Tahoe.CHK.Types ( + Parameters (..), + ) +import Tahoe.CHK.Upload ( + UploadResult (..), + Uploadable (..), + adjustSegmentSize, + encryptAndEncode, + getConvergentKey, + memoryUploadableWithConvergence, + store, + ) +import Tahoe.Server ( + nullStorageServer, + ) +import Test.Tasty ( + TestTree, + testGroup, + ) +import Test.Tasty.HUnit ( + Assertion, + assertBool, + assertEqual, + assertFailure, + testCase, + ) +import Test.Tasty.Hedgehog (testProperty) +import Text.Megaparsec (parse) +import Vectors ( + Format (..), + JSONByteString (..), + Sample (..), + TestCase (..), + VectorSpec (..), + ) + +assertEqual' :: (Generic a, ToExpr a, Eq a) => a -> a -> Assertion +assertEqual' a b = assertBool (show . prettyEditExpr $ ediff a b) (a == b) + +-- | Create tests for each case in the test vector specification. +testsFromVectors :: VectorSpec -> TestTree +testsFromVectors vectorSpec = + testGroup + "Vectors" + [ testCap vectorSpec + , testCapabilityParser vectorSpec + ] + +tests :: TestTree +tests = + testGroup + "CHK" + [ testEncrypt + , testProperty "expand returns the correct number of bytes" prop_expand_length + , testProperty "expand returns bytes containing the template repeated" prop_expand_template + , testProperty "Share round-trips through put / get" prop_share_roundtrip + , testWellKnownShare1of2 + , testWellKnownShare2of3 + , testWellKnownShare3of10 + , testProperty "segmentCiphertext preserves all of the ciphertext" prop_segmentCiphertext_identity + , testProperty "padCiphertext returns a string with a length that is a multiple of the given requiredShares value" prop_paddedCiphertext_boundary + , testProperty "ciphertext round-trips through decode . encode" prop_share_encoding_roundtrip + , testSizes + , testOutOfBoundsShareNumbers + ] + +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 segment size is reduced to the ciphertext size" (fromIntegral $ BL.length ciphertext) . getSegmentSize) shares' + where + getSegmentSize = paramSegmentSize . uriExtCodecParams . shareURIExtension + params = + Parameters + { paramSegmentSize = 100000 + , paramTotalShares = 3 + , paramHappyShares = 1 + , paramRequiredShares = 2 + } + ciphertext = BL.pack [1 .. 56] + +{- | segmentCiphertext may split up ciphertext but it may not change its + content in any way. +-} +prop_segmentCiphertext_identity :: Property +prop_segmentCiphertext_identity = property $ do + ciphertext <- forAll $ BL.fromStrict <$> Gen.bytes (Range.linear 1 1024) + params <- forAll genParameters + + let segments = Tahoe.CHK.segmentCiphertext params ciphertext + recovered = BL.concat segments + + diff ciphertext (==) recovered + +prop_paddedCiphertext_boundary :: Property +prop_paddedCiphertext_boundary = property $ do + ciphertext <- forAll $ BL.fromStrict <$> Gen.bytes (Range.linear 1 1024) + Parameters{paramRequiredShares} <- forAll genParameters + + let padded = padCiphertext paramRequiredShares ciphertext + + 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" + + 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 + + -- Encoded by Tahoe-LAFS itself, hacked to use an 8 byte + -- maximum segment size. + shareContainers <- mapM BL.readFile (pathToExpected <$> [0 .. length shares' - 1]) + + -- 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' + + assertEqual' expectedShares shares' + assertEqual' expectedEncoded encodedShares + assertEqual "The cap matches" (dangerRealShow $ CHKReader cap) expectedCap + +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" + ) + +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" + ) + +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" + ) + +prop_share_encoding_roundtrip :: Property +prop_share_encoding_roundtrip = property $ do + convergenceSecret <- forAll $ Gen.bytes (Range.singleton 32) + ciphertext <- forAll $ BL.fromStrict <$> Gen.bytes (Range.linear 1 2048) + params <- forAll $ fixParams <$> genParameters + let key = getConvergentKey convergenceSecret (adjustSegmentSize params (fromIntegral $ BL.length ciphertext)) ciphertext + (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 + +prop_share_roundtrip :: Property +prop_share_roundtrip = + let decode' = ((\(_, _, sh) -> sh) <$>) . Binary.decodeOrFail + in property $ do + share <- forAll shares + tripping share Binary.encode decode' + +testEncrypt :: TestTree +testEncrypt = + testGroup + "chkEncrypt" + [ testCase "ciphertext" $ do + assertEqual + "expected convergence key" + "oBcuR/wKdCgCV2GKKXqiNg==" + (Base64.encode $ encode convergenceKey) + let b64ciphertext = Base64.encode (BL.toStrict ciphertext) + assertEqual "known result" knownCorrect b64ciphertext + ] + where + -- For all the magic values see + -- allmydata.test.test_upload.FileHandleTests.test_get_encryption_key_convergent + knownCorrect :: B.ByteString + knownCorrect = "Jd2LHCRXozwrEJc=" + + plaintext :: BL.ByteString + plaintext = "hello world" + + ciphertext :: BL.ByteString + ciphertext = encrypt convergenceKey plaintext + + convergenceKey :: AESKey128 + convergenceKey = getConvergentKey convergenceSecret params plaintext + + convergenceSecret = B.replicate convergenceSecretLength 0x42 + params = + adjustSegmentSize + Parameters + { paramSegmentSize = 128 * 1024 + , paramTotalShares = 10 + , paramHappyShares = 5 + , paramRequiredShares = 3 + } + (fromIntegral $ BL.length plaintext) + +{- | Build a test tree that applies a test function to every CHK case in a + test vector. +-} +chkTests :: + -- | A name to give the group of tests. + String -> + -- | A function to call with a CHK test case to get back a test. + (TestCase -> Assertion) -> + -- | The test vector containing CHK test cases. + VectorSpec -> + -- | A test tree with one test per CHK case in the test vector. + TestTree +chkTests name makeOneTest = + testGroup name . map (uncurry ($) . (testCase . unpack . expected &&& makeOneTest)) . filter pickCase . vector + where + pickCase TestCase{format, zfec} = format == CHK && (paramTotalShares zfec > paramRequiredShares zfec && paramTotalShares zfec < 256) + +{- | Every CHK case in the test vector can be reproduced by this + implementation. +-} +testCap :: VectorSpec -> TestTree +testCap = chkTests "chkCap" testOneCase + +{- | Every CHK capability in the test vector can be parsed and then serialized + back to the same byte string. +-} +testCapabilityParser :: VectorSpec -> TestTree +testCapabilityParser = chkTests "testCapabilityParser" testParseOneCapability + +{- | Assert that a specific CHK capability can be parsed and serialized back + to the same byte string. +-} +testParseOneCapability :: TestCase -> Assertion +testParseOneCapability TestCase{expected} = do + serialized <- case parse pCapability "" expected of + Left err -> assertFailure $ show err + Right cap -> pure $ dangerRealShow cap + assertEqual "expected /= serialized" expected serialized + +{- | Assert that verify and read capability strings with n/k/size below the + minimum legal or above the maximum legal value are rejected by the parser. +-} +testOutOfBoundsShareNumbers :: TestTree +testOutOfBoundsShareNumbers = + testCase + "out-of-bounds share numbers cause capability string parse errors" + $ mapM_ assertParseFail cases + where + cases = + [ -- Verify caps with n/k/size too small + "URI:CHK-Verifier:yzxcoagbetwet65ltjpbqyli3m:6b7inuiha2xdtgqzd55i6aeggutnxzr6qfwpv2ep5xlln6pgef7a:0:1:56" + , "URI:CHK-Verifier:yzxcoagbetwet65ltjpbqyli3m:6b7inuiha2xdtgqzd55i6aeggutnxzr6qfwpv2ep5xlln6pgef7a:1:0:56" + , "URI:CHK-Verifier:yzxcoagbetwet65ltjpbqyli3m:6b7inuiha2xdtgqzd55i6aeggutnxzr6qfwpv2ep5xlln6pgef7a:1:1:0" + , -- Read caps with n/k/size too small + "URI:CHK:yzxcoagbetwet65ltjpbqyli3m:6b7inuiha2xdtgqzd55i6aeggutnxzr6qfwpv2ep5xlln6pgef7a:0:1:56" + , "URI:CHK:yzxcoagbetwet65ltjpbqyli3m:6b7inuiha2xdtgqzd55i6aeggutnxzr6qfwpv2ep5xlln6pgef7a:1:0:56" + , "URI:CHK:yzxcoagbetwet65ltjpbqyli3m:6b7inuiha2xdtgqzd55i6aeggutnxzr6qfwpv2ep5xlln6pgef7a:1:1:0" + , -- Verify caps with n/k/size too large + "URI:CHK-Verifier:yzxcoagbetwet65ltjpbqyli3m:6b7inuiha2xdtgqzd55i6aeggutnxzr6qfwpv2ep5xlln6pgef7a:257:256:1000" + , "URI:CHK-Verifier:yzxcoagbetwet65ltjpbqyli3m:6b7inuiha2xdtgqzd55i6aeggutnxzr6qfwpv2ep5xlln6pgef7a:256:257:1000" + , "URI:CHK-Verifier:yzxcoagbetwet65ltjpbqyli3m:6b7inuiha2xdtgqzd55i6aeggutnxzr6qfwpv2ep5xlln6pgef7a:256:256:18446744073709551616" + , -- Read caps with n/k/size too large + "URI:CHK:yzxcoagbetwet65ltjpbqyli3m:6b7inuiha2xdtgqzd55i6aeggutnxzr6qfwpv2ep5xlln6pgef7a:257:256:1000" + , "URI:CHK:yzxcoagbetwet65ltjpbqyli3m:6b7inuiha2xdtgqzd55i6aeggutnxzr6qfwpv2ep5xlln6pgef7a:256:257:1000" + , "URI:CHK:yzxcoagbetwet65ltjpbqyli3m:6b7inuiha2xdtgqzd55i6aeggutnxzr6qfwpv2ep5xlln6pgef7a:256:256:18446744073709551616" + ] + + assertParseFail s = + case parse pCapability "" s of + Left _err -> pure () + Right cap -> + assertFailure . unpack . Data.Text.concat $ + [ "Expected parse failure of " + , s + , " instead got " + , dangerRealShow cap + ] + +{- | Assert that a specific CHK case can be reproduced by this implementation. + This means we can encode the same plaintext using the same secrets to the + same ciphertext and share layout and that the resulting capability string + is the same byte sequence as given by the test vector. +-} +testOneCase :: TestCase -> Assertion +testOneCase + TestCase + { convergence + , format = CHK + , sample + , zfec + , expected + } = + do + uploadable <- memoryUploadableWithConvergence (coerce convergence) (fromIntegral $ sampleLength sample) (BL.fromStrict $ expand sample) zfec + upresult <- store [nullStorageServer] uploadable + assertEqual "yes" (parse pReader "" expected) (Right $ uploadResultReadCap upresult) +testOneCase x = error $ "testOneCase got bad input" <> show x + +expand :: Sample -> B.ByteString +expand (Sample sampleTemplate sampleLength) = + B.take sampleLength . B.concat $ take sampleLength (replicate n bs) + where + n = (sampleLength `div` B.length bs) + 1 + bs = coerce sampleTemplate -- yuck + +prop_expand_length :: Property +prop_expand_length = + property $ do + sample <- forAll $ Sample <$> (JSONByteString <$> Gen.bytes (Range.linear 1 16)) <*> Gen.int (Range.linear 1 1000) + diff (sampleLength sample) (==) (B.length $ expand sample) + +prop_expand_template :: Property +prop_expand_template = + property $ do + template <- forAll $ Gen.bytes (Range.linear 1 16) + sample <- forAll $ Sample (JSONByteString template) <$> Gen.int (Range.linear 1 1000) + assert $ checkTemplate template (expand sample) + where + checkTemplate :: B.ByteString -> B.ByteString -> Bool + checkTemplate _ "" = True + checkTemplate template expanded = + all (uncurry (==)) (B.zip template expanded) + && checkTemplate template (B.drop (B.length template) expanded) diff --git a/test/SpecCrypto.hs b/test/SpecCrypto.hs new file mode 100644 --- /dev/null +++ b/test/SpecCrypto.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SpecCrypto ( + tests, +) where + +import Crypto.Cipher.AES128 ( + AESKey128, + ) +import Crypto.Classes ( + buildKey, + keyLength, + ) +import Crypto.Types (ByteLength) +import qualified Data.ByteString as B +import Data.Char ( + ord, + ) +import Data.Tagged (Tagged, untag) +import Tahoe.CHK.Crypto ( + convergenceEncryptionTag, + convergenceSecretLength, + sha256, + sha256d, + storageIndexHash, + taggedHash, + taggedPairHash, + ) +import Tahoe.CHK.Types ( + Parameters (..), + ) +import Test.Tasty ( + TestTree, + testGroup, + ) +import Test.Tasty.HUnit ( + assertEqual, + testCase, + ) + +tests :: TestTree +tests = + testGroup + "Crypto" + [ testGroup + "sha256" + [ testCase "sha256" $ + assertEqual + "known value" + "\x23\xfb\xe2\x1e\x2f\xae\xde\xb5\x44\x92\xcb\x7a\xc6\x0e\x04\x4a\xbb\x47\x3f\xcb\x13\x1a\x65\x8e\xd2\x5c\xd0\x17\x06\xc3\xf3\x98" + (sha256 "4:tag1,value") + , testCase "sha256d" $ + assertEqual + "known value" + "\x6b\xd0\xdc\xb0\x2f\x11\x0a\xe1\xe9\x41\x1f\x12\x52\x07\x03\x66\xfe\xaa\xcb\xc9\xda\xdb\x66\xa4\xa9\xa0\xc0\xdd\x85\x49\x5d\xc4" + (sha256d "4:tag1,value") + , testCase "storage index tagged hash" $ + -- 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") + (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 "convergence hasher tag" $ + -- See allmydata.test.test_hashutil.HashUtilTests.test_convergence_hasher_tag + let convergenceSecret = B.replicate convergenceSecretLength 0x42 + params = + Parameters + { paramSegmentSize = 1024 + , paramTotalShares = 10 + , paramHappyShares = undefined + , paramRequiredShares = 3 + } + in assertEqual + "known value" + ( mconcat + [ "allmydata_immutable_content_to_key_with_added_secret_v1+" + , "16:\x42\x42\x42\x42\x42\x42\x42\x42\x42\x42\x42\x42\x42\x42\x42\x42," + , "9:3,10,1024," + ] + ) + (convergenceEncryptionTag convergenceSecret params) + ] + ] + where + xKey = buildKey (B.replicate (untag (keyLength :: Tagged AESKey128 ByteLength)) . fromIntegral . ord $ 'x') :: Maybe AESKey128 diff --git a/test/SpecMerkle.hs b/test/SpecMerkle.hs new file mode 100644 --- /dev/null +++ b/test/SpecMerkle.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SpecMerkle ( + tests, +) where + +import Crypto.Hash (HashAlgorithm (hashDigestSize), SHA256 (SHA256)) +import Data.Binary (decodeOrFail, encode) +import Data.ByteString.Base32 ( + encodeBase32Unpadded, + ) +import Data.List ( + sort, + ) +import Data.Maybe ( + isJust, + ) +import Data.Text ( + pack, + ) +import Data.Text.Encoding ( + encodeUtf8, + ) +import Hedgehog ( + Gen, + Property, + annotateShow, + assert, + diff, + failure, + forAll, + property, + tripping, + ) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Tahoe.CHK.Crypto ( + sha256, + taggedHash, + ) +import Tahoe.CHK.Merkle ( + Direction (..), + MerkleTree (MerkleLeaf, MerkleNode), + breadthFirstList, + buildTreeOutOfAllTheNodes, + emptyLeafHash, + height, + leafNumberToNodeNumber, + makeTree, + mapTree, + merklePath, + merkleProof, + neededHashes, + pairHash, + rootHash, + size, + treeFromRows, + ) +import Test.Tasty ( + TestTree, + testGroup, + ) +import Test.Tasty.HUnit ( + assertBool, + assertEqual, + testCase, + ) +import Test.Tasty.Hedgehog (testProperty) + +tests :: TestTree +tests = + testGroup + "Merkle" + [ testCase "pairHash" $ + assertEqual + "simple test vector" + "MNP3F5B64GHVUPQ3U7ZT76D7ZP6NVHHV5KMFLT2IPORIGI5EL57Q" + (encodeBase32Unpadded $ pairHash "abc" "xyz") + , testCase "emptyLeafHash" $ + assertEqual + "simple test vector" + "T3KZA5VWX3TLOWDEMMGDYIGP62JU57QDUYFH7UULNFKC7MJ2NCRQ" + (encodeBase32Unpadded $ emptyLeafHash 3) + , testCase "two leaf tree" $ + assertEqual + "root hash is leaf pair hash" + (Just "NFOM5H52FQH5A4F3OL3JCPGAUECQJEW6FUWKW5HWVQDIFSKPM6DQ") + (encodeBase32Unpadded . rootHash <$> makeTree [sha256 "abc", sha256 "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"]) + , testCase "empty tree" $ + assertEqual + "empty list results in no tree" + Nothing + (makeTree []) + , 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"]) + , testCase "make 6 leaf tree" $ + assertBool "it can be made" $ + isJust (makeTestTree 6) + , testCase "breadth first traversal (small)" $ + assertEqual + "tree with one leaf" + (Just 1) + (length . breadthFirstList <$> makeTestTree 1) + , testCase "breadth first traversal (big)" $ + assertEqual + "tree with 1024 leaves" + (Just (1024 * 2 - 1)) + (length . breadthFirstList <$> makeTestTree 1024) + , testCase "show it" $ do + print $ makeTestTree 2 + return () + , testCase "neededHashes test vectors" $ + let Just tree = makeTestTree 8 + needed = (sort . map fst <$>) . neededHashes tree + in do + assertEqual "test vector 1" (Just [2 :: Int, 4, 8]) (needed 0) + assertEqual "test vector 2" (Just [2, 4, 7]) (needed 1) + assertEqual "test vector 3" (Just [1, 5, 13]) (needed 7) + , testProperty "all paths same length for merkleProof" prop_merkleProof_length + , testProperty "all internal nodes have the correct hash" prop_makeTree_hashes + , testProperty "all merkleProofs prove what they ought" spec_merkleProof_nodeNumbers + , testProperty "all merkleProofs prove what they ought" spec_merkleProof_hashes + , testProperty "all merkle paths have a consistent length" spec_merklePath_length + , 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 "merkle trees round-trip through encode / decode" prop_binary_tripping + ] + +prop_binary_tripping :: Property +prop_binary_tripping = property $ do + (Just someTree) <- forAll genMerkleTree + let third (_, _, x) = x + tripping someTree encode ((third <$>) . decodeOrFail) + +prop_merkleProof_length :: Property +prop_merkleProof_length = property $ do + (Just someTree) <- forAll genMerkleTree + 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) + where + checkMerkleProperty (MerkleLeaf _) = True + checkMerkleProperty (MerkleNode h l r) = h == pairHash (rootHash l) (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 + directions. For the "true" root of the tree, use 1. +-} +pathToNumber :: Int -> [Direction] -> Int +pathToNumber rootNum [] = rootNum +pathToNumber rootNum (d : ds) = pathToNumber childNum ds + where + childNum = case d of + TurnLeft -> rootNum * 2 + TurnRight -> rootNum * 2 + 1 + +{- | Convert a set of directions to a node to the numbers of the nodes on the + proof path to that node. These are the numbers of the nodes that are + _siblings_ to nodes on the given path. +-} +proofPathNodes :: Int -> [Direction] -> [Int] +proofPathNodes _ [] = [] +proofPathNodes rootNum (d : ds) = siblingNum : proofPathNodes childNum ds + where + childNum = case d of + TurnLeft -> rootNum * 2 + TurnRight -> rootNum * 2 + 1 + + siblingNum = case d of + TurnLeft -> rootNum * 2 + 1 + TurnRight -> rootNum * 2 + +{- | merkleProof returns a list of tuples where each tuple gives a node number + and the hash belonging to that node. +-} +spec_merkleProof_hashes :: Property +spec_merkleProof_hashes = property $ do + (Just someTree) <- forAll genMerkleTree + 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 thisNodeNum n@(MerkleLeaf _) targetNodeNum + | thisNodeNum == targetNodeNum = [n] + | otherwise = [] + getNode thisNodeNum n@(MerkleNode _ left right) targetNodeNum + | thisNodeNum == targetNodeNum = [n] + | otherwise = + getNode (thisNodeNum * 2) left targetNodeNum + ++ getNode (thisNodeNum * 2 + 1) right targetNodeNum + + annotateShow proof + + case proof of + Nothing -> failure + Just proof' -> diff (map snd proof') (==) (map (rootHash . head . getNode 1 someTree . fst) proof') + +{- | merkleProof returns a list of tuples where each tuple contains a node + number which is a sibling of a node on the path to a given leaf. +-} +spec_merkleProof_nodeNumbers :: Property +spec_merkleProof_nodeNumbers = property $ do + (Just someTree) <- forAll genMerkleTree + + -- Choose an arbitrary path through the tree. + somePath <- + forAll $ + Gen.list (Range.singleton $ height someTree - 1) $ + Gen.element [TurnLeft, TurnRight] + + let -- Identify the node at the end of the path + nodeNum = pathToNumber 1 somePath + leafNum = nodeNumberToLeafNumber someTree nodeNum + + -- Determine the proof path. It consists of the node numbers of the + -- siblings of the nodes on the merkle path. + someProof = proofPathNodes 1 somePath + + annotateShow nodeNum + annotateShow leafNum + + -- The computed proof path has node numbers which match the proof path node + -- numbers we computed above. + diff (map fst <$> merkleProof someTree leafNum) (==) (Just someProof) + +spec_numberConversion_tripping :: Property +spec_numberConversion_tripping = property $ do + (Just someTree) <- forAll genMerkleTree + 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 + let nodes = breadthFirstList validTree + + let (Just alleged) = buildTreeOutOfAllTheNodes nodes + diff alleged (==) validTree + +-- | Invalid flattened trees produce errors +spec_invalidMerkle :: Property +spec_invalidMerkle = property $ do + (Just validTree) <- forAll genMerkleTree + -- it's a valid list, missing one of the elements + let nodes = tail (breadthFirstList validTree) + + let maybeTree = buildTreeOutOfAllTheNodes nodes + diff maybeTree (==) Nothing + +-- | The length of all merkle paths equals one less than the given height. +spec_merklePath_length :: Property +spec_merklePath_length = property $ do + height' <- forAll $ Gen.integral (Range.linear 2 16) + leafNum <- forAll $ Gen.integral (Range.linear 0 (height' - 1)) + 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]] + +nodeNumberToLeafNumber :: MerkleTree -> Int -> Int +nodeNumberToLeafNumber tree nodeNum = nodeNum - 1 - size tree `div` 2 diff --git a/test/SpecServer.hs b/test/SpecServer.hs new file mode 100644 --- /dev/null +++ b/test/SpecServer.hs @@ -0,0 +1,50 @@ +module SpecServer (tests) where + +import Control.Monad (void, zipWithM_) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Aeson (decode, encode) +import qualified Data.ByteString as BS +import Generators (shareNumbers, storageIndexes, storageServerAnnouncements, storageServerIdentifiers) +import Hedgehog (Property, diff, forAll, property, tripping) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Tahoe.CHK.Server (StorageServer (storageServerRead, storageServerWrite)) +import Tahoe.Server (directoryStorageServer', memoryStorageServer) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +tests :: TestTree +tests = + testGroup + "Server" + [ testProperty + "immutable data round-trips through memoryStorageServer write / read" + (prop_immutable_tripping memoryStorageServer) + , testProperty + "immutable data round-trips through directoryStorageServer write / read" + (prop_immutable_tripping (directoryStorageServer' "SpecServer-storage")) + , testProperty + "Maps of StorageServerAnnouncement round-trip through JSON" + prop_servers_json_tripping + ] + +prop_servers_json_tripping :: Property +prop_servers_json_tripping = property $ do + servers <- forAll $ Gen.map (Range.linear 1 10) ((,) <$> storageServerIdentifiers <*> storageServerAnnouncements) + tripping servers encode decode + +prop_immutable_tripping :: IO StorageServer -> Property +prop_immutable_tripping newServer = property $ do + server <- liftIO newServer + storageIndex <- forAll storageIndexes + shareNum <- forAll shareNumbers + shareChunks <- forAll $ Gen.list (Range.linear 1 100) (Gen.bytes (Range.linear 1 100)) + + let write' = storageServerWrite server storageIndex shareNum + read' = storageServerRead server storageIndex shareNum + offsets = scanl (flip $ (+) . BS.length) 0 shareChunks + + void . liftIO $ zipWithM_ (write' . fromIntegral) offsets shareChunks + + result <- liftIO read' + diff (BS.concat shareChunks) (==) result diff --git a/test/SpecUEB.hs b/test/SpecUEB.hs new file mode 100644 --- /dev/null +++ b/test/SpecUEB.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TypeApplications #-} + +module SpecUEB (tests) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 +import Data.List (isInfixOf) +import qualified Data.Text as T +import Generators +import Hedgehog +import Tahoe.CHK.Types +import Tahoe.CHK.URIExtension +import Tahoe.Netstring +import Test.Tasty +import Test.Tasty.HUnit (assertBool, assertFailure, testCase) +import Test.Tasty.Hedgehog +import Text.Megaparsec + +tests :: TestTree +tests = + testGroup + "URIExtension" + [ testProperty "URIExtension round-trips through put / get" prop_roundtrip + , 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" + -- Replace the legitimate value of 11 for num_segments with a + -- value that overflows Int. + invalidBytes :: BS.ByteString + invalidBytes = + replace + ("num_segments:" <> netstring "11") + ("num_segments:" <> netstring (C8.pack . show . (+ 1) . fromIntegral @Int @Integer $ maxBound)) + validBytes + + -- Make sure we actually invalidated something + assertBool ("invalid == " <> show invalidBytes) (validBytes /= invalidBytes) + let parsed = parse pURIExtension "" invalidBytes + case parsed of + Left err -> do + assertBool "expected error not found" $ "above maximum allowed value" `isInfixOf` show err + Right result -> do + assertFailure $ "expected parse error, got " <> show result + ] + +-- | Like Data.Text.replace but for Data.ByteString.ByteString. +replace :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BS.ByteString +replace target replacement original = e $ T.replace (d target) (d replacement) (d original) + where + d = T.pack . C8.unpack + e = C8.pack . T.unpack + +prop_roundtrip :: Property +prop_roundtrip = property $ do + ueb <- forAll genURIExtension + tripping ueb uriExtensionToBytes (parse pURIExtension "") diff --git a/test/SpecUpload.hs b/test/SpecUpload.hs new file mode 100644 --- /dev/null +++ b/test/SpecUpload.hs @@ -0,0 +1,167 @@ +module SpecUpload ( + tests, +) where + +import Data.ByteString.Base32 ( + encodeBase32Unpadded, + ) +import Data.Maybe (mapMaybe) +import Data.Serialize ( + encode, + ) + +import Test.Tasty ( + TestTree, + testGroup, + ) + +import Test.Tasty.HUnit ( + assertEqual, + testCase, + ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL + +import Tahoe.CHK.Types ( + Parameters (..), + Required, + Size, + ) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Text (Text, pack) +import Data.Text.Encoding (encodeUtf8) +import Generators (storageServerAnnouncements, storageServerIdentifiers) +import Hedgehog (Property, diff, forAll, property) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Tahoe.CHK.Server ( + StorageServerAnnouncement (..), + preferredServers, + ) +import Tahoe.CHK.Upload ( + adjustSegmentSize, + getConvergentKey, + ) +import Test.Tasty.Hedgehog (testProperty) + +tests :: TestTree +tests = + testGroup + "Upload" + [ testConvergence + , testAdjustSegmentSize + ] + +testAdjustSegmentSize :: TestTree +testAdjustSegmentSize = + testGroup + "adjustSegmentSize" + [ testCase "same size" $ + -- If the data size is the same as the segment size, leave the segment + -- size alone. + assertEqual "" (p 3 3) (adjustSegmentSize (p 3 3) 3) + , testCase "bigger" $ + -- If the data size is larger than the segment size the segment size can + -- be left alone. + assertEqual "" (p 3 3) (adjustSegmentSize (p 3 3) 50) + , testCase "smaller, already multiple" $ + -- If the data size is smaller than the segment size and also a multiple + -- of the required value, make the segment size the data size. + assertEqual "" (p 3 3) (adjustSegmentSize (p 4 3) 3) + , testCase "smaller, not multiple" $ + -- If the data size is smaller than the segment size but not a multiple of + -- the required value, make the segment size the next multiple of required + -- larger than the data size. + assertEqual "" (p 3 3) (adjustSegmentSize (p 3 3) 2) + , testCase "regression" $ + assertEqual "" (p 131073 3) (adjustSegmentSize (p 131072 3) 104857600) + , testProperty "preferredServers returns all of the servers passed to it" prop_preferredServers_all + , testCase "preferredServers orders servers just like Tahoe-LAFS" $ + -- Two cases from allmydata.test.test_client.Basic.test_permute + let makeServer :: Int -> (Text, StorageServerAnnouncement) + makeServer n = + ( encodeBase32Unpadded . encodeUtf8 . pack . show $ n + , StorageServerAnnouncement + { storageServerAnnouncementFURL = Just "pb://somewhere/something" + , storageServerAnnouncementNick = Just . pack . show $ n + , storageServerAnnouncementPermutationSeed = Just . encodeUtf8 . pack . show $ n + } + ) + servers = Map.fromList $ makeServer <$> [0 .. 4] + ident = storageServerAnnouncementNick . snd + one = mapMaybe ident $ preferredServers "one" servers + two = mapMaybe ident $ preferredServers "two" servers + in do + assertEqual "case one" ["3", "1", "0", "4", "2"] one + assertEqual "case two" ["0", "4", "2", "1", "3"] two + ] + where + p :: Size -> Required -> Parameters + p segmentSize = Parameters segmentSize 5 4 + +prop_preferredServers_all :: Property +prop_preferredServers_all = property $ do + -- XXX 32 bytes? + storageIndex <- forAll $ Gen.bytes (Range.singleton 32) + servers <- forAll $ Gen.map (Range.linear 1 30) ((,) <$> storageServerIdentifiers <*> storageServerAnnouncements) + let preferred = preferredServers storageIndex servers + diff (Set.fromList . Map.toList $ servers) (==) (Set.fromList preferred) + +testConvergence :: TestTree +testConvergence = + testGroup + "Convergence" + [ testCase "getConvergentKey short data" $ + uncurry verifyConvergentKey short + , testCase "getConvergentKey medium data" $ + uncurry verifyConvergentKey medium + , testCase "getConvergentKey long data" $ + uncurry verifyConvergentKey long + ] + where + -- + -- These known results are correct because this Python program emits them: + -- + -- from allmydata.util.hashutil import convergence_hasher + -- from allmydata.util.base32 import b2a + -- hasher = convergence_hasher(3, 10, 1024, "\x42" * 32) + -- hasher.update(dataContent) + -- print(b2a(hasher.digest()).upper()) + -- + -- using Tahoe-LAFS git revision + -- 4e4114486710a2e88d494dcb6c0adf9e356173e7 (though the convergence + -- function should be extremely stable so it is likely that most + -- versions of Tahoe-LAFS will produce the same result). + -- + short = + ( "Hello, world." + , "3A6SKSC36YBRRZUJBN4IX4WRGU" + ) + medium = + ( B.concat $ replicate 256 "01234567" + , "VEUFRBTL3EBX7WP3SNZL2HCQOU" + ) + long = + ( B.concat $ replicate (1024 * 1024) "01234567" + , "KZXNCMP427WO37EEMH7TJYJQ3M" + ) + + verifyConvergentKey dataContent expectedKeyBytes = + assertEqual + "The key matches the known correct result" + expectedKeyBytes + (encodeBase32Unpadded . encode $ key) + where + key = getConvergentKey secret params (BL.fromStrict dataContent) + + secret = B.replicate 32 0x42 + params = + Parameters + { paramSegmentSize = 1024 + , paramTotalShares = 10 + , paramHappyShares = 7 + , paramRequiredShares = 3 + } diff --git a/test/SpecUtil.hs b/test/SpecUtil.hs new file mode 100644 --- /dev/null +++ b/test/SpecUtil.hs @@ -0,0 +1,54 @@ +module SpecUtil where + +import Hedgehog (Property, assert, diff, forAll, property) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Test.Tasty ( + TestTree, + testGroup, + ) +import Test.Tasty.HUnit (assertEqual, testCase) +import Test.Tasty.Hedgehog (testProperty) + +import qualified Data.ByteString as BS + +import Tahoe.Util (ceilDiv, chunkedBy) + +tests :: TestTree +tests = + testGroup + "utilities" + [ testProperty "BS.concat . chunkedBy n == id" prop_chunkedBy_identity + , testProperty "The length of every result element, except sometimes the last, equals n" prop_chunkedBy_length + , testCeilDiv + ] + +testCeilDiv :: TestTree +testCeilDiv = testCase "ceiling division" $ do + assertEqual "evenly divisible" (ceilDiv 2 1) (2 :: Integer) + assertEqual "needs rounding" (ceilDiv 3 2) (2 :: Integer) + +prop_chunkedBy_identity :: Property +prop_chunkedBy_identity = property $ do + someBytes <- forAll $ Gen.bytes (Range.linear 1 100) + someSize <- forAll $ Gen.int (Range.linear 1 100) + + diff someBytes (==) (BS.concat . chunkedBy someSize $ someBytes) + +prop_chunkedBy_length :: Property +prop_chunkedBy_length = property $ do + someBytes <- forAll $ Gen.bytes (Range.linear 1 100) + someSize <- forAll $ Gen.int (Range.linear 1 100) + + let chunks = chunkedBy someSize someBytes + + -- Handle the possibly-short element separately. + equalSize = tail . reverse $ chunks + short = last chunks + + -- All the rest should have the same length + assert (all ((someSize ==) . BS.length) equalSize) + + -- And the last should just be no longer. + assert (BS.length short <= someSize) diff --git a/test/SpecZFEC.hs b/test/SpecZFEC.hs new file mode 100644 --- /dev/null +++ b/test/SpecZFEC.hs @@ -0,0 +1,71 @@ +module SpecZFEC ( + tests, + prop_encode_decode_roundtrip, +) where + +import Test.Tasty ( + TestTree, + testGroup, + ) + +import Test.Tasty.HUnit ( + assertBool, + testCase, + ) + +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString as BS +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Tasty.Hedgehog + +import Tahoe.CHK (zfec, zunfec) + +tests :: TestTree +tests = + testGroup + "ZFEC" + [ testProperty "data round-trips through encode/decode" prop_encode_decode_roundtrip + , test_encode + , test_decode + ] + +test_encode :: TestTree +test_encode = testCase "ZFEC.encode" $ do + let k = 3 + n = 10 + x = 131073 + plaintext = BS.replicate x 73 + encoded <- liftIO $ zfec k n plaintext + assertBool "It encoded" (and $ (x `div` k ==) . BS.length <$> encoded) + +test_decode :: TestTree +test_decode = testCase "ZFEC.decode" $ do + let k = 3 + n = 10 + x = 131073 `div` k + encoded = replicate k (BS.replicate x 31) + plaintext <- liftIO $ zunfec k n (zip [0 ..] encoded) + assertBool "It decoded" $ BS.length plaintext == 131073 + +{- | Given any `k` output blocks from @'ZFEC.encode' k n plaintext@, @'decode' + k n@ will reproduce the @plaintext@ input. +-} +prop_encode_decode_roundtrip :: Property +prop_encode_decode_roundtrip = property $ do + k <- forAll $ Gen.int (Range.linear 1 254) + n <- forAll $ (k +) <$> Gen.int (Range.linear 1 (255 - k)) + + -- Ensure the plaintext has an allowed length. + plaintextLength <- forAll $ (k *) <$> Gen.integral (Range.linear 1 32) + plaintext <- forAll $ Gen.bytes (Range.singleton plaintextLength) + + encodedBlocks <- evalIO $ zfec k n plaintext + let tagged = zip [0 ..] encodedBlocks + annotateShow encodedBlocks + available <- forAll $ Gen.shuffle tagged + + decodedPlaintext <- evalIO $ zunfec k n (take k available) + + diff plaintext (==) decodedPlaintext diff --git a/test/Vectors.hs b/test/Vectors.hs new file mode 100644 --- /dev/null +++ b/test/Vectors.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Vectors where + +import Control.Exception (IOException, try) +import Data.Aeson ( + FromJSON (..), + ToJSON (..), + Value (..), + withText, + (.:), + ) +import Data.Aeson.Types ( + parseFail, + withObject, + ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Yaml (ParseException, decodeEither') +import GHC.Generics ( + Generic, + ) +import Tahoe.CHK.Types ( + Parameters (..), + ) + +newtype JSONByteString = JSONByteString B.ByteString deriving newtype (Ord, Eq) + +instance Show JSONByteString where + show (JSONByteString bs) = T.unpack . T.decodeLatin1 . Base64.encode $ bs + +instance FromJSON JSONByteString where + parseJSON = + withText + "base64 encoded bytestring" + ( \t -> + case Base64.decode . T.encodeUtf8 $ t of + Left err -> parseFail $ "parsing base64-encoded byte string failed" <> show err + Right stuff -> pure $ JSONByteString stuff + ) + +instance ToJSON JSONByteString where + toJSON (JSONByteString bs) = String . T.decodeLatin1 . Base64.encode $ bs + +data SSKFormat + = SDMF + { sskPrivateKey :: T.Text + } + | MDMF + { sskPrivateKey :: T.Text + } + deriving (Show, Ord, Eq) + +data Format = CHK | SSK SSKFormat deriving (Show, Ord, Eq) + +instance FromJSON Format where + parseJSON = withObject "format" $ \o -> do + kind <- o .: "kind" + case kind of + "chk" -> pure CHK + "ssk" -> SSK <$> o .: "params" + invalid -> parseFail $ "Unsupported format: " <> T.unpack invalid + +instance FromJSON SSKFormat where + parseJSON = withObject "ssk-format" $ \o -> do + format <- o .: "format" + key <- o .: "key" + sskFormat <- case format of + "sdmf" -> pure SDMF + "mdmf" -> pure MDMF + invalid -> parseFail $ "Unsupported SSK format: " <> T.unpack invalid + pure $ sskFormat key + +data Sample = Sample + { sampleTemplate :: JSONByteString + , sampleLength :: Int + } + deriving (Show, Ord, Eq) + +instance FromJSON Sample where + parseJSON = withObject "sample" $ \o -> + Sample <$> o .: "seed" <*> o .: "length" + +data VectorSpec = VectorSpec + { version :: T.Text + , vector :: [TestCase] + } + deriving (Generic, Show, Ord, Eq, FromJSON) + +data TestCase = TestCase + { convergence :: JSONByteString + , format :: Format + , sample :: Sample + , zfec :: Parameters + , expected :: T.Text + } + deriving (Generic, Show, Ord, Eq, FromJSON) + +instance FromJSON Parameters where + parseJSON = withObject "parameters" $ \o -> + Parameters <$> o .: "segmentSize" <*> o .: "total" <*> pure 1 <*> o .: "required" + +data LoadError = IOError IOException | ParseError ParseException deriving (Show) + +-- | Load the test vectors from the yaml file. +loadTestVectorData :: IO (Either LoadError VectorSpec) +loadTestVectorData = go "test_vectors.yaml" + where + go :: String -> IO (Either LoadError VectorSpec) + go path = do + bs <- read' path + pure $ + case bs of + Left le -> Left . IOError $ le + Right bs' -> parse bs' + + read' :: String -> IO (Either IOError B.ByteString) + read' = try . B.readFile + + parse :: B.ByteString -> Either LoadError VectorSpec + parse = either (Left . ParseError) pure . decodeEither'