diff --git a/flake.nix b/flake.nix
index 7b393e118ddd63bdf4f80c39c38fb8a07e3bc208..f5feba570df0b1b4aec8cd7a77f11c664b788aca 100644
--- a/flake.nix
+++ b/flake.nix
@@ -58,7 +58,7 @@
text = ''
cabal update hackage.haskell.org
- cabal build tests
+ cabal build
cabal run tests
'';
}
diff --git a/make-keypairs/Main.hs b/make-keypairs/Main.hs
new file mode 100644
index 0000000000000000000000000000000000000000..c537ae4d3420c2c0ee42f80ac67c4d3cd281cd2b
--- /dev/null
+++ b/make-keypairs/Main.hs
@@ -0,0 +1,27 @@
+module Main where
+
+import Codec.Crypto.RSA (generateKeyPair)
+import Crypto.Random (CryptoRandomGen (newGenIO), SystemRandom)
+import Data.ASN1.BinaryEncoding (DER (DER))
+import Data.ASN1.Encoding (ASN1Encoding (encodeASN1))
+import Data.ASN1.Types (ASN1Object (toASN1))
+import qualified Data.ByteString.Lazy as LB
+
+-- | The size of the keys to generate.
+bits :: Int
+bits = 2048
+
+-- | The number of keys to generate.
+count :: Int
+count = 5
+
+main :: IO ()
+main = do
+ g <- newGenIO :: IO SystemRandom
+ mapM_ (genKey g) [0 .. count - 1]
+
+genKey :: (Show a, CryptoRandomGen c) => c -> a -> IO ()
+genKey g n =
+ let (_, priv, _) = generateKeyPair g bits
+ bytes = encodeASN1 DER (toASN1 priv [])
+ in LB.writeFile ("test/data/rsa-privkey-" <> show n <> ".der") bytes
diff --git a/src/Tahoe/SDMF/Internal/Share.hs b/src/Tahoe/SDMF/Internal/Share.hs
index 392cdf44f22abcd9d6c29884e649d33614570f5d..f4587950a072be0798d3b09a37608e1dfdaf841e 100644
--- a/src/Tahoe/SDMF/Internal/Share.hs
+++ b/src/Tahoe/SDMF/Internal/Share.hs
@@ -1,13 +1,46 @@
-- | Deal with details related to the structural layout of an SDMF share.
module Tahoe.SDMF.Internal.Share where
+import Control.Monad (unless)
import Crypto.Cipher.AES (AES128)
-import Crypto.Types (IV)
-import qualified Crypto.Types.PubKey.RSA as RSA
+import qualified Crypto.PubKey.RSA.Types as RSA
+import Crypto.Types (IV (IV, initializationVector))
+import Data.ASN1.BinaryEncoding (DER (DER))
+import Data.ASN1.Encoding (ASN1Encoding (encodeASN1), decodeASN1')
+import Data.ASN1.Types (ASN1Object (fromASN1, toASN1))
+import Data.Binary (Binary (..), Get, getWord8)
+import Data.Binary.Get (bytesRead, getByteString, getLazyByteString, getRemainingLazyByteString, 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 Data.X509 (PubKey (PubKeyRSA))
+import Tahoe.CHK.Merkle (MerkleTree, leafHashes)
+
+hashSize :: Int
+hashSize = 32
+
+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 hashSize
+ (HashChain c) <- get
+ pure $ HashChain ((n, h) : c)
{- | Structured representation of a single version SDMF share.
@@ -43,7 +76,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,3 +84,88 @@ data Share = Share
, -- | The encrypted 2048 bit "signature" RSA key.
shareEncryptedPrivateKey :: B.ByteString
}
+ 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 [] . PubKeyRSA $ shareVerificationKey
+ blockHashTreeBytes = B.concat . leafHashes $ shareBlockHashTree
+
+ -- TODO Compute these from all the putting.
+ signatureOffset = fromIntegral $ 1 + 8 + hashSize + 16 + 18 + 32 + B.length verificationKeyBytes
+ hashChainOffset = signatureOffset + fromIntegral (B.length shareSignature)
+ 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)
+
+ 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
+
+ pos <- bytesRead
+ shareVerificationKey <- isolate (fromIntegral signatureOffset - fromIntegral pos) getSubjectPublicKeyInfo
+
+ pos <- bytesRead
+ shareSignature <- getByteString (fromIntegral hashChainOffset - fromIntegral pos)
+
+ pos <- bytesRead
+ 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{..}
+
+{- | Read an X.509v3-encoded SubjectPublicKeyInfo structure carrying an ASN.1
+ DER encoded RSA public key.
+-}
+getSubjectPublicKeyInfo :: Get RSA.PublicKey
+getSubjectPublicKeyInfo = do
+ verificationKeyBytes <- getRemainingLazyByteString
+ let (Right asn1s) = decodeASN1' DER . LB.toStrict $ verificationKeyBytes
+ let (Right (PubKeyRSA pubKey, [])) = fromASN1 asn1s
+ pure pubKey
diff --git a/tahoe-ssk.cabal b/tahoe-ssk.cabal
index 742d1498c010fcd77883e54260aaacd88909bb44..e8e79204194a03efb6105a4378fcea6ea50ce25a 100644
--- a/tahoe-ssk.cabal
+++ b/tahoe-ssk.cabal
@@ -66,25 +66,36 @@ library
Tahoe.SDMF.Internal.Share
build-depends:
+ , asn1-encoding
+ , asn1-types
, base
+ , binary
, bytestring
, crypto-api
, crypto-pubkey-types
, cryptonite
+ , RSA
+ , x509
-- 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
-- Import common warning flags.
- import: warnings
+ import: warnings
-- Base language which the package is written in.
- default-language: Haskell2010
+ default-language: Haskell2010
+ default-extensions: OverloadedStrings
-- Modules included in this executable, other than Main.
-- other-modules:
@@ -93,15 +104,47 @@ test-suite tahoe-ssk-test
-- other-extensions:
-- The interface type and version of the test suite.
- type: exitcode-stdio-1.0
+ type: exitcode-stdio-1.0
-- Directories containing source files.
- hs-source-dirs: test
+ hs-source-dirs: test
-- The entrypoint to the test suite.
- main-is: Main.hs
+ main-is: Main.hs
+ other-modules:
+ Generators
+ Spec
-- Test dependencies.
build-depends:
- , base ^>=4.14.3.0
+ , asn1-encoding
+ , asn1-types
+ , base ^>=4.14.3.0
+ , binary
+ , bytestring
+ , crypto-api
+ , crypto-pubkey-types
+ , cryptonite
+ , hedgehog
+ , RSA
+ , tahoe-chk
, tahoe-ssk
+ , tasty
+ , tasty-hedgehog
+ , tasty-hunit
+ , x509
+
+-- A helper for generating RSA key pairs for use by the test suite.
+executable make-keypairs
+ import: warnings
+ default-language: Haskell2010
+ main-is: Main.hs
+ hs-source-dirs: make-keypairs
+ build-depends:
+ , asn1-encoding
+ , asn1-types
+ , base
+ , bytestring
+ , crypto-api
+ , crypto-pubkey-types
+ , RSA
diff --git a/test/Generators.hs b/test/Generators.hs
new file mode 100644
index 0000000000000000000000000000000000000000..916105480e795d564e32d12bbe54d0f7c64ded65
--- /dev/null
+++ b/test/Generators.hs
@@ -0,0 +1,93 @@
+module Generators where
+
+import Crypto.Hash (HashAlgorithm (hashDigestSize))
+import Crypto.Hash.Algorithms (SHA256 (SHA256))
+import qualified Crypto.PubKey.RSA.Types as RSA
+import Crypto.Types (IV (..))
+import Data.ASN1.BinaryEncoding (DER (DER))
+import Data.ASN1.Encoding (ASN1Decoding (decodeASN1), ASN1Encoding (encodeASN1))
+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.X509 (PrivKey (PrivKeyRSA))
+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 = 32
+
+ivLength :: Int
+ivLength = 16
+
+signatureLength :: Range.Range Int
+signatureLength = Range.linear 250 260
+
+{- | Generate SDMF shares. The contents of the share are not necessarily
+ semantically valid.
+-}
+shares :: MonadGen m => m Share
+shares =
+ genRSAKeys >>= \keypair ->
+ Share
+ <$> Gen.word64 Range.exponentialBounded -- shareSequenceNumber
+ <*> Gen.bytes (Range.singleton rootHashLength) -- shareRootHash
+ <*> (IV <$> Gen.bytes (Range.singleton ivLength)) -- shareIV
+ <*> Gen.word8 Range.exponentialBounded -- shareTotalShares
+ <*> Gen.word8 Range.exponentialBounded -- shareRequiredShares
+ <*> Gen.word64 Range.exponentialBounded -- shareSegmentSize
+ <*> Gen.word64 Range.exponentialBounded -- shareDataLength
+ <*> pure (RSA.toPublicKey keypair) -- shareVerificationKey
+ <*> Gen.bytes signatureLength -- shareSignature
+ <*> shareHashChains -- shareHashChain
+ <*> merkleTrees (Range.singleton 1) -- shareBlockHashTree
+ <*> (LB.fromStrict <$> Gen.bytes (Range.exponential 0 1024)) -- shareData
+ <*> (pure . LB.toStrict . toDER . PrivKeyRSA . RSA.toPrivateKey) keypair -- shareEncryptedPrivateKey
+ where
+ toDER = encodeASN1 DER . flip toASN1 []
+
+{- | Build RSA key pairs.
+
+ Because the specific bits of the key pair shouldn't make any difference to
+ any application logic, generating new RSA key pairs is expensive, and
+ generating new RSA key pairs in a way that makes sense in Hedgehog is
+ challenging, this implementation just knows a few RSA key pairs already and
+ will give back one of them.
+-}
+genRSAKeys :: MonadGen m => m RSA.KeyPair
+genRSAKeys = Gen.element (map rsaKeyPair rsaKeyPairBytes)
+
+-- I'm not sure how to do IO in MonadGen so do the IO up front unsafely (but
+-- hopefully not really unsafely).
+rsaKeyPairBytes :: [LB.ByteString]
+{-# NOINLINE rsaKeyPairBytes #-}
+rsaKeyPairBytes = unsafePerformIO $ mapM (\n -> LB.readFile ("test/data/rsa-privkey-" <> show n <> ".der")) [0 .. 4 :: Int]
+
+rsaKeyPair :: LB.ByteString -> RSA.KeyPair
+rsaKeyPair bs = do
+ let (Right kp) = do
+ asn1s <- first show (decodeASN1 DER bs)
+ (r, _) <- fromASN1 asn1s
+ case r of
+ PrivKeyRSA pk -> pure $ RSA.KeyPair pk
+ _ -> error "Expected RSA Private Key"
+ kp
+
+merkleTrees :: MonadGen m => Range.Range Int -> m MerkleTree
+merkleTrees r = makeTreePartial <$> Gen.list r genHash
+
+-- | Generate ByteStrings which could be sha256d digests.
+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 HashChain
+shareHashChains = HashChain <$> Gen.list range element
+ where
+ range = Range.exponential 1 5
+ element = (,) <$> Gen.integral (Range.exponential 0 255) <*> Gen.bytes (Range.singleton 32)
diff --git a/test/Main.hs b/test/Main.hs
index 3e2059e31f5127521b263b051fc7247772685e1a..2b57e2fa4c1baf15aa4a4fd943a832ee043ffa8a 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,4 +1,3 @@
module Main (main) where
-main :: IO ()
-main = putStrLn "Test suite not yet implemented."
+import Spec (main)
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000000000000000000000000000000000000..98914dd558e645bf065f40a11f6e8d49e9212e4d
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,69 @@
+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 Tahoe.SDMF (Share)
+import Test.Tasty (TestTree, defaultMain, testGroup)
+import Test.Tasty.HUnit (assertEqual, testCase)
+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'
+ , testCase "known-correct serialized shares round-trip though Share" $
+ mapM_ knownCorrectRoundTrip [0 :: Int .. 9]
+ ]
+
+{- | Load a known-correct SDMF bucket and assert that bytes in the slot it
+ contains deserializes to a Share and then serializes back to the same bytes
+-}
+knownCorrectRoundTrip :: Show a => a -> IO ()
+knownCorrectRoundTrip n = do
+ -- The files are in "bucket" format. We need to extract the
+ -- "slot". We do so by stripping a prefix and suffix. To avoid
+ -- having to parse the prefix, we assert that the suffix is a
+ -- predictable size.
+ bucket <- LB.readFile ("test/data/3of10." <> show n)
+ let withoutPrefix = LB.drop (32 + 20 + 32 + 8 + 8 + 368) bucket
+ dataSize = LB.length withoutPrefix - 4
+ shareData = LB.take dataSize withoutPrefix
+ suffix = LB.drop dataSize withoutPrefix
+
+ -- Our assumption about the data we're working on...
+ assertEqual "Cannot account for extra leases" suffix "\0\0\0\0"
+
+ let decoded = decode' shareData
+ let encoded = (Binary.encode :: Share -> LB.ByteString) <$> decoded
+ assertEqual "original /= encoded" (Right shareData) encoded
+
+-- | Like `Binary.Binary.decodeOrFail` but only return the decoded value.
+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
diff --git a/test/data/3of10.0 b/test/data/3of10.0
new file mode 100644
index 0000000000000000000000000000000000000000..5c79c79c0bdb7d9c5eef847ee1c3ac7483554df5
Binary files /dev/null and b/test/data/3of10.0 differ
diff --git a/test/data/3of10.1 b/test/data/3of10.1
new file mode 100644
index 0000000000000000000000000000000000000000..c90a0cd7ef73fee85d6322af0d8b35e4f27c5de8
Binary files /dev/null and b/test/data/3of10.1 differ
diff --git a/test/data/3of10.2 b/test/data/3of10.2
new file mode 100644
index 0000000000000000000000000000000000000000..dfa291410b8b50ca12be8fbe6f81a0bbc5397224
Binary files /dev/null and b/test/data/3of10.2 differ
diff --git a/test/data/3of10.3 b/test/data/3of10.3
new file mode 100644
index 0000000000000000000000000000000000000000..a859d241f7a674e8b37a96c27eead10f9979475e
Binary files /dev/null and b/test/data/3of10.3 differ
diff --git a/test/data/3of10.4 b/test/data/3of10.4
new file mode 100644
index 0000000000000000000000000000000000000000..9e5bd0bab2de7ba7bc12b27eba5e916305b0ffc0
Binary files /dev/null and b/test/data/3of10.4 differ
diff --git a/test/data/3of10.5 b/test/data/3of10.5
new file mode 100644
index 0000000000000000000000000000000000000000..c3b19a46d15cef77585f5cee446e0162d3812bc2
Binary files /dev/null and b/test/data/3of10.5 differ
diff --git a/test/data/3of10.6 b/test/data/3of10.6
new file mode 100644
index 0000000000000000000000000000000000000000..49236cdb012d8755108e9b86657c33a0eb26f4e7
Binary files /dev/null and b/test/data/3of10.6 differ
diff --git a/test/data/3of10.7 b/test/data/3of10.7
new file mode 100644
index 0000000000000000000000000000000000000000..5df7362382c60ec4191d84a31f20569d54e3cc63
Binary files /dev/null and b/test/data/3of10.7 differ
diff --git a/test/data/3of10.8 b/test/data/3of10.8
new file mode 100644
index 0000000000000000000000000000000000000000..32baa3014dc7fe9cc073fd459dce4f2418881016
Binary files /dev/null and b/test/data/3of10.8 differ
diff --git a/test/data/3of10.9 b/test/data/3of10.9
new file mode 100644
index 0000000000000000000000000000000000000000..fe23f068432473ce9706b970ca707157dfe3ae0f
Binary files /dev/null and b/test/data/3of10.9 differ
diff --git a/test/data/rsa-privkey-0.der b/test/data/rsa-privkey-0.der
new file mode 100644
index 0000000000000000000000000000000000000000..ad64c6304d32d06ba74f9a9234de2cd14a6820ab
Binary files /dev/null and b/test/data/rsa-privkey-0.der differ
diff --git a/test/data/rsa-privkey-1.der b/test/data/rsa-privkey-1.der
new file mode 100644
index 0000000000000000000000000000000000000000..ad64c6304d32d06ba74f9a9234de2cd14a6820ab
Binary files /dev/null and b/test/data/rsa-privkey-1.der differ
diff --git a/test/data/rsa-privkey-2.der b/test/data/rsa-privkey-2.der
new file mode 100644
index 0000000000000000000000000000000000000000..ad64c6304d32d06ba74f9a9234de2cd14a6820ab
Binary files /dev/null and b/test/data/rsa-privkey-2.der differ
diff --git a/test/data/rsa-privkey-3.der b/test/data/rsa-privkey-3.der
new file mode 100644
index 0000000000000000000000000000000000000000..ad64c6304d32d06ba74f9a9234de2cd14a6820ab
Binary files /dev/null and b/test/data/rsa-privkey-3.der differ
diff --git a/test/data/rsa-privkey-4.der b/test/data/rsa-privkey-4.der
new file mode 100644
index 0000000000000000000000000000000000000000..ad64c6304d32d06ba74f9a9234de2cd14a6820ab
Binary files /dev/null and b/test/data/rsa-privkey-4.der differ