{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

-- To read all the plaintext of a CHK share which you have enough shares for:

-- (-1). Find and download the shares
-- ( 0). Parse the share bytes into the various fields

-- 1. Check the UEB (URI Extension Block) hash
-- 2. Decode the UEB to find the share root hash
-- 3. Build the block hash tree for all shares you have
-- 4. Build the share hash tree out of those block hash tree roots combined with all of the "needed hashes" you pulled out of the shares you have
-- 5. Check the root of the share hash tree against the value in the UEB
-- 6. ZFEC decode the blocks into ciphertext **
-- 7. Check the "crypttext hash" against the hash of the ciphertext
--    (maybe helps catch a ZFEC implementation bug?)
-- 8. Decrypt the ciphertext **

-- 3 of 4
-- Have 4, 5, 6
-- neededHashes a == [ 5, 6, 7 ]

--                                     1
--                  2                                     3
--     4                    5                 6                     7
--     a                    b                 c                     d
--     ^
-- 5+"5s hash"+6+"6s hash"+7+"7s hash"

{- |
A share is a single data object comprising some erasure-encoded data and some
cryptographic hashes which allow certain determinations to be made about that
that data.  One or more shares can be interpreted together, typically to
recover a particular ciphertext object.

This modules exposes a structured representation of the share object along
with an encoder to and decoder from the canonical serialized representation.
-}
module Tahoe.CHK.Share where

import Control.Exception (Exception, throw)
import Control.Lens (makeLenses)
import Crypto.Hash (HashAlgorithm (hashDigestSize), digestFromByteString)
import Data.Bifunctor (Bifunctor (bimap))
import Data.Binary (
    Binary (get, put),
    Word32,
    Word64,
    Word8,
    encode,
 )
import Data.Binary.Get (
    Get,
    bytesRead,
    getLazyByteString,
    isolate,
 )
import Data.Binary.Put (Put, putLazyByteString)
import Data.Bits (shiftL, (.|.))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Either (fromRight)
import Data.Int (Int64)
import Data.List.Extra (dropEnd, sumOn')
import Data.Maybe (fromMaybe)
import Data.TreeDiff.Class (ToExpr)
import Debug.Trace ()
import GHC.Generics (Generic)
import Network.ByteOrder (bytestring32, bytestring64)
import Tahoe.CHK.Merkle (MerkleTree)
import Tahoe.CHK.SHA256d (Digest' (Digest'), SHA256d, toBytes)
import Tahoe.CHK.Types (ShareNum)
import Tahoe.CHK.URIExtension (
    URIExtension,
    pURIExtension,
    uriExtensionToBytes,
 )
import Tahoe.Util (chunkedBy, toStrictByteString)
import Text.Megaparsec (parse)

-- | A byte string of encrypted data.
type Crypttext = BS.ByteString

-- | Structured representation of a single CHK share.
data Share = Share
    { -- | The ZFEC block size.  Legacy value.  Unused.
      Share -> Word64
_blockSize :: Word64
    , -- | The share data length.  Legacy value.  Unused.
      Share -> Word64
_dataSize :: Word64
    , -- | The ZFEC encoded ciphertext blocks.
      Share -> [ByteString]
_blocks :: [LBS.ByteString]
    , -- | A merkle tree of plaintext segment hashes.  Unimplemented.
      Share -> MerkleTree ByteString SHA256d
_plaintextHashTree :: MerkleTree BS.ByteString SHA256d
    , -- | A merkle tree of ciphertext segment hashes.
      Share -> MerkleTree ByteString SHA256d
_crypttextHashTree :: MerkleTree Crypttext SHA256d
    , -- | A merkle tree of hashes of `shareBlocks`.
      Share -> MerkleTree ByteString SHA256d
_blockHashTree :: MerkleTree BS.ByteString SHA256d
    , -- | The information needed to complete a merkle proof for this share.
      Share -> [(ShareNum, Digest' SHA256d)]
_neededHashes :: [(ShareNum, Digest' SHA256d)]
    , -- | Additional metadata about this share.
      Share -> URIExtension
_uriExtension :: URIExtension
    }
    deriving (Share -> Share -> Bool
(Share -> Share -> Bool) -> (Share -> Share -> Bool) -> Eq Share
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Share -> Share -> Bool
$c/= :: Share -> Share -> Bool
== :: Share -> Share -> Bool
$c== :: Share -> Share -> Bool
Eq, Eq Share
Eq Share
-> (Share -> Share -> Ordering)
-> (Share -> Share -> Bool)
-> (Share -> Share -> Bool)
-> (Share -> Share -> Bool)
-> (Share -> Share -> Bool)
-> (Share -> Share -> Share)
-> (Share -> Share -> Share)
-> Ord Share
Share -> Share -> Bool
Share -> Share -> Ordering
Share -> Share -> Share
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 :: Share -> Share -> Share
$cmin :: Share -> Share -> Share
max :: Share -> Share -> Share
$cmax :: Share -> Share -> Share
>= :: Share -> Share -> Bool
$c>= :: Share -> Share -> Bool
> :: Share -> Share -> Bool
$c> :: Share -> Share -> Bool
<= :: Share -> Share -> Bool
$c<= :: Share -> Share -> Bool
< :: Share -> Share -> Bool
$c< :: Share -> Share -> Bool
compare :: Share -> Share -> Ordering
$ccompare :: Share -> Share -> Ordering
$cp1Ord :: Eq Share
Ord, ShareNum -> Share -> ShowS
[Share] -> ShowS
Share -> String
(ShareNum -> Share -> ShowS)
-> (Share -> String) -> ([Share] -> ShowS) -> Show Share
forall a.
(ShareNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Share] -> ShowS
$cshowList :: [Share] -> ShowS
show :: Share -> String
$cshow :: Share -> String
showsPrec :: ShareNum -> Share -> ShowS
$cshowsPrec :: ShareNum -> Share -> ShowS
Show, (forall x. Share -> Rep Share x)
-> (forall x. Rep Share x -> Share) -> Generic Share
forall x. Rep Share x -> Share
forall x. Share -> Rep Share x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Share x -> Share
$cfrom :: forall x. Share -> Rep Share x
Generic, [Share] -> Expr
Share -> Expr
(Share -> Expr) -> ([Share] -> Expr) -> ToExpr Share
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
listToExpr :: [Share] -> Expr
$clistToExpr :: [Share] -> Expr
toExpr :: Share -> Expr
$ctoExpr :: Share -> Expr
ToExpr)

$(makeLenses ''Share)

getWord32 :: Get Word64
getWord32 :: Get Word64
getWord32 = do
    Word32
word32 <- Get Word32
forall t. Binary t => Get t
get :: Get Word32
    Word64 -> Get Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Get Word64) -> Word64 -> Get Word64
forall a b. (a -> b) -> a -> b
$ Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
word32

getWord64 :: Get Word64
getWord64 :: Get Word64
getWord64 = Get Word64
forall t. Binary t => Get t
get

word64To4Bytes :: Word64 -> Maybe BS.ByteString
word64To4Bytes :: Word64 -> Maybe ByteString
word64To4Bytes = (Word32 -> ByteString
bytestring32 (Word32 -> ByteString) -> Maybe Word32 -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe Word32 -> Maybe ByteString)
-> (Word64 -> Maybe Word32) -> Word64 -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Maybe Word32
word64ToWord32

word64To4Bytes' :: Word64 -> Either String BS.ByteString
word64To4Bytes' :: Word64 -> Either String ByteString
word64To4Bytes' Word64
w =
    case Word64 -> Maybe ByteString
word64To4Bytes Word64
w of
        Maybe ByteString
Nothing -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Word64 out of bounds in conversion to Word32"
        Just ByteString
bs -> ByteString -> Either String ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs

word64To8Bytes :: Word64 -> BS.ByteString
word64To8Bytes :: Word64 -> ByteString
word64To8Bytes = Word64 -> ByteString
bytestring64

instance Binary Share where
    -- Serialize a share to its canonical byte representation.  This replaces
    -- much of allmydata.immutable.layout.
    put :: Share -> Put
put
        Share{[(ShareNum, Digest' SHA256d)]
[ByteString]
Word64
URIExtension
MerkleTree ByteString SHA256d
_uriExtension :: URIExtension
_neededHashes :: [(ShareNum, Digest' SHA256d)]
_blockHashTree :: MerkleTree ByteString SHA256d
_crypttextHashTree :: MerkleTree ByteString SHA256d
_plaintextHashTree :: MerkleTree ByteString SHA256d
_blocks :: [ByteString]
_dataSize :: Word64
_blockSize :: Word64
_uriExtension :: Share -> URIExtension
_neededHashes :: Share -> [(ShareNum, Digest' SHA256d)]
_blockHashTree :: Share -> MerkleTree ByteString SHA256d
_crypttextHashTree :: Share -> MerkleTree ByteString SHA256d
_plaintextHashTree :: Share -> MerkleTree ByteString SHA256d
_blocks :: Share -> [ByteString]
_dataSize :: Share -> Word64
_blockSize :: Share -> Word64
..} =
            let -- shareDataSize is supposedly unused.  Avoid making any
                -- calculations based on its value.  We'll serialize it into
                -- the output but otherwise we should ignore it.  Instead,
                -- we'll use this computed value that's consistent with the
                -- rest of our data.
                --
                -- CRSEncoder.set_params
                realSize :: Int64
realSize = (ByteString -> Int64) -> [ByteString] -> Int64
forall b a. Num b => (a -> b) -> [a] -> b
sumOn' ByteString -> Int64
LBS.length [ByteString]
_blocks

                -- Pick a share format version based on the size of our data,
                -- along with helpers to encoding our fields for that format
                -- version.
                --
                -- Okay we won't completely ignore shareDataSize.  We can't
                -- encode sufficiently large values into a v1 format share so
                -- switch to v2 format if shareDataSize needs it.
                --
                -- Tahoe also checks blockSize < 2 ^ 32 but I don't see how it is
                -- possible for blockSize to be greater than dataSize.
                (Word8
version, Word64 -> ByteString
encodeWord, Word64 -> Put
putWord) = Word64 -> (Word8, Word64 -> ByteString, Word64 -> Put)
chooseVersion (Word64 -> (Word8, Word64 -> ByteString, Word64 -> Put))
-> Word64 -> (Word8, Word64 -> ByteString, Word64 -> Put)
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
_dataSize (Int64 -> Word64
int64ToWord64 Int64
realSize)

                -- This excludes the version but otherwise has all of the integer
                -- header fields we need to write.
                header :: [Word64]
header =
                    [ Word64
_blockSize
                    , Word64
_dataSize
                    , (ShareNum -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Word64) ShareNum
headerSize
                    ]
                        [Word64] -> [Word64] -> [Word64]
forall a. Semigroup a => a -> a -> a
<> [Word64]
trailerFieldOffsets

                -- Compute the header size so we can include it in the offset
                -- calculation.  The header is the 4 byte version field and then some
                -- additional number of integer fields.  Each subsequent integer field
                -- is either 4 or 8 bytes depending on the share version.
                headerSize :: ShareNum
headerSize = ShareNum
4 ShareNum -> ShareNum -> ShareNum
forall a. Num a => a -> a -> a
+ Word8 -> ShareNum
fieldSizeForVersion Word8
version ShareNum -> ShareNum -> ShareNum
forall a. Num a => a -> a -> a
* [Word64] -> ShareNum
forall (t :: * -> *) a. Foldable t => t a -> ShareNum
length [Word64]
header

                -- Then compute the offset of each piece of the trailer.  They all
                -- follow the header and all of the share blocks so start there and
                -- advance by the size of each trailer piece.
                trailerOffset :: Word64
trailerOffset = (ShareNum -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Word64) ShareNum
headerSize Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int64 -> Word64
int64ToWord64 Int64
realSize

                -- The scanl would calculate the offset of the field following the
                -- last field - which we don't need or want.  So drop the last size.
                trailerFieldOffsets :: [Word64]
trailerFieldOffsets = (Word64 -> Word64 -> Word64) -> Word64 -> [Word64] -> [Word64]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
(+) Word64
trailerOffset (ShareNum -> [Word64] -> [Word64]
forall a. ShareNum -> [a] -> [a]
dropEnd ShareNum
1 [Word64]
trailerFieldSizes)

                -- We need to write offets to trailer fields into the header.  Compute
                -- the size of each trailer piece so we know how they'll be laid out.
                trailerFieldSizes :: [Word64]
trailerFieldSizes = (ByteString -> Word64) -> [ByteString] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map (Int64 -> Word64
int64ToWord64 (Int64 -> Word64) -> (ByteString -> Int64) -> ByteString -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
LBS.length) [ByteString]
trailerFields

                -- Construct all of the trailing metadata here so we know how
                -- big each piece of it is.  We need to put offsets pointing
                -- at this data into the header.  Keep in mind that nearby
                -- code assumes this list contains one element for each
                -- trailer field which has an offset recorded in the header.
                -- That code will produce an incorrect header if this
                -- assumption is violated.
                ueb :: ByteString
ueb = URIExtension -> ByteString
uriExtensionToBytes URIExtension
_uriExtension
                trailerFields :: [ByteString]
trailerFields =
                    [ MerkleTree ByteString SHA256d -> ByteString
forall a. Binary a => a -> ByteString
encode MerkleTree ByteString SHA256d
_plaintextHashTree
                    , MerkleTree ByteString SHA256d -> ByteString
forall a. Binary a => a -> ByteString
encode MerkleTree ByteString SHA256d
_crypttextHashTree
                    , MerkleTree ByteString SHA256d -> ByteString
forall a. Binary a => a -> ByteString
encode MerkleTree ByteString SHA256d
_blockHashTree
                    , ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [(ShareNum, Digest' SHA256d)] -> ByteString
forall hash.
HashAlgorithm hash =>
[(ShareNum, Digest' hash)] -> ByteString
serializeNeededShares [(ShareNum, Digest' SHA256d)]
_neededHashes
                    , ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> ByteString
encodeWord (ShareNum -> Word64
intToWord64 (ShareNum -> Word64) -> ShareNum -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString -> ShareNum
BS.length ByteString
ueb) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ueb
                    ]
             in do
                    Word32 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
version :: Word32)
                    (Word64 -> Put) -> [Word64] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word64 -> Put
putWord [Word64]
header
                    (ByteString -> Put) -> [ByteString] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> Put
putLazyByteString [ByteString]
_blocks
                    (ByteString -> Put) -> [ByteString] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> Put
putLazyByteString [ByteString]
trailerFields

    get :: Get Share
get = do
        -- Read the version marker to determine the size of certain following
        -- fields.
        (Word8
_version, Get Word64
getWord) <- Get (Word8, Get Word64)
getVersion -- 0, 1
        Word64
_blockSize <- Get Word64
getWord -- 4, 1
        Word64
_dataSize <- Get Word64
getWord -- 8, 1

        -- These offsets are all relative to the beginning of the share.
        Word64
dataOffset <- Get Word64
getWord -- 12, 36
        Word64
plaintextHashTreeOffset <- Get Word64
getWord -- 16, 37
        Word64
crypttextHashTreeOffset <- Get Word64
getWord -- 20, 69
        Word64
blockHashesOffset <- Get Word64
getWord -- 24, 101
        Word64
shareHashesOffset <- Get Word64
getWord -- 28, 133
        Word64
uriExtensionLengthOffset <- Get Word64
getWord -- 32, 167

        -- Load the rest of the fields in the typical order.  The offsets
        -- might place these fields in a different order but they really
        -- shouldn't.  We'll fail with an explicit error in that case thanks
        -- to position checking done in getLazyByteStringInBoundsFrom.  Then
        -- we'll fail to load the share but at least we won't apply an invalid
        -- interpretation to any of the data.
        ByteString
allShareBlocks <- String -> Word64 -> Word64 -> Get ByteString
getLazyByteStringInBoundsFrom String
"share blocks" Word64
dataOffset Word64
plaintextHashTreeOffset -- 36, <1 byte>
        MerkleTree ByteString SHA256d
_plaintextHashTree <- String
-> Word64
-> Word64
-> Get (MerkleTree ByteString SHA256d)
-> Get (MerkleTree ByteString SHA256d)
forall a. String -> Word64 -> Word64 -> Get a -> Get a
isolateBetween String
"plaintext hash tree" Word64
plaintextHashTreeOffset Word64
crypttextHashTreeOffset Get (MerkleTree ByteString SHA256d)
forall t. Binary t => Get t
get -- 37, <69 - 37 == 32 bytes>
        MerkleTree ByteString SHA256d
_crypttextHashTree <- String
-> Word64
-> Word64
-> Get (MerkleTree ByteString SHA256d)
-> Get (MerkleTree ByteString SHA256d)
forall a. String -> Word64 -> Word64 -> Get a -> Get a
isolateBetween String
"crypttext hash tree" Word64
crypttextHashTreeOffset Word64
blockHashesOffset Get (MerkleTree ByteString SHA256d)
forall t. Binary t => Get t
get -- 69, <101 - 69 == 32 bytes>
        MerkleTree ByteString SHA256d
_blockHashTree <- String
-> Word64
-> Word64
-> Get (MerkleTree ByteString SHA256d)
-> Get (MerkleTree ByteString SHA256d)
forall a. String -> Word64 -> Word64 -> Get a -> Get a
isolateBetween String
"block hash tree" Word64
blockHashesOffset Word64
shareHashesOffset Get (MerkleTree ByteString SHA256d)
forall t. Binary t => Get t
get -- 101, <133 - 101 == 32 bytes>
        [(ShareNum, Digest' SHA256d)]
_neededHashes <- [(ShareNum, Digest' SHA256d)]
-> Maybe [(ShareNum, Digest' SHA256d)]
-> [(ShareNum, Digest' SHA256d)]
forall a. a -> Maybe a -> a
fromMaybe (String -> [(ShareNum, Digest' SHA256d)]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Could not parse `needed hashes`") (Maybe [(ShareNum, Digest' SHA256d)]
 -> [(ShareNum, Digest' SHA256d)])
-> (ByteString -> Maybe [(ShareNum, Digest' SHA256d)])
-> ByteString
-> [(ShareNum, Digest' SHA256d)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe [(ShareNum, Digest' SHA256d)]
forall hash.
HashAlgorithm hash =>
ByteString -> Maybe [(ShareNum, Digest' hash)]
unserializeNeededShares (ByteString -> Maybe [(ShareNum, Digest' SHA256d)])
-> (ByteString -> ByteString)
-> ByteString
-> Maybe [(ShareNum, Digest' SHA256d)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict (ByteString -> [(ShareNum, Digest' SHA256d)])
-> Get ByteString -> Get [(ShareNum, Digest' SHA256d)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Word64 -> Word64 -> Get ByteString
getLazyByteStringInBoundsFrom String
"needed shares" Word64
shareHashesOffset Word64
uriExtensionLengthOffset -- 133, <167 - 133 == 34 bytes>
        Int64
uriExtensionLength <- Get Word64
getWord Get Word64 -> (Word64 -> Get Int64) -> Get Int64
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Word64 -> Get Int64
getInt64FromWord64 String
"URI extension length" -- 167,
        ByteString
uriExtensionBytes <- Int64 -> Get ByteString
getLazyByteString Int64
uriExtensionLength
        URIExtension
_uriExtension <-
            (ParseErrorBundle ByteString Void -> Get URIExtension)
-> (URIExtension -> Get URIExtension)
-> Either (ParseErrorBundle ByteString Void) URIExtension
-> Get URIExtension
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                (String -> Get URIExtension
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get URIExtension)
-> (ParseErrorBundle ByteString Void -> String)
-> ParseErrorBundle ByteString Void
-> Get URIExtension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle ByteString Void -> String
forall a. Show a => a -> String
show)
                URIExtension -> Get URIExtension
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (Parsec Void ByteString URIExtension
-> String
-> ByteString
-> Either (ParseErrorBundle ByteString Void) URIExtension
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void ByteString URIExtension
pURIExtension String
"URI extension" (ByteString
 -> Either (ParseErrorBundle ByteString Void) URIExtension)
-> ByteString
-> Either (ParseErrorBundle ByteString Void) URIExtension
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
uriExtensionBytes)

        let _blocks :: [ByteString]
_blocks = Int64 -> ByteString -> [ByteString]
segmentLazyBytes (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
_blockSize) ByteString
allShareBlocks

        Share -> Get Share
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Share -> Get Share) -> Share -> Get Share
forall a b. (a -> b) -> a -> b
$ Share :: Word64
-> Word64
-> [ByteString]
-> MerkleTree ByteString SHA256d
-> MerkleTree ByteString SHA256d
-> MerkleTree ByteString SHA256d
-> [(ShareNum, Digest' SHA256d)]
-> URIExtension
-> Share
Share{[(ShareNum, Digest' SHA256d)]
[ByteString]
Word64
URIExtension
MerkleTree ByteString SHA256d
_blocks :: [ByteString]
_uriExtension :: URIExtension
_neededHashes :: [(ShareNum, Digest' SHA256d)]
_blockHashTree :: MerkleTree ByteString SHA256d
_crypttextHashTree :: MerkleTree ByteString SHA256d
_plaintextHashTree :: MerkleTree ByteString SHA256d
_dataSize :: Word64
_blockSize :: Word64
_uriExtension :: URIExtension
_neededHashes :: [(ShareNum, Digest' SHA256d)]
_blockHashTree :: MerkleTree ByteString SHA256d
_crypttextHashTree :: MerkleTree ByteString SHA256d
_plaintextHashTree :: MerkleTree ByteString SHA256d
_blocks :: [ByteString]
_dataSize :: Word64
_blockSize :: Word64
..}

segmentLazyBytes :: Int64 -> LBS.ByteString -> [LBS.ByteString]
segmentLazyBytes :: Int64 -> ByteString -> [ByteString]
segmentLazyBytes Int64
_segmentSize ByteString
"" = []
segmentLazyBytes Int64
segmentSize ByteString
bs = ByteString
nextSegment ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: Int64 -> ByteString -> [ByteString]
segmentLazyBytes Int64
segmentSize ByteString
theRest
  where
    (ByteString
nextSegment, ByteString
theRest) = Int64 -> ByteString -> (ByteString, ByteString)
LBS.splitAt Int64
segmentSize ByteString
bs

isolateBetween :: String -> Word64 -> Word64 -> Get a -> Get a
isolateBetween :: String -> Word64 -> Word64 -> Get a -> Get a
isolateBetween String
name Word64
start Word64
end Get a
g = do
    Int64
pos <- Get Int64
bytesRead
    if (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int64 -> Word64) Int64
pos Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
start
        then String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get a) -> String -> Get a
forall a b. (a -> b) -> a -> b
$ String
"expected to read from " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
start String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" to get " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" but position is " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show Int64
pos
        else ShareNum -> Get a -> Get a
forall a. ShareNum -> Get a -> Get a
isolate (Word64 -> ShareNum
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
end Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
start)) Get a
g

getLazyByteStringInBoundsFrom :: String -> Word64 -> Word64 -> Get LBS.ByteString
getLazyByteStringInBoundsFrom :: String -> Word64 -> Word64 -> Get ByteString
getLazyByteStringInBoundsFrom String
name Word64
expectedPosition Word64
offset = do
    Int64
pos <- Get Int64
bytesRead
    if (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int64 -> Word64) Int64
pos Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
expectedPosition
        then String -> Get ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ByteString) -> String -> Get ByteString
forall a b. (a -> b) -> a -> b
$ String
"expected to read from " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
expectedPosition String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" to get " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" but position is " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show Int64
pos
        else do
            Int64
offsetInt64 <- String -> Word64 -> Get Int64
getInt64FromWord64 String
name Word64
offset
            Int64 -> Get ByteString
getLazyByteString (Int64
offsetInt64 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
pos)

getInt64FromWord64 :: String -> Word64 -> Get Int64
getInt64FromWord64 :: String -> Word64 -> Get Int64
getInt64FromWord64 String
name = Get Int64 -> (Int64 -> Get Int64) -> Maybe Int64 -> Get Int64
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Get Int64
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Int64) -> String -> Get Int64
forall a b. (a -> b) -> a -> b
$ String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" out of bounds") Int64 -> Get Int64
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int64 -> Get Int64)
-> (Word64 -> Maybe Int64) -> Word64 -> Get Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Maybe Int64
word64ToInt64

word64ToInt64 :: Word64 -> Maybe Int64
word64ToInt64 :: Word64 -> Maybe Int64
word64ToInt64 Word64
w
    | Word64
w Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
maxInt64 = Maybe Int64
forall a. Maybe a
Nothing
    | Bool
otherwise = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w)
  where
    maxInt64 :: Word64
    maxInt64 :: Word64
maxInt64 = Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
forall a. Bounded a => a
maxBound :: Int64)

word64ToWord32 :: Word64 -> Maybe Word32
word64ToWord32 :: Word64 -> Maybe Word32
word64ToWord32 Word64
w
    | Word64
w Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
forall i. Integral i => i
maxWord32 = Maybe Word32
forall a. Maybe a
Nothing
    | Bool
otherwise = Word32 -> Maybe Word32
forall a. a -> Maybe a
Just (Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w)

maxWord32 :: Integral i => i
maxWord32 :: i
maxWord32 = Word32 -> i
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
forall a. Bounded a => a
maxBound :: Word32)

{- | Serialize the list of (share number, block tree root hash) pairs for
 inclusion in the serialized form of a Share.  The inverse of
 unserializeNeededShares.
-}
serializeNeededShares :: HashAlgorithm hash => [(ShareNum, Digest' hash)] -> BS.ByteString
serializeNeededShares :: [(ShareNum, Digest' hash)] -> ByteString
serializeNeededShares = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> ([(ShareNum, Digest' hash)] -> [ByteString])
-> [(ShareNum, Digest' hash)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ShareNum, Digest' hash)] -> [ByteString]
forall a a.
(Integral a, ByteArrayAccess a) =>
[(a, a)] -> [ByteString]
pieces
  where
    pieces :: [(a, a)] -> [ByteString]
pieces [] = []
    pieces ((a
sharenum, a
hash) : [(a, a)]
xs) = (Builder -> ByteString
toStrictByteString (Builder -> ByteString) -> (a -> Builder) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Builder
BS.int16BE (Int16 -> Builder) -> (a -> Int16) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> ByteString) -> a -> ByteString
forall a b. (a -> b) -> a -> b
$ a
sharenum) ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: a -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
toBytes a
hash ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [(a, a)] -> [ByteString]
pieces [(a, a)]
xs

{- | Unserialize a a list of (share number, block tree root hash) pairs from
 their form in a serialized Share.  The inverse of serializeNeededShares.
-}
unserializeNeededShares :: forall hash. HashAlgorithm hash => BS.ByteString -> Maybe [(ShareNum, Digest' hash)]
unserializeNeededShares :: ByteString -> Maybe [(ShareNum, Digest' hash)]
unserializeNeededShares ByteString
bs =
    ((ShareNum, Maybe (Digest' hash))
 -> Maybe (ShareNum, Digest' hash))
-> [(ShareNum, Maybe (Digest' hash))]
-> Maybe [(ShareNum, Digest' hash)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ShareNum, Maybe (Digest' hash)) -> Maybe (ShareNum, Digest' hash)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [(ShareNum, Maybe (Digest' hash))]
result
  where
    chunks :: [ByteString]
chunks = ShareNum -> ByteString -> [ByteString]
chunkedBy (ShareNum
2 ShareNum -> ShareNum -> ShareNum
forall a. Num a => a -> a -> a
+ hash -> ShareNum
forall a. HashAlgorithm a => a -> ShareNum
hashDigestSize (hash
forall a. HasCallStack => a
undefined :: hash)) ByteString
bs
    pairs :: [(ByteString, ByteString)]
pairs = (ByteString -> (ByteString, ByteString))
-> [ByteString] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (ShareNum -> ByteString -> (ByteString, ByteString)
BS.splitAt ShareNum
2) [ByteString]
chunks
    result :: [(ShareNum, Maybe (Digest' hash))]
result = (ByteString -> ShareNum)
-> (ByteString -> Maybe (Digest' hash))
-> (ByteString, ByteString)
-> (ShareNum, Maybe (Digest' hash))
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ByteString -> ShareNum
toShareNum ((Digest hash -> Digest' hash)
-> Maybe (Digest hash) -> Maybe (Digest' hash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Digest hash -> Digest' hash
forall a. Digest a -> Digest' a
Digest' (Maybe (Digest hash) -> Maybe (Digest' hash))
-> (ByteString -> Maybe (Digest hash))
-> ByteString
-> Maybe (Digest' hash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (Digest hash)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString) ((ByteString, ByteString) -> (ShareNum, Maybe (Digest' hash)))
-> [(ByteString, ByteString)] -> [(ShareNum, Maybe (Digest' hash))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ByteString, ByteString)]
pairs

    toShareNum :: BS.ByteString -> ShareNum
    toShareNum :: ByteString -> ShareNum
toShareNum ByteString
x = ShareNum -> ShareNum
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ShareNum -> ShareNum) -> ShareNum -> ShareNum
forall a b. (a -> b) -> a -> b
$ Word8 -> ShareNum
forall a. Enum a => a -> ShareNum
fromEnum Word8
msb ShareNum -> ShareNum -> ShareNum
forall a. Bits a => a -> ShareNum -> a
`shiftL` ShareNum
8 ShareNum -> ShareNum -> ShareNum
forall a. Bits a => a -> a -> a
.|. Word8 -> ShareNum
forall a. Enum a => a -> ShareNum
fromEnum Word8
lsb
      where
        msb :: Word8
msb = ByteString -> Word8
BS.head ByteString
x
        lsb :: Word8
lsb = ByteString -> Word8
BS.last ByteString
x

intToWord64 :: Int -> Word64
intToWord64 :: ShareNum -> Word64
intToWord64 ShareNum
x
    | ShareNum
x ShareNum -> ShareNum -> Bool
forall a. Ord a => a -> a -> Bool
< ShareNum
0 = String -> Word64
forall a. HasCallStack => String -> a
error String
"Negative Int cannot be converted to Word64"
    | Bool
otherwise = ShareNum -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ShareNum
x

int64ToWord64 :: Int64 -> Word64
int64ToWord64 :: Int64 -> Word64
int64ToWord64 Int64
x
    | Int64
x Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
0 = String -> Word64
forall a. HasCallStack => String -> a
error String
"Negative Int64 cannot be converted to Word64"
    | Bool
otherwise = Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
x

getVersion :: Get (Word8, Get Word64)
getVersion :: Get (Word8, Get Word64)
getVersion = do
    Word64
version <- Get Word64
getWord32
    (Word8, Get Word64) -> Get (Word8, Get Word64)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
version
        , case Word64
version of
            Word64
1 -> Get Word64
getWord32
            Word64
2 -> Get Word64
getWord64
            Word64
_ -> String -> Get Word64
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Word64) -> String -> Get Word64
forall a b. (a -> b) -> a -> b
$ String
"unsupported version: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
version
        )

chooseVersion :: Word64 -> (Word8, Word64 -> BS.ByteString, Word64 -> Put)
chooseVersion :: Word64 -> (Word8, Word64 -> ByteString, Word64 -> Put)
chooseVersion Word64
shareDataSize =
    (Word8
version, Word64 -> ByteString
encodeWord, Word64 -> Put
putWord)
  where
    -- Version 1 can encode sizes up to 2^32 bytes.  Version 2 can encode
    -- sizes up to 2^64 bytes.  Choose a version based on the actual data
    -- size.  We only save a handful bytes of header this way so the extra
    -- complexity may not be worth it just for that but it's convenient to
    -- be able to emit either share version for testing.
    version :: Word8
version = if Word64
shareDataSize Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
forall i. Integral i => i
maxWord32 then Word8
1 else Word8
2

    -- Here's where the version makes a difference to the header size.
    -- Choose an integer encoding that uses the right number of bytes.
    encodeWord :: Word64 -> ByteString
encodeWord
        -- word64To4Bytes can't always succeed but if we're picking version 1 then
        -- we believe it will succeed.  If it fails, we'll have to have a hard
        -- error :/ This is not ideal but ... I dunno what to do.
        | Word8
version Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
1 = Word64 -> ByteString
word64To4BytesPartial
        | Word8
version Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
2 = Word64 -> ByteString
word64To8Bytes
        | Bool
otherwise = String -> Word64 -> ByteString
forall a. HasCallStack => String -> a
error (String -> Word64 -> ByteString) -> String -> Word64 -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"unsupported version: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
version
    putWord :: Word64 -> Put
putWord = ByteString -> Put
putLazyByteString (ByteString -> Put) -> (Word64 -> ByteString) -> Word64 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString)
-> (Word64 -> ByteString) -> Word64 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ByteString
encodeWord

fieldSizeForVersion :: Word8 -> Int
fieldSizeForVersion :: Word8 -> ShareNum
fieldSizeForVersion Word8
1 = ShareNum
4
fieldSizeForVersion Word8
2 = ShareNum
8
fieldSizeForVersion Word8
n = String -> ShareNum
forall a. HasCallStack => String -> a
error (String -> ShareNum) -> String -> ShareNum
forall a b. (a -> b) -> a -> b
$ String
"Unsupported version number: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
n

{- | Serialize a Word64 to 4 bytes or throw an exception if the value can not
 fit.
-}
word64To4BytesPartial :: Word64 -> BS.ByteString
word64To4BytesPartial :: Word64 -> ByteString
word64To4BytesPartial Word64
i = ByteString -> Either String ByteString -> ByteString
forall b a. b -> Either a b -> b
fromRight (EncodingError -> ByteString
forall a e. Exception e => e -> a
throw (EncodingError -> ByteString) -> EncodingError -> ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> EncodingError
Word64OutOfBounds Word64
i) (Word64 -> Either String ByteString
word64To4Bytes' Word64
i)

newtype EncodingError = Word64OutOfBounds Word64 deriving (EncodingError -> EncodingError -> Bool
(EncodingError -> EncodingError -> Bool)
-> (EncodingError -> EncodingError -> Bool) -> Eq EncodingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EncodingError -> EncodingError -> Bool
$c/= :: EncodingError -> EncodingError -> Bool
== :: EncodingError -> EncodingError -> Bool
$c== :: EncodingError -> EncodingError -> Bool
Eq, Eq EncodingError
Eq EncodingError
-> (EncodingError -> EncodingError -> Ordering)
-> (EncodingError -> EncodingError -> Bool)
-> (EncodingError -> EncodingError -> Bool)
-> (EncodingError -> EncodingError -> Bool)
-> (EncodingError -> EncodingError -> Bool)
-> (EncodingError -> EncodingError -> EncodingError)
-> (EncodingError -> EncodingError -> EncodingError)
-> Ord EncodingError
EncodingError -> EncodingError -> Bool
EncodingError -> EncodingError -> Ordering
EncodingError -> EncodingError -> EncodingError
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 :: EncodingError -> EncodingError -> EncodingError
$cmin :: EncodingError -> EncodingError -> EncodingError
max :: EncodingError -> EncodingError -> EncodingError
$cmax :: EncodingError -> EncodingError -> EncodingError
>= :: EncodingError -> EncodingError -> Bool
$c>= :: EncodingError -> EncodingError -> Bool
> :: EncodingError -> EncodingError -> Bool
$c> :: EncodingError -> EncodingError -> Bool
<= :: EncodingError -> EncodingError -> Bool
$c<= :: EncodingError -> EncodingError -> Bool
< :: EncodingError -> EncodingError -> Bool
$c< :: EncodingError -> EncodingError -> Bool
compare :: EncodingError -> EncodingError -> Ordering
$ccompare :: EncodingError -> EncodingError -> Ordering
$cp1Ord :: Eq EncodingError
Ord, ShareNum -> EncodingError -> ShowS
[EncodingError] -> ShowS
EncodingError -> String
(ShareNum -> EncodingError -> ShowS)
-> (EncodingError -> String)
-> ([EncodingError] -> ShowS)
-> Show EncodingError
forall a.
(ShareNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EncodingError] -> ShowS
$cshowList :: [EncodingError] -> ShowS
show :: EncodingError -> String
$cshow :: EncodingError -> String
showsPrec :: ShareNum -> EncodingError -> ShowS
$cshowsPrec :: ShareNum -> EncodingError -> ShowS
Show)

instance Exception EncodingError