diff --git a/src/Tahoe/SDMF/Internal/Share.hs b/src/Tahoe/SDMF/Internal/Share.hs index 9f87734ae23952f05e21f7b539086c9c0e9c6ec8..1bf2a53b0edb6c325edbe36592ba28f501569de7 100644 --- a/src/Tahoe/SDMF/Internal/Share.hs +++ b/src/Tahoe/SDMF/Internal/Share.hs @@ -1,13 +1,44 @@ -- | Deal with details related to the structural layout of an SDMF share. module Tahoe.SDMF.Internal.Share where +import Control.Monad (unless, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Crypto.Cipher.AES (AES128) -import Crypto.Types (IV) +import Crypto.Types (IV (IV, initializationVector)) import qualified Crypto.Types.PubKey.RSA as RSA +import Data.ASN1.BinaryEncoding (DER (DER)) +import Data.ASN1.Encoding (ASN1Encoding (encodeASN1), decodeASN1') +import Data.ASN1.Types (ASN1Object (fromASN1, toASN1)) +import Data.Binary (Binary (..), getWord8) +import Data.Binary.Get (bytesRead, getByteString, getLazyByteString, getWord16be, getWord32be, getWord64be, isEmpty, isolate) +import Data.Binary.Put (putByteString, putLazyByteString, putWord16be, putWord32be, putWord64be, putWord8) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB -import Data.Word (Word64, Word8) -import Tahoe.CHK.Merkle (MerkleTree) +import Data.Word (Word16, Word64, Word8) +import Debug.Trace (trace) +import Tahoe.CHK.Merkle (MerkleTree, leafHashes) + +newtype HashChain = HashChain + { hashChain :: [(Word16, B.ByteString)] + } + deriving newtype (Eq, Show) + +instance Binary HashChain where + put (HashChain []) = mempty + put (HashChain ((n, h) : c)) = do + putWord16be n + putByteString h + put (HashChain c) + + get = do + empty <- isEmpty + if empty + then pure $ HashChain [] + else do + n <- getWord16be + h <- getByteString 16 + (HashChain c) <- get + pure $ HashChain ((n, h) : c) {- | Structured representation of a single version SDMF share. @@ -43,7 +74,7 @@ data Share = Share shareSignature :: B.ByteString , -- | The share numbers and shareRootHash values which are required to -- ... something about verification I dunno. XXX - shareHashChain :: [(Word8, B.ByteString)] + shareHashChain :: HashChain , -- | A merkle tree where leaves are the hashes of the blocks in this share. shareBlockHashTree :: MerkleTree , -- | The share data (erasure encoded ciphertext). @@ -51,4 +82,82 @@ data Share = Share , -- | The encrypted 2048 bit "signature" RSA key. shareEncryptedPrivateKey :: B.ByteString } - deriving (Show) + deriving (Eq, Show) + +instance Binary Share where + put Share{..} = do + putWord8 0 + putWord64be shareSequenceNumber + putByteString shareRootHash + putByteString . initializationVector $ shareIV + putWord8 shareTotalShares + putWord8 shareRequiredShares + putWord64be shareSegmentSize + putWord64be shareDataLength + putWord32be signatureOffset + putWord32be hashChainOffset + putWord32be blockHashTreeOffset + putWord32be shareDataOffset + putWord64be encryptedPrivateKeyOffset + putWord64be eofOffset + putByteString verificationKeyBytes + putByteString shareSignature + put shareHashChain + put shareBlockHashTree + putLazyByteString shareData + putByteString shareEncryptedPrivateKey + where + verificationKeyBytes = LB.toStrict . encodeASN1 DER . flip toASN1 [] $ shareVerificationKey + blockHashTreeBytes = B.concat . leafHashes $ shareBlockHashTree + + -- TODO Compute these from all the putting. + signatureOffset = fromIntegral $ 1 + 8 + 32 + 16 + 18 + 32 + B.length verificationKeyBytes + hashChainOffset = signatureOffset + fromIntegral (B.length shareSignature) + blockHashTreeOffset = hashChainOffset + fromIntegral (length (hashChain shareHashChain) * 34) + shareDataOffset = blockHashTreeOffset + fromIntegral (B.length blockHashTreeBytes) + encryptedPrivateKeyOffset = fromIntegral shareDataOffset + fromIntegral (LB.length shareData) + eofOffset = encryptedPrivateKeyOffset + fromIntegral (B.length shareEncryptedPrivateKey) + + get = do + version <- getWord8 + unless (version == 0) (fail $ "Only version 0 is supported; got version " <> show version) + shareSequenceNumber <- getWord64be + shareRootHash <- getByteString 32 + shareIV <- IV <$> getByteString 16 + shareTotalShares <- getWord8 + shareRequiredShares <- getWord8 + shareSegmentSize <- getWord64be + shareDataLength <- getWord64be + signatureOffset <- getWord32be + hashChainOffset <- getWord32be + blockHashTreeOffset <- getWord32be + shareDataOffset <- getWord32be + 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 + + pos <- bytesRead + shareSignature <- getByteString (fromIntegral hashChainOffset - fromIntegral pos) + + pos <- bytesRead + -- -- XXX Magically correct? + shareHashChain <- isolate (fromIntegral blockHashTreeOffset - fromIntegral pos) get + + pos <- bytesRead + shareBlockHashTree <- isolate (fromIntegral shareDataOffset - fromIntegral pos) get + + pos <- bytesRead + shareData <- getLazyByteString (fromIntegral encryptedPrivateKeyOffset - fromIntegral pos) + + pos <- bytesRead + shareEncryptedPrivateKey <- getByteString (fromIntegral eofOffset - fromIntegral pos) + + empty <- isEmpty + unless empty (fail "Expected end of input but there are more bytes") + + pure Share{..} diff --git a/tahoe-ssk.cabal b/tahoe-ssk.cabal index d318e7efb4657494ed2bcaeddd6291514b130338..77795fa828ecb4a8457ea88c73dad2201d7135d3 100644 --- a/tahoe-ssk.cabal +++ b/tahoe-ssk.cabal @@ -66,17 +66,26 @@ library Tahoe.SDMF.Internal.Share build-depends: + , asn1-encoding + , asn1-types , base + , binary , bytestring , crypto-api , crypto-pubkey-types , cryptonite + , RSA -- This dependency isn't ideal. Move common bits out to -- another library. build-depends: tahoe-chk ghc-options: -Wall - default-extensions: OverloadedStrings + default-extensions: + DerivingStrategies + GeneralizedNewtypeDeriving + OverloadedStrings + RecordWildCards + default-language: Haskell2010 test-suite tahoe-ssk-test diff --git a/test/Generators.hs b/test/Generators.hs index 98bfba02a9a2fc4995592e2f839a3586af54a929..ec6c92ee6c8ae03235334771e298489062c4c74c 100644 --- a/test/Generators.hs +++ b/test/Generators.hs @@ -10,22 +10,23 @@ import Data.ASN1.Types (ASN1Object (fromASN1, toASN1)) import Data.Bifunctor (Bifunctor (first)) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB -import Data.Word (Word8) +import Data.Word (Word16) import GHC.IO.Unsafe (unsafePerformIO) import Hedgehog (MonadGen) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Tahoe.CHK.Merkle (MerkleTree (..), makeTreePartial) import Tahoe.SDMF (Share (..)) +import Tahoe.SDMF.Internal.Share (HashChain (HashChain)) rootHashLength :: Int -rootHashLength = undefined +rootHashLength = 32 ivLength :: Int -ivLength = undefined +ivLength = 16 -signatureLength :: Int -signatureLength = undefined +signatureLength :: Range.Range Int +signatureLength = Range.linear 250 260 {- | Generate SDMF shares. The contents of the share are not necessarily semantically valid. @@ -42,11 +43,11 @@ shares = <*> Gen.word64 Range.exponentialBounded -- shareSegmentSize <*> Gen.word64 Range.exponentialBounded -- shareDataLength <*> pure (RSA.toPublicKey keypair) -- shareVerificationKey - <*> Gen.bytes (Range.singleton signatureLength) -- shareSignature + <*> Gen.bytes signatureLength -- shareSignature <*> shareHashChains -- shareHashChain <*> merkleTrees (Range.singleton 1) -- shareBlockHashTree <*> (LB.fromStrict <$> Gen.bytes (Range.exponential 0 1024)) -- shareData - <*> (pure . LB.toStrict . toDER . RSA.toPrivateKey) keypair -- sharePrivateKey + <*> (pure . LB.toStrict . toDER . RSA.toPrivateKey) keypair -- shareEncryptedPrivateKey where toDER = encodeASN1 DER . flip toASN1 [] @@ -83,8 +84,8 @@ genHash :: MonadGen m => m B.ByteString genHash = Gen.bytes . Range.singleton . hashDigestSize $ SHA256 -- | Generate lists of two-tuples of share identifier and share root hash. -shareHashChains :: MonadGen m => m [(Word8, B.ByteString)] -shareHashChains = Gen.list range element +shareHashChains :: MonadGen m => m HashChain +shareHashChains = HashChain <$> Gen.list range element where range = Range.exponential 1 5 - element = (,) <$> Gen.integral (Range.exponential 1 255) <*> Gen.bytes (Range.singleton 32) + element = (,) <$> Gen.integral (Range.exponential 0 255) <*> Gen.bytes (Range.singleton 32) diff --git a/test/Main.hs b/test/Main.hs index eceb1e6e6da4bdf73538c7727ce6568a602ca50b..dca5ca14819512ef15697a5faa39e9969d2f47de 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,14 +1,14 @@ module Main (main) where import Hedgehog ( - Property, forAll, property, tripping, ) import qualified Data.Binary as Binary -import Generators (shares) +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) @@ -17,13 +17,18 @@ tests :: TestTree tests = testGroup "SSK" - [ testProperty "round-trips through bytes" $ + [ 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 - let decode' = ((\(_, _, sh) -> sh) <$>) . Binary.decodeOrFail share <- forAll shares tripping share Binary.encode decode' - pure () ] + where + decode' :: Binary.Binary a => B.ByteString -> a + decode' = ((\(_, _, a) -> a) <$>) . Binary.decodeOrFail main :: IO () main = do