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

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

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

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

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

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

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

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

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

-- | Structured representation of a single CHK share.
data Share = Share
    { -- | The ZFEC block size.  Legacy value.  Unused.
      Share -> Word64
shareBlockSize :: Word64
    , -- | The share data length.  Legacy value.  Unused.
      Share -> Word64
shareDataSize :: Word64
    , -- | The ZFEC encoded ciphertext blocks.
      Share -> [ByteString]
shareBlocks :: [LBS.ByteString]
    , -- | A merkle tree of plaintext segment hashes.  Unimplemented.
      Share -> MerkleTree
sharePlaintextHashTree :: MerkleTree
    , -- | A merkle tree of ciphertext segment hashes.
      Share -> MerkleTree
shareCrypttextHashTree :: MerkleTree
    , -- | A merkle tree of hashes of `shareBlocks`.
      Share -> MerkleTree
shareBlockHashTree :: MerkleTree
    , -- | The information needed to complete a merkle proof for this share.
      Share -> [(ShareNum, ByteString)]
shareNeededHashes :: [(ShareNum, BS.ByteString)]
    , -- | Additional metadata about this share.
      Share -> URIExtension
shareURIExtension :: 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, Int -> Share -> ShowS
[Share] -> ShowS
Share -> String
(Int -> Share -> ShowS)
-> (Share -> String) -> ([Share] -> ShowS) -> Show Share
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Share] -> ShowS
$cshowList :: [Share] -> ShowS
show :: Share -> String
$cshow :: Share -> String
showsPrec :: Int -> Share -> ShowS
$cshowsPrec :: Int -> 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)

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
            { Word64
shareBlockSize :: Word64
shareBlockSize :: Share -> Word64
shareBlockSize
            , Word64
shareDataSize :: Word64
shareDataSize :: Share -> Word64
shareDataSize
            , [ByteString]
shareBlocks :: [ByteString]
shareBlocks :: Share -> [ByteString]
shareBlocks
            , MerkleTree
sharePlaintextHashTree :: MerkleTree
sharePlaintextHashTree :: Share -> MerkleTree
sharePlaintextHashTree
            , MerkleTree
shareCrypttextHashTree :: MerkleTree
shareCrypttextHashTree :: Share -> MerkleTree
shareCrypttextHashTree
            , MerkleTree
shareBlockHashTree :: MerkleTree
shareBlockHashTree :: Share -> MerkleTree
shareBlockHashTree
            , [(ShareNum, ByteString)]
shareNeededHashes :: [(ShareNum, ByteString)]
shareNeededHashes :: Share -> [(ShareNum, ByteString)]
shareNeededHashes
            , URIExtension
shareURIExtension :: URIExtension
shareURIExtension :: Share -> URIExtension
shareURIExtension
            } =
            let -- shareDataSize is supposedly unused.  Avoid making any
                -- calculations based on its value.  We'll serialize it into
                -- the output but otherwise we should ignore it.  Instead,
                -- we'll use this computed value that's consistent with the
                -- rest of our data.
                --
                -- CRSEncoder.set_params
                realSize :: Int64
realSize = (ByteString -> Int64) -> [ByteString] -> Int64
forall b a. Num b => (a -> b) -> [a] -> b
sumOn' ByteString -> Int64
LBS.length [ByteString]
shareBlocks

                -- Pick a share format version based on the size of our data,
                -- along with helpers to encoding our fields for that format
                -- version.
                --
                -- Okay we won't completely ignore shareDataSize.  We can't
                -- encode sufficiently large values into a v1 format share so
                -- switch to v2 format if shareDataSize needs it.
                --
                -- Tahoe also checks blockSize < 2 ^ 32 but I don't see how it is
                -- possible for blockSize to be greater than dataSize.
                (ShareNum
version, Word64 -> ByteString
encodeWord, Word64 -> Put
putWord) = Word64 -> (ShareNum, Word64 -> ByteString, Word64 -> Put)
chooseVersion (Word64 -> (ShareNum, Word64 -> ByteString, Word64 -> Put))
-> Word64 -> (ShareNum, Word64 -> ByteString, Word64 -> Put)
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
shareDataSize (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
shareBlockSize
                    , Word64
shareDataSize
                    , (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Word64) Int
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 :: Int
headerSize = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ShareNum -> Int
fieldSizeForVersion ShareNum
version Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Word64] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
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 = (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Word64) Int
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 (Int -> [Word64] -> [Word64]
forall a. Int -> [a] -> [a]
dropEnd Int
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
shareURIExtension
                trailerFields :: [ByteString]
trailerFields =
                    [ MerkleTree -> ByteString
forall a. Binary a => a -> ByteString
encode MerkleTree
sharePlaintextHashTree
                    , MerkleTree -> ByteString
forall a. Binary a => a -> ByteString
encode MerkleTree
shareCrypttextHashTree
                    , MerkleTree -> ByteString
forall a. Binary a => a -> ByteString
encode MerkleTree
shareBlockHashTree
                    , ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [(ShareNum, ByteString)] -> ByteString
serializeNeededShares [(ShareNum, ByteString)]
shareNeededHashes
                    , ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> ByteString
encodeWord (Int -> Word64
intToWord64 (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
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 (ShareNum -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ShareNum
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]
shareBlocks
                    (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.
        (ShareNum
_version, Get Word64
getWord) <- Get (ShareNum, Get Word64)
getVersion -- 0, 1
        Word64
shareBlockSize <- Get Word64
getWord -- 4, 1
        Word64
shareDataSize <- 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
sharePlaintextHashTree <- String -> Word64 -> Word64 -> Get MerkleTree -> Get MerkleTree
forall a. String -> Word64 -> Word64 -> Get a -> Get a
isolateBetween String
"plaintext hash tree" Word64
plaintextHashTreeOffset Word64
crypttextHashTreeOffset (Get MerkleTree
forall t. Binary t => Get t
get :: Get MerkleTree) -- 37, <69 - 37 == 32 bytes>
        MerkleTree
shareCrypttextHashTree <- String -> Word64 -> Word64 -> Get MerkleTree -> Get MerkleTree
forall a. String -> Word64 -> Word64 -> Get a -> Get a
isolateBetween String
"crypttext hash tree" Word64
crypttextHashTreeOffset Word64
blockHashesOffset (Get MerkleTree
forall t. Binary t => Get t
get :: Get MerkleTree) -- 69, <101 - 69 == 32 bytes>
        MerkleTree
shareBlockHashTree <- String -> Word64 -> Word64 -> Get MerkleTree -> Get MerkleTree
forall a. String -> Word64 -> Word64 -> Get a -> Get a
isolateBetween String
"block hash tree" Word64
blockHashesOffset Word64
shareHashesOffset (Get MerkleTree
forall t. Binary t => Get t
get :: Get MerkleTree) -- 101, <133 - 101 == 32 bytes>
        [(ShareNum, ByteString)]
shareNeededHashes <- ByteString -> [(ShareNum, ByteString)]
unserializeNeededShares (ByteString -> [(ShareNum, ByteString)])
-> (ByteString -> ByteString)
-> ByteString
-> [(ShareNum, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict (ByteString -> [(ShareNum, ByteString)])
-> Get ByteString -> Get [(ShareNum, ByteString)]
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
shareURIExtension <-
            (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 shareBlocks :: [ByteString]
shareBlocks = Int64 -> ByteString -> [ByteString]
segmentLazyBytes (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
shareBlockSize) 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
-> MerkleTree
-> MerkleTree
-> [(ShareNum, ByteString)]
-> URIExtension
-> Share
Share{[(ShareNum, ByteString)]
[ByteString]
Word64
URIExtension
MerkleTree
shareBlocks :: [ByteString]
shareURIExtension :: URIExtension
shareNeededHashes :: [(ShareNum, ByteString)]
shareBlockHashTree :: MerkleTree
shareCrypttextHashTree :: MerkleTree
sharePlaintextHashTree :: MerkleTree
shareDataSize :: Word64
shareBlockSize :: Word64
shareURIExtension :: URIExtension
shareNeededHashes :: [(ShareNum, ByteString)]
shareBlockHashTree :: MerkleTree
shareCrypttextHashTree :: MerkleTree
sharePlaintextHashTree :: MerkleTree
shareBlocks :: [ByteString]
shareDataSize :: Word64
shareBlockSize :: 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 Int -> Get a -> Get a
forall a. Int -> Get a -> Get a
isolate (Word64 -> Int
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)

serializeNeededShares :: [(ShareNum, BS.ByteString)] -> BS.ByteString
serializeNeededShares :: [(ShareNum, ByteString)] -> ByteString
serializeNeededShares = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> ([(ShareNum, ByteString)] -> [ByteString])
-> [(ShareNum, ByteString)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ShareNum, ByteString)] -> [ByteString]
forall a. Integral a => [(a, ByteString)] -> [ByteString]
pieces
  where
    pieces :: [(a, ByteString)] -> [ByteString]
pieces [] = []
    pieces ((a
sharenum, ByteString
hash) : [(a, ByteString)]
xs)
        | ByteString -> Int
BS.length ByteString
hash Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
32 =
            (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]
: ByteString
hash ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [(a, ByteString)] -> [ByteString]
pieces [(a, ByteString)]
xs
        | Bool
otherwise =
            String -> [ByteString]
forall a. HasCallStack => String -> a
error (String -> [ByteString]) -> String -> [ByteString]
forall a b. (a -> b) -> a -> b
$ String
"A 'needed shares' hash had length " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
hash)

unserializeNeededShares :: BS.ByteString -> [(ShareNum, BS.ByteString)]
unserializeNeededShares :: ByteString -> [(ShareNum, ByteString)]
unserializeNeededShares ByteString
bs =
    [(ShareNum, ByteString)]
result
  where
    chunks :: [ByteString]
chunks = Int -> ByteString -> [ByteString]
chunkedBy (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
32) ByteString
bs
    pairs :: [(ByteString, ByteString)]
pairs = (ByteString -> (ByteString, ByteString))
-> [ByteString] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
2) [ByteString]
chunks
    result :: [(ShareNum, ByteString)]
result = ((ByteString, ByteString) -> (ShareNum, ByteString))
-> [(ByteString, ByteString)] -> [(ShareNum, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> ShareNum)
-> (ByteString, ByteString) -> (ShareNum, ByteString)
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst ByteString -> ShareNum
toShareNum) [(ByteString, ByteString)]
pairs

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

intToWord64 :: Int -> Word64
intToWord64 :: Int -> Word64
intToWord64 Int
x
    | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> Word64
forall a. HasCallStack => String -> a
error String
"Negative Int cannot be converted to Word64"
    | Bool
otherwise = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
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 (ShareNum, Get Word64)
getVersion = do
    Word64
version <- Get Word64
getWord32
    (ShareNum, Get Word64) -> Get (ShareNum, Get Word64)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Word64 -> ShareNum
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 -> (ShareNum, Word64 -> ByteString, Word64 -> Put)
chooseVersion Word64
shareDataSize =
    (ShareNum
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 :: ShareNum
version = if Word64
shareDataSize Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
forall i. Integral i => i
maxWord32 then ShareNum
1 else ShareNum
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.
        | ShareNum
version ShareNum -> ShareNum -> Bool
forall a. Eq a => a -> a -> Bool
== ShareNum
1 = Word64 -> ByteString
word64To4BytesPartial
        | ShareNum
version ShareNum -> ShareNum -> Bool
forall a. Eq a => a -> a -> Bool
== ShareNum
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
<> ShareNum -> String
forall a. Show a => a -> String
show ShareNum
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 :: ShareNum -> Int
fieldSizeForVersion ShareNum
1 = Int
4
fieldSizeForVersion ShareNum
2 = Int
8
fieldSizeForVersion ShareNum
n = String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"Unsupported version number: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShareNum -> String
forall a. Show a => a -> String
show ShareNum
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, Int -> EncodingError -> ShowS
[EncodingError] -> ShowS
EncodingError -> String
(Int -> EncodingError -> ShowS)
-> (EncodingError -> String)
-> ([EncodingError] -> ShowS)
-> Show EncodingError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EncodingError] -> ShowS
$cshowList :: [EncodingError] -> ShowS
show :: EncodingError -> String
$cshow :: EncodingError -> String
showsPrec :: Int -> EncodingError -> ShowS
$cshowsPrec :: Int -> EncodingError -> ShowS
Show)

instance Exception EncodingError