diff --git a/src/Tahoe/SDMF/Internal/Share.hs b/src/Tahoe/SDMF/Internal/Share.hs index 1bf2a53b0edb6c325edbe36592ba28f501569de7..c33b4d8ab67b1e461ae11a291e6fd925cf176b00 100644 --- a/src/Tahoe/SDMF/Internal/Share.hs +++ b/src/Tahoe/SDMF/Internal/Share.hs @@ -18,6 +18,9 @@ import Data.Word (Word16, Word64, Word8) import Debug.Trace (trace) import Tahoe.CHK.Merkle (MerkleTree, leafHashes) +hashSize :: Int +hashSize = 32 + newtype HashChain = HashChain { hashChain :: [(Word16, B.ByteString)] } @@ -36,7 +39,7 @@ instance Binary HashChain where then pure $ HashChain [] else do n <- getWord16be - h <- getByteString 16 + h <- getByteString hashSize (HashChain c) <- get pure $ HashChain ((n, h) : c) @@ -111,9 +114,9 @@ instance Binary Share where blockHashTreeBytes = B.concat . leafHashes $ shareBlockHashTree -- TODO Compute these from all the putting. - signatureOffset = fromIntegral $ 1 + 8 + 32 + 16 + 18 + 32 + B.length verificationKeyBytes + signatureOffset = fromIntegral $ 1 + 8 + hashSize + 16 + 18 + 32 + B.length verificationKeyBytes hashChainOffset = signatureOffset + fromIntegral (B.length shareSignature) - blockHashTreeOffset = hashChainOffset + fromIntegral (length (hashChain shareHashChain) * 34) + blockHashTreeOffset = hashChainOffset + fromIntegral (length (hashChain shareHashChain) * (hashSize + 2)) shareDataOffset = blockHashTreeOffset + fromIntegral (B.length blockHashTreeBytes) encryptedPrivateKeyOffset = fromIntegral shareDataOffset + fromIntegral (LB.length shareData) eofOffset = encryptedPrivateKeyOffset + fromIntegral (B.length shareEncryptedPrivateKey) @@ -135,8 +138,6 @@ instance Binary Share where encryptedPrivateKeyOffset <- getWord64be eofOffset <- getWord64be - pure $ trace (show $ (signatureOffset, hashChainOffset, blockHashTreeOffset, shareDataOffset, encryptedPrivateKeyOffset, eofOffset)) () - pos <- bytesRead verificationKeyBytes <- getByteString (fromIntegral signatureOffset - fromIntegral pos) let Right (Right (shareVerificationKey, _)) = fmap fromASN1 . decodeASN1' DER $ verificationKeyBytes @@ -145,7 +146,6 @@ instance Binary Share where shareSignature <- getByteString (fromIntegral hashChainOffset - fromIntegral pos) pos <- bytesRead - -- -- XXX Magically correct? shareHashChain <- isolate (fromIntegral blockHashTreeOffset - fromIntegral pos) get pos <- bytesRead diff --git a/tahoe-ssk.cabal b/tahoe-ssk.cabal index 77795fa828ecb4a8457ea88c73dad2201d7135d3..2e446c3a5f59bb6dbb21fcf4e04e25d82b5cd733 100644 --- a/tahoe-ssk.cabal +++ b/tahoe-ssk.cabal @@ -109,7 +109,9 @@ test-suite tahoe-ssk-test -- The entrypoint to the test suite. main-is: Main.hs - other-modules: Generators + other-modules: + Generators + Spec -- Test dependencies. build-depends: diff --git a/test/Main.hs b/test/Main.hs index dca5ca14819512ef15697a5faa39e9969d2f47de..2b57e2fa4c1baf15aa4a4fd943a832ee043ffa8a 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,41 +1,3 @@ module Main (main) where -import Hedgehog ( - forAll, - property, - tripping, - ) - -import qualified Data.Binary as Binary -import qualified Data.ByteString as B -import Generators (shareHashChains, shares) -import System.IO (hSetEncoding, stderr, stdout, utf8) -import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.Hedgehog (testProperty) - -tests :: TestTree -tests = - testGroup - "SSK" - [ testProperty "Hash chain round-trips through bytes" $ - property $ do - hashChain <- forAll shareHashChains - tripping hashChain Binary.encode decode' - , testProperty "Share round-trips through bytes" $ - property $ do - share <- forAll shares - tripping share Binary.encode decode' - ] - where - decode' :: Binary.Binary a => B.ByteString -> a - decode' = ((\(_, _, a) -> a) <$>) . Binary.decodeOrFail - -main :: IO () -main = do - -- Hedgehog writes some non-ASCII and the whole test process will die if - -- it can't be encoded. Increase the chances that all of the output can - -- be encoded by forcing the use of UTF-8 (overriding the LANG-based - -- choice normally made). - hSetEncoding stdout utf8 - hSetEncoding stderr utf8 - defaultMain tests +import Spec (main) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000000000000000000000000000000000000..e4b0f45056e208c9a4c8ec9361d4600baccce5ee --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,42 @@ +module Spec where + +import Hedgehog ( + forAll, + property, + tripping, + ) + +import qualified Data.Binary as Binary +import Data.Binary.Get (ByteOffset) +import qualified Data.ByteString.Lazy as LB +import Generators (shareHashChains, shares) +import System.IO (hSetEncoding, stderr, stdout, utf8) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +tests :: TestTree +tests = + testGroup + "SSK" + [ testProperty "Hash chain round-trips through bytes" $ + property $ do + hashChain <- forAll shareHashChains + tripping hashChain Binary.encode decode' + , testProperty "Share round-trips through bytes" $ + property $ do + share <- forAll shares + tripping share Binary.encode decode' + ] + where + decode' :: Binary.Binary b => LB.ByteString -> Either (LB.ByteString, ByteOffset, String) b + decode' = ((\(_, _, a) -> a) <$>) . Binary.decodeOrFail + +main :: IO () +main = do + -- Hedgehog writes some non-ASCII and the whole test process will die if + -- it can't be encoded. Increase the chances that all of the output can + -- be encoded by forcing the use of UTF-8 (overriding the LANG-based + -- choice normally made). + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + defaultMain tests