diff --git a/cabal.project b/cabal.project
index 473de17fc163f47ae5bc06266af134a08889b4de..78fa3af55a5c1c65dc617f30e2ced0b5e78c37f6 100644
--- a/cabal.project
+++ b/cabal.project
@@ -4,6 +4,8 @@ packages: .
-- soon.
https://whetstone.private.storage/privatestorage/tahoe-chk/-/archive/0.1.0.1/tahoe-chk-0.1.0.1.tar.gz
+tests: True
+
package zlib
-- Turn on discovery of the underlying zlib using pkg-config. This
-- fixes build failures when the underlying zlib is not in the
diff --git a/src/Tahoe/SDMF.hs b/src/Tahoe/SDMF.hs
index b398639b237c260f58d3faf046d8455bd138a00a..35466344adecbdbb2d0ddd24a94906ab377d1ad2 100644
--- a/src/Tahoe/SDMF.hs
+++ b/src/Tahoe/SDMF.hs
@@ -2,7 +2,22 @@
module Tahoe.SDMF (
module Tahoe.SDMF.Internal.Share,
module Tahoe.SDMF.Internal.Capability,
+ module Tahoe.SDMF.Internal.Encoding,
+ module Tahoe.SDMF.Internal.Encrypting,
) where
-import Tahoe.SDMF.Internal.Capability (Reader (..), Writer (..))
-import Tahoe.SDMF.Internal.Share (Share (..))
+import Tahoe.SDMF.Internal.Capability (
+ Reader (..),
+ Writer (..),
+ )
+import Tahoe.SDMF.Internal.Encoding (
+ decode,
+ encode,
+ )
+import Tahoe.SDMF.Internal.Encrypting (
+ decrypt,
+ encrypt,
+ )
+import Tahoe.SDMF.Internal.Share (
+ Share (..),
+ )
diff --git a/src/Tahoe/SDMF/Internal/Capability.hs b/src/Tahoe/SDMF/Internal/Capability.hs
index 56d6ed1616af9478126c40404844e279d0ee43bd..9db37c3339188a2a248743df4d8ff85bf1df1f39 100644
--- a/src/Tahoe/SDMF/Internal/Capability.hs
+++ b/src/Tahoe/SDMF/Internal/Capability.hs
@@ -4,7 +4,7 @@ module Tahoe.SDMF.Internal.Capability where
import Prelude hiding (Read)
import qualified Data.ByteString as B
-import Tahoe.SDMF.Internal.Keys (Read, Write)
+import Tahoe.SDMF.Internal.Keys (Read, Write, deriveReadKey)
-- | A read capability for an SDMF object.
data Reader = Reader
@@ -19,3 +19,7 @@ data Writer = Writer
, writerReader :: Reader
}
deriving (Show)
+
+-- | Diminish a write key to a read key and wrap it in a reader capability.
+deriveReader :: Write -> B.ByteString -> Maybe Reader
+deriveReader w fingerprint = Reader <$> deriveReadKey w <*> pure fingerprint
diff --git a/src/Tahoe/SDMF/Internal/Converting.hs b/src/Tahoe/SDMF/Internal/Converting.hs
new file mode 100644
index 0000000000000000000000000000000000000000..84672ac9ff13d03f308aab2d88d842f201774170
--- /dev/null
+++ b/src/Tahoe/SDMF/Internal/Converting.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+{- | Conversion between types with a known level of safety. *Heavily* inspired
+ by `witch` (which has dependencies that make it hard for us to use just yet).
+-}
+module Tahoe.SDMF.Internal.Converting where
+
+import Data.Int (Int64)
+import Data.Word (Word16, Word32, Word64, Word8)
+
+-- | Precise, infallible conversion between two types.
+class From a b where
+ from :: a -> b
+
+-- | Precise, fallible conversion between two types.
+class TryFrom a b m where
+ tryFrom ::
+ -- | An error message for context if the conversion fails.
+ String ->
+ -- | The value to convert.
+ a ->
+ m b
+
+instance MonadFail m => TryFrom Int Word32 m where
+ tryFrom msg n
+ | n < 0 = fail msg
+ | n > maxWord32 = fail msg
+ | otherwise = pure $ fromIntegral n
+ where
+ maxWord32 = from @Word32 @Int maxBound
+
+instance MonadFail m => TryFrom Int Word64 m where
+ tryFrom msg n
+ | n < 0 = fail msg
+ | otherwise = pure $ fromIntegral n
+
+instance MonadFail m => TryFrom Int64 Word64 m where
+ tryFrom msg n
+ | n < 0 = fail msg
+ | otherwise = pure $ fromIntegral n
+
+instance From Word16 Int where
+ from = fromIntegral
+
+instance From Word8 Int where
+ from = fromIntegral
+
+instance From Word8 Word16 where
+ from = fromIntegral
+
+instance From Word32 Word64 where
+ from = fromIntegral
+
+instance From Word32 Int where
+ from = fromIntegral
+
+instance From Int64 Int where
+ from = fromIntegral
+
+instance From Int Int64 where
+ from = fromIntegral
+
+instance MonadFail m => TryFrom Word64 Int m where
+ tryFrom msg n
+ | n > maxInt = fail msg
+ | otherwise = pure $ fromIntegral n
+ where
+ maxInt = fromIntegral (maxBound :: Int) :: Word64
+
+instance MonadFail m => TryFrom Word16 Word8 m where
+ tryFrom msg n
+ | n > maxWord8 = fail msg
+ | otherwise = pure $ fromIntegral n
+ where
+ maxWord8 = from @Word8 @Word16 maxBound
+
+instance MonadFail m => TryFrom Word64 Int64 m where
+ tryFrom msg n
+ | n > maxInt64 = fail msg
+ | otherwise = pure $ fromIntegral n
+ where
+ maxInt64 = fromIntegral (maxBound :: Int64) :: Word64
+
+{- | Like `from` but with the order of the input/output type parameters
+ reversed.
+-}
+into :: forall b a. From a b => a -> b
+into = from
+
+{- | Like `tryFrom` but with the order of the input/output type parameters
+ reverse.
+-}
+tryInto :: forall b a m. TryFrom a b m => String -> a -> m b
+tryInto = tryFrom
diff --git a/src/Tahoe/SDMF/Internal/Encoding.hs b/src/Tahoe/SDMF/Internal/Encoding.hs
new file mode 100644
index 0000000000000000000000000000000000000000..085a09f3ed5940cdc51825c2d65f3104cb2b0a0a
--- /dev/null
+++ b/src/Tahoe/SDMF/Internal/Encoding.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{- | Implement the scheme for encoding ciphertext into SDMF shares (and
+ decoding it again).
+-}
+module Tahoe.SDMF.Internal.Encoding where
+
+import Control.Monad (when)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Crypto.Cipher.Types (BlockCipher (blockSize), IV, makeIV)
+import Crypto.Random (MonadRandom (getRandomBytes))
+import Data.Bifunctor (Bifunctor (bimap))
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
+import Data.Int (Int64)
+import qualified Data.Text as T
+import Data.Word (Word16, Word64, Word8)
+import Tahoe.CHK (padCiphertext, zfec, zunfec)
+import Tahoe.CHK.Merkle (MerkleTree (MerkleLeaf))
+import Tahoe.SDMF.Internal.Capability (Reader (..), Writer (..), deriveReader)
+import Tahoe.SDMF.Internal.Converting (from, tryInto)
+import qualified Tahoe.SDMF.Internal.Keys as Keys
+import Tahoe.SDMF.Internal.Share (HashChain (HashChain), Share (..))
+
+-- | Randomly generate a new IV suitable for use with some BlockCipher.
+randomIV :: forall c m. (BlockCipher c, MonadRandom m) => m (Maybe (IV c))
+randomIV = (makeIV :: B.ByteString -> Maybe (IV c)) <$> getRandomBytes (blockSize (undefined :: c))
+
+{- | Given a pre-determined key pair and sequence number, encode some
+ ciphertext into a collection of SDMF shares.
+
+ A key pair *uniquely identifies* a "slot" (the storage location for the shares).
+ Thus they cannot be re-used for "different" data. Any shares created with a
+ given key pair are part of the same logical data object.
+-}
+encode :: (MonadFail m, MonadIO m, MonadRandom m) => Keys.KeyPair -> Word64 -> Word16 -> Word16 -> LB.ByteString -> m ([Share], Writer)
+encode keypair shareSequenceNumber required total ciphertext = do
+ -- Make sure the encoding parameters fit into a Word8
+ requiredAsWord8 <- tryInto @Word8 ("must have 0 < required < 255 but required == " <> show required) required
+ totalAsWord8 <- tryInto @Word8 ("must have 0 < total < 256 but total == " <> show total) total
+
+ -- And that they make sense together.
+ when (required >= total) (fail $ "must have required < total but required == " <> show required <> ", total == " <> show total)
+
+ -- They look okay, we can proceed.
+ blocks <- liftIO $ fmap LB.fromStrict <$> zfec (from required) (from total) paddedCiphertext
+
+ (Just iv) <- randomIV
+
+ -- We know the length won't be negative (doesn't make sense) and we
+ -- know all positive values fit into a Word64 so we can do this
+ -- conversion safely. But if it needs to fail for some reason, it
+ -- can do so safely.
+ dataLength <- tryInto @Word64 "must have 0 <= data length" (LB.length ciphertext)
+
+ -- All segments are the same so we can figure the size from any one
+ -- block. This conversion might fail because of Int64 vs Word64 but
+ -- only for truly, truly tremendous share data.
+ shareSegmentSize <- tryInto @Word64 "must have segment size < 2^63" (LB.length (head blocks))
+
+ let makeShare' =
+ flip $
+ makeShare
+ shareSequenceNumber
+ (Keys.SDMF_IV iv)
+ requiredAsWord8
+ totalAsWord8
+ dataLength
+ shareSegmentSize
+ (Keys.toVerificationKey keypair)
+
+ let makeShare'' = makeShare' <$> blocks
+
+ resultE :: Either T.Text [Share]
+ resultE = (traverse . flip fmap) encryptedPrivateKey makeShare''
+ either (fail . T.unpack) pure ((,) <$> resultE <*> cap)
+ where
+ paddedCiphertext = LB.toStrict $ padCiphertext required ciphertext
+ -- We can compute a capability immediately.
+ cap = capabilityForKeyPair keypair
+ encryptedPrivateKey = flip Keys.encryptSignatureKey (Keys.toSignatureKey keypair) <$> (writerWriteKey <$> cap)
+
+makeShare ::
+ Word64 ->
+ Keys.SDMF_IV ->
+ Word8 ->
+ Word8 ->
+ Word64 ->
+ Word64 ->
+ Keys.Verification ->
+ B.ByteString ->
+ LB.ByteString ->
+ Share
+makeShare shareSequenceNumber shareIV shareRequiredShares shareTotalShares shareDataLength shareSegmentSize shareVerificationKey shareEncryptedPrivateKey shareData = Share{..}
+ where
+ shareRootHash = B.replicate 32 0
+ shareSignature = B.replicate 32 0 -- XXX Actually compute sig, and is it 32 bytes?
+ shareHashChain = HashChain []
+ shareBlockHashTree = MerkleLeaf (B.replicate 32 0) -- XXX Real hash here, plus length check
+
+{- | Decode some SDMF shares to recover the original ciphertext.
+
+ TODO: Use the read capability to verify the shares were constructed with
+ information from the matching write capability.
+-}
+decode :: (MonadFail m, MonadIO m) => Reader -> [(Word16, Share)] -> m LB.ByteString
+decode _ [] = fail "Cannot decode with no shares"
+decode _ s@((_, Share{shareRequiredShares, shareTotalShares, shareDataLength}) : shares)
+ -- Make sure we have enough shares.
+ | length s < requiredAsInt =
+ fail $ "got " <> show (length shares) <> " shares, required " <> show shareRequiredShares
+ | otherwise = do
+ -- Make sure this implementation can handle the amount of data involved.
+ -- Since we use lazy ByteString we're limited to 2^63-1 bytes rather than
+ -- 2^64-1 bytes so there are some SDMF shares we can't interpret right
+ -- now.
+ shareDataLength' <- tryInto @Int64 ("share data length " <> show shareDataLength <> " is beyond maximum supported by this implementation " <> show (maxBound :: Int64)) shareDataLength
+ ciphertext <- liftIO $ zunfec requiredAsInt totalAsInt (take requiredAsInt blocks)
+ pure . LB.take shareDataLength' . LB.fromStrict $ ciphertext
+ where
+ blocks = bimap (from @Word16) (LB.toStrict . shareData) <$> s
+
+ requiredAsInt = from shareRequiredShares
+ totalAsInt = from shareTotalShares
+
+-- | Compute an SDMF write capability for a given keypair.
+capabilityForKeyPair :: Keys.KeyPair -> Either T.Text Writer
+capabilityForKeyPair keypair =
+ Writer <$> writerWriteKey <*> maybeToEither' "Failed to derive read capability" writerReader
+ where
+ writerWriteKey = maybeToEither "Failed to derive write key" . Keys.deriveWriteKey . Keys.toSignatureKey $ keypair
+ verificationKeyHash = Keys.deriveVerificationHash . Keys.toVerificationKey $ keypair
+ writerReader = deriveReader <$> writerWriteKey <*> pure verificationKeyHash
+
+maybeToEither :: a -> Maybe b -> Either a b
+maybeToEither a Nothing = Left a
+maybeToEither _ (Just b) = Right b
+
+maybeToEither' :: e -> Either e (Maybe a) -> Either e a
+maybeToEither' e (Right Nothing) = Left e
+maybeToEither' _ (Right (Just r)) = Right r
+maybeToEither' _ (Left e) = Left e
diff --git a/src/Tahoe/SDMF/Internal/Encrypting.hs b/src/Tahoe/SDMF/Internal/Encrypting.hs
new file mode 100644
index 0000000000000000000000000000000000000000..b3b1db8155d1335b82029aacc6a36515e202df01
--- /dev/null
+++ b/src/Tahoe/SDMF/Internal/Encrypting.hs
@@ -0,0 +1,18 @@
+-- | Implement the encryption scheme used by SDMF.
+module Tahoe.SDMF.Internal.Encrypting where
+
+import Crypto.Cipher.Types (ctrCombine, nullIV)
+import qualified Data.ByteString.Lazy as LB
+import qualified Tahoe.SDMF.Internal.Keys as Keys
+
+{- | Encrypt plaintext bytes according to the scheme used for SDMF share
+ construction.
+-}
+encrypt :: Keys.Data -> LB.ByteString -> LB.ByteString
+encrypt Keys.Data{unData} = LB.fromStrict . ctrCombine unData nullIV . LB.toStrict
+
+{- | Decrypt ciphertext bytes according to the scheme used for SDMF share
+ construction.
+-}
+decrypt :: Keys.Data -> LB.ByteString -> LB.ByteString
+decrypt = encrypt
diff --git a/src/Tahoe/SDMF/Internal/Keys.hs b/src/Tahoe/SDMF/Internal/Keys.hs
index 29f38c6881086c25ab7b3467edd48298d9d77525..47484f0909e5edb9faa3bbfdb68164406bdc58ba 100644
--- a/src/Tahoe/SDMF/Internal/Keys.hs
+++ b/src/Tahoe/SDMF/Internal/Keys.hs
@@ -8,14 +8,17 @@ import Prelude hiding (Read)
import Control.Monad (when)
import Crypto.Cipher.AES (AES128)
-import Crypto.Cipher.Types (Cipher (cipherInit, cipherKeySize), IV, KeySizeSpecifier (KeySizeFixed))
-import Crypto.Error (maybeCryptoError)
+import Crypto.Cipher.Types (BlockCipher (ctrCombine), Cipher (cipherInit, cipherKeySize), IV, KeySizeSpecifier (KeySizeFixed), nullIV)
+import Crypto.Error (CryptoFailable (CryptoPassed), maybeCryptoError)
import qualified Crypto.PubKey.RSA as RSA
import Crypto.Random (MonadRandom)
import Data.ASN1.BinaryEncoding (DER (DER))
import Data.ASN1.Encoding (ASN1Encoding (encodeASN1), decodeASN1')
import Data.ASN1.Types (ASN1 (End, IntVal, Null, OID, OctetString, Start), ASN1ConstructionType (Sequence), ASN1Object (fromASN1, toASN1))
import Data.Bifunctor (Bifunctor (first))
+import Data.Binary (Binary (get, put))
+import Data.Binary.Get (getByteString)
+import Data.Binary.Put (putByteString)
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString as B
import Data.ByteString.Base32 (encodeBase32Unpadded)
@@ -29,19 +32,43 @@ newtype KeyPair = KeyPair {toPrivateKey :: RSA.PrivateKey} deriving newtype (Sho
toPublicKey :: KeyPair -> RSA.PublicKey
toPublicKey = RSA.private_pub . toPrivateKey
+toSignatureKey :: KeyPair -> Signature
+toSignatureKey = Signature . toPrivateKey
+
+toVerificationKey :: KeyPair -> Verification
+toVerificationKey = Verification . toPublicKey
+
newtype Verification = Verification {unVerification :: RSA.PublicKey}
+ deriving newtype (Eq, Show)
+
newtype Signature = Signature {unSignature :: RSA.PrivateKey}
deriving newtype (Eq, Show)
data Write = Write {unWrite :: AES128, writeKeyBytes :: ByteArray.ScrubbedBytes}
+instance Binary Write where
+ put = putByteString . ByteArray.convert . writeKeyBytes
+ get = do
+ writeKeyBytes <- ByteArray.convert <$> getByteString keyLength
+ let (CryptoPassed unWrite) = cipherInit writeKeyBytes
+ pure Write{..}
+
instance Show Write where
show (Write _ bs) = T.unpack $ T.concat ["<WriteKey ", encodeBase32Unpadded (ByteArray.convert bs), ">"]
data Read = Read {unRead :: AES128, readKeyBytes :: ByteArray.ScrubbedBytes}
+instance Binary Read where
+ put = putByteString . ByteArray.convert . readKeyBytes
+ get = do
+ readKeyBytes <- ByteArray.convert <$> getByteString keyLength
+ let (CryptoPassed unRead) = cipherInit readKeyBytes
+ pure Read{..}
+
instance Show Read where
show (Read _ bs) = T.unpack $ T.concat ["<ReadKey ", encodeBase32Unpadded (ByteArray.convert bs), ">"]
+instance Eq Read where
+ (Read _ left) == (Read _ right) = left == right
newtype StorageIndex = StorageIndex {unStorageIndex :: B.ByteString}
@@ -50,6 +77,16 @@ newtype WriteEnablerMaster = WriteEnablerMaster ByteArray.ScrubbedBytes
newtype WriteEnabler = WriteEnabler ByteArray.ScrubbedBytes
data Data = Data {unData :: AES128, dataKeyBytes :: ByteArray.ScrubbedBytes}
+instance Show Data where
+ show (Data _ bs) = T.unpack $ T.concat ["<DataKey ", encodeBase32Unpadded (ByteArray.convert bs), ">"]
+instance Eq Data where
+ (Data _ left) == (Data _ right) = left == right
+instance Binary Data where
+ put = putByteString . ByteArray.convert . dataKeyBytes
+ get = do
+ dataKeyBytes <- ByteArray.convert <$> getByteString keyLength
+ let (CryptoPassed unData) = cipherInit dataKeyBytes
+ pure Data{..}
newtype SDMF_IV = SDMF_IV (IV AES128)
deriving (Eq)
@@ -145,6 +182,18 @@ deriveWriteEnabler peerid (WriteEnablerMaster master) = WriteEnabler bs
mutableWriteEnablerTag :: B.ByteString
mutableWriteEnablerTag = "allmydata_mutable_write_enabler_master_and_nodeid_to_write_enabler_v1"
+{- | Compute the verification key hash of the given verification key for
+ inclusion in an SDMF share.
+-}
+deriveVerificationHash :: Verification -> B.ByteString
+deriveVerificationHash = taggedHash 32 mutableVerificationKeyHashTag . verificationKeyToBytes
+
+{- | The tag used when hashing the verification key to the verification key
+ hash for inclusion in SDMF shares.
+-}
+mutableVerificationKeyHashTag :: B.ByteString
+mutableVerificationKeyHashTag = "allmydata_mutable_pubkey_to_fingerprint_v1"
+
{- | Encode a public key to the Tahoe-LAFS canonical bytes representation -
X.509 SubjectPublicKeyInfo of the ASN.1 DER serialization of an RSA
PublicKey.
@@ -203,3 +252,7 @@ signatureKeyFromBytes bs = do
case key of
(PrivKeyRSA privKey) -> Right $ Signature privKey
_ -> Left ("Expect RSA private key, found " <> show key)
+
+-- | Encrypt the signature key for inclusion in the SDMF share itself.
+encryptSignatureKey :: Write -> Signature -> B.ByteString
+encryptSignatureKey Write{unWrite} = ctrCombine unWrite nullIV . signatureKeyToBytes
diff --git a/src/Tahoe/SDMF/Internal/Share.hs b/src/Tahoe/SDMF/Internal/Share.hs
index 8d90b2aaf21576cde2a5d9116c1342187b0e4aeb..685e1f4f29f64dffa0eff18cbb58df003f975c78 100644
--- a/src/Tahoe/SDMF/Internal/Share.hs
+++ b/src/Tahoe/SDMF/Internal/Share.hs
@@ -2,8 +2,7 @@
module Tahoe.SDMF.Internal.Share where
import Control.Monad (unless)
-import Crypto.Cipher.AES (AES128)
-import Crypto.Cipher.Types (IV, makeIV)
+import Crypto.Cipher.Types (makeIV)
import qualified Crypto.PubKey.RSA.Types as RSA
import Data.ASN1.BinaryEncoding (DER (DER))
import Data.ASN1.Encoding (ASN1Encoding (encodeASN1), decodeASN1')
@@ -14,10 +13,12 @@ import Data.Binary.Put (putByteString, putLazyByteString, putWord16be, putWord32
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
-import Data.Word (Word16, Word64, Word8)
-import Data.X509 (PubKey (PubKeyRSA))
+import Data.Int (Int64)
+import Data.Word (Word16, Word32, Word64, Word8)
+import Data.X509 (PrivKey (PrivKeyRSA), PubKey (PubKeyRSA))
import Tahoe.CHK.Merkle (MerkleTree, leafHashes)
-import Tahoe.SDMF.Internal.Keys (SDMF_IV (..))
+import Tahoe.SDMF.Internal.Converting (From (from), into, tryInto)
+import qualified Tahoe.SDMF.Internal.Keys as Keys
hashSize :: Int
hashSize = 32
@@ -25,7 +26,7 @@ hashSize = 32
newtype HashChain = HashChain
{ hashChain :: [(Word16, B.ByteString)]
}
- deriving newtype (Eq, Show)
+ deriving newtype (Eq, Show, Semigroup)
instance Binary HashChain where
put (HashChain []) = mempty
@@ -41,8 +42,7 @@ instance Binary HashChain where
else do
n <- getWord16be
h <- getByteString hashSize
- (HashChain c) <- get
- pure $ HashChain ((n, h) : c)
+ (HashChain [(n, h)] <>) <$> get
{- | Structured representation of a single version SDMF share.
@@ -59,17 +59,18 @@ data Share = Share
, -- | "R" (root of share hash merkle tree)
shareRootHash :: B.ByteString
, -- | The IV for encryption of share data.
- shareIV :: SDMF_IV
+ shareIV :: Keys.SDMF_IV
, -- | The total number of encoded shares (k).
shareTotalShares :: Word8
, -- | The number of shares required for decoding (N).
shareRequiredShares :: Word8
- , -- | The size of a single ciphertext segment.
+ , -- | The size of a single ciphertext segment. This differs from
+ -- shareDataLength in that it includes padding.
shareSegmentSize :: Word64
, -- | The length of the original plaintext.
shareDataLength :: Word64
, -- | The 2048 bit "verification" RSA key.
- shareVerificationKey :: RSA.PublicKey
+ shareVerificationKey :: Keys.Verification
, -- | The RSA signature of
-- H('\x00'+shareSequenceNumber+shareRootHash+shareIV+encoding
-- parameters) where '\x00' gives the version of this share format (0)
@@ -94,8 +95,8 @@ instance Binary Share where
putWord64be shareSequenceNumber
putByteString shareRootHash
putByteString . ByteArray.convert $ shareIV
- putWord8 shareTotalShares
putWord8 shareRequiredShares
+ putWord8 shareTotalShares
putWord64be shareSegmentSize
putWord64be shareDataLength
putWord32be signatureOffset
@@ -111,16 +112,46 @@ instance Binary Share where
putLazyByteString shareData
putByteString shareEncryptedPrivateKey
where
- verificationKeyBytes = LB.toStrict . encodeASN1 DER . flip toASN1 [] . PubKeyRSA $ shareVerificationKey
+ verificationKeyBytes = Keys.verificationKeyToBytes 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)
+ -- Some conversions could fail because we can't be completely sure of
+ -- the size of the data we're working with. Put has no good failure
+ -- mechanism though. Try to provide the best failure behavior we can
+ -- here.
+ signatureOffset =
+ case tryInto @Word32 "" $ 1 + 8 + hashSize + 16 + 18 + 32 + B.length verificationKeyBytes of
+ Nothing -> error "Binary.put Share could not represent signature offset"
+ Just x -> x
+
+ hashChainOffset =
+ signatureOffset
+ + case tryInto @Word32 "" (B.length shareSignature) of
+ Nothing -> error "Binary.put Share could not represent hash chain offset"
+ Just x -> x
+ blockHashTreeOffset =
+ hashChainOffset
+ + case tryInto @Word32 "" (length (hashChain shareHashChain) * (hashSize + 2)) of
+ Nothing -> error "Binary.put Share could not represent block hash tree offset"
+ Just x -> x
+ shareDataOffset =
+ blockHashTreeOffset
+ + case tryInto @Word32 "" (B.length blockHashTreeBytes) of
+ Nothing -> error "Binary.put Share could not represent share data offset"
+ Just x -> x
+
+ -- Then there are a couple 64 bit offsets, represented as Word64s, for
+ -- positions that follow the share data.
+ encryptedPrivateKeyOffset =
+ into @Word64 shareDataOffset
+ + case tryInto @Word64 "" (LB.length shareData) of
+ Nothing -> error "Binary.put Share could not represent share data length"
+ Just x -> x
+ eofOffset =
+ encryptedPrivateKeyOffset
+ + case tryInto @Word64 "" (B.length shareEncryptedPrivateKey) of
+ Nothing -> error "Binary.put Share could not represent encrypted private key length"
+ Just x -> x
get = do
version <- getWord8
@@ -128,13 +159,12 @@ instance Binary Share where
shareSequenceNumber <- getWord64be
shareRootHash <- getByteString 32
ivBytes <- getByteString 16
- shareIV <-
- SDMF_IV <$> case makeIV ivBytes of
- Nothing -> fail "Could not decode IV"
- Just iv -> pure iv
+ shareIV <- case makeIV ivBytes of
+ Nothing -> fail "Could not decode IV"
+ Just iv -> pure (Keys.SDMF_IV iv)
- shareTotalShares <- getWord8
shareRequiredShares <- getWord8
+ shareTotalShares <- getWord8
shareSegmentSize <- getWord64be
shareDataLength <- getWord64be
signatureOffset <- getWord32be
@@ -144,23 +174,22 @@ instance Binary Share where
encryptedPrivateKeyOffset <- getWord64be
eofOffset <- getWord64be
- pos <- bytesRead
- shareVerificationKey <- isolate (fromIntegral signatureOffset - fromIntegral pos) getSubjectPublicKeyInfo
+ -- This offset is not the encoded share but it's defined as being
+ -- right where we've read to. Give it a name that follows the
+ -- pattern.
+ shareVerificationOffset <- bytesRead
- pos <- bytesRead
- shareSignature <- getByteString (fromIntegral hashChainOffset - fromIntegral pos)
+ -- Read in the values between all those offsets.
+ shareVerificationKey <- Keys.Verification <$> isolate (from signatureOffset - from shareVerificationOffset) getSubjectPublicKeyInfo
+ shareSignature <- getByteString (from $ hashChainOffset - signatureOffset)
+ shareHashChain <- isolate (from $ blockHashTreeOffset - hashChainOffset) get
+ shareBlockHashTree <- isolate (from $ shareDataOffset - blockHashTreeOffset) get
- pos <- bytesRead
- shareHashChain <- isolate (fromIntegral blockHashTreeOffset - fromIntegral pos) get
+ blockLength <- tryInto @Int64 "Binary.get Share could not represent share block length" (encryptedPrivateKeyOffset - into @Word64 shareDataOffset)
+ shareData <- getLazyByteString blockLength
- 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)
+ keyBytesLength <- tryInto @Int "Binary.get Share cannot represent private key length" (eofOffset - encryptedPrivateKeyOffset)
+ shareEncryptedPrivateKey <- getByteString keyBytesLength
empty <- isEmpty
unless empty (fail "Expected end of input but there are more bytes")
@@ -172,7 +201,14 @@ instance Binary Share where
-}
getSubjectPublicKeyInfo :: Get RSA.PublicKey
getSubjectPublicKeyInfo = do
- verificationKeyBytes <- getRemainingLazyByteString
- let (Right asn1s) = decodeASN1' DER . LB.toStrict $ verificationKeyBytes
+ bytes <- getRemainingLazyByteString
+ let (Right asn1s) = decodeASN1' DER . LB.toStrict $ bytes
let (Right (PubKeyRSA pubKey, [])) = fromASN1 asn1s
pure pubKey
+
+{- | Encode a private key to the Tahoe-LAFS canonical bytes representation -
+ X.509 SubjectPublicKeyInfo of the ASN.1 DER serialization of an RSA
+ PublicKey.
+-}
+signatureKeyToBytes :: RSA.PrivateKey -> B.ByteString
+signatureKeyToBytes = LB.toStrict . encodeASN1 DER . flip toASN1 [] . PrivKeyRSA
diff --git a/src/Tahoe/SDMF/Keys.hs b/src/Tahoe/SDMF/Keys.hs
index 165915612de3689305539139b0c0e53807b323da..c9150e75dfd2f61f4edffdedbc9804622b8f1a8e 100644
--- a/src/Tahoe/SDMF/Keys.hs
+++ b/src/Tahoe/SDMF/Keys.hs
@@ -16,5 +16,6 @@ import Tahoe.SDMF.Internal.Keys (
deriveWriteEnabler,
deriveWriteEnablerMaster,
deriveWriteKey,
- toPublicKey,
+ toSignatureKey,
+ toVerificationKey,
)
diff --git a/tahoe-ssk.cabal b/tahoe-ssk.cabal
index a87dac7d758781bcd3043fb7a3b8c145f3d41513..ba613c54768b953bbb1fe36fb25cb64520022d75 100644
--- a/tahoe-ssk.cabal
+++ b/tahoe-ssk.cabal
@@ -60,11 +60,28 @@ extra-source-files: test/data/*
common warnings
ghc-options: -Wall
+common language
+ default-extensions:
+ DerivingStrategies
+ GeneralizedNewtypeDeriving
+ NamedFieldPuns
+ OverloadedStrings
+ PackageImports
+ RecordWildCards
+ TypeApplications
+
+ default-language: Haskell2010
+
library
- hs-source-dirs: src
+ import: warnings
+ import: language
+ hs-source-dirs: src
exposed-modules:
Tahoe.SDMF
Tahoe.SDMF.Internal.Capability
+ Tahoe.SDMF.Internal.Converting
+ Tahoe.SDMF.Internal.Encoding
+ Tahoe.SDMF.Internal.Encrypting
Tahoe.SDMF.Internal.Keys
Tahoe.SDMF.Internal.Share
Tahoe.SDMF.Keys
@@ -76,6 +93,7 @@ library
, base32
, binary
, bytestring
+ , cereal
, cryptonite
, memory
, text
@@ -83,19 +101,12 @@ library
-- This dependency isn't ideal. Move common bits out to
-- another library.
- build-depends: tahoe-chk
- ghc-options: -Wall
- default-extensions:
- DerivingStrategies
- GeneralizedNewtypeDeriving
- OverloadedStrings
- RecordWildCards
-
- default-language: Haskell2010
+ build-depends: tahoe-chk
test-suite tahoe-ssk-test
-- Import common warning flags.
import: warnings
+ import: language
-- Base language which the package is written in.
default-language: Haskell2010
diff --git a/test/Generators.hs b/test/Generators.hs
index 21bee5bb4b2c369d5f52d99e48feecb242cecbdb..a002c501a4905a9703688d780f7650c84d5a9ff6 100644
--- a/test/Generators.hs
+++ b/test/Generators.hs
@@ -9,6 +9,7 @@ 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 (Word16)
import Data.X509 (PrivKey (PrivKeyRSA))
import GHC.IO.Unsafe (unsafePerformIO)
import Hedgehog (MonadGen)
@@ -46,7 +47,7 @@ shares = do
<*> Gen.word8 Range.exponentialBounded -- shareRequiredShares
<*> Gen.word64 Range.exponentialBounded -- shareSegmentSize
<*> Gen.word64 Range.exponentialBounded -- shareDataLength
- <*> pure (Keys.toPublicKey keypair) -- shareVerificationKey
+ <*> pure (Keys.toVerificationKey keypair) -- shareVerificationKey
<*> Gen.bytes signatureLength -- shareSignature
<*> shareHashChains -- shareHashChain
<*> merkleTrees (Range.singleton 1) -- shareBlockHashTree
@@ -95,3 +96,10 @@ shareHashChains = HashChain <$> Gen.list range element
where
range = Range.exponential 1 5
element = (,) <$> Gen.integral (Range.exponential 0 255) <*> Gen.bytes (Range.singleton 32)
+
+-- | Build a valid pair of (required, total) encoding parameters.
+encodingParameters :: MonadGen m => m (Word16, Word16)
+encodingParameters = do
+ required <- Gen.integral (Range.exponential 1 254)
+ total <- Gen.integral (Range.exponential (required + 1) 255)
+ pure (required, total)
diff --git a/test/Spec.hs b/test/Spec.hs
index e185dc49dcb1d803fa8f0b21ec09d97bc8fe549d..176fe8800f3ca3ebdda9871e5adc3af5c7efc9de 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1,11 +1,18 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
module Spec where
import Hedgehog (
+ annotateShow,
+ diff,
forAll,
property,
tripping,
)
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
import Crypto.Cipher.Types (makeIV)
import Data.ASN1.BinaryEncoding (DER (DER))
import Data.ASN1.Encoding (decodeASN1')
@@ -13,12 +20,14 @@ import qualified Data.Binary as Binary
import Data.Binary.Get (ByteOffset)
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString as B
-import Data.ByteString.Base32 (encodeBase32Unpadded)
+import Data.ByteString.Base32 (decodeBase32Unpadded, encodeBase32Unpadded)
import qualified Data.ByteString.Lazy as LB
import qualified Data.Text as T
-import Generators (genRSAKeys, shareHashChains, shares)
+import Generators (encodingParameters, genRSAKeys, shareHashChains, shares)
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
import System.IO (hSetEncoding, stderr, stdout, utf8)
-import Tahoe.SDMF (Share)
+import qualified Tahoe.SDMF
import Tahoe.SDMF.Internal.Keys (signatureKeyFromBytes, signatureKeyToBytes)
import qualified Tahoe.SDMF.Keys as Keys
import Test.Tasty (TestTree, defaultMain, testGroup)
@@ -139,10 +148,73 @@ tests =
tripping share Binary.encode decode'
, testCase "known-correct serialized shares round-trip though Share" $
mapM_ knownCorrectRoundTrip [0 :: Int .. 9]
+ , testProperty "Ciphertext round-trips through encode . decode" $
+ property $ do
+ keypair <- forAll genRSAKeys
+ ciphertext <- forAll $ LB.fromStrict <$> Gen.bytes (Range.exponential 1 1024)
+ sequenceNumber <- forAll $ Gen.integral Range.exponentialBounded
+ (required, total) <- forAll encodingParameters
+
+ (shares', Tahoe.SDMF.Writer{Tahoe.SDMF.writerReader}) <- liftIO $ Tahoe.SDMF.encode keypair sequenceNumber required total ciphertext
+
+ annotateShow shares'
+
+ recovered <- Tahoe.SDMF.decode writerReader (zip [0 ..] shares')
+ diff ciphertext (==) recovered
+ , testProperty "Plaintext round-trips through encrypt . decrypt" $
+ property $
+ do
+ keypair <- forAll genRSAKeys
+ (Just iv) <- fmap Keys.SDMF_IV <$> (makeIV <$> forAll (Gen.bytes (Range.singleton 16)))
+ let (Just dataKey) = do
+ writeKey <- Keys.deriveWriteKey (Keys.toSignatureKey keypair)
+ readKey <- Keys.deriveReadKey writeKey
+ Keys.deriveDataKey iv readKey
+ plaintext <- forAll $ LB.fromStrict <$> Gen.bytes (Range.exponential 1 1024)
+ tripping plaintext (Tahoe.SDMF.encrypt dataKey) (Just . Tahoe.SDMF.decrypt dataKey)
+ , testCase "Recover plaintext from a known-correct slot" $ do
+ s0 <- liftIO $ Binary.decode <$> (LB.readFile "test/data/3of10.0" >>= readShareFromBucket)
+ s6 <- liftIO $ Binary.decode <$> (LB.readFile "test/data/3of10.6" >>= readShareFromBucket)
+ s9 <- liftIO $ Binary.decode <$> (LB.readFile "test/data/3of10.9" >>= readShareFromBucket)
+
+ let (Right writeKey) = Binary.decode . LB.fromStrict <$> decodeBase32Unpadded "vdv6pcqkblsguvkagrblr3gopu"
+ (Just readerReadKey) = Keys.deriveReadKey writeKey
+ readerVerificationKeyHash = "junk"
+ reader = Tahoe.SDMF.Reader{..}
+ ciphertext <- Tahoe.SDMF.decode reader [(0, s0), (6, s6), (9, s9)]
+ let (Right expectedCiphertext) = LB.fromStrict <$> decodeBase32Unpadded "6gutkha6qd4g3lxahth2dw2wjekadwoxvmazrnfq5u5j6a7quu5qy6nz3dvosx2gisdjshdtd5xphqvqjco5pq73qi"
+ (Right (Just expectedIV)) = fmap (fmap Keys.SDMF_IV . makeIV) . decodeBase32Unpadded $ "xkczackg4djsvtx5brgy4z3pse"
+ (Right expectedReadKey) = Binary.decode . LB.fromStrict <$> decodeBase32Unpadded "g4fimjxgdpwrvpfguyz5a6hvz4"
+ (Right expectedDataKey) = Binary.decode . LB.fromStrict <$> decodeBase32Unpadded "crblibtnjacos5xwjpxb2d5hla"
+ expectedPlaintext = "abcdefghijklmnopqrstuvwxyzZYXWVUTSRQPONMLKJIJHGRFCBA1357"
+
+ (Just dataKey) = Keys.deriveDataKey (Tahoe.SDMF.shareIV s0) readerReadKey
+ recoveredPlaintext = Tahoe.SDMF.decrypt dataKey ciphertext
+
+ assertEqual "read key: expected /= derived" expectedReadKey readerReadKey
+ assertEqual "data key: expected /= derived" expectedDataKey dataKey
+ assertEqual "iv: expected /= loaded" expectedIV (Tahoe.SDMF.shareIV s0)
+ assertEqual "ciphertext: expected /= decoded" expectedCiphertext ciphertext
+
+ assertEqual "expected /= recovered" expectedPlaintext recoveredPlaintext
]
+readShareFromBucket :: MonadFail m => LB.ByteString -> m LB.ByteString
+readShareFromBucket bucket =
+ 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
+ in do
+ when (suffix /= "\0\0\0\0") (fail "Cannot account for extra leases")
+ pure shareData
+
{- | 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
+
+ Note: The capability for the test data is:
+
+ URI:SSK:vdv6pcqkblsguvkagrblr3gopu:6pd5r2qrsb3zuq2n6ocvcsg2a6b47ehclqxidkzd5awdabhtdo6a
-}
knownCorrectRoundTrip :: Show a => a -> IO ()
knownCorrectRoundTrip n = do
@@ -151,18 +223,17 @@ knownCorrectRoundTrip n = do
-- 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"
+ shareData <- readShareFromBucket bucket
let decoded = decode' shareData
- let encoded = (Binary.encode :: Share -> LB.ByteString) <$> decoded
+ let encoded = (Binary.encode :: Tahoe.SDMF.Share -> LB.ByteString) <$> decoded
assertEqual "original /= encoded" (Right shareData) encoded
+ -- We also know some specific things about the know-correct shares.
+ let (Right sh) = decoded
+ assertEqual "3 /= required" 3 (Tahoe.SDMF.shareRequiredShares sh)
+ assertEqual "10 /= total" 10 (Tahoe.SDMF.shareTotalShares sh)
+
-- | 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