{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# 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,
    DecodeError (..),
) where

import qualified Codec.FEC as ZFEC
import Control.Applicative (Alternative (empty))
import Control.Lens (view)
import Crypto.Cipher.AES (AES128)
import Crypto.Hash (
    Context,
    HashAlgorithm,
    hashFinalize,
    hashInit,
    hashUpdate,
 )
import Data.Bifunctor (Bifunctor (bimap), first, second)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.Foldable (foldlM)
import Data.Int (Int64)
import Data.List (partition, sort, transpose)
import Data.List.Extra (snoc)
import Data.Maybe (fromJust, mapMaybe)
import Data.Word (Word64)
import qualified Tahoe.CHK.Capability as Cap
import Tahoe.CHK.Cipher (Key)
import Tahoe.CHK.Crypto (
    blockHash',
    ciphertextSegmentHash',
    ciphertextTag,
    uriExtensionHash,
 )
import Tahoe.CHK.Merkle (
    MerkleTree,
    buildTreeOutOfAllTheNodes,
    leafHashes,
    leafNumberToNodeNumber,
    makeTreePartial,
    neededHashes,
    rootHash,
 )
import Tahoe.CHK.SHA256d (Digest' (Digest'), zero)
import Tahoe.CHK.Share (Share (..), crypttextHashTree, uriExtension)
import Tahoe.CHK.Types (
    BlockHash,
    CrypttextHash,
    Parameters (..),
    Required,
    requiredToInt,
    totalToInt,
 )
import Tahoe.CHK.URIExtension (
    URIExtension (..),
    codecParams,
 )
import Tahoe.CHK.Validate (
    matchingBlockHashRoot,
    matchingCrypttextHashRoot,
    shareValidBlocks,
    validFingerprint,
    validSegments,
    validShareRootHash,
 )
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 :: Int -> Int -> ByteString -> IO [ByteString]
zfec Int
k Int
n ByteString
segment =
    [ByteString] -> IO [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString] -> IO [ByteString])
-> [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ [ByteString]
chunks [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ FECParams -> [ByteString] -> [ByteString]
ZFEC.encode (Int -> Int -> FECParams
ZFEC.fec Int
k Int
n) [ByteString]
chunks
  where
    chunks_ :: [ByteString]
chunks_ = Int -> ByteString -> [ByteString]
chunkedBy (ByteString -> Int
B.length ByteString
segment Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
k) ByteString
segment
    _msg :: String
_msg =
        String
"zfec"
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" k="
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
k
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" n="
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", segment len "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
B.length ByteString
segment)
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", chunk lengths "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Int] -> String
forall a. Show a => a -> String
show ((ByteString -> Int) -> [ByteString] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Int
B.length [ByteString]
chunks_)
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", segment "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
segment
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-> chunks "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> String
forall a. Show a => a -> String
show [ByteString]
chunks_
    chunks :: [ByteString]
chunks = {- trace _msg -} [ByteString]
chunks_

-- | Version of `zfec` that operates on lazy ByteStrings.
zfecLazy :: Int -> Int -> LB.ByteString -> IO [LB.ByteString]
zfecLazy :: Int -> Int -> ByteString -> IO [ByteString]
zfecLazy Int
k Int
n ByteString
segment = (ByteString -> ByteString
LB.fromStrict (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> ByteString -> IO [ByteString]
zfec Int
k Int
n (ByteString -> ByteString
LB.toStrict ByteString
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 :: Int -> Int -> [(Int, ByteString)] -> IO ByteString
zunfec Int
k Int
n [(Int, ByteString)]
blocks = ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat (FECParams -> [(Int, ByteString)] -> [ByteString]
ZFEC.decode (Int -> Int -> FECParams
ZFEC.fec Int
k Int
n) [(Int, ByteString)]
blocks)

-- | Version of `zunfec` that operates on lazy ByteStrings.
zunfecLazy :: Int -> Int -> [(Int, LB.ByteString)] -> IO LB.ByteString
zunfecLazy :: Int -> Int -> [(Int, ByteString)] -> IO ByteString
zunfecLazy Int
k Int
n [(Int, ByteString)]
blocks = do
    ByteString
segment_ <- ByteString -> ByteString
LB.fromStrict (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> [(Int, ByteString)] -> IO ByteString
zunfec Int
k Int
n ((ByteString -> ByteString)
-> (Int, ByteString) -> (Int, ByteString)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ByteString -> ByteString
LB.toStrict ((Int, ByteString) -> (Int, ByteString))
-> [(Int, ByteString)] -> [(Int, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, ByteString)]
blocks)
    let _msg :: String
_msg =
            String
"zunfec"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" k="
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
k
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" n="
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" blocks="
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(Int, ByteString)] -> String
forall a. Show a => a -> String
show [(Int, ByteString)]
blocks
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" -> segment "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
segment_

    -- pure (trace _msg) segment_
    ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
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 hash = CPState
    { -- A single hash of all crypttext segments encoded so far.
      EncodingState hash -> Context hash
cpCrypttextHash :: Crypto.Hash.Context hash
    , -- A list of hashes of each ciphertext segment encoded so far
      EncodingState hash -> [CrypttextHash hash]
cpCrypttextHashes :: [CrypttextHash hash]
    , -- Hashes of blocks encoded so far.
      EncodingState hash -> [[BlockHash hash]]
cpBlockHashes :: [[BlockHash hash]]
    , -- Blocks encoded so far.
      EncodingState hash -> [[ByteString]]
cpBlocks :: [[LB.ByteString]]
    }

-- | The initial state for CHK encoding.
initEncodingState :: forall hash. HashAlgorithm hash => EncodingState hash
initEncodingState :: EncodingState hash
initEncodingState =
    CPState :: forall hash.
Context hash
-> [CrypttextHash hash]
-> [[CrypttextHash hash]]
-> [[ByteString]]
-> EncodingState hash
CPState
        { cpCrypttextHash :: Context hash
cpCrypttextHash = Context hash -> ByteString -> Context hash
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (HashAlgorithm hash => Context hash
forall a. HashAlgorithm a => Context a
hashInit @hash) (ByteString -> ByteString
netstring ByteString
ciphertextTag)
        , cpCrypttextHashes :: [CrypttextHash hash]
cpCrypttextHashes = [CrypttextHash hash]
forall a. Monoid a => a
mempty
        , cpBlockHashes :: [[CrypttextHash hash]]
cpBlockHashes = [[CrypttextHash hash]]
forall a. Monoid a => a
mempty
        , cpBlocks :: [[ByteString]]
cpBlocks = [[ByteString]]
forall a. Monoid a => a
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 -> ByteString -> [ByteString]
segmentCiphertext Parameters{SegmentSize
paramSegmentSize :: Parameters -> SegmentSize
paramSegmentSize :: SegmentSize
paramSegmentSize} ByteString
ciphertext =
    [ByteString]
result
  where
    result :: [ByteString]
result = {- trace ("segmentCiphertext: " <> show ciphertext) -} [ByteString]
result_
    result_ :: [ByteString]
result_ = ByteString -> ByteString
LB.fromStrict (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ByteString -> [ByteString]
chunkedBy (SegmentSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral SegmentSize
paramSegmentSize) (ByteString -> ByteString
LB.toStrict ByteString
ciphertext)

{- | Process ciphertext into blocks, carrying hashes computed along the way as
 state.
-}
processCiphertext :: forall hash. HashAlgorithm hash => Parameters -> [LB.ByteString] -> IO (EncodingState hash)
processCiphertext :: Parameters -> [ByteString] -> IO (EncodingState hash)
processCiphertext Parameters{Required
paramRequiredShares :: Parameters -> Required
paramRequiredShares :: Required
paramRequiredShares, Required
paramTotalShares :: Parameters -> Required
paramTotalShares :: Required
paramTotalShares} =
    (EncodingState hash -> ByteString -> IO (EncodingState hash))
-> EncodingState hash -> [ByteString] -> IO (EncodingState hash)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM EncodingState hash -> ByteString -> IO (EncodingState hash)
forall hash.
HashAlgorithm hash =>
EncodingState hash -> ByteString -> IO (EncodingState hash)
processSegment (HashAlgorithm hash => EncodingState hash
forall hash. HashAlgorithm hash => EncodingState hash
initEncodingState @hash)
  where
    processSegment :: EncodingState hash -> ByteString -> IO (EncodingState hash)
processSegment CPState{[[ByteString]]
[[BlockHash hash]]
[BlockHash hash]
Context hash
cpBlocks :: [[ByteString]]
cpBlockHashes :: [[BlockHash hash]]
cpCrypttextHashes :: [BlockHash hash]
cpCrypttextHash :: Context hash
cpBlocks :: forall hash. EncodingState hash -> [[ByteString]]
cpBlockHashes :: forall hash. EncodingState hash -> [[CrypttextHash hash]]
cpCrypttextHashes :: forall hash. EncodingState hash -> [CrypttextHash hash]
cpCrypttextHash :: forall hash. EncodingState hash -> Context hash
..} ByteString
segment = do
        -- Produce the FEC blocks for this piece of ciphertext.
        [ByteString]
blocks <-
            Int -> Int -> ByteString -> IO [ByteString]
zfecLazy
                (Required -> Int
requiredToInt Required
paramRequiredShares)
                (Required -> Int
totalToInt Required
paramTotalShares)
                (Required -> ByteString -> ByteString
padCiphertext Required
paramRequiredShares ByteString
segment)
        EncodingState hash -> IO (EncodingState hash)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EncodingState hash -> IO (EncodingState hash))
-> EncodingState hash -> IO (EncodingState hash)
forall a b. (a -> b) -> a -> b
$
            CPState :: forall hash.
Context hash
-> [CrypttextHash hash]
-> [[CrypttextHash hash]]
-> [[ByteString]]
-> EncodingState hash
CPState
                { cpCrypttextHash :: Context hash
cpCrypttextHash = Context hash -> ByteString -> Context hash
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate Context hash
cpCrypttextHash (ByteString -> ByteString
LB.toStrict ByteString
segment)
                , cpCrypttextHashes :: [BlockHash hash]
cpCrypttextHashes = [BlockHash hash] -> BlockHash hash -> [BlockHash hash]
forall a. [a] -> a -> [a]
snoc [BlockHash hash]
cpCrypttextHashes (ByteString -> BlockHash hash
forall hash. HashAlgorithm hash => ByteString -> Digest' hash
ciphertextSegmentHash' (ByteString -> ByteString
LB.toStrict ByteString
segment))
                , cpBlockHashes :: [[BlockHash hash]]
cpBlockHashes = [[BlockHash hash]] -> [BlockHash hash] -> [[BlockHash hash]]
forall a. [a] -> a -> [a]
snoc [[BlockHash hash]]
cpBlockHashes (ByteString -> BlockHash hash
forall hash. HashAlgorithm hash => ByteString -> Digest' hash
blockHash' (ByteString -> BlockHash hash)
-> (ByteString -> ByteString) -> ByteString -> BlockHash hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LB.toStrict (ByteString -> BlockHash hash) -> [ByteString] -> [BlockHash hash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
blocks)
                , cpBlocks :: [[ByteString]]
cpBlocks = [[ByteString]] -> [ByteString] -> [[ByteString]]
forall a. [a] -> a -> [a]
snoc [[ByteString]]
cpBlocks [ByteString]
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 :: Required -> ByteString -> ByteString
padCiphertext Required
requiredShares ByteString
bs
    | Int64
paddingLength Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0 = ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int64 -> Word8 -> ByteString
LB.replicate Int64
paddingLength Word8
0x00
    | Bool
otherwise = ByteString
bs
  where
    desiredLength :: Int64
desiredLength = Required -> Int64 -> Int64
forall m v. (Integral m, Integral v) => m -> v -> v
nextMultipleOf Required
requiredShares (ByteString -> Int64
LB.length ByteString
bs)
    paddingLength :: Int64
paddingLength = Int64
desiredLength Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- ByteString -> Int64
LB.length ByteString
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.
    Key AES128 ->
    -- | 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 :: Key AES128 -> Parameters -> ByteString -> IO ([Share], Reader)
encode Key AES128
readKey initParams :: Parameters
initParams@(Parameters SegmentSize
maximumSegmentSize Required
total Int
_ Required
required) ByteString
ciphertext =
    Parameters -> [ByteString] -> IO (EncodingState SHA256d)
forall hash.
HashAlgorithm hash =>
Parameters -> [ByteString] -> IO (EncodingState hash)
processCiphertext Parameters
p (Parameters -> ByteString -> [ByteString]
segmentCiphertext Parameters
p ByteString
ciphertext) IO (EncodingState SHA256d)
-> (EncodingState SHA256d -> IO ([Share], Reader))
-> IO ([Share], Reader)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CPState{[[ByteString]]
[[BlockHash SHA256d]]
[BlockHash SHA256d]
Context SHA256d
cpBlocks :: [[ByteString]]
cpBlockHashes :: [[BlockHash SHA256d]]
cpCrypttextHashes :: [BlockHash SHA256d]
cpCrypttextHash :: Context SHA256d
cpBlocks :: forall hash. EncodingState hash -> [[ByteString]]
cpBlockHashes :: forall hash. EncodingState hash -> [[CrypttextHash hash]]
cpCrypttextHashes :: forall hash. EncodingState hash -> [CrypttextHash hash]
cpCrypttextHash :: forall hash. EncodingState hash -> Context hash
..} ->
        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 :: Int
numSegments = [[ByteString]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[ByteString]]
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 :: Int
effectiveSegments = Int -> Int -> Int
forall p. (Ord p, Num p) => p -> p -> p
nextPowerOf Int
2 Int
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 MerkleTree value SHA256d
plaintextHashTree =
                [BlockHash SHA256d] -> Maybe (MerkleTree value SHA256d)
forall hash value.
(Show hash, HashAlgorithm hash) =>
[Digest' hash] -> Maybe (MerkleTree value hash)
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.
                    ([BlockHash SHA256d] -> Maybe (MerkleTree value SHA256d))
-> (BlockHash SHA256d -> [BlockHash SHA256d])
-> BlockHash SHA256d
-> Maybe (MerkleTree value SHA256d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> BlockHash SHA256d -> [BlockHash SHA256d]
forall a. Int -> a -> [a]
replicate (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
effectiveSegments Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                    -- And make every node all nul.
                    (BlockHash SHA256d -> Maybe (MerkleTree value SHA256d))
-> BlockHash SHA256d -> Maybe (MerkleTree value SHA256d)
forall a b. (a -> b) -> a -> b
$ BlockHash SHA256d
forall hash. HashAlgorithm hash => Digest' hash
zero

            -- shareTree is a MerkleTree of MerkleTree
            shareTree :: MerkleTree (MerkleTree ByteString SHA256d) SHA256d
shareTree =
                -- trace ("shareTree: " <> show shareTree')
                MerkleTree (MerkleTree ByteString SHA256d) SHA256d
shareTree'
              where
                shareTree' :: MerkleTree (MerkleTree ByteString SHA256d) SHA256d
shareTree' = [MerkleTree ByteString SHA256d]
-> MerkleTree (MerkleTree ByteString SHA256d) SHA256d
forall hash.
HashAlgorithm hash =>
[MerkleTree ByteString hash]
-> MerkleTree (MerkleTree ByteString hash) hash
makeShareTree ([MerkleTree ByteString SHA256d]
 -> MerkleTree (MerkleTree ByteString SHA256d) SHA256d)
-> ([[BlockHash SHA256d]] -> [MerkleTree ByteString SHA256d])
-> [[BlockHash SHA256d]]
-> MerkleTree (MerkleTree ByteString SHA256d) SHA256d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([BlockHash SHA256d] -> MerkleTree ByteString SHA256d)
-> [[BlockHash SHA256d]] -> [MerkleTree ByteString SHA256d]
forall a b. (a -> b) -> [a] -> [b]
map [BlockHash SHA256d] -> MerkleTree ByteString SHA256d
forall hash value.
HashAlgorithm hash =>
[Digest' hash] -> MerkleTree value hash
makeTreePartial ([[BlockHash SHA256d]] -> [MerkleTree ByteString SHA256d])
-> ([[BlockHash SHA256d]] -> [[BlockHash SHA256d]])
-> [[BlockHash SHA256d]]
-> [MerkleTree ByteString SHA256d]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[BlockHash SHA256d]] -> [[BlockHash SHA256d]]
forall a. [[a]] -> [[a]]
transpose ([[BlockHash SHA256d]]
 -> MerkleTree (MerkleTree ByteString SHA256d) SHA256d)
-> [[BlockHash SHA256d]]
-> MerkleTree (MerkleTree ByteString SHA256d) SHA256d
forall a b. (a -> b) -> a -> b
$ [[BlockHash SHA256d]]
cpBlockHashes

            -- A bag of additional metadata about the share and encoded object.
            uriExt :: URIExtension
uriExt =
                URIExtension :: ByteString
-> Parameters
-> Parameters
-> SegmentSize
-> SegmentSize
-> Int
-> Required
-> Required
-> BlockHash SHA256d
-> BlockHash SHA256d
-> BlockHash SHA256d
-> URIExtension
URIExtension
                    { _codecName :: ByteString
_codecName = ByteString
"crs"
                    , _codecParams :: Parameters
_codecParams = Parameters
p -- trace ("Params: " <> show p) p
                    , _size :: SegmentSize
_size = Int64 -> SegmentSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> SegmentSize) -> Int64 -> SegmentSize
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LB.length ByteString
ciphertext
                    , _segmentSize :: SegmentSize
_segmentSize = SegmentSize
segmentSize
                    , _neededShares :: Required
_neededShares = Required
required
                    , _totalShares :: Required
_totalShares = Required
total
                    , _numSegments :: Int
_numSegments = Int
numSegments
                    , _tailCodecParams :: Parameters
_tailCodecParams = Parameters -> Int64 -> Parameters
forall a. Integral a => Parameters -> a -> Parameters
tailParams Parameters
p (ByteString -> Int64
LB.length ByteString
ciphertext)
                    , _crypttextHash :: BlockHash SHA256d
_crypttextHash = Context SHA256d -> BlockHash SHA256d
forall hash.
HashAlgorithm hash =>
Context hash -> CrypttextHash hash
makeCrypttextHash Context SHA256d
cpCrypttextHash
                    , _crypttextRootHash :: BlockHash SHA256d
_crypttextRootHash = [BlockHash SHA256d] -> BlockHash SHA256d
forall hash.
HashAlgorithm hash =>
[CrypttextHash hash] -> CrypttextHash hash
makeCrypttextRootHash [BlockHash SHA256d]
cpCrypttextHashes
                    , _shareRootHash :: BlockHash SHA256d
_shareRootHash = MerkleTree (MerkleTree ByteString SHA256d) SHA256d
-> BlockHash SHA256d
forall v a. MerkleTree v a -> Digest' a
rootHash MerkleTree (MerkleTree ByteString SHA256d) SHA256d
shareTree
                    }

            -- The read capability for the encoded object.
            cap :: Reader
cap =
                Key AES128
-> ByteString -> Required -> Required -> SegmentSize -> Reader
Cap.makeReader
                    Key AES128
readKey
                    (URIExtension -> ByteString
uriExtensionHash URIExtension
uriExt)
                    Required
required
                    Required
total
                    (Int64 -> SegmentSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> SegmentSize) -> Int64 -> SegmentSize
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LB.length ByteString
ciphertext)

            toShare :: Int -> [ByteString] -> [BlockHash SHA256d] -> Share
toShare Int
sharenum [ByteString]
blocks [BlockHash SHA256d]
blockHashes =
                Share :: Word64
-> Word64
-> [ByteString]
-> MerkleTree ByteString SHA256d
-> MerkleTree ByteString SHA256d
-> MerkleTree ByteString SHA256d
-> [(Int, BlockHash SHA256d)]
-> URIExtension
-> Share
Share
                    { _blockSize :: Word64
_blockSize = Parameters -> Word64
shareBlockSize Parameters
p
                    , _dataSize :: Word64
_dataSize = Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word64) -> Int64 -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LB.length ByteString
ciphertext Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`ceilDiv` Required -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Required
required
                    , _blocks :: [ByteString]
_blocks = [ByteString]
blocks
                    , _plaintextHashTree :: MerkleTree ByteString SHA256d
_plaintextHashTree = MerkleTree ByteString SHA256d
forall value. MerkleTree value SHA256d
plaintextHashTree
                    , _crypttextHashTree :: MerkleTree ByteString SHA256d
_crypttextHashTree = [BlockHash SHA256d] -> MerkleTree ByteString SHA256d
forall hash value.
HashAlgorithm hash =>
[Digest' hash] -> MerkleTree value hash
makeTreePartial [BlockHash SHA256d]
cpCrypttextHashes
                    , _blockHashTree :: MerkleTree ByteString SHA256d
_blockHashTree = [BlockHash SHA256d] -> MerkleTree ByteString SHA256d
forall hash value.
HashAlgorithm hash =>
[Digest' hash] -> MerkleTree value hash
makeTreePartial [BlockHash SHA256d]
blockHashes
                    , _neededHashes :: [(Int, BlockHash SHA256d)]
_neededHashes = [(Int, BlockHash SHA256d)] -> [(Int, BlockHash SHA256d)]
forall a. Ord a => [a] -> [a]
sort ([(Int, BlockHash SHA256d)] -> [(Int, BlockHash SHA256d)])
-> ([(Int, BlockHash SHA256d)] -> [(Int, BlockHash SHA256d)])
-> [(Int, BlockHash SHA256d)]
-> [(Int, BlockHash SHA256d)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, BlockHash SHA256d) -> (Int, BlockHash SHA256d))
-> [(Int, BlockHash SHA256d)] -> [(Int, BlockHash SHA256d)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Int)
-> (Int, BlockHash SHA256d) -> (Int, BlockHash SHA256d)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([(Int, BlockHash SHA256d)] -> [(Int, BlockHash SHA256d)])
-> [(Int, BlockHash SHA256d)] -> [(Int, BlockHash SHA256d)]
forall a b. (a -> b) -> a -> b
$ MerkleTree (MerkleTree ByteString SHA256d) SHA256d
-> Int -> [(Int, BlockHash SHA256d)]
forall hash.
MerkleTree (MerkleTree ByteString hash) hash
-> Int -> [(Int, Digest' hash)]
computeNeededHashes MerkleTree (MerkleTree ByteString SHA256d) SHA256d
shareTree Int
sharenum
                    , _uriExtension :: URIExtension
_uriExtension = URIExtension
uriExt
                    }

            -- 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 -> Word64
shareBlockSize Parameters{SegmentSize
paramSegmentSize :: SegmentSize
paramSegmentSize :: Parameters -> SegmentSize
paramSegmentSize, Required
paramRequiredShares :: Required
paramRequiredShares :: Parameters -> Required
paramRequiredShares} =
                SegmentSize -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral SegmentSize
paramSegmentSize Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`ceilDiv` Required -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Required
paramRequiredShares
         in ([Share], Reader) -> IO ([Share], Reader)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( (Int -> [ByteString] -> [BlockHash SHA256d] -> Share)
-> [Int] -> [[ByteString]] -> [[BlockHash SHA256d]] -> [Share]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> [ByteString] -> [BlockHash SHA256d] -> Share
toShare [Int
0 ..] ([[ByteString]] -> [[ByteString]]
forall a. [[a]] -> [[a]]
transpose [[ByteString]]
cpBlocks) ([[BlockHash SHA256d]] -> [[BlockHash SHA256d]]
forall a. [[a]] -> [[a]]
transpose [[BlockHash SHA256d]]
cpBlockHashes)
                , Reader
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
p@(Parameters SegmentSize
segmentSize Required
_ Int
_ Required
required') =
        Parameters
initParams
            { paramSegmentSize :: SegmentSize
paramSegmentSize = Required -> SegmentSize -> SegmentSize
forall m v. (Integral m, Integral v) => m -> v -> v
nextMultipleOf Required
required' (SegmentSize -> SegmentSize) -> SegmentSize -> SegmentSize
forall a b. (a -> b) -> a -> b
$ SegmentSize -> SegmentSize -> SegmentSize
forall a. Ord a => a -> a -> a
min SegmentSize
maximumSegmentSize (Int64 -> SegmentSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> SegmentSize) -> Int64 -> SegmentSize
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LB.length ByteString
ciphertext)
            }

-- | A problem was encountered during decoding.
data DecodeError
    = -- | The size of the data is greater than the limits imposed by this implementation.
      SizeOverflow
    | -- | There weren't enough shares supplied to attempt erasure decoding.
      NotEnoughShares
    | -- | After discarding shares for which the fingerprint from the read
      -- | capability did not match the URI extension block, there weren't
      -- | enough shares left to attempt erasure decoding.
      IntegrityError
        { DecodeError -> [(Int, Share, InvalidShare)]
integrityErrorInvalidShares :: [(Int, Share, InvalidShare)]
        }
    | -- | The hash of one or more blocks did not match the expected value.
      BlockHashError
    | -- | The hash of one or more ciphertext segments did not match the expected value.
      CiphertextHashError
    deriving (DecodeError -> DecodeError -> Bool
(DecodeError -> DecodeError -> Bool)
-> (DecodeError -> DecodeError -> Bool) -> Eq DecodeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecodeError -> DecodeError -> Bool
$c/= :: DecodeError -> DecodeError -> Bool
== :: DecodeError -> DecodeError -> Bool
$c== :: DecodeError -> DecodeError -> Bool
Eq, Eq DecodeError
Eq DecodeError
-> (DecodeError -> DecodeError -> Ordering)
-> (DecodeError -> DecodeError -> Bool)
-> (DecodeError -> DecodeError -> Bool)
-> (DecodeError -> DecodeError -> Bool)
-> (DecodeError -> DecodeError -> Bool)
-> (DecodeError -> DecodeError -> DecodeError)
-> (DecodeError -> DecodeError -> DecodeError)
-> Ord DecodeError
DecodeError -> DecodeError -> Bool
DecodeError -> DecodeError -> Ordering
DecodeError -> DecodeError -> DecodeError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DecodeError -> DecodeError -> DecodeError
$cmin :: DecodeError -> DecodeError -> DecodeError
max :: DecodeError -> DecodeError -> DecodeError
$cmax :: DecodeError -> DecodeError -> DecodeError
>= :: DecodeError -> DecodeError -> Bool
$c>= :: DecodeError -> DecodeError -> Bool
> :: DecodeError -> DecodeError -> Bool
$c> :: DecodeError -> DecodeError -> Bool
<= :: DecodeError -> DecodeError -> Bool
$c<= :: DecodeError -> DecodeError -> Bool
< :: DecodeError -> DecodeError -> Bool
$c< :: DecodeError -> DecodeError -> Bool
compare :: DecodeError -> DecodeError -> Ordering
$ccompare :: DecodeError -> DecodeError -> Ordering
$cp1Ord :: Eq DecodeError
Ord, Int -> DecodeError -> String -> String
[DecodeError] -> String -> String
DecodeError -> String
(Int -> DecodeError -> String -> String)
-> (DecodeError -> String)
-> ([DecodeError] -> String -> String)
-> Show DecodeError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DecodeError] -> String -> String
$cshowList :: [DecodeError] -> String -> String
show :: DecodeError -> String
$cshow :: DecodeError -> String
showsPrec :: Int -> DecodeError -> String -> String
$cshowsPrec :: Int -> DecodeError -> String -> String
Show)

{- | 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 Right of the ciphertext contained by the
    -- shares if it is possible to recover it, or Left with information about
    -- why it is not.
    IO (Either DecodeError LB.ByteString)
decode :: Reader -> [(Int, Share)] -> IO (Either DecodeError ByteString)
decode Reader
reader [(Int, Share)]
shares
    | Reader -> SegmentSize
size Reader
reader SegmentSize -> SegmentSize -> Bool
forall a. Ord a => a -> a -> Bool
> Int64 -> SegmentSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int64 @Integer Int64
forall a. Bounded a => a
maxBound = Either DecodeError ByteString -> IO (Either DecodeError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DecodeError ByteString
 -> IO (Either DecodeError ByteString))
-> Either DecodeError ByteString
-> IO (Either DecodeError ByteString)
forall a b. (a -> b) -> a -> b
$ DecodeError -> Either DecodeError ByteString
forall a b. a -> Either a b
Left DecodeError
SizeOverflow
    | [(Int, Share)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Share)]
shares Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Required -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Reader -> Required
required Reader
reader) = Either DecodeError ByteString -> IO (Either DecodeError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DecodeError ByteString
 -> IO (Either DecodeError ByteString))
-> Either DecodeError ByteString
-> IO (Either DecodeError ByteString)
forall a b. (a -> b) -> a -> b
$ DecodeError -> Either DecodeError ByteString
forall a b. a -> Either a b
Left DecodeError
NotEnoughShares
    | [(Int, Share)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Share)]
validShares Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Required -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Reader -> Required
required Reader
reader) = Either DecodeError ByteString -> IO (Either DecodeError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DecodeError ByteString
 -> IO (Either DecodeError ByteString))
-> ([(Int, Share, InvalidShare)] -> Either DecodeError ByteString)
-> [(Int, Share, InvalidShare)]
-> IO (Either DecodeError ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeError -> Either DecodeError ByteString
forall a b. a -> Either a b
Left (DecodeError -> Either DecodeError ByteString)
-> ([(Int, Share, InvalidShare)] -> DecodeError)
-> [(Int, Share, InvalidShare)]
-> Either DecodeError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Share, InvalidShare)] -> DecodeError
IntegrityError ([(Int, Share, InvalidShare)]
 -> IO (Either DecodeError ByteString))
-> [(Int, Share, InvalidShare)]
-> IO (Either DecodeError ByteString)
forall a b. (a -> b) -> a -> b
$ [(Int, Share, InvalidShare)]
invalidShares
    | Bool
otherwise = do
        let -- The ZFEC decoder takes as input a list of (share number, block
            -- bytes) tuples (and the encoding parameters).  It wants the list
            -- to contain *exactly* `k` distinct blocks.  Our job is to give
            -- it these such a list, then.  If there were shares with metadata
            -- that disqualified them from use we have already discarded them.
            -- We have not yet verified the integrity of the actual blocks so
            -- we will do so now.
            --
            -- It could be that we initially appear to have some extra data
            -- available (more than `k` shares) but then discover that *some*
            -- blocks are invalid.  If we can disqualify *blocks* for being
            -- invalid rather than disqualifying entire shares then we will be
            -- able to recover data in more situations so we will try to do
            -- that.

            -- Start by annotating every block of every share with a boolean
            -- of whether its hash matches the good hash from the block hash
            -- tree.  The outer list gives a share number along with that
            -- share's data.  Each inner list gives a validated block or
            -- nothing if validation failed.
            blocksWithValidity :: [[(Int, Maybe LB.ByteString)]]
            blocksWithValidity :: [[(Int, Maybe ByteString)]]
blocksWithValidity = (Int, [Maybe ByteString]) -> [(Int, Maybe ByteString)]
forall a. (Int, [a]) -> [(Int, a)]
fixBlocks ((Int, [Maybe ByteString]) -> [(Int, Maybe ByteString)])
-> ((Int, Share) -> (Int, [Maybe ByteString]))
-> (Int, Share)
-> [(Int, Maybe ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Share -> [Maybe ByteString])
-> (Int, Share) -> (Int, [Maybe ByteString])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Share -> [Maybe ByteString]
shareValidBlocks ((Int, Share) -> [(Int, Maybe ByteString)])
-> [(Int, Share)] -> [[(Int, Maybe ByteString)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Share)]
validShares

            -- Change the container structure.  The outer list corresponds to
            -- erasure-encoded segments.  The order corresponds to the order
            -- of the segments from the original input.  Each inner list
            -- contains the blocks we were able to validate for that segment.
            explodedBlocks :: [[(Int, Maybe LB.ByteString)]]
            explodedBlocks :: [[(Int, Maybe ByteString)]]
explodedBlocks = [[(Int, Maybe ByteString)]] -> [[(Int, Maybe ByteString)]]
forall a. [[a]] -> [[a]]
transpose [[(Int, Maybe ByteString)]]
blocksWithValidity

            -- Then filter down to only the validated blocks.
            validBlocks :: [[(Int, LB.ByteString)]]
            validBlocks :: [[(Int, ByteString)]]
validBlocks = ((Int, Maybe ByteString) -> Maybe (Int, ByteString))
-> [(Int, Maybe ByteString)] -> [(Int, ByteString)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Int
num, Maybe ByteString
mbs) -> (Int
num,) (ByteString -> (Int, ByteString))
-> Maybe ByteString -> Maybe (Int, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
mbs) ([(Int, Maybe ByteString)] -> [(Int, ByteString)])
-> [[(Int, Maybe ByteString)]] -> [[(Int, ByteString)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(Int, Maybe ByteString)]]
explodedBlocks

            -- If we end up with fewer than `required` blocks for any
            -- particular segment, we cannot decode that segment.  Throw out
            -- the data we cannot use and structure what's left so we can
            -- easily skip over those segments if desired.
            enoughBlocks :: [Maybe [(Int, LB.ByteString)]]
            enoughBlocks :: [Maybe [(Int, ByteString)]]
enoughBlocks = ([(Int, ByteString)] -> Bool)
-> [(Int, ByteString)] -> Maybe [(Int, ByteString)]
forall (f :: * -> *) a. Alternative f => (a -> Bool) -> a -> f a
guarded ((Required -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Reader -> Required
required Reader
reader) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=) (Int -> Bool)
-> ([(Int, ByteString)] -> Int) -> [(Int, ByteString)] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, ByteString)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([(Int, ByteString)] -> Maybe [(Int, ByteString)])
-> [[(Int, ByteString)]] -> [Maybe [(Int, ByteString)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(Int, ByteString)]]
validBlocks

            -- Figure out how many bytes are expected to be in each segment.
            -- Depending on the ZFEC encoding parameters, it is possible that
            -- we will end up with blocks that are not completely "filled"
            -- 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 :: SegmentSize
segSize = Parameters -> SegmentSize
paramSegmentSize (Parameters -> SegmentSize)
-> (Share -> Parameters) -> Share -> SegmentSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Parameters Share Parameters -> Share -> Parameters
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((URIExtension -> Const Parameters URIExtension)
-> Share -> Const Parameters Share
Lens' Share URIExtension
uriExtension ((URIExtension -> Const Parameters URIExtension)
 -> Share -> Const Parameters Share)
-> ((Parameters -> Const Parameters Parameters)
    -> URIExtension -> Const Parameters URIExtension)
-> Getting Parameters Share Parameters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Parameters -> Const Parameters Parameters)
-> URIExtension -> Const Parameters URIExtension
Lens' URIExtension Parameters
codecParams) (Share -> SegmentSize) -> Share -> SegmentSize
forall a b. (a -> b) -> a -> b
$ Share
anyValidShare

            -- The final segment might be short.  Find out.  Note we don't
            -- read the segment size from the tail codec params in the
            -- URIExtension because that *includes* padding and we're trying
            -- to *exclude* padding.  Instead we compute the result from the
            -- real application data size and the non-tail segment size.
            tailSegSize :: SegmentSize
tailSegSize = case Reader -> SegmentSize
size Reader
reader SegmentSize -> SegmentSize -> SegmentSize
forall a. Integral a => a -> a -> a
`mod` SegmentSize
segSize of
                SegmentSize
0 -> SegmentSize
segSize
                SegmentSize
n -> SegmentSize
n

            -- A helper that knows the correct parameters to do ZFEC decoding
            -- for us.
            --
            -- XXX Do we need this LB.take at the front?  Shouldn't each block
            -- be segSize bytes in length anyway (disregarding the tail
            -- segment, which we're not doing anything to handle here anyway)?
            -- We chunked the bytes up in to blocks, we know how big they are.
            -- But we chunked them based on `_blockSize` from the share, not
            -- `segSize` from the codec params.  Perhaps if we validated those
            -- are consistent then we could be confident of consistency here
            -- w/o the LB.take.
            zunfec' :: [(Int, ByteString)] -> IO ByteString
zunfec' = (Int64 -> ByteString -> ByteString
LB.take (SegmentSize -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral SegmentSize
segSize) (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (IO ByteString -> IO ByteString)
-> ([(Int, ByteString)] -> IO ByteString)
-> [(Int, ByteString)]
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> [(Int, ByteString)] -> IO ByteString
zunfecLazy (Required -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Reader -> Required
required Reader
reader)) (Required -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Reader -> Required
total Reader
reader))

            -- Get ready to decode the groups of blocks back to the original
            -- segments, where this is possible.  We might have even more than
            -- we need at this point so be sure to discard any extras so
            -- zunfec doesn't grow angry.
            getSegments :: [Maybe (IO LB.ByteString)]
            getSegments :: [Maybe (IO ByteString)]
getSegments = (Maybe [(Int, ByteString)] -> Maybe (IO ByteString))
-> [Maybe [(Int, ByteString)]] -> [Maybe (IO ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Int, ByteString)] -> IO ByteString
zunfec' ([(Int, ByteString)] -> IO ByteString)
-> ([(Int, ByteString)] -> [(Int, ByteString)])
-> [(Int, ByteString)]
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [(Int, ByteString)] -> [(Int, ByteString)]
forall a. Int -> [a] -> [a]
take (Required -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Reader -> Required
required Reader
reader)) ([(Int, ByteString)] -> IO ByteString)
-> Maybe [(Int, ByteString)] -> Maybe (IO ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Maybe [(Int, ByteString)]]
enoughBlocks

        -- Actually do it
        [Maybe ByteString]
maybeSegments <- (Maybe (IO ByteString) -> IO (Maybe ByteString))
-> [Maybe (IO ByteString)] -> IO [Maybe ByteString]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Maybe (IO ByteString) -> IO (Maybe ByteString)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe (IO ByteString)]
getSegments :: IO [Maybe LB.ByteString]

        Either DecodeError ByteString -> IO (Either DecodeError ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DecodeError ByteString
 -> IO (Either DecodeError ByteString))
-> Either DecodeError ByteString
-> IO (Either DecodeError ByteString)
forall a b. (a -> b) -> a -> b
$ do
            -- This function produces a monolithic result - everything or nothing.
            -- So change the structure from "results and errors for individual
            -- blocks" to "a result or an error from somewhere".  A function with
            -- an incremental result interface could consider just completing with
            -- `segments` from above.  Or perhaps further transforming it to
            --
            --   (Traversable t, Functor f) => t (IO (f LB.ByteString))
            [ByteString]
segments <- Either DecodeError [ByteString]
-> ([ByteString] -> Either DecodeError [ByteString])
-> Maybe [ByteString]
-> Either DecodeError [ByteString]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DecodeError -> Either DecodeError [ByteString]
forall a b. a -> Either a b
Left DecodeError
BlockHashError) [ByteString] -> Either DecodeError [ByteString]
forall a b. b -> Either a b
Right ([Maybe ByteString] -> Maybe [ByteString]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe ByteString]
maybeSegments)

            -- Now check the validity of the segments themselves against the
            -- crypttext hash tree.
            let maybeValidSegments :: [Maybe ByteString]
maybeValidSegments =
                    [BlockHash SHA256d] -> [ByteString] -> [Maybe ByteString]
validSegments
                        (MerkleTree ByteString SHA256d -> [BlockHash SHA256d]
forall v a. MerkleTree v a -> [Digest' a]
leafHashes (MerkleTree ByteString SHA256d -> [BlockHash SHA256d])
-> MerkleTree ByteString SHA256d -> [BlockHash SHA256d]
forall a b. (a -> b) -> a -> b
$ Getting
  (MerkleTree ByteString SHA256d)
  Share
  (MerkleTree ByteString SHA256d)
-> Share -> MerkleTree ByteString SHA256d
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (MerkleTree ByteString SHA256d)
  Share
  (MerkleTree ByteString SHA256d)
Lens' Share (MerkleTree ByteString SHA256d)
crypttextHashTree Share
anyValidShare)
                        -- Take care to validate the tail segment *without* padding.
                        (ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int64 -> [ByteString] -> [ByteString]
trimTailSegment (SegmentSize -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral SegmentSize
tailSegSize) [ByteString]
segments)

            Either DecodeError ByteString
-> ([ByteString] -> Either DecodeError ByteString)
-> Maybe [ByteString]
-> Either DecodeError ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                -- Signal overall failure if any segments were excluded by the previous step.
                (DecodeError -> Either DecodeError ByteString
forall a b. a -> Either a b
Left DecodeError
CiphertextHashError)
                -- Combine the segments to produce the complete result if they all check out.
                (ByteString -> Either DecodeError ByteString
forall a b. b -> Either a b
Right (ByteString -> Either DecodeError ByteString)
-> ([ByteString] -> ByteString)
-> [ByteString]
-> Either DecodeError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
LB.concat ([ByteString] -> ByteString)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString
LB.fromStrict (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>))
                -- Get rid of any segments which do not agree with the hashes
                -- in the crypttext hash tree.
                ([Maybe ByteString] -> Maybe [ByteString]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe ByteString]
maybeValidSegments)
  where
    -- Separate the shares into those we can use and those we cannot.
    --
    -- Make the list pattern match lazy (with `~`) in case there are *no*
    -- valid shares.  The guard above will check if there are any valid shares
    -- before we need to match that part of the pattern.  This lets us bind a
    -- name to some valid share which is helpful inside the body of the guard
    -- where we need to read some value that is shared across all shares.
    (validShares :: [(Int, Share)]
validShares@(~((Int
_, Share
anyValidShare) : [(Int, Share)]
_)), [(Int, Share, InvalidShare)]
invalidShares) = Verifier
-> [(Int, Share)] -> ([(Int, Share)], [(Int, Share, InvalidShare)])
partitionShares (Getting Verifier Reader Verifier -> Reader -> Verifier
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Verifier Reader Verifier
Lens' Reader Verifier
Cap.verifier Reader
reader) [(Int, Share)]
shares

    -- Project the share number out across all of that share's blocks.  The
    -- result is something we can transpose into the correct form for ZFEC
    -- decoding.
    fixBlocks :: (Int, [a]) -> [(Int, a)]
    fixBlocks :: (Int, [a]) -> [(Int, a)]
fixBlocks (Int
sharenum, [a]
bs) = [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Int]
forall a. a -> [a]
repeat Int
sharenum) [a]
bs

    size :: Reader -> SegmentSize
size = Getting SegmentSize Reader SegmentSize -> Reader -> SegmentSize
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Verifier -> Const SegmentSize Verifier)
-> Reader -> Const SegmentSize Reader
Lens' Reader Verifier
Cap.verifier ((Verifier -> Const SegmentSize Verifier)
 -> Reader -> Const SegmentSize Reader)
-> ((SegmentSize -> Const SegmentSize SegmentSize)
    -> Verifier -> Const SegmentSize Verifier)
-> Getting SegmentSize Reader SegmentSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SegmentSize -> Const SegmentSize SegmentSize)
-> Verifier -> Const SegmentSize Verifier
Lens' Verifier SegmentSize
Cap.size)
    required :: Reader -> Required
required = Getting Required Reader Required -> Reader -> Required
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Verifier -> Const Required Verifier)
-> Reader -> Const Required Reader
Lens' Reader Verifier
Cap.verifier ((Verifier -> Const Required Verifier)
 -> Reader -> Const Required Reader)
-> ((Required -> Const Required Required)
    -> Verifier -> Const Required Verifier)
-> Getting Required Reader Required
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Required -> Const Required Required)
-> Verifier -> Const Required Verifier
Lens' Verifier Required
Cap.required)
    total :: Reader -> Required
total = Getting Required Reader Required -> Reader -> Required
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Verifier -> Const Required Verifier)
-> Reader -> Const Required Reader
Lens' Reader Verifier
Cap.verifier ((Verifier -> Const Required Verifier)
 -> Reader -> Const Required Reader)
-> ((Required -> Const Required Required)
    -> Verifier -> Const Required Verifier)
-> Getting Required Reader Required
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Required -> Const Required Required)
-> Verifier -> Const Required Verifier
Lens' Verifier Required
Cap.total)

    -- Return a list like the one given except that the last element is
    -- shortened to the given length.
    trimTailSegment :: Int64 -> [LB.ByteString] -> [LB.ByteString]
    trimTailSegment :: Int64 -> [ByteString] -> [ByteString]
trimTailSegment Int64
segSize = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a. (a -> a) -> [a] -> [a]
mapLast (Int64 -> ByteString -> ByteString
LB.take Int64
segSize)

    -- Apply a function to the last element of a list, if there is one.
    mapLast :: (a -> a) -> [a] -> [a]
mapLast a -> a
_ [] = []
    mapLast a -> a
f [a
x] = [a -> a
f a
x]
    mapLast a -> a
f (a
x : [a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> a) -> [a] -> [a]
mapLast a -> a
f [a]
xs

-- | Give a reason a share is considered invalid.
data InvalidShare
    = -- | The fingerprint in the capability does not match the fingerprint of the share.
      FingerprintMismatch
    | -- | The values in the share for the block hash tree root and the
      -- share's own entry in "needed shares" do not match.
      BlockHashRootMismatch
    | -- | The "share root hash" in the share's URIExtension doesn't agree
      -- with the root hash constructed from the "block hash tree" roots in
      -- the share's "needed shares" value.
      ShareRootHashInvalid
    | -- | The "crypttext root hash" in the share's URIExtension doesn't agree
      -- | with the root hash constructed from the "crypttext hash tree"
      -- | hashes in the share.
      CrypttextHashRootMismatch
    deriving (Eq InvalidShare
Eq InvalidShare
-> (InvalidShare -> InvalidShare -> Ordering)
-> (InvalidShare -> InvalidShare -> Bool)
-> (InvalidShare -> InvalidShare -> Bool)
-> (InvalidShare -> InvalidShare -> Bool)
-> (InvalidShare -> InvalidShare -> Bool)
-> (InvalidShare -> InvalidShare -> InvalidShare)
-> (InvalidShare -> InvalidShare -> InvalidShare)
-> Ord InvalidShare
InvalidShare -> InvalidShare -> Bool
InvalidShare -> InvalidShare -> Ordering
InvalidShare -> InvalidShare -> InvalidShare
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: InvalidShare -> InvalidShare -> InvalidShare
$cmin :: InvalidShare -> InvalidShare -> InvalidShare
max :: InvalidShare -> InvalidShare -> InvalidShare
$cmax :: InvalidShare -> InvalidShare -> InvalidShare
>= :: InvalidShare -> InvalidShare -> Bool
$c>= :: InvalidShare -> InvalidShare -> Bool
> :: InvalidShare -> InvalidShare -> Bool
$c> :: InvalidShare -> InvalidShare -> Bool
<= :: InvalidShare -> InvalidShare -> Bool
$c<= :: InvalidShare -> InvalidShare -> Bool
< :: InvalidShare -> InvalidShare -> Bool
$c< :: InvalidShare -> InvalidShare -> Bool
compare :: InvalidShare -> InvalidShare -> Ordering
$ccompare :: InvalidShare -> InvalidShare -> Ordering
$cp1Ord :: Eq InvalidShare
Ord, InvalidShare -> InvalidShare -> Bool
(InvalidShare -> InvalidShare -> Bool)
-> (InvalidShare -> InvalidShare -> Bool) -> Eq InvalidShare
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InvalidShare -> InvalidShare -> Bool
$c/= :: InvalidShare -> InvalidShare -> Bool
== :: InvalidShare -> InvalidShare -> Bool
$c== :: InvalidShare -> InvalidShare -> Bool
Eq, Int -> InvalidShare -> String -> String
[InvalidShare] -> String -> String
InvalidShare -> String
(Int -> InvalidShare -> String -> String)
-> (InvalidShare -> String)
-> ([InvalidShare] -> String -> String)
-> Show InvalidShare
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [InvalidShare] -> String -> String
$cshowList :: [InvalidShare] -> String -> String
show :: InvalidShare -> String
$cshow :: InvalidShare -> String
showsPrec :: Int -> InvalidShare -> String -> String
$cshowsPrec :: Int -> InvalidShare -> String -> String
Show)

{- | Split a list of shares into those which pass all of the validation checks
 and those which do not.
-}
partitionShares :: Cap.Verifier -> [(Int, Share)] -> ([(Int, Share)], [(Int, Share, InvalidShare)])
partitionShares :: Verifier
-> [(Int, Share)] -> ([(Int, Share)], [(Int, Share, InvalidShare)])
partitionShares Verifier
verifier [(Int, Share)]
shares =
    ( [(Int, Share)]
validShares
    , ((Int, Share) -> (Int, Share, InvalidShare))
-> [(Int, Share)] -> [(Int, Share, InvalidShare)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Share) -> InvalidShare -> (Int, Share, InvalidShare)
forall a b c. (a, b) -> c -> (a, b, c)
`err` InvalidShare
FingerprintMismatch) [(Int, Share)]
haveInvalidFingerprint
        [(Int, Share, InvalidShare)]
-> [(Int, Share, InvalidShare)] -> [(Int, Share, InvalidShare)]
forall a. [a] -> [a] -> [a]
++ ((Int, Share) -> (Int, Share, InvalidShare))
-> [(Int, Share)] -> [(Int, Share, InvalidShare)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Share) -> InvalidShare -> (Int, Share, InvalidShare)
forall a b c. (a, b) -> c -> (a, b, c)
`err` InvalidShare
BlockHashRootMismatch) [(Int, Share)]
haveInvalidBlockHashRoot
        [(Int, Share, InvalidShare)]
-> [(Int, Share, InvalidShare)] -> [(Int, Share, InvalidShare)]
forall a. [a] -> [a] -> [a]
++ ((Int, Share) -> (Int, Share, InvalidShare))
-> [(Int, Share)] -> [(Int, Share, InvalidShare)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Share) -> InvalidShare -> (Int, Share, InvalidShare)
forall a b c. (a, b) -> c -> (a, b, c)
`err` InvalidShare
ShareRootHashInvalid) [(Int, Share)]
haveInvalidShareRootHash
        [(Int, Share, InvalidShare)]
-> [(Int, Share, InvalidShare)] -> [(Int, Share, InvalidShare)]
forall a. [a] -> [a] -> [a]
++ ((Int, Share) -> (Int, Share, InvalidShare))
-> [(Int, Share)] -> [(Int, Share, InvalidShare)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Share) -> InvalidShare -> (Int, Share, InvalidShare)
forall a b c. (a, b) -> c -> (a, b, c)
`err` InvalidShare
CrypttextHashRootMismatch) [(Int, Share)]
haveMismatchingCrypttextHashRoot
    )
  where
    -- Helper to build our error structure
    err :: (a, b) -> c -> (a, b, c)
err = (a -> b -> c -> (a, b, c)) -> (a, b) -> c -> (a, b, c)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (,,)

    -- The hash of the UEB must equal the fingerprint in the capability.
    ([(Int, Share)]
haveValidFingerprint, [(Int, Share)]
haveInvalidFingerprint) = ((Int, Share) -> Bool)
-> [(Int, Share)] -> ([(Int, Share)], [(Int, Share)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Verifier -> Share -> Bool
validFingerprint Verifier
verifier (Share -> Bool) -> ((Int, Share) -> Share) -> (Int, Share) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Share) -> Share
forall a b. (a, b) -> b
snd) [(Int, Share)]
shares

    -- The root of the share block tree in the share body must equal the
    -- share's hash in the "needed hashes" merkle proof.
    ([(Int, Share)]
haveValidBlockHashRoot, [(Int, Share)]
haveInvalidBlockHashRoot) = ((Int, Share) -> Bool)
-> [(Int, Share)] -> ([(Int, Share)], [(Int, Share)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Int -> Share -> Bool) -> (Int, Share) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Share -> Bool
matchingBlockHashRoot) [(Int, Share)]
haveValidFingerprint

    ([(Int, Share)]
haveMatchingCrypttextHashRoot, [(Int, Share)]
haveMismatchingCrypttextHashRoot) = ((Int, Share) -> Bool)
-> [(Int, Share)] -> ([(Int, Share)], [(Int, Share)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Share -> Bool
matchingCrypttextHashRoot (Share -> Bool) -> ((Int, Share) -> Share) -> (Int, Share) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Share) -> Share
forall a b. (a, b) -> b
snd) [(Int, Share)]
haveValidBlockHashRoot

    -- The "needed hashes" merkle proof must be valid with respect to the "share root hash" in the UEB.
    shareRootValidations :: [(Bool, (Int, Share))]
shareRootValidations = [Bool] -> [(Int, Share)] -> [(Bool, (Int, Share))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([(Int, Share)] -> [Bool]
validShareRootHash [(Int, Share)]
stillValid) [(Int, Share)]
stillValid
      where
        stillValid :: [(Int, Share)]
stillValid = [(Int, Share)]
haveMatchingCrypttextHashRoot
    ([(Int, Share)]
haveValidShareRootHash, [(Int, Share)]
haveInvalidShareRootHash) = ([(Bool, (Int, Share))] -> [(Int, Share)])
-> ([(Bool, (Int, Share))] -> [(Int, Share)])
-> ([(Bool, (Int, Share))], [(Bool, (Int, Share))])
-> ([(Int, Share)], [(Int, Share)])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((Bool, (Int, Share)) -> (Int, Share)
forall a b. (a, b) -> b
snd ((Bool, (Int, Share)) -> (Int, Share))
-> [(Bool, (Int, Share))] -> [(Int, Share)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ((Bool, (Int, Share)) -> (Int, Share)
forall a b. (a, b) -> b
snd ((Bool, (Int, Share)) -> (Int, Share))
-> [(Bool, (Int, Share))] -> [(Int, Share)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([(Bool, (Int, Share))], [(Bool, (Int, Share))])
 -> ([(Int, Share)], [(Int, Share)]))
-> ([(Bool, (Int, Share))], [(Bool, (Int, Share))])
-> ([(Int, Share)], [(Int, Share)])
forall a b. (a -> b) -> a -> b
$ ((Bool, (Int, Share)) -> Bool)
-> [(Bool, (Int, Share))]
-> ([(Bool, (Int, Share))], [(Bool, (Int, Share))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool, (Int, Share)) -> Bool
forall a b. (a, b) -> a
fst [(Bool, (Int, Share))]
shareRootValidations

    validShares :: [(Int, Share)]
validShares = [(Int, Share)]
haveValidShareRootHash

{- | Build a merkle tree where the leaves are the root hashes of the block
 hash tree of each share.
-}
makeShareTree :: HashAlgorithm hash => [MerkleTree B.ByteString hash] -> MerkleTree (MerkleTree B.ByteString hash) hash
makeShareTree :: [MerkleTree ByteString hash]
-> MerkleTree (MerkleTree ByteString hash) hash
makeShareTree = [Digest' hash] -> MerkleTree (MerkleTree ByteString hash) hash
forall hash value.
HashAlgorithm hash =>
[Digest' hash] -> MerkleTree value hash
makeTreePartial ([Digest' hash] -> MerkleTree (MerkleTree ByteString hash) hash)
-> ([MerkleTree ByteString hash] -> [Digest' hash])
-> [MerkleTree ByteString hash]
-> MerkleTree (MerkleTree ByteString hash) hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MerkleTree ByteString hash -> Digest' hash)
-> [MerkleTree ByteString hash] -> [Digest' hash]
forall a b. (a -> b) -> [a] -> [b]
map MerkleTree ByteString hash -> Digest' hash
forall v a. MerkleTree v a -> Digest' a
rootHash

makeCrypttextHash :: HashAlgorithm hash => Context hash -> CrypttextHash hash
makeCrypttextHash :: Context hash -> CrypttextHash hash
makeCrypttextHash = Digest hash -> CrypttextHash hash
forall a. Digest a -> Digest' a
Digest' (Digest hash -> CrypttextHash hash)
-> (Context hash -> Digest hash)
-> Context hash
-> CrypttextHash hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context hash -> Digest hash
forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize

makeCrypttextRootHash :: HashAlgorithm hash => [CrypttextHash hash] -> CrypttextHash hash
makeCrypttextRootHash :: [CrypttextHash hash] -> CrypttextHash hash
makeCrypttextRootHash = MerkleTree Any hash -> CrypttextHash hash
forall v a. MerkleTree v a -> Digest' a
rootHash (MerkleTree Any hash -> CrypttextHash hash)
-> ([CrypttextHash hash] -> MerkleTree Any hash)
-> [CrypttextHash hash]
-> CrypttextHash hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CrypttextHash hash] -> MerkleTree Any hash
forall hash value.
HashAlgorithm hash =>
[Digest' hash] -> MerkleTree value hash
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 :: Parameters -> a -> Parameters
tailParams p :: Parameters
p@Parameters{SegmentSize
paramSegmentSize :: SegmentSize
paramSegmentSize :: Parameters -> SegmentSize
paramSegmentSize, Required
paramRequiredShares :: Required
paramRequiredShares :: Parameters -> Required
paramRequiredShares} a
dataSize =
    Parameters
p{paramSegmentSize :: SegmentSize
paramSegmentSize = Required -> SegmentSize -> SegmentSize
forall m v. (Integral m, Integral v) => m -> v -> v
nextMultipleOf Required
paramRequiredShares SegmentSize
tailSize'}
  where
    tailSize' :: SegmentSize
tailSize' =
        if SegmentSize
tailSize SegmentSize -> SegmentSize -> Bool
forall a. Eq a => a -> a -> Bool
== SegmentSize
0
            then SegmentSize
paramSegmentSize
            else SegmentSize
tailSize
    tailSize :: SegmentSize
tailSize = a -> SegmentSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
dataSize SegmentSize -> SegmentSize -> SegmentSize
forall a. Integral a => a -> a -> a
`mod` SegmentSize
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.
-}
computeNeededHashes :: MerkleTree (MerkleTree B.ByteString hash) hash -> Int -> [(Int, Digest' hash)]
computeNeededHashes :: MerkleTree (MerkleTree ByteString hash) hash
-> Int -> [(Int, Digest' hash)]
computeNeededHashes MerkleTree (MerkleTree ByteString hash) hash
shareTree Int
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).
    (MerkleTree (MerkleTree ByteString hash) hash -> Int -> Int
forall v a. MerkleTree v a -> Int -> Int
leafNumberToNodeNumber MerkleTree (MerkleTree ByteString hash) hash
shareTree Int
sharenum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, MerkleTree (MerkleTree ByteString hash) hash -> Int -> Digest' hash
forall hash.
MerkleTree (MerkleTree ByteString hash) hash -> Int -> Digest' hash
blockHashRoot MerkleTree (MerkleTree ByteString hash) hash
shareTree Int
sharenum) (Int, Digest' hash)
-> [(Int, Digest' hash)] -> [(Int, Digest' hash)]
forall a. a -> [a] -> [a]
: Maybe [(Int, Digest' hash)] -> [(Int, Digest' hash)]
forall a. HasCallStack => Maybe a -> a
fromJust (MerkleTree (MerkleTree ByteString hash) hash
-> Int -> Maybe [(Int, Digest' hash)]
forall v a. MerkleTree v a -> Int -> Maybe [(Int, Digest' a)]
neededHashes MerkleTree (MerkleTree ByteString hash) hash
shareTree Int
sharenum)

{- | Find the block tree root hash for the nth share in the given share hash
 tree.
-}
blockHashRoot :: MerkleTree (MerkleTree B.ByteString hash) hash -> Int -> Digest' hash
blockHashRoot :: MerkleTree (MerkleTree ByteString hash) hash -> Int -> Digest' hash
blockHashRoot MerkleTree (MerkleTree ByteString hash) hash
tree Int
n
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> Digest' hash
forall a. HasCallStack => String -> a
error String
"Cannot have a negative leaf number"
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [Digest' hash] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Digest' hash]
leafs = String -> Digest' hash
forall a. HasCallStack => String -> a
error String
"Leaf number goes past the end of the tree"
    | Bool
otherwise = [Digest' hash]
leafs [Digest' hash] -> Int -> Digest' hash
forall a. [a] -> Int -> a
!! Int
n
  where
    leafs :: [Digest' hash]
leafs = MerkleTree (MerkleTree ByteString hash) hash -> [Digest' hash]
forall v a. MerkleTree v a -> [Digest' a]
leafHashes MerkleTree (MerkleTree ByteString hash) hash
tree

-- | Conditionally lift a value into a context.
guarded :: Alternative f => (a -> Bool) -> a -> f a
guarded :: (a -> Bool) -> a -> f a
guarded a -> Bool
predicate a
value
    | a -> Bool
predicate a
value = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value
    | Bool
otherwise = f a
forall (f :: * -> *) a. Alternative f => f a
empty