{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
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 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,
)
zfec ::
Int ->
Int ->
B.ByteString ->
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 = [ByteString]
chunks_
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)
zunfec ::
Int ->
Int ->
[(Int, B.ByteString)] ->
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)
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_
ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
segment_
data EncodingState = CPState
{
EncodingState -> Context SHA256
cpCrypttextHash :: Crypto.Hash.Context Crypto.Hash.SHA256
,
EncodingState -> [ByteString]
cpCrypttextHashes :: [CrypttextHash]
,
EncodingState -> [[ByteString]]
cpBlockHashes :: [[BlockHash]]
,
EncodingState -> [[ByteString]]
cpBlocks :: [[LB.ByteString]]
}
initEncodingState :: EncodingState
initEncodingState :: EncodingState
initEncodingState =
CPState :: Context SHA256
-> [ByteString]
-> [[ByteString]]
-> [[ByteString]]
-> EncodingState
CPState
{ cpCrypttextHash :: Context SHA256
cpCrypttextHash = Context SHA256 -> ByteString -> Context SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (Context SHA256
forall a. HashAlgorithm a => Context a
hashInit :: Context SHA256) (ByteString -> ByteString
netstring ByteString
ciphertextTag)
, cpCrypttextHashes :: [ByteString]
cpCrypttextHashes = [ByteString]
forall a. Monoid a => a
mempty
, cpBlockHashes :: [[ByteString]]
cpBlockHashes = [[ByteString]]
forall a. Monoid a => a
mempty
, cpBlocks :: [[ByteString]]
cpBlocks = [[ByteString]]
forall a. Monoid a => a
mempty
}
segmentCiphertext ::
Parameters ->
LB.ByteString ->
[LB.ByteString]
segmentCiphertext :: Parameters -> ByteString -> [ByteString]
segmentCiphertext Parameters{SegmentSize
paramSegmentSize :: Parameters -> SegmentSize
paramSegmentSize :: SegmentSize
paramSegmentSize} ByteString
ciphertext =
[ByteString]
result
where
result :: [ByteString]
result = [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)
processCiphertext :: Parameters -> [LB.ByteString] -> IO EncodingState
processCiphertext :: Parameters -> [ByteString] -> IO EncodingState
processCiphertext Parameters{Required
paramRequiredShares :: Parameters -> Required
paramRequiredShares :: Required
paramRequiredShares, Required
paramTotalShares :: Parameters -> Required
paramTotalShares :: Required
paramTotalShares} =
(EncodingState -> ByteString -> IO EncodingState)
-> EncodingState -> [ByteString] -> IO EncodingState
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM EncodingState -> ByteString -> IO EncodingState
processSegment EncodingState
initEncodingState
where
processSegment :: EncodingState -> ByteString -> IO EncodingState
processSegment CPState{[[ByteString]]
[[ByteString]]
[ByteString]
Context SHA256
cpBlocks :: [[ByteString]]
cpBlockHashes :: [[ByteString]]
cpCrypttextHashes :: [ByteString]
cpCrypttextHash :: Context SHA256
cpBlocks :: EncodingState -> [[ByteString]]
cpBlockHashes :: EncodingState -> [[ByteString]]
cpCrypttextHashes :: EncodingState -> [ByteString]
cpCrypttextHash :: EncodingState -> Context SHA256
..} ByteString
segment = do
[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 -> IO EncodingState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EncodingState -> IO EncodingState)
-> EncodingState -> IO EncodingState
forall a b. (a -> b) -> a -> b
$
CPState :: Context SHA256
-> [ByteString]
-> [[ByteString]]
-> [[ByteString]]
-> EncodingState
CPState
{ cpCrypttextHash :: Context SHA256
cpCrypttextHash = Context SHA256 -> ByteString -> Context SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate Context SHA256
cpCrypttextHash (ByteString -> ByteString
LB.toStrict ByteString
segment)
, cpCrypttextHashes :: [ByteString]
cpCrypttextHashes = [ByteString] -> ByteString -> [ByteString]
forall a. [a] -> a -> [a]
snoc [ByteString]
cpCrypttextHashes (ByteString -> ByteString
ciphertextSegmentHash (ByteString -> ByteString
LB.toStrict ByteString
segment))
, cpBlockHashes :: [[ByteString]]
cpBlockHashes = [[ByteString]] -> [ByteString] -> [[ByteString]]
forall a. [a] -> a -> [a]
snoc [[ByteString]]
cpBlockHashes (ByteString -> ByteString
blockHash (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> [ByteString] -> [ByteString]
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
}
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 ::
AESKey128 ->
Parameters ->
LB.ByteString ->
IO ([Share], Cap.Reader)
encode :: AESKey128 -> Parameters -> ByteString -> IO ([Share], Reader)
encode AESKey128
readKey initParams :: Parameters
initParams@(Parameters SegmentSize
maximumSegmentSize Required
total Word8
_ Required
required) ByteString
ciphertext =
Parameters -> [ByteString] -> IO EncodingState
processCiphertext Parameters
p (Parameters -> ByteString -> [ByteString]
segmentCiphertext Parameters
p ByteString
ciphertext) IO EncodingState
-> (EncodingState -> IO ([Share], Reader)) -> IO ([Share], Reader)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CPState{[[ByteString]]
[[ByteString]]
[ByteString]
Context SHA256
cpBlocks :: [[ByteString]]
cpBlockHashes :: [[ByteString]]
cpCrypttextHashes :: [ByteString]
cpCrypttextHash :: Context SHA256
cpBlocks :: EncodingState -> [[ByteString]]
cpBlockHashes :: EncodingState -> [[ByteString]]
cpCrypttextHashes :: EncodingState -> [ByteString]
cpCrypttextHash :: EncodingState -> Context SHA256
..} ->
let
numSegments :: Int
numSegments = [[ByteString]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[ByteString]]
cpBlocks
effectiveSegments :: Int
effectiveSegments = Int -> Int -> Int
forall p. (Ord p, Num p) => p -> p -> p
nextPowerOf Int
2 Int
numSegments
Just MerkleTree
plaintextHashTree =
[ByteString] -> Maybe MerkleTree
buildTreeOutOfAllTheNodes
([ByteString] -> Maybe MerkleTree)
-> (ByteString -> [ByteString]) -> ByteString -> Maybe MerkleTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> [ByteString]
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)
(ByteString -> Maybe MerkleTree) -> ByteString -> Maybe MerkleTree
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
B.replicate (SHA256 -> Int
forall a. HashAlgorithm a => a -> Int
hashDigestSize SHA256
SHA256) Word8
0
crypttextHashTree :: MerkleTree
crypttextHashTree = [ByteString] -> MerkleTree
makeTreePartial [ByteString]
cpCrypttextHashes
shareTree :: MerkleTree
shareTree =
MerkleTree
shareTree'
where
shareTree' :: MerkleTree
shareTree' = [MerkleTree] -> MerkleTree
makeShareTree ([MerkleTree] -> MerkleTree)
-> ([[ByteString]] -> [MerkleTree]) -> [[ByteString]] -> MerkleTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ByteString] -> MerkleTree) -> [[ByteString]] -> [MerkleTree]
forall a b. (a -> b) -> [a] -> [b]
map [ByteString] -> MerkleTree
makeTreePartial ([[ByteString]] -> [MerkleTree])
-> ([[ByteString]] -> [[ByteString]])
-> [[ByteString]]
-> [MerkleTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[ByteString]] -> [[ByteString]]
forall a. [[a]] -> [[a]]
transpose ([[ByteString]] -> MerkleTree) -> [[ByteString]] -> MerkleTree
forall a b. (a -> b) -> a -> b
$ [[ByteString]]
cpBlockHashes
uriExtension :: URIExtension
uriExtension =
URIExtension :: ByteString
-> Parameters
-> Parameters
-> SegmentSize
-> SegmentSize
-> Int
-> Required
-> Required
-> ByteString
-> ByteString
-> ByteString
-> URIExtension
URIExtension
{ uriExtCodecName :: ByteString
uriExtCodecName = ByteString
"crs"
, uriExtCodecParams :: Parameters
uriExtCodecParams = Parameters
p
, uriExtSize :: SegmentSize
uriExtSize = 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
, uriExtSegmentSize :: SegmentSize
uriExtSegmentSize = SegmentSize
segmentSize
, uriExtNeededShares :: Required
uriExtNeededShares = Required
required
, uriExtTotalShares :: Required
uriExtTotalShares = Required
total
, uriExtNumSegments :: Int
uriExtNumSegments = Int
numSegments
, uriExtTailCodecParams :: Parameters
uriExtTailCodecParams = Parameters -> Int64 -> Parameters
forall a. Integral a => Parameters -> a -> Parameters
tailParams Parameters
p (ByteString -> Int64
LB.length ByteString
ciphertext)
, uriExtCrypttextHash :: ByteString
uriExtCrypttextHash = Context SHA256 -> ByteString
makeCrypttextHash Context SHA256
cpCrypttextHash
, uriExtCrypttextRootHash :: ByteString
uriExtCrypttextRootHash = [ByteString] -> ByteString
makeCrypttextRootHash [ByteString]
cpCrypttextHashes
, uriExtShareRootHash :: ByteString
uriExtShareRootHash = MerkleTree -> ByteString
rootHash MerkleTree
shareTree
}
cap :: Reader
cap =
AESKey128
-> ByteString -> Required -> Required -> SegmentSize -> Reader
Cap.makeReader
AESKey128
readKey
(URIExtension -> ByteString
uriExtensionHash URIExtension
uriExtension)
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] -> [ByteString] -> Share
toShare Int
sharenum [ByteString]
blocks [ByteString]
blockHashes =
Share :: Word64
-> Word64
-> [ByteString]
-> MerkleTree
-> MerkleTree
-> MerkleTree
-> [(Word8, ByteString)]
-> URIExtension
-> Share
Share
{ shareBlockSize :: Word64
shareBlockSize = Parameters -> Word64
shareBlockSize Parameters
p
, shareDataSize :: Word64
shareDataSize = 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
, shareBlocks :: [ByteString]
shareBlocks = [ByteString]
blocks
, sharePlaintextHashTree :: MerkleTree
sharePlaintextHashTree = MerkleTree
plaintextHashTree
, shareCrypttextHashTree :: MerkleTree
shareCrypttextHashTree = MerkleTree
crypttextHashTree
, shareBlockHashTree :: MerkleTree
shareBlockHashTree = [ByteString] -> MerkleTree
makeTreePartial [ByteString]
blockHashes
, shareNeededHashes :: [(Word8, ByteString)]
shareNeededHashes = [(Word8, ByteString)] -> [(Word8, ByteString)]
forall a. Ord a => [a] -> [a]
sort ([(Word8, ByteString)] -> [(Word8, ByteString)])
-> ([(Int, ByteString)] -> [(Word8, ByteString)])
-> [(Int, ByteString)]
-> [(Word8, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, ByteString) -> (Word8, ByteString))
-> [(Int, ByteString)] -> [(Word8, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Word8) -> (Int, ByteString) -> (Word8, ByteString)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([(Int, ByteString)] -> [(Word8, ByteString)])
-> [(Int, ByteString)] -> [(Word8, ByteString)]
forall a b. (a -> b) -> a -> b
$ MerkleTree -> Int -> [(Int, ByteString)]
computeNeededShares MerkleTree
shareTree Int
sharenum
, shareURIExtension :: URIExtension
shareURIExtension = URIExtension
uriExtension
}
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] -> [ByteString] -> Share)
-> [Int] -> [[ByteString]] -> [[ByteString]] -> [Share]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> [ByteString] -> [ByteString] -> Share
toShare [Int
0 ..] ([[ByteString]] -> [[ByteString]]
forall a. [[a]] -> [[a]]
transpose [[ByteString]]
cpBlocks) ([[ByteString]] -> [[ByteString]]
forall a. [[a]] -> [[a]]
transpose [[ByteString]]
cpBlockHashes)
, Reader
cap
)
where
p :: Parameters
p@(Parameters SegmentSize
segmentSize Required
_ Word8
_ 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)
}
decode ::
Cap.Reader ->
[(Int, Share)] ->
IO (Maybe LB.ByteString)
decode :: Reader -> [(Int, Share)] -> IO (Maybe ByteString)
decode Cap.Reader{verifier :: Reader -> Verifier
verifier = Cap.Verifier{Required
required :: Verifier -> Required
required :: Required
required, Required
total :: Verifier -> Required
total :: Required
total, SegmentSize
size :: Verifier -> SegmentSize
size :: SegmentSize
size}} [(Int, Share)]
shares
| SegmentSize
size 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 = Maybe ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
| [(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 Required
required = Maybe ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
| Bool
otherwise = do
let
enoughShares :: [(Int, Share)]
enoughShares = Int -> [(Int, Share)] -> [(Int, Share)]
forall a. Int -> [a] -> [a]
take (Required -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Required
required) [(Int, Share)]
shares
blocks :: [(Int, [LB.ByteString])]
blocks :: [(Int, [ByteString])]
blocks = (Share -> [ByteString]) -> (Int, Share) -> (Int, [ByteString])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Share -> [ByteString]
shareBlocks ((Int, Share) -> (Int, [ByteString]))
-> [(Int, Share)] -> [(Int, [ByteString])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Share)]
enoughShares
explodedBlocks :: [[(Int, LB.ByteString)]]
explodedBlocks :: [[(Int, ByteString)]]
explodedBlocks = [[(Int, ByteString)]] -> [[(Int, ByteString)]]
forall a. [[a]] -> [[a]]
transpose ([[(Int, ByteString)]] -> [[(Int, ByteString)]])
-> [[(Int, ByteString)]] -> [[(Int, ByteString)]]
forall a b. (a -> b) -> a -> b
$ (Int, [ByteString]) -> [(Int, ByteString)]
fixBlocks ((Int, [ByteString]) -> [(Int, ByteString)])
-> [(Int, [ByteString])] -> [[(Int, ByteString)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, [ByteString])]
blocks
segSize :: Int64
segSize = SegmentSize -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SegmentSize -> Int64)
-> ([(Int, Share)] -> SegmentSize) -> [(Int, Share)] -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parameters -> SegmentSize
paramSegmentSize (Parameters -> SegmentSize)
-> ([(Int, Share)] -> Parameters) -> [(Int, Share)] -> SegmentSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URIExtension -> Parameters
uriExtCodecParams (URIExtension -> Parameters)
-> ([(Int, Share)] -> URIExtension) -> [(Int, Share)] -> Parameters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Share -> URIExtension
shareURIExtension (Share -> URIExtension)
-> ([(Int, Share)] -> Share) -> [(Int, Share)] -> URIExtension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Share) -> Share
forall a b. (a, b) -> b
snd ((Int, Share) -> Share)
-> ([(Int, Share)] -> (Int, Share)) -> [(Int, Share)] -> Share
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Share)] -> (Int, Share)
forall a. [a] -> a
head ([(Int, Share)] -> Int64) -> [(Int, Share)] -> Int64
forall a b. (a -> b) -> a -> b
$ [(Int, Share)]
enoughShares
zunfec' :: [(Int, ByteString)] -> IO ByteString
zunfec' = (Int64 -> ByteString -> ByteString
LB.take Int64
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 Required
required) (Required -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Required
total)
[ByteString]
segments <- ([(Int, ByteString)] -> IO ByteString)
-> [[(Int, ByteString)]] -> IO [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [(Int, ByteString)] -> IO ByteString
zunfec' [[(Int, ByteString)]]
explodedBlocks
Maybe ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> ByteString -> ByteString
LB.take (SegmentSize -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral SegmentSize
size) (ByteString -> ByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
LB.concat ([ByteString] -> Maybe ByteString)
-> [ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString]
segments
where
fixBlocks :: (Int, [LB.ByteString]) -> [(Int, LB.ByteString)]
fixBlocks :: (Int, [ByteString]) -> [(Int, ByteString)]
fixBlocks (Int
sharenum, [ByteString]
bs) = [Int] -> [ByteString] -> [(Int, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Int]
forall a. a -> [a]
repeat Int
sharenum) [ByteString]
bs
makeShareTree :: [MerkleTree] -> MerkleTree
makeShareTree :: [MerkleTree] -> MerkleTree
makeShareTree = [ByteString] -> MerkleTree
makeTreePartial ([ByteString] -> MerkleTree)
-> ([MerkleTree] -> [ByteString]) -> [MerkleTree] -> MerkleTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MerkleTree -> ByteString) -> [MerkleTree] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map MerkleTree -> ByteString
rootHash
makeCrypttextHash :: Context SHA256 -> CrypttextHash
makeCrypttextHash :: Context SHA256 -> ByteString
makeCrypttextHash = ByteString -> ByteString
sha256 (ByteString -> ByteString)
-> (Context SHA256 -> ByteString) -> Context SHA256 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256 -> ByteString
toBytes (Digest SHA256 -> ByteString)
-> (Context SHA256 -> Digest SHA256)
-> Context SHA256
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context SHA256 -> Digest SHA256
forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize
where
toBytes :: Digest SHA256 -> ByteString
toBytes = [Word8] -> ByteString
B.pack ([Word8] -> ByteString)
-> (Digest SHA256 -> [Word8]) -> Digest SHA256 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256 -> [Word8]
forall a. ByteArrayAccess a => a -> [Word8]
BA.unpack
makeCrypttextRootHash :: [CrypttextHash] -> CrypttextHash
makeCrypttextRootHash :: [ByteString] -> ByteString
makeCrypttextRootHash = MerkleTree -> ByteString
rootHash (MerkleTree -> ByteString)
-> ([ByteString] -> MerkleTree) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> MerkleTree
makeTreePartial
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
computeNeededShares :: MerkleTree -> Int -> [(Int, B.ByteString)]
computeNeededShares :: MerkleTree -> Int -> [(Int, ByteString)]
computeNeededShares MerkleTree
shareTree Int
sharenum =
(MerkleTree -> Int -> Int
leafNumberToNodeNumber MerkleTree
shareTree Int
sharenum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, MerkleTree -> Int -> ByteString
blockHashRoot MerkleTree
shareTree Int
sharenum) (Int, ByteString) -> [(Int, ByteString)] -> [(Int, ByteString)]
forall a. a -> [a] -> [a]
: Maybe [(Int, ByteString)] -> [(Int, ByteString)]
forall a. HasCallStack => Maybe a -> a
fromJust (MerkleTree -> Int -> Maybe [(Int, ByteString)]
neededHashes MerkleTree
shareTree Int
sharenum)
blockHashRoot :: MerkleTree -> Int -> B.ByteString
blockHashRoot :: MerkleTree -> Int -> ByteString
blockHashRoot MerkleTree
tree Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> ByteString
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
>= [ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
leafs = String -> ByteString
forall a. HasCallStack => String -> a
error String
"Leaf number goes past the end of the tree"
| Bool
otherwise = [ByteString]
leafs [ByteString] -> Int -> ByteString
forall a. [a] -> Int -> a
!! Int
n
where
leafs :: [ByteString]
leafs = MerkleTree -> [ByteString]
leafHashes MerkleTree
tree