mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-09-27 22:18:36 +00:00
Alain Brenzikofer
dd0dcbf2bc
Non-custodial in-app SimpleX name registration. Wallet and ERC-5564 stealth crypto, the names-service interface with an in-memory mock that verifies real EIP-712 signatures, SQLite/Postgres migrations, the signed-intent commands, and CLI + end-to-end test coverage (WalletTests, ChatTests.Names). Bumps the simplexmq pin to c85a895a. GUI code follows in a stacked PR.
364 lines
17 KiB
Haskell
364 lines
17 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
-- | The wallet's derivation layout.
|
|
--
|
|
-- These tests exist because the layout is the one part of the design that
|
|
-- cannot be changed after release: altering a path once a user holds a name
|
|
-- means moving assets, and there is no safe migration. Everything here is
|
|
-- therefore a pin, not a behaviour check — if a test in this module fails, the
|
|
-- question is never "how do I update the expected value".
|
|
module WalletTests where
|
|
|
|
import Control.Concurrent.STM (TVar)
|
|
import Crypto.Random (ChaChaDRG)
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString as B
|
|
import Data.Word (Word8)
|
|
import Numeric (showHex)
|
|
import Simplex.Chat.Names.Service
|
|
import Simplex.Chat.Names.Service.Mock
|
|
import Simplex.Chat.Names.Snrc
|
|
import Simplex.Chat.Wallet
|
|
import Simplex.Chat.Wallet.Stealth
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Eth.Address (Address, checksumAddress)
|
|
import qualified Simplex.Messaging.Eth.Stealth as St
|
|
import Test.Hspec
|
|
|
|
walletTests :: Spec
|
|
walletTests = do
|
|
describe "derivation paths" $ do
|
|
it "main account is BIP-44 Ethereum" $
|
|
mainPath ChainEth 0 `shouldBe` Right [0x8000002C, 0x8000003C, 0x80000000, 0, 0]
|
|
it "main account varies only in the account level" $
|
|
mainPath ChainEth 7 `shouldBe` Right [0x8000002C, 0x8000003C, 0x80000007, 0, 0]
|
|
it "ethereum stealth keys use purpose 5564" $ do
|
|
stealthSpendPath ChainEth 0 `shouldBe` Right [0x800015BC, 0x8000003C, 0x80000000, 0x80000000, 0]
|
|
stealthViewPath ChainEth 0 `shouldBe` Right [0x800015BC, 0x8000003C, 0x80000000, 0x80000001, 0]
|
|
it "bitcoin stealth keys use BIP-352 purpose 352" $ do
|
|
stealthSpendPath ChainBtc 3 `shouldBe` Right [0x80000160, 0x80000000, 0x80000003, 0x80000000, 0]
|
|
stealthViewPath ChainBtc 3 `shouldBe` Right [0x80000160, 0x80000000, 0x80000003, 0x80000001, 0]
|
|
it "unimplemented chains fail rather than deriving something plausible" $ do
|
|
mainPath ChainBtc 0 `shouldSatisfy` isLeft
|
|
mainPath ChainXmr 0 `shouldSatisfy` isLeft
|
|
stealthSpendPath ChainXmr 0 `shouldSatisfy` isLeft
|
|
|
|
describe "account derivation" $ do
|
|
it "derives the published BIP-44 address for the standard mnemonic" $
|
|
-- m/44'/60'/0'/0/0 of "abandon abandon ... about", the BIP-39 all-zero
|
|
-- entropy vector. Externally verifiable against any BIP-44 wallet.
|
|
(checksumAddress . accountAddress <$> deriveAccount zeroSeed 0)
|
|
`shouldBe` Right "0x9858EfFD232B4033E47d90003D41EC34EcaEda94"
|
|
it "gives every profile a distinct address" $ do
|
|
a <- expectRight $ accountAddress <$> deriveAccount zeroSeed 0
|
|
b <- expectRight $ accountAddress <$> deriveAccount zeroSeed 1
|
|
a `shouldNotBe` b
|
|
|
|
describe "stealth keys" $ do
|
|
it "spend and view keys differ, and differ from the main key" $ do
|
|
ks <- expectRight $ deriveStealthKeys zeroSeed ChainEth 0
|
|
acct <- expectRight $ deriveAccount zeroSeed 0
|
|
skSpend ks `shouldNotBe` skView ks
|
|
skSpend ks `shouldNotBe` waKey acct
|
|
skView ks `shouldNotBe` waKey acct
|
|
it "differ per account, so profiles are not linkable through them" $ do
|
|
k0 <- expectRight $ deriveStealthKeys zeroSeed ChainEth 0
|
|
k1 <- expectRight $ deriveStealthKeys zeroSeed ChainEth 1
|
|
accountMetaAddress k0 `shouldNotBe` accountMetaAddress k1
|
|
it "publishes the spending key first, then the viewing key" $ do
|
|
ks <- expectRight $ deriveStealthKeys zeroSeed ChainEth 0
|
|
let bs = St.metaAddressBytes (accountMetaAddress ks)
|
|
B.length bs `shouldBe` St.metaAddressSize
|
|
B.index bs 0 `shouldSatisfy` isCompressedPrefix
|
|
B.index bs 33 `shouldSatisfy` isCompressedPrefix
|
|
it "is stable for a given seed and account" $ do
|
|
-- Change-detector, not an external vector: purpose 5564 is ours, so no
|
|
-- other wallet derives these keys. The ERC-5564 encoding around them is
|
|
-- covered by simplexmq's own cross-checked vector. A diff here means the
|
|
-- derivation layout moved.
|
|
ks <- expectRight $ deriveStealthKeys zeroSeed ChainEth 0
|
|
hex (St.metaAddressBytes $ accountMetaAddress ks)
|
|
`shouldBe` "03dac487b400b6bdcfcbf258266638a76038d23b7c1665127eb8490c571b335b12"
|
|
<> "024f660d285a9ab4e8e8906d423311e42c7c090289bd9a694f56ee8a0d4060918f"
|
|
it "round-trips through the published encoding" $ do
|
|
ks <- expectRight $ deriveStealthKeys zeroSeed ChainEth 0
|
|
let ma = accountMetaAddress ks
|
|
St.parseMetaAddress (St.metaAddressBytes ma) `shouldBe` Right ma
|
|
|
|
describe "chain tags" $
|
|
it "round-trip through their stored form" $
|
|
map (parseChain . chainText) [ChainEth, ChainBtc, ChainXmr]
|
|
`shouldBe` map Just [ChainEth, ChainBtc, ChainXmr]
|
|
|
|
describe "receiving a gifted name" receivingTests
|
|
|
|
describe "renewing a name" renewTests
|
|
|
|
describe "seed setup" seedSetupTests
|
|
|
|
-- | The gifting path end to end against the mock chain: Bob derives a
|
|
-- destination from Alice's published meta-address with no handshake, the
|
|
-- transfer carries the announcement, and Alice finds the name by scanning
|
|
-- alone — no message, which is the case a recovery from the phrase faces.
|
|
receivingTests :: Spec
|
|
receivingTests = do
|
|
it "the recipient finds a gift by scanning, with no message" $ do
|
|
(c, svc, g) <- setup
|
|
aliceKs <- expectRight $ deriveStealthKeys zeroSeed ChainEth 0
|
|
bob <- expectRight $ deriveAccount zeroSeed 1
|
|
_ <- giveName c "gifted.simplex" (accountAddress bob)
|
|
|
|
-- Bob only ever sees the published meta-address.
|
|
dest <- expectRight =<< giftDestination g (accountMetaAddress aliceKs)
|
|
tx <- relayGift svc bob "gifted" (St.sdAddress dest) dest
|
|
tx `shouldSatisfy` isRight
|
|
|
|
-- Alice, with no chat message at all, scans the announcement log.
|
|
(as, cursor) <- expectRightIO $ announcementsFrom svc Nothing
|
|
length as `shouldBe` 1
|
|
cursor `shouldBe` "1"
|
|
case scanAnnouncements aliceKs as of
|
|
[(an, addr)] -> do
|
|
addr `shouldBe` St.sdAddress dest
|
|
ota <- expectRight $ oneTimeAccount aliceKs (anEphemeralPubKey an)
|
|
otaAddress ota `shouldBe` St.sdAddress dest
|
|
owner <- expectRightIO $ resolveName svc "gifted.simplex"
|
|
nrvOwner owner `shouldBe` otaAddress ota
|
|
r -> expectationFailure $ "expected exactly one match, got " <> show (length r)
|
|
|
|
it "a bystander holding the meta-address still cannot find it" $ do
|
|
(c, svc, g) <- setup
|
|
aliceKs <- expectRight $ deriveStealthKeys zeroSeed ChainEth 0
|
|
malloryKs <- expectRight $ deriveStealthKeys zeroSeed ChainEth 9
|
|
bob <- expectRight $ deriveAccount zeroSeed 1
|
|
_ <- giveName c "gifted.simplex" (accountAddress bob)
|
|
dest <- expectRight =<< giftDestination g (accountMetaAddress aliceKs)
|
|
_ <- relayGift svc bob "gifted" (St.sdAddress dest) dest
|
|
(as, _) <- expectRightIO $ announcementsFrom svc Nothing
|
|
-- Mallory has Alice's meta-address — it is in her profile — but that is a
|
|
-- public key pair, not a viewing key, so it locates nothing.
|
|
scanAnnouncements malloryKs as `shouldBe` []
|
|
|
|
it "the derived key is what signs for the name afterwards" $ do
|
|
(c, svc, g) <- setup
|
|
aliceKs <- expectRight $ deriveStealthKeys zeroSeed ChainEth 0
|
|
bob <- expectRight $ deriveAccount zeroSeed 1
|
|
_ <- giveName c "gifted.simplex" (accountAddress bob)
|
|
dest <- expectRight =<< giftDestination g (accountMetaAddress aliceKs)
|
|
_ <- relayGift svc bob "gifted" (St.sdAddress dest) dest
|
|
ota <- expectRight $ oneTimeAccount aliceKs (St.sdEphemeralPubKey dest)
|
|
-- The exported key is an ordinary secp256k1 key for that address and
|
|
-- nothing else: this is what keeps a received name non-custodial.
|
|
B.length (exportOneTimeKey ota) `shouldBe` 64
|
|
owner <- expectRightIO $ resolveName svc "gifted.simplex"
|
|
nrvOwner owner `shouldBe` otaAddress ota
|
|
|
|
it "refuses a self-transfer, so announcements cost a real gift" $ do
|
|
(c, svc, g) <- setup
|
|
bob <- expectRight $ deriveAccount zeroSeed 1
|
|
_ <- giveName c "gifted.simplex" (accountAddress bob)
|
|
dest <- expectRight =<< giftDestination g (accountMetaAddress bobKs)
|
|
r <- relayGift svc bob "gifted" (accountAddress bob) dest
|
|
r `shouldBe` Left SESelfTransfer
|
|
(as, _) <- expectRightIO $ announcementsFrom svc Nothing
|
|
as `shouldBe` []
|
|
where
|
|
bobKs = either error id $ deriveStealthKeys zeroSeed ChainEth 1
|
|
|
|
setup :: IO (MockChain, NamesService, TVar ChaChaDRG)
|
|
setup = do
|
|
c <- newMockChain
|
|
-- No commit-reveal wait: these tests are about what happens after a name
|
|
-- exists, not about registration timing.
|
|
setPendingRounds c 0
|
|
g <- C.newRandom
|
|
pure (c, mockNamesService c, g)
|
|
|
|
-- | Put a name in the mock chain owned by @owner@, bypassing purchase.
|
|
giveName :: MockChain -> ByteString -> Address -> IO ()
|
|
giveName c name owner = do
|
|
let svc = mockNamesService c
|
|
pid <- expectRightIO $ buyName svc BuyRequest {brLabel = B.take (B.length name - 8) name, brOwner = owner, brYears = 1, brPayment = PPRedeemCode "test", brContactLink = Nothing, brChannelLink = Nothing}
|
|
-- The mock writes the name on the status poll, mirroring the reveal step of
|
|
-- commit-reveal rather than completing inside buy.
|
|
registrationStatus svc pid >>= \case
|
|
Right RegConfirmed {} -> pure ()
|
|
r -> fail $ "registration did not confirm: " <> show r
|
|
|
|
relayGift :: NamesService -> WalletAccount -> ByteString -> Address -> St.StealthDestination -> IO (Either ServiceError ByteString)
|
|
relayGift svc from label to dest = do
|
|
n <- either (error . show) id <$> currentNonce svc (accountAddress from)
|
|
let intent = TransferName {tiFrom = accountAddress from, tiTo = to, tiLabel = label, tiNonce = n, tiDeadline = 4102444800}
|
|
digest = either error id $ intentDigest mockDeployment intent
|
|
sig = either error id $ signDigest from digest
|
|
relayIntent svc SignedIntent {siIntent = intent, siSignature = sig} $
|
|
Just Announcement {anEphemeralPubKey = St.sdEphemeralPubKey dest, anViewTag = St.sdViewTag dest}
|
|
|
|
expectRightIO :: Show a => IO (Either a b) -> IO b
|
|
expectRightIO = (>>= either (fail . show) pure)
|
|
|
|
-- | The BIP-39 all-zero entropy vector: "abandon abandon … about".
|
|
zeroSeed :: WalletSeed
|
|
zeroSeed = WalletSeed {wsId = SeedId 1, wsEntropy = B.replicate 16 0, wsBackedUp = False}
|
|
|
|
isCompressedPrefix :: Word8 -> Bool
|
|
isCompressedPrefix w = w == 0x02 || w == 0x03
|
|
|
|
isLeft :: Either a b -> Bool
|
|
isLeft = either (const True) (const False)
|
|
|
|
isRight :: Either a b -> Bool
|
|
isRight = not . isLeft
|
|
|
|
expectRight :: Show a => Either a b -> IO b
|
|
expectRight = either (fail . show) pure
|
|
|
|
hex :: ByteString -> String
|
|
hex = concatMap byte . B.unpack
|
|
where
|
|
byte w = let s = showHex w "" in if length s == 1 then '0' : s else s
|
|
|
|
-- | Renewal, around the boundaries where it changes behaviour: the expiry
|
|
-- itself, the end of the grace period, and someone else taking the name.
|
|
renewTests :: Spec
|
|
renewTests = do
|
|
it "extends from the current expiry, so renewing early does not lose time" $ do
|
|
(mc, svc, _) <- setup
|
|
ownerA <- expectRight $ accountAddress <$> deriveAccount zeroSeed 0
|
|
giveName mc "renewme.simplex" ownerA
|
|
exp0 <- nrvExpires <$> expectRightIO (resolveName svc "renewme.simplex")
|
|
exp1 <- expectRightIO $ renewName svc "renewme" 1 (PPRedeemCode "t")
|
|
-- a year added to the old expiry, not to now
|
|
exp1 - exp0 `shouldBe` 31536000
|
|
|
|
it "adds edit credits rather than replacing them" $ do
|
|
(mc, svc, _) <- setup
|
|
ownerA <- expectRight $ accountAddress <$> deriveAccount zeroSeed 0
|
|
giveName mc "renewme.simplex" ownerA
|
|
exp0 <- nrvEditCredits <$> expectRightIO (resolveName svc "renewme.simplex")
|
|
_ <- expectRightIO $ renewName svc "renewme" 1 (PPRedeemCode "t")
|
|
exp1 <- nrvEditCredits <$> expectRightIO (resolveName svc "renewme.simplex")
|
|
-- an unauthenticated renewal must never shrink the owner's allowance
|
|
exp1 `shouldBe` exp0 + editCreditsPerYear
|
|
|
|
it "still works after expiry, while in the grace period" $ do
|
|
(mc, svc, _) <- setup
|
|
ownerA <- expectRight $ accountAddress <$> deriveAccount zeroSeed 0
|
|
giveName mc "renewme.simplex" ownerA
|
|
advanceClock mc (31536000 + 86400) -- a day past expiry
|
|
stale <- nrvExpires <$> expectRightIO (resolveName svc "renewme.simplex")
|
|
exp1 <- expectRightIO $ renewName svc "renewme" 1 (PPRedeemCode "t")
|
|
-- extended from now, not backdated from the stale expiry
|
|
exp1 `shouldSatisfy` (> stale)
|
|
|
|
it "refuses once the grace period has passed" $ do
|
|
(mc, svc, _) <- setup
|
|
ownerA <- expectRight $ accountAddress <$> deriveAccount zeroSeed 0
|
|
giveName mc "renewme.simplex" ownerA
|
|
advanceClock mc (31536000 + gracePeriod + 1)
|
|
renewName svc "renewme" 1 (PPRedeemCode "t") `shouldReturn` Left SENotFound
|
|
|
|
it "the name is still the owner's during grace: nobody else can take it" $ do
|
|
(mc, svc, _) <- setup
|
|
ownerA <- expectRight $ accountAddress <$> deriveAccount zeroSeed 0
|
|
giveName mc "renewme.simplex" ownerA
|
|
advanceClock mc (31536000 + 86400)
|
|
q <- expectRightIO $ quoteName svc "renewme"
|
|
nqAvailable q `shouldBe` False
|
|
|
|
it "becomes available to anyone once grace has passed" $ do
|
|
(mc, svc, _) <- setup
|
|
ownerA <- expectRight $ accountAddress <$> deriveAccount zeroSeed 0
|
|
giveName mc "renewme.simplex" ownerA
|
|
advanceClock mc (31536000 + gracePeriod + 1)
|
|
q <- expectRightIO $ quoteName svc "renewme"
|
|
nqAvailable q `shouldBe` True
|
|
|
|
it "an expired but untaken name is still listed as the owner's" $ do
|
|
(mc, svc, _) <- setup
|
|
ownerA <- expectRight $ accountAddress <$> deriveAccount zeroSeed 0
|
|
giveName mc "renewme.simplex" ownerA
|
|
advanceClock mc (31536000 + gracePeriod + 1)
|
|
owned <- expectRightIO $ namesOwnedBy svc ownerA
|
|
-- past grace and unclaimed: still recoverable by buying it again
|
|
owned `shouldBe` ["renewme.simplex"]
|
|
|
|
it "disappears from the list once someone else registers it" $ do
|
|
(mc, svc, _) <- setup
|
|
ownerA <- expectRight $ accountAddress <$> deriveAccount zeroSeed 0
|
|
otherA <- expectRight $ accountAddress <$> deriveAccount zeroSeed 5
|
|
giveName mc "renewme.simplex" ownerA
|
|
advanceClock mc (31536000 + gracePeriod + 1)
|
|
giveName mc "renewme.simplex" otherA
|
|
expectRightIO (namesOwnedBy svc ownerA) `shouldReturn` []
|
|
expectRightIO (namesOwnedBy svc otherA) `shouldReturn` ["renewme.simplex"]
|
|
|
|
it "cannot be renewed once someone else holds it" $ do
|
|
(mc, svc, _) <- setup
|
|
ownerA <- expectRight $ accountAddress <$> deriveAccount zeroSeed 0
|
|
otherA <- expectRight $ accountAddress <$> deriveAccount zeroSeed 5
|
|
giveName mc "renewme.simplex" ownerA
|
|
advanceClock mc (31536000 + gracePeriod + 1)
|
|
giveName mc "renewme.simplex" otherA
|
|
-- renewal now extends the new holder's registration, not the old owner's:
|
|
-- the old owner has no claim, which is what losing a name means
|
|
e <- expectRightIO (resolveName svc "renewme.simplex")
|
|
nrvOwner e `shouldBe` otherA
|
|
|
|
it "rejects a renewal whose payment is refused" $ do
|
|
(mc, svc, _) <- setup
|
|
ownerA <- expectRight $ accountAddress <$> deriveAccount zeroSeed 0
|
|
giveName mc "renewme.simplex" ownerA
|
|
setPaymentValidator mc (const $ Left "declined")
|
|
renewName svc "renewme" 1 (PPRedeemCode "t") `shouldReturn` Left (SEPaymentRejected "declined")
|
|
|
|
it "refuses to renew a name that never existed" $ do
|
|
(_mc, svc, _) <- setup
|
|
renewName svc "nosuchname" 1 (PPRedeemCode "t") `shouldReturn` Left SENotFound
|
|
|
|
-- | Binding a profile to a wallet. The rule these all defend: a stored seed is
|
|
-- never overwritten and a bound profile is never re-pointed, because either one
|
|
-- silently loses the names that profile owns.
|
|
seedSetupTests :: Spec
|
|
seedSetupTests = do
|
|
it "a new seed is a new row, leaving stored seeds untouched" $
|
|
-- entropy differs, so the rows cannot be the same seed
|
|
wsEntropy zeroSeed `shouldNotBe` wsEntropy otherSeed
|
|
|
|
it "importing the same phrase twice yields the same entropy" $ do
|
|
-- import is deterministic, so re-importing is not a way to lose a key
|
|
a <- expectRight $ importRecoveryKey canonicalPhrase
|
|
b <- expectRight $ importRecoveryKey canonicalPhrase
|
|
a `shouldBe` b
|
|
|
|
it "a phrase round-trips through the stored form" $ do
|
|
e <- expectRight $ importRecoveryKey canonicalPhrase
|
|
let w = WalletSeed {wsId = SeedId 1, wsEntropy = e, wsBackedUp = False}
|
|
expectRight (recoveryKeyPhrase w) >>= (`shouldBe` canonicalPhrase)
|
|
|
|
it "two accounts on one seed never share an address" $ do
|
|
a <- expectRight $ accountAddress <$> deriveAccount zeroSeed 0
|
|
b <- expectRight $ accountAddress <$> deriveAccount zeroSeed 1
|
|
a `shouldNotBe` b
|
|
|
|
it "the same index on different seeds gives different addresses" $ do
|
|
a <- expectRight $ accountAddress <$> deriveAccount zeroSeed 0
|
|
b <- expectRight $ accountAddress <$> deriveAccount otherSeed 0
|
|
a `shouldNotBe` b
|
|
|
|
it "a profile on its own seed is not derivable from the shared one" $ do
|
|
-- what "generate a new seed for this profile" has to mean
|
|
k0 <- expectRight $ deriveStealthKeys zeroSeed ChainEth 0
|
|
k1 <- expectRight $ deriveStealthKeys otherSeed ChainEth 0
|
|
accountMetaAddress k0 `shouldNotBe` accountMetaAddress k1
|
|
|
|
it "rejects a phrase that is not a valid recovery key" $
|
|
importRecoveryKey "not actually a recovery key at all" `shouldSatisfy` isLeft
|
|
|
|
canonicalPhrase :: ByteString
|
|
canonicalPhrase = "abandon abandon abandon abandon abandon abandon abandon abandon abandon abandon abandon about"
|
|
|
|
otherSeed :: WalletSeed
|
|
otherSeed = WalletSeed {wsId = SeedId 2, wsEntropy = B.replicate 16 7, wsBackedUp = False}
|