diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,19 @@ +# Changelog for tahoe-ssk + +## 0.2.1.0 + +* Add Ord instances for StorageIndex, Verifier, Reader, and Writer. +* Add ConfidentialShowable instances for SDMF, Verifier, Reader, and Writer. +* Deprecate dangerRealShow. + +## 0.2.0.0 + +* Add the IV as a parameter to Tahoe.SDMF.encode. + The IV must be the value used to create the ciphertext so Tahoe.SDMF.encode cannot randomly generate one. +* Add Tahoe.SDMF.randomIV for randomly generating a new IV. + +## 0.1.0.0 + +* Initial release. +* Very basic non-verifying decoding support. +* Enough encoding support for simple round-trip tests for the decoding functionality. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright 2023 +Jean-Paul Calderone + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jean-Paul Calderone nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,108 @@ +# tahoe-ssk + +## What is it? + +Tahoe-SSK is a Haskell implementation of the [Tahoe-LAFS](https://tahoe-lafs.org/) SSK crytographic protocols. +This includes (S)mall (D)istributed (M)utable (F)iles (SDMF) and (M)edium (D)istributed (M)utable (F)iles (MDMF). +It aims for bit-for-bit compatibility with the original Python implementation. + +It will not include an implementation of any network protocol for transferring SSK shares. +However, its APIs are intended to be easy to integrate with such an implementation. + +### What is the current state? + +* SDMF write, read, and verify capabilities can be parsed and serialized. +* SDMF shares can be deserialized, decoded, and decrypted. + * The cryptographic integrity and authenticity is not verified. +* Plaintext can be encrypted, encoded into shares, and the shares serialized to bytes. + * Not all fields of the shares contain correctly initialized values. + * Enough fields are correctly populated to recover the original plaintext. + +## Why does it exist? + +A Haskell implementation can be used in places the original Python implementation cannot be +(for example, runtime environments where it is difficult to have a Python interpreter). +Additionally, +with the benefit of the experience gained from creating and maintaining the Python implementation, +a number of implementation decisions can be made differently to produce a more efficient, more flexible, simpler implementation and API. +Also, +the Python implementation claims no public library API for users outside of the Tahoe-LAFS project itself. + +## Cryptographic Library Choice + +This library uses cryptonite for cryptography, +motivated by the following considerations. + +SDMF uses +* SHA256 for tagged hashes for key derivation and for integrity (XXX right word?) checks on some data. +* AES128 for encryption of the signature key and the application plaintext data. +* RSA for signatures proving write authority. + +There are a number of Haskell libraries that provide all of these: + +* Crypto + * Does not support the AES mode we require (CTR). + +* HsOpenSSL + * Bindings to a C library, OpenSSL, which may complicate the build process. + * OpenSSL's security and reliability track record also leaves something to be desired. + +* cryptonite + * Has all of the primitive cryptographic functionality we need. + +We want a library that: + +* Can be used with reflex-platform + * ghc 8.6.5 compatible +* Can be cross-compiled to different targets from x86_64-linux + * Mainly armeabi and armv7 +* Is suitable for real-world security purposes + * not a demo or a toy library + * documents its limitations + * is well-tested + * avoids real-world pitfalls (side-channel attacks, etc), not just textbook issues + * has more than a handful of other users + * is well-maintained + * developers are responsive to security reports + * has a channel for security-related disclosures + * has sound documentation for proper, safe usage + +And, +of course, +implements the required functionality. + +### SHA256 + +There are a number of Haskell libraries that provide this primitive: + +* Crypto +* HsOpenSSL +* SHA +* cryptohash +* cryptonite +* dhall +* hashing +* nettle +* sbv +* tls + +### AES128 + +* Crypto +* HsOpenSSL +* cipher-aes +* cipher-aes128 +* crypto +* cryptocipher +* cryptonite +* cryptostore +* nettle + +### RSA + +SDMF depends on RSA for signatures proving write authority. + +* Crypto +* HsOpenSSL +* RSA +* cryptonite diff --git a/encode-ssk/Main.hs b/encode-ssk/Main.hs new file mode 100644 --- /dev/null +++ b/encode-ssk/Main.hs @@ -0,0 +1,30 @@ +module Main where + +import qualified Crypto.PubKey.RSA as RSA +import Data.Binary (encode) +import Data.ByteString.Base32 (encodeBase32Unpadded) +import qualified Data.ByteString.Lazy as LB +import qualified Data.Text as T +import qualified Data.Text.IO as T +import System.IO (stdin) +import Tahoe.Capability (confidentiallyShow) +import qualified Tahoe.SDMF as SDMF +import qualified Tahoe.SDMF.Keys as SDMF.Keys + +main :: IO () +main = do + plaintext <- LB.hGetContents stdin + keypair <- SDMF.Keys.KeyPair . snd <$> RSA.generate (2048 `div` 8) e + Just iv <- SDMF.randomIV + + let ciphertext = SDMF.encrypt keypair iv plaintext + (shares, writeCap) <- SDMF.encode keypair iv 1 3 5 ciphertext + let shareBytes = encode <$> shares + + let si = SDMF.Keys.unStorageIndex . SDMF.verifierStorageIndex . SDMF.readerVerifier . SDMF.writerReader $ writeCap + + mapM_ (uncurry (writeShare si)) (zip [0 :: Int ..] shareBytes) + T.putStrLn $ confidentiallyShow writeCap + where + e = 0x10001 + writeShare si shnum = LB.writeFile $ (T.unpack . T.toLower . encodeBase32Unpadded $ si) <> "." <> show shnum diff --git a/make-keypairs/Main.hs b/make-keypairs/Main.hs new file mode 100644 --- /dev/null +++ b/make-keypairs/Main.hs @@ -0,0 +1,30 @@ +module Main where + +import qualified Crypto.PubKey.RSA as RSA +import qualified Data.ByteString as B +import Tahoe.SDMF.Internal.Keys (signatureKeyToBytes) +import Tahoe.SDMF.Keys (Signature (..)) + +-- | 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 + mapM_ genKey [0 .. count - 1] + +genKey :: Show a => a -> IO () +genKey n = do + print "Generating RSA key..." + (_, priv) <- RSA.generate (bits `div` 8) e + print $ "Serializing key " <> show n + let bytes = signatureKeyToBytes (Signature priv) + print $ "Generated them (" <> show (B.length bytes) <> " bytes)" + B.writeFile ("test/data/rsa-privkey-" <> show n <> ".der") bytes + print "Wrote them to the file." + where + e = 0x10001 diff --git a/src/Tahoe/SDMF.hs b/src/Tahoe/SDMF.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/SDMF.hs @@ -0,0 +1,31 @@ +-- | Expose the library's public interface. +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 (..), + SDMF (..), + Verifier (..), + Writer (..), + dangerRealShow, + pCapability, + pReader, + pVerifier, + pWriter, + ) +import Tahoe.SDMF.Internal.Encoding ( + decode, + encode, + ) +import Tahoe.SDMF.Internal.Encrypting ( + decrypt, + encrypt, + randomIV, + ) +import Tahoe.SDMF.Internal.Share ( + Share (..), + ) diff --git a/src/Tahoe/SDMF/Internal/Capability.hs b/src/Tahoe/SDMF/Internal/Capability.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/SDMF/Internal/Capability.hs @@ -0,0 +1,217 @@ +-- | Structured representations of SDMF capabilities. +module Tahoe.SDMF.Internal.Capability where + +import Prelude hiding (Read) + +import Control.Applicative ((<|>)) +import Control.Monad (void) +import Crypto.Hash (Digest, SHA256, digestFromByteString) +import Data.Binary (decode) +import qualified Data.ByteArray as ByteArray +import qualified Data.ByteString as B +import qualified Data.ByteString.Base32 as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Void (Void) +import Data.Word (Word16) +import Tahoe.Capability (ConfidentialShowable (..)) +import Tahoe.SDMF.Internal.Keys ( + Read (readKeyBytes), + StorageIndex (StorageIndex, unStorageIndex), + Write (writeKeyBytes), + deriveReadKey, + deriveStorageIndex, + readKeyBytes, + showBase32, + ) +import Text.Megaparsec ( + ErrorFancy (ErrorFail), + Parsec, + count, + failure, + fancyFailure, + oneOf, + ) +import Text.Megaparsec.Char (char, string) + +-- | Any kind of SDMF capability. +data SDMF + = SDMFVerifier Verifier + | SDMFReader Reader + | SDMFWriter Writer + deriving (Eq, Show) + +instance ConfidentialShowable SDMF where + confidentiallyShow = dangerRealShow + +-- | A verify capability for an SDMF object. +data Verifier = Verifier + { verifierStorageIndex :: StorageIndex + , verifierVerificationKeyHash :: Digest SHA256 + } + deriving (Eq, Show) + +instance Ord Verifier where + a <= b = verifierStorageIndex a <= verifierStorageIndex b + +instance ConfidentialShowable Verifier where + confidentiallyShow = dangerRealShow . SDMFVerifier + +-- | A read capability for an SDMF object. +data Reader = Reader + { readerReadKey :: Read + , readerVerifier :: Verifier + } + deriving (Eq, Show) + +instance Ord Reader where + a <= b = readerVerifier a <= readerVerifier b + +instance ConfidentialShowable Reader where + confidentiallyShow = dangerRealShow . SDMFReader + +-- | A write capability for an SDMF object. +data Writer = Writer + { writerWriteKey :: Write + , writerReader :: Reader + } + deriving (Eq, Show) + +instance Ord Writer where + a <= b = writerReader a <= writerReader b + +instance ConfidentialShowable Writer where + confidentiallyShow = dangerRealShow . SDMFWriter + +-- | Diminish a write key to a read key and wrap it in a reader capability. +deriveReader :: Write -> Digest SHA256 -> Maybe Reader +deriveReader w fingerprint = Reader <$> readKey <*> verifier + where + readKey = deriveReadKey w + verifier = flip deriveVerifier fingerprint <$> readKey + +-- | Diminish a read key to a verify key and wrap it in a verifier capability. +deriveVerifier :: Read -> Digest SHA256 -> Verifier +deriveVerifier readKey = Verifier storageIndex + where + storageIndex = deriveStorageIndex readKey + +type Parser = Parsec Void T.Text + +-- | A parser for any kind of SDMF capability type. +pCapability :: Parser SDMF +pCapability = (SDMFVerifier <$> pVerifier) <|> (SDMFReader <$> pReader) <|> (SDMFWriter <$> pWriter) + +-- | A parser for an SDMF verifier capability. +pVerifier :: Parser Verifier +pVerifier = uncurry Verifier <$> pPieces "URI:SSK-Verifier:" StorageIndex + +-- | A parser for an SDMF reader capability. +pReader :: Parser Reader +pReader = do + (readKey, verificationKeyHash) <- pPieces "URI:SSK-RO:" (decode . LB.fromStrict) + let verifier = deriveVerifier readKey verificationKeyHash + pure $ Reader readKey verifier + +-- | A parser for an SDMF writer capability. +pWriter :: Parser Writer +pWriter = do + (writeKey, verificationKeyHash) <- pPieces "URI:SSK:" (decode . LB.fromStrict) + let reader = deriveReader writeKey verificationKeyHash + case Writer writeKey <$> reader of + Nothing -> failure Nothing mempty + Just writer -> pure writer + +{- | A parser for two base32-encoded bytestrings with some given prefix, + formatted as they are in the string representation of an SDMF capability. +-} +pPieces :: + -- | The prefix to expect. + T.Text -> + -- | A function to convert the first bytestring to a result value. + (B.ByteString -> a) -> + -- | A parser for the two pieces of the SDMF capability. + Parser (a, Digest SHA256) +pPieces prefix convertSecret = do + void $ string prefix + secret <- convertSecret <$> pBase32 rfc3548Alphabet 128 + void $ char ':' + digestBytes <- pBase32 rfc3548Alphabet 256 + case digestFromByteString digestBytes of + Nothing -> failure Nothing mempty + Just verificationKeyHash -> + pure (secret, verificationKeyHash) + +{- | A parser combinator for an arbitrary byte string of a fixed length, + encoded using base32. + + TODO: Avoid duplicating this implementation here and in tahoe-chk. +-} +pBase32 :: + -- | The alphabet to use. For example, *rfc3548Alphabet*. + [Char] -> + -- | The number of bits in the encoded byte string. + Word16 -> + -- | A parser for the byte string. Strings that are not valid base32 will + -- be rejected. Strings that are the wrong length are *not necessarily* + -- currently rejected! Please fix that, somebody. + Parser B.ByteString +pBase32 alpha bits = do + b32Text <- pBase32Text + either (fancyFailure . Set.singleton . ErrorFail . T.unpack) pure (decodeBase32Text b32Text) + where + decodeBase32Text = B.decodeBase32Unpadded . T.encodeUtf8 + pBase32Text = T.snoc <$> stem <*> trailer + + -- Determine how many full characters to expect along with how many bits + -- are left to expect encoded in the final character. + (full, extra) = bits `divMod` 5 + + -- Match the base32 characters that represent the full 5 bits + -- possible. fromIntegral is okay here because `full` is only a + -- Word16 and will definitely fit safely into the Int count wants. + stem :: Parser T.Text + stem = T.pack <$> count (fromIntegral full) (oneOf alpha) + + -- Match the final character that represents fewer than 5 bits. + trailer :: Parser Char + trailer = oneOf $ trailingChars alpha extra + + -- XXX The real trailing character set is smaller than this. This + -- parser will let through invalid characters that result in giving us + -- possibly too many bits. + trailingChars :: [Char] -> Word16 -> [Char] + trailingChars alpha' _ = alpha' + +{- | The RFC3548 standard alphabet used by Gnutella, Content-Addressable Web, + THEX, Bitzi, Web-Calculus... +-} +rfc3548Alphabet :: [Char] +rfc3548Alphabet = "abcdefghijklmnopqrstuvwxyz234567" + +-- | Show an SDMF capability, including all secret information. +{-# DEPRECATED dangerRealShow "Use the ConfidentialShowable instance" #-} +dangerRealShow :: SDMF -> T.Text +dangerRealShow (SDMFVerifier Verifier{verifierStorageIndex, verifierVerificationKeyHash}) = + T.concat + [ "URI:SSK-Verifier:" + , showBase32 . unStorageIndex $ verifierStorageIndex + , ":" + , showBase32 . ByteArray.convert $ verifierVerificationKeyHash + ] +dangerRealShow (SDMFReader Reader{readerReadKey, readerVerifier}) = + T.concat + [ "URI:SSK-RO:" + , showBase32 . ByteArray.convert . readKeyBytes $ readerReadKey + , ":" + , showBase32 . ByteArray.convert . verifierVerificationKeyHash $ readerVerifier + ] +dangerRealShow (SDMFWriter Writer{writerWriteKey, writerReader}) = + T.concat + [ "URI:SSK:" + , showBase32 . ByteArray.convert . writeKeyBytes $ writerWriteKey + , ":" + , showBase32 . ByteArray.convert . verifierVerificationKeyHash . readerVerifier $ writerReader + ] diff --git a/src/Tahoe/SDMF/Internal/Converting.hs b/src/Tahoe/SDMF/Internal/Converting.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/SDMF/Internal/Converting.hs @@ -0,0 +1,97 @@ +{-# 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 Control.Monad.Fail (MonadFail) +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 --- /dev/null +++ b/src/Tahoe/SDMF/Internal/Encoding.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{- | Implement the scheme for encoding ciphertext into SDMF shares (and + decoding it again). +-} +module Tahoe.SDMF.Internal.Encoding where + +import Control.Monad.Fail (MonadFail) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Crypto.Hash (digestFromByteString) +import Crypto.Random (MonadRandom) +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 (..)) + +{- | 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 -> Keys.SDMF_IV -> Word64 -> Word16 -> Word16 -> LB.ByteString -> m ([Share], Writer) +encode keypair iv 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 + + -- 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 + 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 = digestFromByteString . Keys.deriveVerificationHash . Keys.toVerificationKey $ keypair + writerReader = deriveReader <$> writerWriteKey <*> maybeToEither "Failed to interpret verification hash" 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 --- /dev/null +++ b/src/Tahoe/SDMF/Internal/Encrypting.hs @@ -0,0 +1,44 @@ +-- | Implement the encryption scheme used by SDMF. +module Tahoe.SDMF.Internal.Encrypting where + +import Crypto.Cipher.AES (AES128) +import Crypto.Cipher.Types (BlockCipher (blockSize), ctrCombine, makeIV, nullIV) +import Crypto.Random (MonadRandom (getRandomBytes)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Tahoe.SDMF.Internal.Keys as Keys + +-- | Randomly generate a new IV suitable for use with the block cipher used by SDMF. +randomIV :: MonadRandom m => m (Maybe Keys.SDMF_IV) +randomIV = (fmap Keys.SDMF_IV . makeIV :: B.ByteString -> Maybe Keys.SDMF_IV) <$> getRandomBytes (blockSize (undefined :: AES128)) + +{- | Encrypt plaintext bytes according to the scheme used for SDMF share + construction. +-} +encrypt :: Keys.KeyPair -> Keys.SDMF_IV -> LB.ByteString -> LB.ByteString +encrypt keypair iv = encryptWithDataKey dataKey + where + signatureKey = Keys.toSignatureKey keypair + (Just writeKey) = Keys.deriveWriteKey signatureKey + (Just readKey) = Keys.deriveReadKey writeKey + (Just dataKey) = Keys.deriveDataKey iv readKey + +{- | Decrypt ciphertext bytes according to the scheme used for SDMF share + construction. +-} +decrypt :: Keys.Read -> Keys.SDMF_IV -> LB.ByteString -> LB.ByteString +decrypt readKey iv = decryptWithDataKey dataKey + where + (Just dataKey) = Keys.deriveDataKey iv readKey + +{- | Encrypt plaintext bytes according to the scheme used for SDMF share + construction using a pre-computed data encryption key. +-} +encryptWithDataKey :: Keys.Data -> LB.ByteString -> LB.ByteString +encryptWithDataKey Keys.Data{unData} = LB.fromStrict . ctrCombine unData nullIV . LB.toStrict + +{- | Decrypt ciphertext bytes according to the scheme used for SDMF share + construction using a pre-computed data encryption key. +-} +decryptWithDataKey :: Keys.Data -> LB.ByteString -> LB.ByteString +decryptWithDataKey = encryptWithDataKey diff --git a/src/Tahoe/SDMF/Internal/Keys.hs b/src/Tahoe/SDMF/Internal/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/SDMF/Internal/Keys.hs @@ -0,0 +1,305 @@ +{- | Key types, derivations, and related functionality for SDMF. + + See docs/specifications/mutable.rst for details. +-} +module Tahoe.SDMF.Internal.Keys where + +import Prelude hiding (Read) + +import Control.Monad (when) +import Crypto.Cipher.AES (AES128) +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) +import qualified Data.ByteString.Lazy as LB +import qualified Data.Text as T +import Data.X509 (PrivKey (PrivKeyRSA), PubKey (PubKeyRSA)) +import Tahoe.CHK.Crypto (taggedHash, taggedPairHash) + +newtype KeyPair = KeyPair {toPrivateKey :: RSA.PrivateKey} deriving newtype (Show) + +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 Eq Write where + (Write _ left) == (Write _ right) = left == right + +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 + [ "" + ] + +data Read = Read {unRead :: AES128, readKeyBytes :: ByteArray.ScrubbedBytes} + +instance Eq Read where + (Read _ left) == (Read _ right) = left == right + +instance Show Read where + show (Read _ bs) = + T.unpack $ + T.concat + [ "" + ] + +instance Binary Read where + put = putByteString . ByteArray.convert . readKeyBytes + get = do + readKeyBytes <- ByteArray.convert <$> getByteString keyLength + let (CryptoPassed unRead) = cipherInit readKeyBytes + pure Read{..} + +newtype StorageIndex = StorageIndex {unStorageIndex :: B.ByteString} deriving newtype (Eq, Ord) + +instance Show StorageIndex where + show (StorageIndex si) = + T.unpack $ + T.concat + [ "" + ] + +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 + [ "" + ] + +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) + deriving newtype (ByteArray.ByteArrayAccess) + +instance Show SDMF_IV where + show (SDMF_IV iv) = T.unpack . showBase32 . ByteArray.convert $ iv + +-- | The size of the public/private key pair to generate. +keyPairBits :: Int +keyPairBits = 2048 + +-- | The number of bytes in the block cipher key. +keyLength :: Int +(KeySizeFixed keyLength) = cipherKeySize (undefined :: AES128) + +{- | Create a new, random key pair (public/private aka verification/signature) + of the appropriate type and size for SDMF encryption. +-} +newKeyPair :: MonadRandom m => m KeyPair +newKeyPair = do + (_, priv) <- RSA.generate keyPairBits e + pure $ KeyPair priv + where + e = 0x10001 + +-- | Compute the write key for a given signature key for an SDMF share. +deriveWriteKey :: Signature -> Maybe Write +deriveWriteKey s = + Write <$> key <*> pure (ByteArray.convert sbs) + where + sbs = taggedHash keyLength mutableWriteKeyTag . signatureKeyToBytes $ s + key = maybeCryptoError . cipherInit $ sbs + +mutableWriteKeyTag :: B.ByteString +mutableWriteKeyTag = "allmydata_mutable_privkey_to_writekey_v1" + +-- | Compute the read key for a given write key for an SDMF share. +deriveReadKey :: Write -> Maybe Read +deriveReadKey w = + Read <$> key <*> pure (ByteArray.convert sbs) + where + sbs = taggedHash keyLength mutableReadKeyTag . ByteArray.convert . writeKeyBytes $ w + key = maybeCryptoError . cipherInit $ sbs + +mutableReadKeyTag :: B.ByteString +mutableReadKeyTag = "allmydata_mutable_writekey_to_readkey_v1" + +-- | Compute the data encryption/decryption key for a given read key for an SDMF share. +deriveDataKey :: SDMF_IV -> Read -> Maybe Data +deriveDataKey (SDMF_IV iv) r = + Data <$> key <*> pure (ByteArray.convert sbs) + where + -- XXX taggedPairHash has a bug where it doesn't ever truncate so we + -- truncate for it. + sbs = B.take keyLength . taggedPairHash keyLength mutableDataKeyTag (B.pack . ByteArray.unpack $ iv) . ByteArray.convert . readKeyBytes $ r + key = maybeCryptoError . cipherInit $ sbs + +mutableDataKeyTag :: B.ByteString +mutableDataKeyTag = "allmydata_mutable_readkey_to_datakey_v1" + +-- | Compute the storage index for a given read key for an SDMF share. +deriveStorageIndex :: Read -> StorageIndex +deriveStorageIndex r = StorageIndex si + where + si = taggedHash keyLength mutableStorageIndexTag . ByteArray.convert . readKeyBytes $ r + +mutableStorageIndexTag :: B.ByteString +mutableStorageIndexTag = "allmydata_mutable_readkey_to_storage_index_v1" + +{- | Derive the "write enabler master" secret for a given write key for an + SDMF share. +-} +deriveWriteEnablerMaster :: Write -> WriteEnablerMaster +deriveWriteEnablerMaster w = WriteEnablerMaster bs + where + -- This one shouldn't be truncated. Set the length to the size of sha256d + -- output. + bs = ByteArray.convert . taggedHash 32 mutableWriteEnablerMasterTag . ByteArray.convert . writeKeyBytes $ w + +mutableWriteEnablerMasterTag :: B.ByteString +mutableWriteEnablerMasterTag = "allmydata_mutable_writekey_to_write_enabler_master_v1" + +{- | Derive the "write enabler" secret for a given peer and "write enabler + master" for an SDMF share. +-} +deriveWriteEnabler :: B.ByteString -> WriteEnablerMaster -> WriteEnabler +deriveWriteEnabler peerid (WriteEnablerMaster master) = WriteEnabler bs + where + -- This one shouldn't be truncated. Set the length to the size of sha256d + -- output. + bs = ByteArray.convert . taggedPairHash 32 mutableWriteEnablerTag (ByteArray.convert master) $ peerid + +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. +-} +verificationKeyToBytes :: Verification -> B.ByteString +verificationKeyToBytes = LB.toStrict . encodeASN1 DER . flip toASN1 [] . PubKeyRSA . unVerification + +{- | 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 :: Signature -> B.ByteString +signatureKeyToBytes = LB.toStrict . encodeASN1 DER . toPKCS8 + where + -- The ASN1Object instance for PrivKeyRSA can interpret an x509 + -- "Private-Key Information" (aka PKCS8; see RFC 5208, section 5) + -- structure but it _produces_ some other format. We must have exactly + -- this format. + -- + -- XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + -- + -- RFC 5208 says: + -- + -- privateKey is an octet string whose contents are the value of the + -- private key. The interpretation of the contents is defined in the + -- registration of the private-key algorithm. For an RSA private key, + -- for example, the contents are a BER encoding of a value of type + -- RSAPrivateKey. + -- + -- The ASN.1 BER encoding for a given structure is *not guaranteed to be + -- unique*. This means that in general there is no guarantee of a unique + -- bytes representation of a signature key in this scheme so *key + -- derivations are not unique*. If any two implementations disagree on + -- this encoding (which BER allows them to do) they will not interoperate. + toPKCS8 (Signature privKey) = + [ Start Sequence + , IntVal 0 + , Start Sequence + , OID [1, 2, 840, 113549, 1, 1, 1] + , Null + , End Sequence + , -- Our ASN.1 encoder doesn't even pretend to support BER. Use DER! + -- It results in the same bytes as Tahoe-LAFS is working with so ... + -- Maybe we're lucky or maybe Tahoe-LAFS isn't actually following + -- the spec. + OctetString (LB.toStrict . encodeASN1 DER . toASN1 (PrivKeyRSA privKey) $ []) + , End Sequence + ] + +-- | Decode a private key from the Tahoe-LAFS canonical bytes representation. +signatureKeyFromBytes :: B.ByteString -> Either String Signature +signatureKeyFromBytes bs = do + asn1s <- first show $ decodeASN1' DER bs + (key, extra) <- fromASN1 asn1s + when (extra /= []) (Left $ "left over data: " <> show extra) + 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 + +{- | Replace most of the tail of a string with a short placeholder. If the + string is not much longer than `n` then the result might not actually be + shorter. + + TODO: Deduplicate this between here and tahoe-chk. +-} +shorten :: Int -> T.Text -> T.Text +shorten n = (<> "...") . T.take n + +showBase32 :: B.ByteString -> T.Text +showBase32 = T.toLower . encodeBase32Unpadded diff --git a/src/Tahoe/SDMF/Internal/Share.hs b/src/Tahoe/SDMF/Internal/Share.hs new file mode 100644 --- /dev/null +++ b/src/Tahoe/SDMF/Internal/Share.hs @@ -0,0 +1,214 @@ +-- | 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.Types (makeIV) +import qualified Crypto.PubKey.RSA.Types 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 (..), 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.ByteArray as ByteArray +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +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.Converting (From (from), into, tryInto) +import qualified Tahoe.SDMF.Internal.Keys as Keys + +hashSize :: Int +hashSize = 32 + +newtype HashChain = HashChain + { hashChain :: [(Word16, B.ByteString)] + } + deriving newtype (Eq, Show, Semigroup) + +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 [(n, h)] <>) <$> get + +{- | Structured representation of a single version SDMF share. + + See Tahoe-LAFS "mutable" specification document, section title "SDMF Slot + Format". + + Since the only version of SDMF that is specified uses version 0, this + implicitly represents a version 0 SDMF. If new versions of SDMF are + specified then new constructors may be added. +-} +data Share = Share + { -- | sequence number. 2^64-1 must be handled specially, TBD + shareSequenceNumber :: Word64 + , -- | "R" (root of share hash merkle tree) + shareRootHash :: B.ByteString + , -- | The IV for encryption of share data. + 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. 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 :: Keys.Verification + , -- | The RSA signature of + -- H('\x00'+shareSequenceNumber+shareRootHash+shareIV+encoding + -- parameters) where '\x00' gives the version of this share format (0) + -- and the encoding parameters are a certain serialization of + -- shareRequiredShares and shareTotalShares. + shareSignature :: B.ByteString + , -- | The share numbers and shareRootHash values which are required to + -- ... something about verification I dunno. XXX + shareHashChain :: HashChain + , -- | A merkle tree where leaves are the hashes of the blocks in this share. + shareBlockHashTree :: MerkleTree + , -- | The share data (erasure encoded ciphertext). + shareData :: LB.ByteString + , -- | 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 . ByteArray.convert $ shareIV + putWord8 shareRequiredShares + putWord8 shareTotalShares + 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 = Keys.verificationKeyToBytes shareVerificationKey + blockHashTreeBytes = B.concat . leafHashes $ shareBlockHashTree + + -- 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 + unless (version == 0) (fail $ "Only version 0 is supported; got version " <> show version) + shareSequenceNumber <- getWord64be + shareRootHash <- getByteString 32 + ivBytes <- getByteString 16 + shareIV <- case makeIV ivBytes of + Nothing -> fail "Could not decode IV" + Just iv -> pure (Keys.SDMF_IV iv) + + shareRequiredShares <- getWord8 + shareTotalShares <- getWord8 + shareSegmentSize <- getWord64be + shareDataLength <- getWord64be + signatureOffset <- getWord32be + hashChainOffset <- getWord32be + blockHashTreeOffset <- getWord32be + shareDataOffset <- getWord32be + encryptedPrivateKeyOffset <- getWord64be + eofOffset <- getWord64be + + -- 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 + + -- 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 + + blockLength <- tryInto @Int64 "Binary.get Share could not represent share block length" (encryptedPrivateKeyOffset - into @Word64 shareDataOffset) + shareData <- getLazyByteString blockLength + + 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") + + pure Share{..} + +{- | Read an X.509v3-encoded SubjectPublicKeyInfo structure carrying an ASN.1 + DER encoded RSA public key. +-} +getSubjectPublicKeyInfo :: Get RSA.PublicKey +getSubjectPublicKeyInfo = do + 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 new file mode 100644 --- /dev/null +++ b/src/Tahoe/SDMF/Keys.hs @@ -0,0 +1,21 @@ +module Tahoe.SDMF.Keys (module Tahoe.SDMF.Internal.Keys) where + +import Tahoe.SDMF.Internal.Keys ( + Data (..), + KeyPair (..), + Read (..), + SDMF_IV (..), + Signature (..), + StorageIndex (..), + Write (..), + WriteEnabler (..), + WriteEnablerMaster (..), + deriveDataKey, + deriveReadKey, + deriveStorageIndex, + deriveWriteEnabler, + deriveWriteEnablerMaster, + deriveWriteKey, + toSignatureKey, + toVerificationKey, + ) diff --git a/tahoe-ssk.cabal b/tahoe-ssk.cabal new file mode 100644 --- /dev/null +++ b/tahoe-ssk.cabal @@ -0,0 +1,210 @@ +cabal-version: 2.4 + +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'tahoe-ssk' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: tahoe-ssk + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.2.1.0 + +-- A short (one-line) description of the package. +synopsis: + An implementation of the Tahoe-LAFS SSK cryptographic protocols + +-- A longer description of the package. +description: + This currently includes a partial implementation of SDMF. A future version + may include an implementation of MDMF. + +-- URL for the project homepage or repository. +homepage: https://whetstone.private.storage/PrivateStorage/tahoe-ssk + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Jean-Paul Calderone + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: exarkun@twistedmatrix.com + +-- A copyright notice. +-- copyright: +category: Cryptography,Library,Parsers,Security +build-type: Simple + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: + CHANGELOG.md + README.md + +-- Extra source files to be distributed with the package, such as examples, or +-- a tutorial module. +extra-source-files: + test/data/3of10.0 + test/data/3of10.1 + test/data/3of10.2 + test/data/3of10.3 + test/data/3of10.4 + test/data/3of10.5 + test/data/3of10.6 + test/data/3of10.7 + test/data/3of10.8 + test/data/3of10.9 + test/data/rsa-privkey-0.der + test/data/rsa-privkey-1.der + test/data/rsa-privkey-2.der + test/data/rsa-privkey-3.der + test/data/rsa-privkey-4.der + test/data/tahoe-lafs-generated-rsa-privkey.der + +source-repository head + type: git + location: + gitlab@whetstone.private.storage:privatestorage/tahoe-ssk.git + +common warnings + ghc-options: -Wall -Werror=missing-fields + +common language + default-extensions: + DerivingStrategies + GeneralizedNewtypeDeriving + NamedFieldPuns + OverloadedStrings + PackageImports + RecordWildCards + TypeApplications + + -- Base language which the package is written in. + default-language: Haskell2010 + +library + import: + warnings + , 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 + + build-depends: + , asn1-encoding >=0.9.6 && <0.10 + , asn1-types >=0.3.4 && <0.4 + , base >=4.7 && <5 + , base32 >=0.2.1 && <0.3 + , binary >=0.8.6 && <0.9 + , bytestring >=0.10.8.2 && <0.11 + , cereal >=0.5.8.1 && <0.6 + , containers >=0.6.0.1 && <0.7 + , cryptonite >=0.27 && <0.30 + , megaparsec >=8.0 && <9.3 + , memory >=0.15 && <0.17 + , tahoe-capabilities >=0.1 && <0.2 + , text >=1.2.3.1 && <1.3 + , x509 >=1.7.5 && <1.8 + + -- This dependency isn't ideal. Move common bits out to + -- another library. + build-depends: tahoe-chk >=0.1 && <0.2 + +test-suite tahoe-ssk-test + import: + warnings + , language + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + other-modules: + Generators + Spec + + -- Test dependencies. + build-depends: + , asn1-encoding >=0.9.6 && <0.10 + , asn1-types >=0.3.4 && <0.4 + , base >=4.7 && <5 + , base32 >=0.2.1 && <0.3 + , binary >=0.8.6 && <0.9 + , bytestring >=0.10.8.2 && <0.11 + , cryptonite >=0.27 && <0.30 + , hedgehog >=1.0.3 && <1.1 + , megaparsec >=8.0 && <9.3 + , memory >=0.15 && <0.17 + , tahoe-capabilities >=0.1 && <0.2 + , tahoe-chk >=0.1 && <0.2 + , tahoe-ssk + , tasty >=1.2.3 && <1.5 + , tasty-hedgehog >=1.0.0.2 && <1.2 + , tasty-hunit >=0.10.0.2 && <0.11 + , text >=1.2.3.1 && <1.3 + , x509 >=1.7.5 && <1.8 + +-- A helper for generating RSA key pairs for use by the test suite. +executable make-keypairs + import: + warnings + , language + + main-is: Main.hs + hs-source-dirs: make-keypairs + build-depends: + , asn1-encoding >=0.9.6 && <0.10 + , asn1-types >=0.3.4 && <0.4 + , base >=4.7 && <5 + , bytestring >=0.10.8.2 && <0.11 + , cryptonite >=0.27 && <0.30 + , tahoe-ssk + , x509 >=1.7.5 && <1.8 + +executable encode-ssk + import: + warnings + , language + + main-is: Main.hs + hs-source-dirs: encode-ssk + build-depends: + , base >=4.7 && <5 + , base32 >=0.2.1 && <0.3 + , binary >=0.8.6 && <0.9 + , bytestring >=0.10.8.2 && <0.11 + , cryptonite >=0.27 && <0.30 + , tahoe-capabilities >=0.1 && <0.2 + , tahoe-ssk + , text >=1.2.3.1 && <1.3 diff --git a/test/Generators.hs b/test/Generators.hs new file mode 100644 --- /dev/null +++ b/test/Generators.hs @@ -0,0 +1,148 @@ +module Generators where + +import Crypto.Cipher.Types (makeIV) +import Crypto.Hash (Digest, HashAlgorithm (hashDigestSize), SHA256, digestFromByteString) +import Crypto.Hash.Algorithms (SHA256 (SHA256)) +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.Binary as Binary +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import Data.Maybe (fromJust) +import Data.Word (Word16) +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 (Reader (..), SDMF (..), Share (..), Verifier (..), Writer (..)) +import Tahoe.SDMF.Internal.Capability (deriveReader) +import Tahoe.SDMF.Internal.Keys (keyLength) +import Tahoe.SDMF.Internal.Share (HashChain (HashChain)) +import qualified Tahoe.SDMF.Keys as Keys + +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 = do + keypair <- genRSAKeys + iv <- makeIV <$> Gen.bytes (Range.singleton ivLength) + case iv of + Nothing -> error "Could not build IV for SDMF share" + Just iv' -> + Share + <$> Gen.word64 Range.exponentialBounded -- shareSequenceNumber + <*> Gen.bytes (Range.singleton rootHashLength) -- shareRootHash + <*> pure (Keys.SDMF_IV iv') -- shareIV + <*> Gen.word8 Range.exponentialBounded -- shareTotalShares + <*> Gen.word8 Range.exponentialBounded -- shareRequiredShares + <*> Gen.word64 Range.exponentialBounded -- shareSegmentSize + <*> Gen.word64 Range.exponentialBounded -- shareDataLength + <*> pure (Keys.toVerificationKey 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 . Keys.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 Keys.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 -> Keys.KeyPair +rsaKeyPair bs = do + let (Right kp) = do + asn1s <- first show (decodeASN1 DER bs) + (r, _) <- fromASN1 asn1s + case r of + PrivKeyRSA pk -> pure $ Keys.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) + +-- | 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) + +-- | Build all kinds of SDMF capabilities values. +capabilities :: MonadGen m => m SDMF +capabilities = + Gen.choice + [ SDMFVerifier <$> verifiers + , SDMFReader <$> readers + , SDMFWriter <$> writers + ] + +-- | Build SDMF writer capabilities. +writers :: MonadGen m => m Writer +writers = do + writeKey <- writeKeys + reader <- deriveReader writeKey <$> digests + pure $ Writer writeKey (fromJust reader) + +-- | Build SDMF writer capability keys. +writeKeys :: MonadGen m => m Keys.Write +writeKeys = key + where + writeBytes = Gen.bytes (Range.singleton 16) + key = Binary.decode . LB.fromStrict <$> writeBytes + +-- | Build SDMF reader capabilities. +readers :: MonadGen m => m Reader +readers = writerReader <$> writers + +-- | Build SDMF verifier capabilities. +verifiers :: MonadGen m => m Verifier +verifiers = readerVerifier <$> readers + +-- | Build SDMF storage indexes. +storageIndexes :: MonadGen m => m Keys.StorageIndex +storageIndexes = Keys.StorageIndex <$> Gen.bytes (Range.singleton keyLength) + +-- | Build SHA256 digests. +digests :: MonadGen m => m (Digest SHA256) +digests = fromJust . digestFromByteString <$> Gen.bytes (Range.singleton 32) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,3 @@ +module Main (main) where + +import Spec (main) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,276 @@ +module Spec where + +import Hedgehog ( + annotateShow, + diff, + forAll, + property, + tripping, + ) + +import Control.Monad (when) +import Control.Monad.Fail (MonadFail) +import Control.Monad.IO.Class (liftIO) +import Crypto.Cipher.Types (makeIV) +import Crypto.Hash (digestFromByteString) +import Data.ASN1.BinaryEncoding (DER (DER)) +import Data.ASN1.Encoding (decodeASN1') +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 (decodeBase32Unpadded, encodeBase32Unpadded) +import qualified Data.ByteString.Lazy as LB +import Data.Either (rights) +import qualified Data.Text as T +import Generators (capabilities, encodingParameters, genRSAKeys, ivLength, shareHashChains, shares) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import System.IO (hSetEncoding, stderr, stdout, utf8) +import Tahoe.Capability (confidentiallyShow) +import qualified Tahoe.SDMF +import Tahoe.SDMF.Internal.Capability (deriveVerifier) +import Tahoe.SDMF.Internal.Keys (signatureKeyFromBytes, signatureKeyToBytes) +import qualified Tahoe.SDMF.Keys as Keys +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) +import Test.Tasty.Hedgehog (testProperty) +import Text.Megaparsec (parse) + +-- The test suite compares against some hard-coded opaque strings. These +-- expected values were determined using the expected_values.py program in +-- this directory. + +tests :: TestTree +tests = + testGroup + "SSK" + [ testProperty "Hash chain round-trips through bytes" $ + property $ do + hashChain <- forAll shareHashChains + tripping hashChain Binary.encode decode' + , testProperty "Signatures round-trip through signatureKeyToBytes . signatureKeyFromBytes" $ + property $ do + key <- forAll genRSAKeys + tripping (Keys.Signature . Keys.toPrivateKey $ key) signatureKeyToBytes signatureKeyFromBytes + , testCase "Signature byte-serializations round-trip through signatureKeyFromBytes . signatureKeyToBytes" $ do + let keyPaths = + [ -- Check ours + "test/data/rsa-privkey-0.der" + , "test/data/rsa-privkey-1.der" + , "test/data/rsa-privkey-2.der" + , "test/data/rsa-privkey-3.der" + , "test/data/rsa-privkey-4.der" + , -- And one from Tahoe-LAFS + "test/data/tahoe-lafs-generated-rsa-privkey.der" + ] + checkSignatureRoundTrip p = + B.readFile p >>= \original -> + let (Right sigKey) = signatureKeyFromBytes original + serialized = signatureKeyToBytes sigKey + in do + -- They should decode to the same structure. This + -- has the advantage of representing differences a + -- little more transparently than the next + -- assertion. + assertEqual + "decodeASN1 original /= decodeASN1 serialized" + (decodeASN1' DER original) + (decodeASN1' DER serialized) + -- Also check the raw bytes in case there + -- are different representations of the + -- structure possible. The raw bytes + -- matter because we hash them in key + -- derivations. + assertEqual "original /= serialized" original serialized + -- Check them all + mapM_ checkSignatureRoundTrip keyPaths + , testCase "derived keys equal known-correct values" $ + -- The path is relative to the root of the package, which is where + -- at least some test runners will run the test process. If + B.readFile "test/data/rsa-privkey-0.der" >>= \privBytes -> + let -- Load the test key. + (Right sigKey) = signatureKeyFromBytes privBytes + + -- Hard-code the expected result. + expectedWriteKey = ("v7iymuxkc5yv2fomi3xwbjdd4e" :: T.Text) + expectedReadKey = ("6ir6husgx6ubro3tbimmzskqri" :: T.Text) + expectedDataKey = ("bbj67exlrkfcaqutwlgwvukbfe" :: T.Text) + expectedStorageIndex = ("cmkuloz2t6fhsh7npxxteba6sq" :: T.Text) + expectedWriteEnablerMaster = ("qgptod5dsanfep2kbimvxl2yixndnoks7ndoeamczj7g33gokcvq" :: T.Text) + expectedWriteEnabler = ("bg4ldrgfyiffufltcuttr3cnrmrjfpoxc65qdoqa6d5izkzofl5q" :: T.Text) + + -- Constants involved in the derivation. These agree with + -- those used to generate the above expected values. + (Just iv) = Keys.SDMF_IV <$> makeIV (B.replicate 16 0x42) + peerid = B.replicate 20 0x42 + + -- Derive all the keys. + (Just w@(Keys.Write _ derivedWriteKey)) = Keys.deriveWriteKey sigKey + (Just r@(Keys.Read _ derivedReadKey)) = Keys.deriveReadKey w + (Just (Keys.Data _ derivedDataKey)) = Keys.deriveDataKey iv r + (Keys.StorageIndex derivedStorageIndex) = Keys.deriveStorageIndex r + wem@(Keys.WriteEnablerMaster derivedWriteEnablerMaster) = Keys.deriveWriteEnablerMaster w + (Keys.WriteEnabler derivedWriteEnabler) = Keys.deriveWriteEnabler peerid wem + -- A helper to format a key as text for convenient + -- comparison to expected value. + fmtKey = T.toLower . encodeBase32Unpadded . ByteArray.convert + in do + -- In general it might make more sense to convert expected + -- into ScrubbedBytes instead of converting derived into + -- ByteString but ScrubbedBytes doesn't have a useful Show + -- instance so we go the other way. We're not worried about + -- the safety of these test-only keys anyway. + assertEqual + "writekey: expected /= derived" + expectedWriteKey + (fmtKey derivedWriteKey) + assertEqual + "readkey: expected /= derived" + expectedReadKey + (fmtKey derivedReadKey) + assertEqual + "datakey: expected /= derived" + expectedDataKey + (fmtKey derivedDataKey) + assertEqual + "storage index: expected /= derived" + expectedStorageIndex + (T.toLower . encodeBase32Unpadded $ derivedStorageIndex) + assertEqual + "write enabler master: expected /= derived" + expectedWriteEnablerMaster + (fmtKey derivedWriteEnablerMaster) + assertEqual + "write enabler: expected /= derived" + expectedWriteEnabler + (fmtKey derivedWriteEnabler) + , testCase "known-correct SDMF capability strings round-trip through parse . confidentiallyShow" $ do + let validWrite = "URI:SSK:vbopclzrkxces6okoqfarapmou:xlwog3jxbgsuaddh3bsofwmyhncv7fanmo7ujhqiy26usx2v2neq" + validRead = "URI:SSK-RO:ro7pnpq6duaduuolookwbv5lqy:xlwog3jxbgsuaddh3bsofwmyhncv7fanmo7ujhqiy26usx2v2neq" + validVerify = "URI:SSK-Verifier:gz4s2zkkqy2geblvv77atyoppi:xlwog3jxbgsuaddh3bsofwmyhncv7fanmo7ujhqiy26usx2v2neq" + + parsed = rights $ parse Tahoe.SDMF.pCapability "" <$> [validWrite, validRead, validVerify] + serialized = confidentiallyShow <$> parsed + + assertEqual "parsing failed" 3 (length parsed) + assertEqual "original /= serialized" [validWrite, validRead, validVerify] serialized + + let [Tahoe.SDMF.SDMFWriter writeCap, Tahoe.SDMF.SDMFReader readCap, Tahoe.SDMF.SDMFVerifier verifyCap] = parsed + derivedReader = Tahoe.SDMF.writerReader writeCap + derivedVerifier = Tahoe.SDMF.readerVerifier readCap + + assertEqual "derived reader /= parsed reader" derivedReader readCap + assertEqual "serialized derived reader /= original" (confidentiallyShow derivedReader) validRead + assertEqual "derived verifier /= parsed verifier" derivedVerifier verifyCap + assertEqual "serialized derived verifier /= original" (confidentiallyShow derivedVerifier) validVerify + , testProperty "SDMF capabilities round-trip through confidentiallyShow . parse pCapability" $ + property $ do + cap <- forAll capabilities + tripping cap confidentiallyShow (parse Tahoe.SDMF.pCapability "") + , 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] + , testProperty "Ciphertext round-trips through encode . decode" $ + property $ do + keypair <- forAll genRSAKeys + ivBytes <- forAll $ Gen.bytes (Range.singleton ivLength) + let Just iv = Keys.SDMF_IV <$> makeIV ivBytes + 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 iv 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 readKey) = do + writeKey <- Keys.deriveWriteKey (Keys.toSignatureKey keypair) + Keys.deriveReadKey writeKey + plaintext <- forAll $ LB.fromStrict <$> Gen.bytes (Range.exponential 1 1024) + tripping plaintext (Tahoe.SDMF.encrypt keypair iv) (Just . Tahoe.SDMF.decrypt readKey iv) + , 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 + (Just readerVerifier) = deriveVerifier readerReadKey <$> digestFromByteString ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" :: B.ByteString) + 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 readerReadKey (Tahoe.SDMF.shareIV s0) 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 + -- 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) + shareData <- readShareFromBucket bucket + + let decoded = decode' shareData + 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 + +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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 Binary files /dev/null and b/test/data/rsa-privkey-4.der differ diff --git a/test/data/tahoe-lafs-generated-rsa-privkey.der b/test/data/tahoe-lafs-generated-rsa-privkey.der new file mode 100644 Binary files /dev/null and b/test/data/tahoe-lafs-generated-rsa-privkey.der differ