diff --git a/src/Tahoe/CHK/Decode.hs b/src/Tahoe/CHK/Decode.hs
index 5a92dc725324d1ef9ff6fc15465780ac77ed481d..37b98ebe09ef92befc50194fad31d40caa9a3f58 100644
--- a/src/Tahoe/CHK/Decode.hs
+++ b/src/Tahoe/CHK/Decode.hs
@@ -180,16 +180,16 @@ instance Binary Share where
-- 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
+ shareBlockSize <- getWord -- 4, 184
+ shareDataSize <- getWord -- 8, 184
-- These offsets are all relative to the beginning of the share.
dataOffset <- getWord -- 12, 36
- plaintextHashTreeOffset <- getWord -- 16, 37
- crypttextHashTreeOffset <- getWord -- 20, 69
- blockHashesOffset <- getWord -- 24, 101
- shareHashesOffset <- getWord -- 28, 133
- uriExtensionLengthOffset <- getWord -- 32, 167
+ plaintextHashTreeOffset <- getWord -- 16, 220
+ crypttextHashTreeOffset <- getWord -- 20, 252
+ blockHashesOffset <- getWord -- 24, 284
+ shareHashesOffset <- getWord -- 28, 316
+ uriExtensionLengthOffset <- getWord -- 32, 418
-- Load the rest of the fields in the typical order. The offsets
-- might place these fields in a different order but they really
@@ -210,7 +210,7 @@ instance Binary Share where
pure
(parse pURIExtension "URI extension" $ LBS.toStrict uriExtensionBytes)
- let shareBlocks = segmentLazyBytes (fromIntegral shareBlockSize) allShareBlocks
+ let shareBlocks = segmentLazyBytes (fromIntegral . paramSegmentSize . uriExtCodecParams $ shareURIExtension) allShareBlocks
pure $ Share{..}
diff --git a/test/SpecCHK.hs b/test/SpecCHK.hs
index bf656b85ace7c1d52231ea9e781826574525ac09..b63f403e52c9cd2fc1a94fa821b03aedea26ad53 100644
--- a/test/SpecCHK.hs
+++ b/test/SpecCHK.hs
@@ -14,7 +14,7 @@ import Crypto.Cipher.AES128 (
import Crypto.Classes (
encode,
)
-import qualified Data.Binary as Binary
+import Data.Binary
import qualified Data.ByteString as B
import Data.ByteString.Base64 (encodeBase64)
import qualified Data.ByteString.Lazy as BL
@@ -33,6 +33,12 @@ import Hedgehog (
property,
tripping,
)
+
+import qualified Paths_tahoe_chk as Paths
+
+import Data.Binary.Get (getByteString, getWord32be)
+import Data.Binary.Put (putByteString, putWord32be)
+import Data.Either (partitionEithers)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Tahoe.CHK (
@@ -40,6 +46,7 @@ import Tahoe.CHK (
)
import Tahoe.CHK.Capability
import Tahoe.CHK.Crypto (convergenceSecretLength)
+import Tahoe.CHK.Decode (Share)
import Tahoe.CHK.Types
import Tahoe.CHK.Upload (
UploadResult (..),
@@ -58,12 +65,13 @@ import Test.Tasty (
)
import Test.Tasty.HUnit (
Assertion,
+ assertBool,
assertEqual,
assertFailure,
testCase,
)
import Test.Tasty.Hedgehog (testProperty)
-import Text.Megaparsec (parse)
+import Text.Megaparsec (many, parse)
import Vectors (
Format (..),
JSONByteString (..),
@@ -72,6 +80,47 @@ import Vectors (
VectorSpec (..),
)
+data Lease = Lease
+ { leaseOwner :: Word32
+ , leaseRenewSecret :: B.ByteString
+ , leaseCancelSecret :: B.ByteString
+ , leaseExpirationTime :: Word32
+ }
+ deriving (Show, Eq, Ord)
+
+instance Binary Lease where
+ put Lease{leaseOwner, leaseRenewSecret, leaseCancelSecret, leaseExpirationTime} = do
+ putWord32be leaseOwner
+ putByteString leaseRenewSecret
+ putByteString leaseCancelSecret
+ putWord32be leaseExpirationTime
+
+ get = Lease <$> getWord32be <*> getByteString 32 <*> getByteString 32 <*> getWord32be
+
+data ImmutableContainer = ImmutableContainer
+ { immutableContainerVersion :: Word32
+ , immutableContainerDataLength :: Word32
+ , immutableContainerShareData :: Share
+ , immutableContainerLeases :: [Lease]
+ }
+ deriving (Show, Eq, Ord)
+
+instance Binary ImmutableContainer where
+ put ImmutableContainer{immutableContainerVersion, immutableContainerDataLength, immutableContainerShareData, immutableContainerLeases} = do
+ putWord32be immutableContainerVersion
+ putWord32be immutableContainerDataLength
+ putWord32be $ fromIntegral @Int @Word32 (length immutableContainerLeases)
+ put immutableContainerShareData
+ mapM_ put immutableContainerLeases
+
+ get =
+ ImmutableContainer
+ <$> getWord32be
+ <*> getWord32be
+ <* getWord32be
+ <*> get
+ <*> many get
+
tests :: VectorSpec -> TestTree
tests vectorSpec =
testGroup
@@ -82,26 +131,66 @@ tests vectorSpec =
, testProperty "expand returns the correct number of bytes" prop_expand_length
, testProperty "expand returns bytes containing the template repeated" prop_expand_template
, testProperty "Share round-trips through put / get" prop_share_roundtrip
+ , testWholeShare
]
prop_share_roundtrip :: Property
prop_share_roundtrip =
- let decode' = ((\(_, _, sh) -> sh) <$>) . Binary.decodeOrFail
+ let decode' = ((\(_, _, sh) -> sh) <$>) . decodeOrFail
in property $ do
share <- forAll shares
- tripping share Binary.encode decode'
+ tripping share Data.Binary.encode decode'
testWholeShare :: TestTree
testWholeShare = testCase "the whole share is byte-for-byte equal" $ do
- convergence <- B.readFile "convergence"
- plaintext <- BL.readFile "plaintext.txt"
+ datadir <- Paths.getDataFileName "test/vectors/"
+ convergence <- B.readFile (datadir <> "convergence")
+ plaintext <- BL.readFile (datadir <> "plaintext.txt")
uploadable <- memoryUploadableWithConvergence convergence (fromIntegral @Int64 @Integer $ BL.length plaintext) plaintext (Parameters (128 * 1024) 3 1 1)
server <- memoryStorageServer
result <- store [server] uploadable
let index = storageIndex . verifier . uploadResultReadCap $ result
- shares <- mapM (storageServerRead server index) [0, 1, 2]
- expected <- mapM B.readFile ["0", "1", "2"]
- assertEqual "the shares match" shares expected
+ decode' = fmap $ fmap (immutableContainerShareData . (\(_, _, c) -> c)) . decodeOrFail
+
+ (actualErrors, actualShares) <- partitionEithers <$> mapM (decode' . fmap BL.fromStrict . storageServerRead server index) [0, 1, 2]
+ assertEqual "Our shares can be decoded" [] actualErrors
+
+ (expectedErrors, expectedShares) <-
+ partitionEithers
+ <$> mapM
+ (decode' . (BL.readFile . (datadir <>)))
+ ["0", "1", "2"]
+ assertEqual "Tahoe-LAFS shares can be decoded" [] expectedErrors
+
+ mapM_ (\(e, a) -> assertBool (diffShares e a) (e == a)) (zip expectedShares actualShares)
+
+diffShares :: Share -> Share -> String
+diffShares a b
+ | a == b = ""
+ | otherwise =
+ ""
+
+-- differences :: [B.ByteString] -> [B.ByteString] -> String
+-- differences [] [] = ""
+-- differences xs [] = "Extra elements, left: " <> show xs
+-- differences [] ys = "Extra elements, right: " <> show ys
+-- differences (x : xs) (y : ys) =
+-- ( case x == y of
+-- True -> ""
+-- False -> differencesBytes x y
+-- )
+-- <> "\n"
+-- <> differences xs ys
+
+-- differencesBytes :: B.ByteString -> B.ByteString -> String
+-- differencesBytes x y
+-- | x == y = ""
+-- | otherwise =
+-- if x `isPrefixOf` y
+-- then
+-- case stripPrefix x y of
+-- Nothing -> case stripSuffix x y of
+-- Nothing -> case
testEncrypt :: TestTree
testEncrypt =
@@ -111,7 +200,7 @@ testEncrypt =
assertEqual
"expected convergence key"
"oBcuR/wKdCgCV2GKKXqiNg=="
- (encodeBase64 $ encode convergenceKey)
+ (encodeBase64 $ Crypto.Classes.encode convergenceKey)
ciphertext <- encrypt
let b64ciphertext = encodeBase64 ciphertext
assertEqual "known result" knownCorrect b64ciphertext