packages feed

tahoe-chk (empty) → 0.1.0.2

raw patch · 30 files changed

+4538/−0 lines, 30 filesdep +aesondep +asyncdep +base

Dependencies added: aeson, async, base, base32, base64-bytestring, binary, bytestring, cereal, cipher-aes128, concurrency, containers, crypto-api, cryptonite, directory, extra, fec, filepath, hedgehog, megaparsec, memory, monad-loops, network-byte-order, optparse-applicative, parser-combinators, primitive, scientific, tagged, tahoe-chk, tasty, tasty-hedgehog, tasty-hunit, temporary, text, tree-diff, utility-ht, vector, yaml

Files

+ ChangeLog.md view
@@ -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.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ app/Main.hs view
@@ -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
+ src/Tahoe/CHK.hs view
@@ -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
+ src/Tahoe/CHK/Capability.hs view
@@ -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"
+ src/Tahoe/CHK/Crypto.hs view
@@ -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
+ src/Tahoe/CHK/Encrypt.hs view
@@ -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
+ src/Tahoe/CHK/Merkle.hs view
@@ -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
+ src/Tahoe/CHK/Parsing.hs view
@@ -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)
+ src/Tahoe/CHK/Server.hs view
@@ -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
+ src/Tahoe/CHK/Share.hs view
@@ -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
+ src/Tahoe/CHK/Types.hs view
@@ -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
+ src/Tahoe/CHK/URIExtension.hs view
@@ -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
+ src/Tahoe/CHK/Upload.hs view
@@ -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))
+ src/Tahoe/Netstring.hs view
@@ -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+        , ","+        ]
+ src/Tahoe/Server.hs view
@@ -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
+ src/Tahoe/Util.hs view
@@ -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
+ tahoe-chk.cabal view
@@ -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 <https://whetstone.private.storage/privatestorage/tahoe-chk/-/blob/main/README.md>++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
+ test/Generators.hs view
@@ -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
+ test/Spec.hs view
@@ -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)
+ test/SpecCHK.hs view
@@ -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)
+ test/SpecCrypto.hs view
@@ -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
+ test/SpecMerkle.hs view
@@ -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
+ test/SpecServer.hs view
@@ -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
+ test/SpecUEB.hs view
@@ -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 "")
+ test/SpecUpload.hs view
@@ -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+            }
+ test/SpecUtil.hs view
@@ -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)
+ test/SpecZFEC.hs view
@@ -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
+ test/Vectors.hs view
@@ -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'