diff --git a/src/Tahoe/CHK.hs b/src/Tahoe/CHK.hs
index dc76da5a4387488c0da34eab2281bd970e59b783..edb85f20e93d6707bb00f3e4198560b2db2b620a 100644
--- a/src/Tahoe/CHK.hs
+++ b/src/Tahoe/CHK.hs
@@ -72,6 +72,7 @@ module Tahoe.CHK (
import qualified Codec.FEC as ZFEC
import Control.Applicative (Alternative (empty))
+import Control.Lens (view, _2)
import Crypto.Cipher.AES128 (
AESKey128,
)
@@ -108,7 +109,7 @@ import Tahoe.CHK.Merkle (
rootHash,
)
import Tahoe.CHK.SHA256d (Digest' (Digest'), zero)
-import Tahoe.CHK.Share (Share (..))
+import Tahoe.CHK.Share (Share (..), uriExtension)
import Tahoe.CHK.Types (
BlockHash,
CrypttextHash,
@@ -119,6 +120,7 @@ import Tahoe.CHK.Types (
)
import Tahoe.CHK.URIExtension (
URIExtension (..),
+ codecParams,
)
import Tahoe.CHK.Validate (matchingBlockHashRoot, shareValidBlocks, validFingerprint, validShareRootHash)
import Tahoe.Netstring (
@@ -336,40 +338,40 @@ encode readKey initParams@(Parameters maximumSegmentSize total _ required) ciphe
shareTree' = makeShareTree . map makeTreePartial . transpose $ cpBlockHashes
-- A bag of additional metadata about the share and encoded object.
- uriExtension =
+ uriExt =
URIExtension
- { uriExtCodecName = "crs"
- , uriExtCodecParams = p -- trace ("Params: " <> show p) p
- , uriExtSize = fromIntegral $ LB.length ciphertext
- , uriExtSegmentSize = segmentSize
- , uriExtNeededShares = required
- , uriExtTotalShares = total
- , uriExtNumSegments = numSegments
- , uriExtTailCodecParams = tailParams p (LB.length ciphertext)
- , uriExtCrypttextHash = makeCrypttextHash cpCrypttextHash
- , uriExtCrypttextRootHash = makeCrypttextRootHash cpCrypttextHashes
- , uriExtShareRootHash = rootHash shareTree
+ { _codecName = "crs"
+ , _codecParams = p -- trace ("Params: " <> show p) p
+ , _size = fromIntegral $ LB.length ciphertext
+ , _segmentSize = segmentSize
+ , _neededShares = required
+ , _totalShares = total
+ , _numSegments = numSegments
+ , _tailCodecParams = tailParams p (LB.length ciphertext)
+ , _crypttextHash = makeCrypttextHash cpCrypttextHash
+ , _crypttextRootHash = makeCrypttextRootHash cpCrypttextHashes
+ , _shareRootHash = rootHash shareTree
}
-- The read capability for the encoded object.
cap =
Cap.makeReader
readKey
- (uriExtensionHash uriExtension)
+ (uriExtensionHash uriExt)
required
total
(fromIntegral $ LB.length ciphertext)
toShare sharenum blocks blockHashes =
Share
- { shareBlockSize = shareBlockSize p
- , shareDataSize = fromIntegral $ LB.length ciphertext `ceilDiv` fromIntegral required
- , shareBlocks = blocks
- , sharePlaintextHashTree = plaintextHashTree
- , shareCrypttextHashTree = crypttextHashTree
- , shareBlockHashTree = makeTreePartial blockHashes
- , shareNeededHashes = sort . fmap (first fromIntegral) $ computeNeededHashes shareTree sharenum
- , shareURIExtension = uriExtension
+ { _blockSize = shareBlockSize p
+ , _dataSize = fromIntegral $ LB.length ciphertext `ceilDiv` fromIntegral required
+ , _blocks = blocks
+ , _plaintextHashTree = plaintextHashTree
+ , _crypttextHashTree = crypttextHashTree
+ , _blockHashTree = makeTreePartial blockHashes
+ , _neededHashes = sort . fmap (first fromIntegral) $ computeNeededHashes shareTree sharenum
+ , _uriExtension = uriExt
}
-- The size in bytes of one erasure-encoded block of data.
@@ -422,10 +424,10 @@ decode ::
-- shares if it is possible to recover it, or Left with information about
-- why it is not.
IO (Either DecodeError LB.ByteString)
-decode Cap.Reader{verifier = verifier@Cap.Verifier{required, total, size}} shares
- | size > fromIntegral @Int64 @Integer maxBound = pure $ Left SizeOverflow
- | length shares < fromIntegral required = pure $ Left NotEnoughShares
- | length validShares < fromIntegral required = pure . Left . IntegrityError $ invalidShares
+decode reader shares
+ | size reader > fromIntegral @Int64 @Integer maxBound = pure $ Left SizeOverflow
+ | length shares < fromIntegral (required reader) = pure $ Left NotEnoughShares
+ | length validShares < fromIntegral (required reader) = pure . Left . IntegrityError $ invalidShares
| otherwise = do
let -- The ZFEC decoder takes as input a list of (share number, block
-- bytes) tuples (and the encoding parameters). It wants the list
@@ -466,7 +468,7 @@ decode Cap.Reader{verifier = verifier@Cap.Verifier{required, total, size}} share
-- the data we cannot use and structure what's left so we can
-- easily skip over those segments if desired.
enoughBlocks :: [Maybe [(Int, LB.ByteString)]]
- enoughBlocks = guarded ((fromIntegral required <=) . length) <$> validBlocks
+ enoughBlocks = guarded ((fromIntegral (required reader) <=) . length) <$> validBlocks
-- Figure out how many bytes are expected to be in each segment.
-- Depending on the ZFEC encoding parameters, it is possible that
@@ -475,18 +477,18 @@ decode Cap.Reader{verifier = verifier@Cap.Verifier{required, total, size}} share
-- bytes in the result. By knowing how many bytes were originally
-- in our segments, we can recognize and discard these extra
-- bytes.
- segSize = fromIntegral . paramSegmentSize . uriExtCodecParams . shareURIExtension . snd . head $ shares
+ segSize = fromIntegral . paramSegmentSize . view (_2 . uriExtension . codecParams) $ head shares
-- A helper that knows the correct parameters to do ZFEC decoding
-- for us.
- zunfec' = (LB.take segSize <$>) . zunfecLazy (fromIntegral required) (fromIntegral total)
+ zunfec' = (LB.take segSize <$>) . zunfecLazy (fromIntegral (required reader)) (fromIntegral (total reader))
-- Get ready to decode the groups of blocks back to the original
-- segments, where this is possible. We might have even more than
-- we need at this point so be sure to discard any extras so
-- zunfec doesn't grow angry.
getSegments :: [Maybe (IO LB.ByteString)]
- getSegments = fmap (zunfec' . take (fromIntegral required) <$>) enoughBlocks
+ getSegments = fmap (zunfec' . take (fromIntegral (required reader)) <$>) enoughBlocks
-- Actually do it
maybeSegments <- traverse sequence getSegments :: IO [Maybe LB.ByteString]
@@ -506,10 +508,10 @@ decode Cap.Reader{verifier = verifier@Cap.Verifier{required, total, size}} share
-- careful to find the tail segment size for use with the tail segment
-- so there might still be some extra bytes in the `segments` list
-- here. This additional truncation addresses that.
- pure . Right . LB.take (fromIntegral size) . LB.concat $ segments
+ pure . Right . LB.take (fromIntegral (size reader)) . LB.concat $ segments
where
-- Separate the shares into those we can use and those we cannot.
- (validShares, invalidShares) = partitionShares verifier shares
+ (validShares, invalidShares) = partitionShares (view Cap.verifier reader) shares
-- Project the share number out across all of that share's blocks. The
-- result is something we can transpose into the correct form for ZFEC
@@ -517,6 +519,10 @@ decode Cap.Reader{verifier = verifier@Cap.Verifier{required, total, size}} share
fixBlocks :: (Int, [a]) -> [(Int, a)]
fixBlocks (sharenum, bs) = zip (repeat sharenum) bs
+ size = view (Cap.verifier . Cap.size)
+ required = view (Cap.verifier . Cap.required)
+ total = view (Cap.verifier . Cap.total)
+
-- | Give a reason a share is considered invalid.
data InvalidShare
= -- | The fingerprint in the capability does not match the fingerprint of the share.
diff --git a/src/Tahoe/CHK/Capability.hs b/src/Tahoe/CHK/Capability.hs
index 625e931d7cafbeb0afe2705cfbf97259bbf6f943..b2fa06893d0c6186adaa42d5e54673c856db159d 100644
--- a/src/Tahoe/CHK/Capability.hs
+++ b/src/Tahoe/CHK/Capability.hs
@@ -1,11 +1,19 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TemplateHaskell #-}
module Tahoe.CHK.Capability (
CHK (..),
- Reader (..),
- Verifier (..),
+ Reader,
+ readKey,
+ verifier,
+ Verifier,
+ storageIndex,
+ fingerprint,
+ required,
+ total,
+ size,
makeReader,
pCapability,
pVerifier,
@@ -13,6 +21,8 @@ module Tahoe.CHK.Capability (
dangerRealShow,
) where
+import Control.Lens (view)
+import Control.Lens.TH (makeLenses)
import Crypto.Cipher.AES128 (
AESKey128,
)
@@ -61,27 +71,29 @@ data Verifier = Verifier
-- content-addressable storage system that is a storage server. It can be
-- used to ask storage servers for "shares" (ciphertext plus some
-- metadata) to download.
- storageIndex :: B.ByteString
+ _storageIndex :: B.ByteString
, -- | The fingerprint (aka "UEB hash" aka "URI extension block hash") is a
-- cryptographic hash that covers the URI extension block at the end of a
-- CHK share. The URI extension block itself contains various other
-- cryptographic hashes. Altogether this allows for integrity checking so
-- shares downloaded from storage servers can be checked for validity (ie,
-- that they are the same as what was uploaded) before they are processed.
- fingerprint :: B.ByteString
+ _fingerprint :: B.ByteString
, -- | The number of shares required to ZFEC decode the contents of the
-- shares. ZFEC calls this *K*. It must be that 1 <= required <= 256 and
-- required <= total. ZFEC is not defined outside of these bounds.
- required :: Word16
+ _required :: Word16
, -- | The total number of shares produced by ZFEC encoding. ZFEC calls
-- this *n*. It must be that 1 <= total <= 256 and required <= total.
- total :: Word16
+ _total :: Word16
, -- | The size (in bytes) of the plaintext encoded in the shares. It must
-- be that size >= 0 and in practice it is usually true that size >= 56.
- size :: Integer
+ _size :: Integer
}
deriving (Ord, Eq, Generic, ToExpr)
+$(makeLenses ''Verifier)
+
{- | Replace most of the tail of a string with a short placeholder. If the
string is not much longer than `n` then the result might not actually be
shorter.
@@ -102,17 +114,17 @@ bounded :: (Ord n, Integral n) => n -> n -> Parser n
bounded = Tahoe.CHK.Parsing.bounded decimal
instance Show Verifier where
- show Verifier{storageIndex, fingerprint, required, total, size} =
+ show v =
T.unpack $
T.intercalate
":"
[ "URI"
, "CHK-Verifier"
- , shorten 4 . showBase32 $ storageIndex
- , shorten 4 . showBase32 $ fingerprint
- , showT required
- , showT total
- , showT size
+ , shorten 4 . showBase32 $ view storageIndex v
+ , shorten 4 . showBase32 $ view fingerprint v
+ , showT $ view required v
+ , showT $ view total v
+ , showT $ view size v
]
{- | Represent a CHK "read" capability. This capability type can be diminished
@@ -126,11 +138,13 @@ data Reader = Reader
-- key to turn the original plaintext into ciphertext and back again. The
-- read key is also used to derive the verify key for the verify
-- capability. See ``storageIndexHash``.
- readKey :: AESKey128
+ _readKey :: AESKey128
, -- | The verify capability for this read capability.
- verifier :: Verifier
+ _verifier :: Verifier
}
+$(makeLenses ''Reader)
+
-- AESKey128 has no Eq or Ord instances so derive these for Reader manually.
-- We do include the AESKey128 in our comparison by encoding it to bytes
-- first.
@@ -149,23 +163,23 @@ instance ToExpr Reader where
secret key.
-}
instance Show Reader where
- show Reader{readKey, verifier} =
+ show reader =
T.unpack $
T.intercalate
":"
[ "URI"
, "CHK"
- , shorten 4 . showBase32 . encode $ readKey
- , shorten 4 . showBase32 . fingerprint $ verifier
- , showT . required $ verifier
- , showT . total $ verifier
- , showT . size $ verifier
+ , shorten 4 . showBase32 . encode $ view readKey reader
+ , shorten 4 . showBase32 $ view (verifier . fingerprint) reader
+ , showT $ view (verifier . required) reader
+ , showT $ view (verifier . total) reader
+ , showT $ view (verifier . size) reader
]
-- Construct a key with Eq and Ord instances for the Reader Eq and Ord
-- instances.
readerKey :: Reader -> (B.ByteString, Verifier)
-readerKey r = (encode . readKey $ r, verifier r)
+readerKey r = (encode $ view readKey r, view verifier r)
{- | A "Content-Hash-Key" (CHK) capability is small value that can be used to
perform some operation on a (usually) larger value that may be stored
@@ -185,27 +199,27 @@ data CHK = CHKVerifier Verifier | CHKReader Reader deriving (Ord, Eq)
implementation of Tahoe-LAFS.
-}
dangerRealShow :: CHK -> T.Text
-dangerRealShow (CHKVerifier (Verifier{storageIndex, fingerprint, required, total, size})) =
+dangerRealShow (CHKVerifier v) =
T.intercalate
":"
[ "URI"
, "CHK-Verifier"
- , showBase32 storageIndex
- , showBase32 fingerprint
- , showT required
- , showT total
- , showT size
+ , showBase32 $ view storageIndex v
+ , showBase32 $ view fingerprint v
+ , showT $ view required v
+ , showT $ view total v
+ , showT $ view size v
]
-dangerRealShow (CHKReader (Reader{readKey, verifier})) =
+dangerRealShow (CHKReader r) =
T.intercalate
":"
[ "URI"
, "CHK"
- , showBase32 . encode $ readKey
- , showBase32 . fingerprint $ verifier
- , showT . required $ verifier
- , showT . total $ verifier
- , showT . size $ verifier
+ , showBase32 . encode $ view readKey r
+ , showBase32 $ view (verifier . fingerprint) r
+ , showT $ view (verifier . required) r
+ , showT $ view (verifier . total) r
+ , showT $ view (verifier . size) r
]
{- | A parser combinator for parsing either a verify or read CHK capability
@@ -249,8 +263,8 @@ pReader =
correct derivation of the corresponding CHK verify capability.
-}
makeReader :: AESKey128 -> B.ByteString -> Word16 -> Word16 -> Integer -> Reader
-makeReader readKey fingerprint required total size =
- Reader readKey (deriveVerifier readKey fingerprint required total size)
+makeReader readKey' fingerprint' required' total' size' =
+ Reader readKey' (deriveVerifier readKey' fingerprint' required' total' size')
{- | Given all of the fields of a CHK read capability, derive and return the
corresponding CHK verify capability.
diff --git a/src/Tahoe/CHK/Share.hs b/src/Tahoe/CHK/Share.hs
index 10576c1688de98289943403d14d0f31c53329c49..8caef4d1e2ea126d8df0b72b7bb19289b051c82f 100644
--- a/src/Tahoe/CHK/Share.hs
+++ b/src/Tahoe/CHK/Share.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
-- To read all the plaintext of a CHK share which you have enough shares for:
@@ -42,6 +43,7 @@ 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 (
@@ -84,24 +86,26 @@ import Text.Megaparsec (parse)
-- | Structured representation of a single CHK share.
data Share = Share
{ -- | The ZFEC block size. Legacy value. Unused.
- shareBlockSize :: Word64
+ _blockSize :: Word64
, -- | The share data length. Legacy value. Unused.
- shareDataSize :: Word64
+ _dataSize :: Word64
, -- | The ZFEC encoded ciphertext blocks.
- shareBlocks :: [LBS.ByteString]
+ _blocks :: [LBS.ByteString]
, -- | A merkle tree of plaintext segment hashes. Unimplemented.
- sharePlaintextHashTree :: MerkleTree BS.ByteString SHA256d
+ _plaintextHashTree :: MerkleTree BS.ByteString SHA256d
, -- | A merkle tree of ciphertext segment hashes.
- shareCrypttextHashTree :: MerkleTree BS.ByteString SHA256d
+ _crypttextHashTree :: MerkleTree BS.ByteString SHA256d
, -- | A merkle tree of hashes of `shareBlocks`.
- shareBlockHashTree :: MerkleTree BS.ByteString SHA256d
+ _blockHashTree :: MerkleTree BS.ByteString SHA256d
, -- | The information needed to complete a merkle proof for this share.
- shareNeededHashes :: [(ShareNum, Digest' SHA256d)]
+ _neededHashes :: [(ShareNum, Digest' SHA256d)]
, -- | Additional metadata about this share.
- shareURIExtension :: URIExtension
+ _uriExtension :: URIExtension
}
deriving (Eq, Ord, Show, Generic, ToExpr)
+$(makeLenses ''Share)
+
getWord32 :: Get Word64
getWord32 = do
word32 <- get :: Get Word32
@@ -126,16 +130,7 @@ instance Binary Share where
-- Serialize a share to its canonical byte representation. This replaces
-- much of allmydata.immutable.layout.
put
- Share
- { shareBlockSize
- , shareDataSize
- , shareBlocks
- , sharePlaintextHashTree
- , shareCrypttextHashTree
- , shareBlockHashTree
- , shareNeededHashes
- , shareURIExtension
- } =
+ Share{..} =
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,
@@ -143,7 +138,7 @@ instance Binary Share where
-- rest of our data.
--
-- CRSEncoder.set_params
- realSize = sumOn' LBS.length shareBlocks
+ realSize = sumOn' LBS.length _blocks
-- Pick a share format version based on the size of our data,
-- along with helpers to encoding our fields for that format
@@ -155,13 +150,13 @@ instance Binary Share where
--
-- Tahoe also checks blockSize < 2 ^ 32 but I don't see how it is
-- possible for blockSize to be greater than dataSize.
- (version, encodeWord, putWord) = chooseVersion $ max shareDataSize (int64ToWord64 realSize)
+ (version, encodeWord, putWord) = chooseVersion $ max _dataSize (int64ToWord64 realSize)
-- This excludes the version but otherwise has all of the integer
-- header fields we need to write.
header =
- [ shareBlockSize
- , shareDataSize
+ [ _blockSize
+ , _dataSize
, (fromIntegral :: Int -> Word64) headerSize
]
<> trailerFieldOffsets
@@ -192,26 +187,26 @@ instance Binary Share where
-- trailer field which has an offset recorded in the header.
-- That code will produce an incorrect header if this
-- assumption is violated.
- ueb = uriExtensionToBytes shareURIExtension
+ ueb = uriExtensionToBytes _uriExtension
trailerFields =
- [ encode sharePlaintextHashTree
- , encode shareCrypttextHashTree
- , encode shareBlockHashTree
- , LBS.fromStrict $ serializeNeededShares shareNeededHashes
+ [ encode _plaintextHashTree
+ , encode _crypttextHashTree
+ , encode _blockHashTree
+ , LBS.fromStrict $ serializeNeededShares _neededHashes
, LBS.fromStrict $ encodeWord (intToWord64 $ BS.length ueb) <> ueb
]
in do
put (fromIntegral version :: Word32)
mapM_ putWord header
- mapM_ putLazyByteString shareBlocks
+ mapM_ putLazyByteString _blocks
mapM_ putLazyByteString trailerFields
get = do
-- Read the version marker to determine the size of certain following
-- fields.
(_version, getWord) <- getVersion -- 0, 1
- shareBlockSize <- getWord -- 4, 1
- shareDataSize <- getWord -- 8, 1
+ _blockSize <- getWord -- 4, 1
+ _dataSize <- getWord -- 8, 1
-- These offsets are all relative to the beginning of the share.
dataOffset <- getWord -- 12, 36
@@ -228,19 +223,19 @@ instance Binary Share where
-- we'll fail to load the share but at least we won't apply an invalid
-- interpretation to any of the data.
allShareBlocks <- getLazyByteStringInBoundsFrom "share blocks" dataOffset plaintextHashTreeOffset -- 36, <1 byte>
- sharePlaintextHashTree <- isolateBetween "plaintext hash tree" plaintextHashTreeOffset crypttextHashTreeOffset get -- 37, <69 - 37 == 32 bytes>
- shareCrypttextHashTree <- isolateBetween "crypttext hash tree" crypttextHashTreeOffset blockHashesOffset get -- 69, <101 - 69 == 32 bytes>
- shareBlockHashTree <- isolateBetween "block hash tree" blockHashesOffset shareHashesOffset get -- 101, <133 - 101 == 32 bytes>
- shareNeededHashes <- fromMaybe (fail "Could not parse `needed hashes`") . unserializeNeededShares . LBS.toStrict <$> getLazyByteStringInBoundsFrom "needed shares" shareHashesOffset uriExtensionLengthOffset -- 133, <167 - 133 == 34 bytes>
+ _plaintextHashTree <- isolateBetween "plaintext hash tree" plaintextHashTreeOffset crypttextHashTreeOffset get -- 37, <69 - 37 == 32 bytes>
+ _crypttextHashTree <- isolateBetween "crypttext hash tree" crypttextHashTreeOffset blockHashesOffset get -- 69, <101 - 69 == 32 bytes>
+ _blockHashTree <- isolateBetween "block hash tree" blockHashesOffset shareHashesOffset get -- 101, <133 - 101 == 32 bytes>
+ _neededHashes <- fromMaybe (fail "Could not parse `needed hashes`") . unserializeNeededShares . LBS.toStrict <$> getLazyByteStringInBoundsFrom "needed shares" shareHashesOffset uriExtensionLengthOffset -- 133, <167 - 133 == 34 bytes>
uriExtensionLength <- getWord >>= getInt64FromWord64 "URI extension length" -- 167,
uriExtensionBytes <- getLazyByteString uriExtensionLength
- shareURIExtension <-
+ _uriExtension <-
either
(fail . show)
pure
(parse pURIExtension "URI extension" $ LBS.toStrict uriExtensionBytes)
- let shareBlocks = segmentLazyBytes (fromIntegral shareBlockSize) allShareBlocks
+ let _blocks = segmentLazyBytes (fromIntegral _blockSize) allShareBlocks
pure $ Share{..}
diff --git a/src/Tahoe/CHK/URIExtension.hs b/src/Tahoe/CHK/URIExtension.hs
index 16cb0f226844ed3fc81a2ec4d3d40cf7baa16234..41b4f9441c92fd8c3ccad21f10ea9896bf7a3187 100644
--- a/src/Tahoe/CHK/URIExtension.hs
+++ b/src/Tahoe/CHK/URIExtension.hs
@@ -2,9 +2,21 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
module Tahoe.CHK.URIExtension (
URIExtension (..),
+ codecName,
+ codecParams,
+ tailCodecParams,
+ size,
+ segmentSize,
+ numSegments,
+ neededShares,
+ totalShares,
+ crypttextHash,
+ crypttextRootHash,
+ shareRootHash,
uriExtensionToBytes,
showBytes,
pURIExtension,
@@ -12,6 +24,8 @@ module Tahoe.CHK.URIExtension (
import Control.Applicative.Combinators (count)
import Control.Applicative.Permutations (runPermutation, toPermutation)
+import Control.Lens (view)
+import Control.Lens.TH (makeLenses)
import Control.Monad (join, void, (>=>))
import Crypto.Hash (HashAlgorithm, digestFromByteString)
import Data.TreeDiff.Class (ToExpr)
@@ -58,37 +72,39 @@ import Tahoe.Netstring (
-- | Represent additional metadata that appears at the end of each share.
data URIExtension = URIExtension
{ -- | The name of the encoding function. Only "zfec" is implemented.
- uriExtCodecName :: B.ByteString
+ _codecName :: B.ByteString
, -- | The parameters for the encoding function for all except the final
-- segment.
- uriExtCodecParams :: Parameters
+ _codecParams :: Parameters
, -- | The parameters for the encoding function for the final segment.
- uriExtTailCodecParams :: Parameters
+ _tailCodecParams :: Parameters
, -- | The application data size in bytes.
- uriExtSize :: Size
+ _size :: Size
, -- | The individual segment size in bytes.
- uriExtSegmentSize :: Size
+ _segmentSize :: Size
, -- | The number of segments of application data. Note the last segment
-- may be short so it is not necessarily the case that uriExtSize ==
-- uriExtSegmentSize * uriExtNumSegments.
- uriExtNumSegments :: SegmentNum
+ _numSegments :: SegmentNum
, -- | The required (K) parameter to the encoding function. This is a
-- duplicate of the values in uriExtCodecParams and uriExtTailCodecParams.
- uriExtNeededShares :: Required
+ _neededShares :: Required
, -- | The total (N) parameter to the encoding function. This too is a
-- duplicate.
- uriExtTotalShares :: Total
+ _totalShares :: Total
, -- | A tagged sha256d hash of the complete ciphertext.
- uriExtCrypttextHash :: CrypttextHash SHA256d
+ _crypttextHash :: CrypttextHash SHA256d
, -- | The root hash of a merkle tree where the leaf hashes are of segments of ciphertext.
- uriExtCrypttextRootHash :: CrypttextHash SHA256d
+ _crypttextRootHash :: CrypttextHash SHA256d
, -- | The root hash of a merkle tree where leaf hashes are the root hashes of all of the block hash trees.
- uriExtShareRootHash :: CrypttextHash SHA256d
+ _shareRootHash :: CrypttextHash SHA256d
}
deriving (Eq, Ord, Generic, ToExpr)
+$(makeLenses ''URIExtension)
+
instance Show URIExtension where
- show (URIExtension name params tailParams size segSize numSegs needed total hash1 hash2 hash3) =
+ show (URIExtension name params tailParams sz segSize numSegs needed total hash1 hash2 hash3) =
T.unpack . T.concat $
[ "URIExtension { "
, "codec = "
@@ -98,7 +114,7 @@ instance Show URIExtension where
, "; tail-codec-params = "
, showText tailParams
, "; size = "
- , showText size
+ , showText sz
, "; segment-size = "
, showText segSize
, "; num-segments = "
@@ -125,17 +141,17 @@ uriExtensionToBytes :: URIExtension -> B.ByteString
uriExtensionToBytes =
toWeirdString
-- all of the below values are authenticated by the capability you get when you store data in Tahoe
- [ ("codec_name", uriExtCodecName)
- , ("codec_params", paramsToBytes . uriExtCodecParams)
- , ("tail_codec_params", paramsToBytes . uriExtTailCodecParams)
- , ("size", showBytes . uriExtSize)
- , ("segment_size", showBytes . uriExtSegmentSize)
- , ("num_segments", showBytes . uriExtNumSegments)
- , ("needed_shares", showBytes . uriExtNeededShares)
- , ("total_shares", showBytes . uriExtTotalShares)
- , ("crypttext_hash", toBytes . uriExtCrypttextHash) -- hash of the *entire* cipher text
- , ("crypttext_root_hash", toBytes . uriExtCrypttextRootHash) -- root hash of the *cipher text* merkle tree
- , ("share_root_hash", toBytes . uriExtShareRootHash) -- root hash of the *share* merkle tree
+ [ ("codec_name", view codecName)
+ , ("codec_params", paramsToBytes . view codecParams)
+ , ("tail_codec_params", paramsToBytes . view tailCodecParams)
+ , ("size", showBytes . view size)
+ , ("segment_size", showBytes . view segmentSize)
+ , ("num_segments", showBytes . view numSegments)
+ , ("needed_shares", showBytes . view neededShares)
+ , ("total_shares", showBytes . view totalShares)
+ , ("crypttext_hash", toBytes . view crypttextHash) -- hash of the *entire* cipher text
+ , ("crypttext_root_hash", toBytes . view crypttextRootHash) -- root hash of the *cipher text* merkle tree
+ , ("share_root_hash", toBytes . view shareRootHash) -- root hash of the *share* merkle tree
]
type Parser = Parsec Void B.ByteString
diff --git a/src/Tahoe/CHK/Validate.hs b/src/Tahoe/CHK/Validate.hs
index d8ba0beab517274923f0ee732f652ddcaf40bc1c..a7e3dec2aec442e6b59c2750f42fb9724bb3a452 100644
--- a/src/Tahoe/CHK/Validate.hs
+++ b/src/Tahoe/CHK/Validate.hs
@@ -1,53 +1,51 @@
-{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Tahoe.CHK.Validate where
+import Control.Lens (view)
import Crypto.Hash (HashAlgorithm)
import Data.Bifunctor (Bifunctor (first))
import qualified Data.ByteString.Lazy as LB
-import Tahoe.CHK.Capability (Verifier (fingerprint))
+import Tahoe.CHK.Capability (Verifier, fingerprint)
import Tahoe.CHK.Crypto (blockHash', uriExtensionHash)
import Tahoe.CHK.Merkle (checkMerkleProof, heightForLeafCount, leafHashes, rootHash)
import Tahoe.CHK.SHA256d (Digest', SHA256d)
-import Tahoe.CHK.Share (Share (..))
-import Tahoe.CHK.URIExtension (URIExtension (URIExtension, uriExtShareRootHash, uriExtTotalShares))
+import Tahoe.CHK.Share (Share (..), blockHashTree, blocks, neededHashes, uriExtension)
+import Tahoe.CHK.URIExtension (shareRootHash, totalShares)
{- | Determine the validity of the given share's fingerprint as defined by the
given capability.
-}
validFingerprint :: Verifier -> Share -> Bool
-validFingerprint cap = (== fingerprint cap) . uriExtensionHash . shareURIExtension
+validFingerprint cap = (== view fingerprint cap) . uriExtensionHash . _uriExtension
{- | True if the share's own hash in the `shareNeededHashes` list equals the
root of the share's block hash merkle tree, False otherwise.
-}
matchingBlockHashRoot :: Int -> Share -> Bool
-matchingBlockHashRoot
- shareNum
- Share{shareNeededHashes, shareBlockHashTree, shareURIExtension = URIExtension{uriExtTotalShares}} =
- -- We should find exactly one element with a share number matching our
- -- share number and the associated hash should match our hash. If we find
- -- none or more than one then the share is mis-encoded and we should fail
- -- validation (though maybe we should do so with a distinct error value).
- isMatching
- where
- isMatching =
- checkMatch
- . findOwnHash
- $ shareNeededHashes
+matchingBlockHashRoot shareNum share =
+ -- We should find exactly one element with a share number matching our
+ -- share number and the associated hash should match our hash. If we find
+ -- none or more than one then the share is mis-encoded and we should fail
+ -- validation (though maybe we should do so with a distinct error value).
+ isMatching
+ where
+ isMatching =
+ checkMatch
+ . findOwnHash
+ $ view neededHashes share
- checkMatch = ([rootHash shareBlockHashTree] ==) . map snd
+ checkMatch = ([rootHash (view blockHashTree share)] ==) . map snd
- -- Note that shareNeededHashes contains "node numbers" while our
- -- shareNum is a "leaf number". So, convert.
- findOwnHash = filter ((== nodeNumber) . fst)
+ -- Note that shareNeededHashes contains "node numbers" while our
+ -- shareNum is a "leaf number". So, convert.
+ findOwnHash = filter ((== nodeNumber) . fst)
- nodeNumber :: Int
- nodeNumber = toNodeNumber shareNum
+ nodeNumber :: Int
+ nodeNumber = toNodeNumber shareNum
- toNodeNumber num = num + (2 ^ treeHeight) - 1
- treeHeight = heightForLeafCount uriExtTotalShares
+ toNodeNumber num = num + (2 ^ treeHeight) - 1
+ treeHeight = heightForLeafCount . view (uriExtension . totalShares) $ share
{- | Determine the validity of each of the given shares' "share root hash"
values with respect to the other shares in the list.
@@ -63,19 +61,19 @@ validShareRootHash shares@((_, aShare) : _) =
-- hash from the UEB has also been validated and we can use it. The UEB
-- is the same for all shares so we can pull this value from an arbitrary
-- share.
- expected = uriExtShareRootHash . shareURIExtension $ aShare
+ expected = view (uriExtension . shareRootHash) aShare
-- Extract the proof for each share in the given list.
proofs = uncurry oneProof <$> shares
-- Also extract each share's leaf hash to supply to the proof checker.
- leafs = rootHash . shareBlockHashTree . snd <$> shares
+ leafs = rootHash . view blockHashTree . snd <$> shares
oneProof :: Int -> Share -> [(Int, Digest' SHA256d)]
- oneProof shareNum Share{shareNeededHashes} = fmap (first (+ 1)) proof
+ oneProof shareNum share = fmap (first (+ 1)) proof
where
-- The length of the proof equals the height of the tree.
- treeHeight = length shareNeededHashes
+ treeHeight = length (view neededHashes share)
-- Since inclusion of our block tree root hash is what the proof is
-- proving we don't want it. We need to take it out to use our proof
@@ -90,7 +88,7 @@ validShareRootHash shares@((_, aShare) : _) =
-- The proof is all of the needed hashes except for this share's own
-- hash which we will feed into the proof checker separately.
- proof = filter ((/= nodeNum) . fst) (first fromIntegral <$> shareNeededHashes)
+ proof = filter ((/= nodeNum) . fst) (first fromIntegral <$> view neededHashes share)
showHashes :: (Show a, Show b) => [(a, b)] -> String
showHashes = unwords . fmap showHash
@@ -102,8 +100,8 @@ showHash (n, bs) = unwords [show n, show bs]
the values in the Share's "block hash tree".
-}
shareValidBlocks :: Share -> [Maybe LB.ByteString]
-shareValidBlocks Share{shareBlocks, shareBlockHashTree} =
- zipWith checkHash shareBlocks (leafHashes shareBlockHashTree)
+shareValidBlocks share =
+ zipWith checkHash (view blocks share) (leafHashes (view blockHashTree share))
where
checkHash :: forall hash. HashAlgorithm hash => LB.ByteString -> Digest' hash -> Maybe LB.ByteString
checkHash bs expected
diff --git a/tahoe-chk.cabal b/tahoe-chk.cabal
index 44a0c47324a3aec5d30eb9a3c013411e2ad62081..570d1785376ae3693009c7a2b005564239f3ddad 100644
--- a/tahoe-chk.cabal
+++ b/tahoe-chk.cabal
@@ -68,6 +68,7 @@ library
, extra >=1.7.7 && <1.8
, fec >=0.1.1 && <0.2
, filepath >=1.4.2 && <1.5
+ , lens >=5.0 && <5.3
, megaparsec >=8.0 && <9.3
, memory >=0.15 && <0.17
, monad-loops >=0.4.3 && <0.5
@@ -135,6 +136,7 @@ test-suite tahoe-chk-tests
, fec >=0.1.1 && <0.2
, filepath >=1.4.2 && <1.5
, hedgehog >=1.0.3 && <1.1
+ , lens >=5.0 && <5.3
, megaparsec >=8.0 && <9.3
, memory >=0.15 && <0.17
, scientific >=0.3.6.2 && <0.4
diff --git a/test/Generators.hs b/test/Generators.hs
index 87c0e07d2f6852def2f791eda6be08b445f5b7b9..78bdc83e4704a2a17bb1a851938026aed2a06a61 100644
--- a/test/Generators.hs
+++ b/test/Generators.hs
@@ -4,6 +4,8 @@
module Generators where
+import Control.Lens (over, view)
+import Control.Lens.Tuple (_2)
import Control.Monad (zipWithM)
import Crypto.Hash (
HashAlgorithm,
@@ -13,7 +15,7 @@ import Crypto.Hash (
import Crypto.Hash.Algorithms (
SHA256 (SHA256),
)
-import Data.Bifunctor (Bifunctor (first, second))
+import Data.Bifunctor (Bifunctor (first))
import Data.ByteArray (xor)
import qualified Data.ByteString as BS
import Data.ByteString.Base32 (encodeBase32Unpadded)
@@ -24,12 +26,12 @@ import qualified Data.Text as T
import Hedgehog (MonadGen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
-import Tahoe.CHK.Capability (Reader (..), Verifier (..))
+import Tahoe.CHK.Capability (Reader, fingerprint, verifier)
import Tahoe.CHK.Crypto (storageIndexLength)
import Tahoe.CHK.Merkle (MerkleTree, makeTreePartial)
import Tahoe.CHK.SHA256d (Digest' (..), SHA256d, toBytes)
import Tahoe.CHK.Server (StorageServerAnnouncement (StorageServerAnnouncement))
-import Tahoe.CHK.Share (Share (..))
+import Tahoe.CHK.Share (Share (..), blocks, neededHashes)
import Tahoe.CHK.Types (Parameters (..), Required, ShareNum, StorageIndex, Total)
import Tahoe.CHK.URIExtension (URIExtension (URIExtension))
@@ -88,7 +90,7 @@ shares = do
-- memory (and even if they didn't, they would be constrained by disk
-- space and speed) and maxBound :: Int64 is a lot of bytes...
let maxSize = 65536
- shareBlockSize <- Gen.integral (Range.exponential 1 maxSize)
+ _blockSize <- Gen.integral (Range.exponential 1 maxSize)
numBlocks <- Gen.integral (Range.exponential 1 32)
-- We don't make shareDataSize agree with the rest of the share data
@@ -97,21 +99,21 @@ shares = do
--
-- We can go all the way up to an unreasonable maximum here because this
-- doesn't influence how many bytes are actually in the share.
- shareDataSize <- fromIntegral <$> Gen.integral (Range.linear 1 maxInt64)
+ _dataSize <- fromIntegral <$> Gen.integral (Range.linear 1 maxInt64)
- shareBlocks <- Gen.list (Range.singleton numBlocks) (LBS.fromStrict <$> Gen.bytes (Range.singleton $ fromIntegral shareBlockSize))
+ _blocks <- Gen.list (Range.singleton numBlocks) (LBS.fromStrict <$> Gen.bytes (Range.singleton $ fromIntegral _blockSize))
-- XXX These merkle trees and the "needed hashes" list all have a size
-- that really needs to be dictated by the encoding parameters (k and n).
- sharePlaintextHashTree <- merkleTrees (Range.exponential 1 256)
- shareCrypttextHashTree <- merkleTrees (Range.exponential 1 256)
- shareBlockHashTree <- merkleTrees (Range.exponential 1 256)
- shareNeededHashes <- Gen.list (Range.exponential 1 100) ((,) <$> Gen.integral (Range.exponential 1 255) <*> digests)
+ _plaintextHashTree <- merkleTrees (Range.exponential 1 256)
+ _crypttextHashTree <- merkleTrees (Range.exponential 1 256)
+ _blockHashTree <- merkleTrees (Range.exponential 1 256)
+ _neededHashes <- Gen.list (Range.exponential 1 100) ((,) <$> Gen.integral (Range.exponential 1 255) <*> digests)
-- XXX A valid share will have a URI extension that agrees with some of
-- the other fields we've just generated, which we're not even trying to
-- do here.
- shareURIExtension <- genURIExtension
+ _uriExtension <- genURIExtension
pure $ Share{..}
@@ -172,28 +174,32 @@ data ShareBitFlips
capability.
-}
fingerprintBitFlipper :: MonadGen m => Reader -> m ShareBitFlips
-fingerprintBitFlipper (Reader{verifier = Verifier{fingerprint}}) = do
- FingerprintBitFlips <$> (Gen.bytes . Range.singleton . BS.length) fingerprint
+fingerprintBitFlipper reader = do
+ FingerprintBitFlips <$> (Gen.bytes . Range.singleton . BS.length) (view (verifier . fingerprint) reader)
-- | Choose a function to run on a value based on a boolean.
conditionally :: (a -> b) -> (a -> b) -> Bool -> a -> b
conditionally f g p x = if p then f x else g x
-- | Generate instructions for flipping some bits in some blocks.
-blockBitFlipper :: MonadGen m => Parameters -> [Share] -> m ShareBitFlips
+blockBitFlipper :: forall m. MonadGen m => Parameters -> [Share] -> m ShareBitFlips
blockBitFlipper Parameters{paramRequiredShares, paramTotalShares} shares' = do
-- Pick the shares the blocks of which will be modified.
whichShares <- enoughModifiedShares paramRequiredShares paramTotalShares
-- Make up some masks to do the block modification.
- masks <- zipWithM (conditionally maskForShare zerosForShare) whichShares shares'
+ masks <- zipWithM (conditionally maskForShare (pure . zerosForShare)) whichShares shares'
pure $ BlockBitFlips masks
where
- zerosForShare Share{shareBlocks = []} = pure []
- zerosForShare Share{shareBlocks = blocks@(block : _)} = pure $ replicate (length blocks) (BS.replicate (fromIntegral @Int64 @Int $ LBS.length block) 0)
+ -- Replace all the Word8s in the share blocks with 0s.
+ zerosForShare :: Share -> [BS.ByteString]
+ zerosForShare = (LBS.toStrict <$>) . (LBS.map (const 0) <$>) . view blocks
- maskForShare Share{shareBlocks = []} = pure []
- maskForShare Share{shareBlocks = blocks@(block : _)} = Gen.list (Range.singleton (length blocks)) (nonZeroBytes (Range.singleton (fromIntegral @Int64 @Int $ LBS.length block)))
+ maskForShare :: Share -> m [BS.ByteString]
+ maskForShare = go . view blocks
+ where
+ go :: [LBS.ByteString] -> m [BS.ByteString]
+ go = mapM (nonZeroBytes . Range.singleton . fromIntegral @Int64 @Int . LBS.length)
{- | Generate flags indicating which shares should be modified in order to
make the whole set unusable.
@@ -214,20 +220,18 @@ enoughModifiedShares required total = do
-- | Execute the ShareTreeLeafBitFlips instruction on a list of shares.
applyShareBitFlips :: ShareBitFlips -> ([Share], Reader) -> ([Share], Reader)
-applyShareBitFlips (FingerprintBitFlips flips) = second flipFingerprint
- where
- flipFingerprint cap@(Reader{verifier = v@(Verifier{fingerprint})}) = cap{verifier = v{fingerprint = xor flips fingerprint}}
+applyShareBitFlips (FingerprintBitFlips flips) = over (_2 . verifier . fingerprint) (xor flips)
applyShareBitFlips (ShareTreeLeafBitFlips shareFlips) = first (zipWith flipLeaves shareFlips)
where
flipLeaves :: [BS.ByteString] -> Share -> Share
- flipLeaves leafFlips share = share{shareNeededHashes = zipWith flipBits (shareNeededHashes share) leafFlips}
+ flipLeaves leafFlips share = share{_neededHashes = zipWith flipBits (view neededHashes share) leafFlips}
flipBits :: forall hash a. HashAlgorithm hash => (a, Digest' hash) -> BS.ByteString -> (a, Digest' hash)
flipBits (a, x) y = (a, Digest' . fromJust . digestFromByteString @hash $ xor @BS.ByteString @BS.ByteString @BS.ByteString (toBytes x) y)
applyShareBitFlips (BlockBitFlips blockFlips) = first (zipWith flipBlocks blockFlips)
where
flipBlocks :: [BS.ByteString] -> Share -> Share
- flipBlocks masks s@Share{shareBlocks} = s{shareBlocks = LBS.fromStrict <$> zipWith xor (LBS.toStrict <$> shareBlocks) masks}
+ flipBlocks masks s@Share{_blocks} = s{_blocks = LBS.fromStrict <$> zipWith xor (LBS.toStrict <$> _blocks) masks}
{- | Generate lists of shares like the one given but with some bits in the
hashes needed to validate the merkle path to each share's "share root
@@ -246,17 +250,17 @@ shareTreeLeafBitFlipper Parameters{paramRequiredShares, paramTotalShares} shares
zeroMask = BS.replicate bytesInMask 0
modifiedShare :: MonadGen m => Bool -> Share -> m [BS.ByteString]
- modifiedShare False Share{shareNeededHashes} = pure $ replicate (length shareNeededHashes) zeroMask
- modifiedShare True Share{shareNeededHashes} = do
+ modifiedShare False Share{_neededHashes} = pure $ replicate (length _neededHashes) zeroMask
+ modifiedShare True Share{_neededHashes} = do
let -- We have to change *something*
minHashesToModify = 1
-- We might change everything
- maxHashesToModify = length shareNeededHashes
+ maxHashesToModify = length _neededHashes
-- Now choose how many we will change.
numHashesToModify <- Gen.integral $ Range.linear minHashesToModify (maxHashesToModify - 1)
-- And which ones
- modifyHash <- Gen.shuffle $ (< numHashesToModify) <$> [0 .. length shareNeededHashes - 1]
+ modifyHash <- Gen.shuffle $ (< numHashesToModify) <$> [0 .. length _neededHashes - 1]
mapM modifiedHash modifyHash
diff --git a/test/SpecCHK.hs b/test/SpecCHK.hs
index 24ddaac2ec6d902e1e6e2dc95c742484376133ce..8fa8fe50416bf05dadf26933cd9b98b98e85a3fe 100644
--- a/test/SpecCHK.hs
+++ b/test/SpecCHK.hs
@@ -9,6 +9,7 @@ module SpecCHK (
import Control.Arrow (
(&&&),
)
+import Control.Lens (view)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Crypto.Cipher.AES128 (
AESKey128,
@@ -50,19 +51,19 @@ import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Tahoe.CHK (padCiphertext)
import qualified Tahoe.CHK (decode, encode, segmentCiphertext)
-import Tahoe.CHK.Capability (Reader (verifier), dangerRealShow, pCapability, pReader)
+import Tahoe.CHK.Capability (Reader, dangerRealShow, pCapability, pReader, verifier)
import Tahoe.CHK.Crypto (convergenceSecretLength)
import Tahoe.CHK.Encrypt (encrypt)
import Tahoe.CHK.Share (
Share (
- shareBlockSize,
- shareURIExtension
+ _blockSize
),
+ uriExtension,
)
import Tahoe.CHK.Types (
Parameters (..),
)
-import Tahoe.CHK.URIExtension (uriExtCodecParams)
+import Tahoe.CHK.URIExtension (codecParams)
import Tahoe.CHK.Upload (
UploadResult (..),
Uploadable (..),
@@ -189,10 +190,10 @@ testSizes =
testCase "the maximum segment size encoded in the UEB equals the actual segment size" $ do
uploadable <- memoryUploadableWithConvergence (B.replicate 32 0x00) (fromIntegral $ BL.length ciphertext) ciphertext params
(shares', _cap) <- Tahoe.CHK.encode (uploadableKey uploadable) params ciphertext
- mapM_ (assertEqual "The shareBlockSize reflects the parameters and real ciphertext size" (fromIntegral $ BL.length ciphertext `div` 2) . shareBlockSize) shares'
+ mapM_ (assertEqual "The shareBlockSize reflects the parameters and real ciphertext size" (fromIntegral $ BL.length ciphertext `div` 2) . _blockSize) shares'
mapM_ (assertEqual "The segment size is reduced to the ciphertext size" (fromIntegral $ BL.length ciphertext) . getSegmentSize) shares'
where
- getSegmentSize = paramSegmentSize . uriExtCodecParams . shareURIExtension
+ getSegmentSize = paramSegmentSize . view (uriExtension . codecParams)
params =
Parameters
{ paramSegmentSize = 100000
@@ -246,7 +247,7 @@ wellKnownCase WellKnown{..} =
assertEqual' expectedShares shares'
assertEqual' wellKnownShares encodedShares
assertEqual "The cap matches" cap wellKnownCapability
- assertEqual "The fingerprint matches" allValid ((validFingerprint . verifier $ wellKnownCapability) <$> expectedShares)
+ assertEqual "The fingerprint matches" allValid ((validFingerprint . view verifier $ wellKnownCapability) <$> expectedShares)
assertEqual "The block tree root hash matches the proof" allValid (zipWith matchingBlockHashRoot [0 ..] expectedShares)
assertEqual "The share tree root hash is consistent" allValid (validShareRootHash $ zip [0 ..] expectedShares)
pure ()