From dd0dcbf2bc80df7f063a72bed89ed0b455d49d9c Mon Sep 17 00:00:00 2001 From: Alain Brenzikofer Date: Mon, 17 Aug 2026 10:24:27 +0200 Subject: [PATCH] SimpleX names v2: core, CLI and end-to-end tests 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. --- .gitignore | 2 + apps/simplex-names-demo/Main.hs | 230 ++++++++++ cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- simplex-chat.cabal | 34 ++ src/Simplex/Chat/Controller.hs | 101 ++++ src/Simplex/Chat/Core.hs | 2 +- src/Simplex/Chat/Library/Commands.hs | 430 +++++++++++++++++- src/Simplex/Chat/Library/Internal.hs | 12 +- src/Simplex/Chat/Library/Subscriber.hs | 28 +- src/Simplex/Chat/Names/Service.hs | 161 +++++++ src/Simplex/Chat/Names/Service/Default.hs | 35 ++ src/Simplex/Chat/Names/Service/Mock.hs | 391 ++++++++++++++++ src/Simplex/Chat/Names/Snrc.hs | 98 ++++ src/Simplex/Chat/ProfileGenerator.hs | 2 +- src/Simplex/Chat/Protocol.hs | 33 ++ src/Simplex/Chat/Store/Connections.hs | 8 +- src/Simplex/Chat/Store/ContactRequest.hs | 4 +- src/Simplex/Chat/Store/Direct.hs | 24 +- src/Simplex/Chat/Store/Messages.hs | 10 +- src/Simplex/Chat/Store/Postgres/Migrations.hs | 6 +- .../Migrations/M20260806_wallet_seeds.hs | 56 +++ .../M20260807_profile_meta_address.hs | 20 + src/Simplex/Chat/Store/Profiles.hs | 4 +- src/Simplex/Chat/Store/SQLite/Migrations.hs | 6 +- .../Migrations/M20260806_wallet_seeds.hs | 74 +++ .../M20260807_profile_meta_address.hs | 34 ++ .../Store/SQLite/Migrations/chat_schema.sql | 36 +- src/Simplex/Chat/Store/Shared.hs | 34 +- src/Simplex/Chat/Store/Wallets.hs | 292 ++++++++++++ src/Simplex/Chat/Types.hs | 21 +- src/Simplex/Chat/View.hs | 78 +++- src/Simplex/Chat/Wallet.hs | 270 +++++++++++ src/Simplex/Chat/Wallet/Stealth.hs | 155 +++++++ tests/Bots/BroadcastTests.hs | 2 +- tests/Bots/DirectoryTests.hs | 2 +- tests/ChatTests/Names.hs | 65 +++ tests/ChatTests/Profiles.hs | 2 +- tests/ChatTests/Utils.hs | 2 +- tests/ProtocolTests.hs | 4 +- tests/Test.hs | 2 + tests/WalletTests.hs | 363 +++++++++++++++ 42 files changed, 3070 insertions(+), 67 deletions(-) create mode 100644 apps/simplex-names-demo/Main.hs create mode 100644 src/Simplex/Chat/Names/Service.hs create mode 100644 src/Simplex/Chat/Names/Service/Default.hs create mode 100644 src/Simplex/Chat/Names/Service/Mock.hs create mode 100644 src/Simplex/Chat/Names/Snrc.hs create mode 100644 src/Simplex/Chat/Store/Postgres/Migrations/M20260806_wallet_seeds.hs create mode 100644 src/Simplex/Chat/Store/Postgres/Migrations/M20260807_profile_meta_address.hs create mode 100644 src/Simplex/Chat/Store/SQLite/Migrations/M20260806_wallet_seeds.hs create mode 100644 src/Simplex/Chat/Store/SQLite/Migrations/M20260807_profile_meta_address.hs create mode 100644 src/Simplex/Chat/Store/Wallets.hs create mode 100644 src/Simplex/Chat/Wallet.hs create mode 100644 src/Simplex/Chat/Wallet/Stealth.hs create mode 100644 tests/WalletTests.hs diff --git a/.gitignore b/.gitignore index 035d24c6cd..becb0d9c78 100644 --- a/.gitignore +++ b/.gitignore @@ -87,3 +87,5 @@ website/test/stubs-layout-cache/_includes/*.js apps/android/app/release apps/multiplatform/.kotlin/sessions +.idea/ +cabal.project.dev \ No newline at end of file diff --git a/apps/simplex-names-demo/Main.hs b/apps/simplex-names-demo/Main.hs new file mode 100644 index 0000000000..542107ce4e --- /dev/null +++ b/apps/simplex-names-demo/Main.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | End-to-end walkthrough of the SimpleX names UX against a mocked service. +-- +-- The periphery is mocked — no store payment, no relayer, no chain — but the +-- crypto is real: every intent is signed with the profile's derived key, and the +-- mock recovers the signer from the signature and applies the same rules the +-- contracts do. A step that prints OK here is a step the contracts would accept. +-- +-- Run: cabal run simplex-names-demo +module Main (main) where + +import Control.Concurrent.STM +import Control.Monad (forM_, unless) +import Crypto.Random (drgNew) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BC +import Data.Word (Word32) +import Simplex.Chat.Names.Service +import Simplex.Chat.Names.Service.Mock +import Simplex.Chat.Names.Snrc +import Simplex.Chat.Wallet +import qualified Simplex.Messaging.Crypto.BIP39 as B39 +import System.Exit (exitFailure) + +main :: IO () +main = do + g <- newTVarIO =<< drgNew + chain <- newMockChain + let svc = mockNamesService chain + setPendingRounds chain 2 -- stand in for the 60s commit-reveal wait + + section "1. First purchase creates the seed, lazily" + entropy <- atomically $ newSeed B39.MS128 g + let wallet = WalletSeed {wsId = SeedId 1, wsEntropy = entropy, wsBackedUp = False} + phrase <- expect "recovery key" $ recoveryKeyPhrase wallet + say $ " seed created, id " <> bshow (wsId wallet) + say $ " recovery key: " <> phrase + say " (shown once after purchase; a reminder persists until acknowledged)" + + section "2. Each chat profile derives its own address from that one seed" + alice <- expect "alice key" $ deriveAccount wallet 0 + bob <- expect "bob key" $ deriveAccount wallet 1 + say $ " profile 0 (personal) -> " <> bshow (accountAddress alice) + say $ " profile 1 (anonymous) -> " <> bshow (accountAddress bob) + unless (accountAddress alice /= accountAddress bob) $ die "profiles must not share an address" + say " different addresses, so names under the two are unlinked on-chain" + + section "3. Quote a name" + checkQuote svc "ab" "too short is rejected" + checkQuote svc "simplex" "reserved name is rejected" + q <- expectIO "quote" $ quoteName svc "alicechat" + say $ " alicechat.simplex available=" <> bshow (nqAvailable q) <> " price=" <> money (nqPriceCents q) <> "/yr" + + section "4. Pay and register (payment proof mocked, registration sponsored)" + let contactLink = "https://smp16.simplex.im/a#alice-contact" + pid <- + expectIO "purchase" $ + buyName + svc + BuyRequest + { brLabel = "alicechat", + brOwner = accountAddress alice, + brYears = 1, + brPayment = PPAppleReceipt "mock-storekit-jws", + brContactLink = Just contactLink, + brChannelLink = Nothing + } + say $ " purchase accepted: " <> bshow pid + reg <- pollUntilConfirmed svc pid + say $ " registered, tx " <> BC.take 18 (rsTxHash reg) <> "..." + + section "5. The app confirms independently by resolving the name" + rec1 <- expectIO "resolve" $ resolveName svc "alicechat.simplex" + say $ " owner " <> bshow (nrvOwner rec1) + say $ " contact " <> bshow (nrvContact rec1) + unless (nrvOwner rec1 == accountAddress alice) $ die "owner is not our derived address" + say " owner matches our key -> the name is ours; profile claim can now be set" + + section "6. Repoint the name after rotating the contact address" + let newLink = "https://smp11.simplex.im/a#alice-rotated" + n0 <- expectIO "nonce" $ currentNonce svc (accountAddress alice) + txSet <- + relaySigned svc alice $ + SetTextRecord + { sxName = "alicechat.simplex", + sxKey = contactRecordKey, + sxValue = newLink, + sxNonce = n0, + sxDeadline = farFuture + } + say $ " relayed setTextWithSig, tx " <> BC.take 18 txSet <> "..." + rec2 <- expectIO "resolve" $ resolveName svc "alicechat.simplex" + unless (nrvContact rec2 == [newLink]) $ die "record did not change" + say $ " contact now " <> bshow (nrvContact rec2) + + section "7. Forgery and replay are rejected" + -- Bob signs an intent over Alice's name. Use *Bob's* nonce so the request is + -- otherwise well-formed and the ownership check is what actually rejects it — + -- signing with Alice's nonce would trip the nonce check first and prove nothing. + nBob <- expectIO "nonce" $ currentNonce svc (accountAddress bob) + let forged = + SetTextRecord + { sxName = "alicechat.simplex", + sxKey = contactRecordKey, + sxValue = "https://evil.example/a#hijack", + sxNonce = nBob, + sxDeadline = farFuture + } + relaySignedRaw svc bob forged >>= \case + Left SENotOwner -> say " forged by another key: rejected as not the owner" + Left e -> die $ "expected SENotOwner, got: " <> serviceErrorText e + Right _ -> die "a forged intent was accepted" + -- Alice replaying her own already-used nonce. + nAlice <- expectIO "nonce" $ currentNonce svc (accountAddress alice) + relaySignedRaw svc alice forged {sxNonce = nAlice - 1} >>= \case + Left SEBadNonce -> say " replayed nonce: rejected" + Left e -> die $ "expected SEBadNonce, got: " <> serviceErrorText e + Right _ -> die "a replayed nonce was accepted" + -- An expired deadline. + relaySignedRaw svc alice forged {sxNonce = nAlice, sxDeadline = 0} >>= \case + Left SEExpiredIntent -> say " expired deadline: rejected" + Left e -> die $ "expected SEExpiredIntent, got: " <> serviceErrorText e + Right _ -> die "an expired intent was accepted" + + section "8. Gift the name to a contact" + say $ " recipient address " <> bshow (accountAddress bob) <> " (how this is learned is the open decision in the plan)" + n2 <- expectIO "nonce" $ currentNonce svc (accountAddress alice) + txXfer <- + relaySigned svc alice $ + TransferName + { tiFrom = accountAddress alice, + tiTo = accountAddress bob, + tiLabel = "alicechat", + tiNonce = n2, + tiDeadline = farFuture + } + say $ " relayed transferWithSig, tx " <> BC.take 18 txXfer <> "..." + rec3 <- expectIO "resolve" $ resolveName svc "alicechat.simplex" + unless (nrvOwner rec3 == accountAddress bob) $ die "transfer did not move ownership" + say $ " owner now " <> bshow (nrvOwner rec3) + say $ " records carried over: " <> bshow (nrvContact rec3) + + section "9. The previous owner can no longer touch it" + n3 <- expectIO "nonce" $ currentNonce svc (accountAddress alice) + afterGift <- + relaySignedRaw svc alice $ + SetTextRecord + { sxName = "alicechat.simplex", + sxKey = contactRecordKey, + sxValue = "https://smp16.simplex.im/a#taken-back", + sxNonce = n3, + sxDeadline = farFuture + } + case afterGift of + Left SENotOwner -> say " rejected: no longer the owner" + Left e -> say $ " rejected: " <> serviceErrorText e + Right _ -> die "the old owner could still write records" + + section "10. Recovery: wipe the device, re-import the recovery key" + imported <- expect "import" $ importRecoveryKey phrase + let restored = WalletSeed {wsId = SeedId 1, wsEntropy = imported, wsBackedUp = True} + forM_ [(0 :: Word32, "personal"), (1, "anonymous")] $ \(i, label) -> do + pk <- expect "derive" $ deriveAccount restored i + owned <- expectIO "ownedBy" $ namesOwnedBy svc (accountAddress pk) + say $ " profile " <> bshow i <> " (" <> label <> ") " <> bshow (accountAddress pk) <> " owns " <> bshow owned + restoredAlice <- expect "derive" $ deriveAccount restored 0 + unless (accountAddress restoredAlice == accountAddress alice) $ die "recovery derived a different address" + say " same addresses recovered from the phrase alone" + + putStrLn "" + putStrLn "ALL STEPS OK" + +-- helpers + +farFuture :: Integer +farFuture = 1786000000 + 3600 + +section :: ByteString -> IO () +section t = putStrLn "" >> BC.putStrLn t + +say :: ByteString -> IO () +say = BC.putStrLn + +bshow :: Show a => a -> ByteString +bshow = BC.pack . show + +money :: Int -> ByteString +money cents = BC.pack $ "$" <> show (cents `div` 100) <> "." <> pad (cents `mod` 100) + where + pad n = let s = show n in if length s < 2 then '0' : s else s + +die :: ByteString -> IO a +die msg = BC.putStrLn ("FAILED: " <> msg) >> exitFailure + +expect :: ByteString -> Either String a -> IO a +expect what = either (\e -> die (what <> ": " <> BC.pack e)) pure + +expectIO :: ByteString -> IO (Either ServiceError a) -> IO a +expectIO what act = act >>= either (\e -> die (what <> ": " <> serviceErrorText e)) pure + +checkQuote :: NamesService -> ByteString -> ByteString -> IO () +checkQuote svc label why = + quoteName svc label >>= \case + Left e -> say $ " " <> why <> " (" <> serviceErrorText e <> ")" + Right _ -> die $ "expected rejection: " <> label + +pollUntilConfirmed :: NamesService -> PurchaseId -> IO RegistrationStatus +pollUntilConfirmed svc pid = go (10 :: Int) + where + go 0 = die "registration never confirmed" + go n = + expectIO "status" (registrationStatus svc pid) >>= \case + RegPending -> say " waiting for commit-reveal..." >> go (n - 1) + RegFailed e -> die $ "registration failed: " <> e + r@RegConfirmed {} -> pure r + +-- | Sign an intent with a profile key and hand it to the relayer. +relaySigned :: NamesService -> WalletAccount -> Intent -> IO ByteString +relaySigned svc pk intent = + relaySignedRaw svc pk intent >>= either (\e -> die ("relay: " <> serviceErrorText e)) pure + +relaySignedRaw :: NamesService -> WalletAccount -> Intent -> IO (Either ServiceError ByteString) +relaySignedRaw svc pk intent = do + digest <- expect "digest" $ intentDigest mockDeployment intent + sig <- expect "sign" $ signDigest pk digest + relayIntent svc SignedIntent {siIntent = intent, siSignature = sig} Nothing diff --git a/cabal.project b/cabal.project index dbb26ad0f2..f880322c39 100644 --- a/cabal.project +++ b/cabal.project @@ -21,7 +21,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: ee4dd0d8ded0f66f70a8890ce09d69e3610aa276 + tag: c85a895a2f1e01965c89471f8209603b67aeee73 source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 7e422c51fe..0cda6a97dd 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."ee4dd0d8ded0f66f70a8890ce09d69e3610aa276" = "0zahz4011adavfz680wkcqvcrl2f9zjdx6dly6yqkcin4bpr6v3k"; + "https://github.com/simplex-chat/simplexmq.git"."c85a895a2f1e01965c89471f8209603b67aeee73" = "0ziwmw9yxxsq9s22m3vak615xz0hdrcsgygdjjb8n96d8zilv2bd"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 51f2ac8e91..d4c79ed9d2 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -41,6 +41,12 @@ library Simplex.Chat.Badges Simplex.Chat.Badges.CLI Simplex.Chat.Names + Simplex.Chat.Names.Service + Simplex.Chat.Names.Service.Default + Simplex.Chat.Names.Service.Mock + Simplex.Chat.Names.Snrc + Simplex.Chat.Wallet + Simplex.Chat.Wallet.Stealth Simplex.Chat.Call Simplex.Chat.Controller Simplex.Chat.Delivery @@ -82,6 +88,7 @@ library Simplex.Chat.Store.Files Simplex.Chat.Store.Groups Simplex.Chat.Store.Messages + Simplex.Chat.Store.Wallets Simplex.Chat.Store.NoteFolders Simplex.Chat.Store.Profiles Simplex.Chat.Store.RelayRequests @@ -153,6 +160,8 @@ library Simplex.Chat.Store.Postgres.Migrations.M20260716_signed_history Simplex.Chat.Store.Postgres.Migrations.M20260720_server_roles Simplex.Chat.Store.Postgres.Migrations.M20260723_contact_request_rejection + Simplex.Chat.Store.Postgres.Migrations.M20260806_wallet_seeds + Simplex.Chat.Store.Postgres.Migrations.M20260807_profile_meta_address else exposed-modules: Simplex.Chat.Archive @@ -323,6 +332,8 @@ library Simplex.Chat.Store.SQLite.Migrations.M20260716_signed_history Simplex.Chat.Store.SQLite.Migrations.M20260720_server_roles Simplex.Chat.Store.SQLite.Migrations.M20260723_contact_request_rejection + Simplex.Chat.Store.SQLite.Migrations.M20260806_wallet_seeds + Simplex.Chat.Store.SQLite.Migrations.M20260807_profile_meta_address other-modules: Paths_simplex_chat hs-source-dirs: @@ -396,6 +407,28 @@ library , template-haskell ==2.16.* , text >=1.2.4.0 && <1.3 +executable simplex-names-demo + if flag(client_library) + buildable: False + main-is: Main.hs + other-modules: + Paths_simplex_chat + hs-source-dirs: + apps/simplex-names-demo + default-extensions: + StrictData + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -Werror=name-shadowing -threaded + build-depends: + base >=4.7 && <5 + , bytestring + , crypton ==0.34.* + , simplex-chat + , simplexmq + , stm + default-language: Haskell2010 + if flag(client_postgres) + cpp-options: -DdbPostgres + executable simplex-bot if flag(client_library) buildable: False @@ -611,6 +644,7 @@ test-suite simplex-chat-test RemoteTests ValidNames ViewTests + WalletTests API.Docs.Commands API.Docs.Events API.Docs.Generate diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index af20d97bee..923f101f40 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -544,6 +544,44 @@ data ChatCommand | APIConnect {userId :: UserId, incognito :: IncognitoEnabled, preparedLink_ :: Maybe ACreatedConnLink} -- Maybe is used to report link parsing failure as special error | Connect {incognito :: IncognitoEnabled, connTarget_ :: Maybe AConnectTarget} | APIVerifyContactDomain {contactId :: ContactId} + | APINameAddress {userId :: UserId} + | APINameStatus {userId :: UserId} + | -- | Bind this profile to a wallet, explicitly. There is no implicit + -- creation: a profile gets keys only when the user chooses how. + APINameSetupWallet {userId :: UserId, walletSetup :: WalletSetup} + | APINameRenew {userId :: UserId, nameFqdn :: Text, nameYears :: Int, namePaymentToken :: Text} + | APINameRecoveryKey {userId :: UserId} + | APINameRecoveryKeyImport {userId :: UserId, recoveryPhrase :: Text} + | APINameRecoveryKeySaved {userId :: UserId} + | APINameQuote {userId :: UserId, nameLabel :: Text} + | APINameBuy {userId :: UserId, nameLabel :: Text, nameYears :: Int, namePaymentToken :: Text, nameLink :: Maybe Text} + | APINameList {userId :: UserId} + | APINameInfo {userId :: UserId, nameFqdn :: Text} + | APINameSetLink {userId :: UserId, nameFqdn :: Text, nameLink_ :: Text} + | APINameGift {userId :: UserId, nameLabel :: Text, nameRecipient :: Text} + | APINameIncoming {userId :: UserId} + | APINameAccept {userId :: UserId, nameOneTimeAddress :: Text} + | APINameDecline {userId :: UserId, nameOneTimeAddress :: Text} + | APINameExportKey {userId :: UserId, nameOneTimeAddress :: Text} + | APINameRescan {userId :: UserId} + | NameAddress + | NameStatus + | NameSetup {walletSetup :: WalletSetup} + | NameRenew {nameFqdn :: Text, nameYears :: Int} + | NameRecoveryKey + | NameRecoveryKeyImport {recoveryPhrase :: Text} + | NameRecoveryKeySaved + | NameQuoteCmd {nameLabel :: Text} + | NameBuy {nameLabel :: Text, nameYears :: Int, namePaymentToken :: Text, nameLink :: Maybe Text} + | NameList + | NameInfo {nameFqdn :: Text} + | NameSetLink {nameFqdn :: Text, nameLink_ :: Text} + | NameGift {nameLabel :: Text, nameRecipient :: Text} + | NameIncoming + | NameAccept {nameOneTimeAddress :: Text} + | NameDecline {nameOneTimeAddress :: Text} + | NameExportKey {nameOneTimeAddress :: Text} + | NameRescan | APIVerifyGroupDomain {groupId :: GroupId} | APIConnectContactViaAddress UserId IncognitoEnabled ContactId | ConnectSimplex IncognitoEnabled -- UserId (not used in UI) @@ -923,6 +961,30 @@ data ChatResponse | CRAgentSubsDetails {agentSubs :: SubscriptionsInfo} | CRAgentQueuesInfo {agentQueuesInfo :: AgentQueuesInfo} | CRAppSettings {appSettings :: AppSettings} + | CRNameAddress {user :: User, nameAddress :: Text, nameAccount :: Int, nameMetaAddress :: Text} + | -- | Read-only: never creates a wallet. Screens use this to decide what to + -- offer, so that opening one cannot create keys or notify contacts. + CRNameStatus {user :: User, nameHasWallet :: Bool, nameKeySaved :: Bool, nameAnySeed :: Bool} + | CRNameRecoveryKey {user :: User, recoveryPhrase :: Text, recoveryKeySaved :: Bool} + | CRNameQuoted {user :: User, nameLabel :: Text, nameAvailable :: Bool, namePriceCents :: Int} + | CRNameRegistered {user :: User, nameFqdn :: Text, nameTxHash :: Text} + | CRNamesOwned {user :: User, ownedNames :: [OwnedName]} + | CRNameInfo {user :: User, nameFqdn :: Text, nameOwner :: Text, nameContact :: [Text], nameChannel :: [Text], nameExpires :: Int, nameEditCredits :: Int} + | CRNameIntentRelayed {user :: User, nameAction :: Text, nameFqdn :: Text, nameTxHash :: Text} + | -- | A gift was relayed. Carries the ephemeral public key so the client can + -- put it in the message it sends the recipient: with it they can use the + -- name at once, without waiting for a scan of the chain announcement. + CRNameGifted {user :: User, nameFqdn :: Text, nameTxHash :: Text, nameEphemeralPubKey :: Text} + | -- | @nameReRegistered@ is True when the grace period had passed and the + -- name had to be bought again rather than extended: the same outcome for + -- the user, a different act on chain, and only possible while no one else + -- has taken it. + CRNameRenewed {user :: User, nameFqdn :: Text, nameExpires :: Int, nameReRegistered :: Bool} + | CRNamesIncoming {user :: User, incomingNames :: [IncomingName]} + | CRNameAccepted {user :: User, nameOneTimeAddr :: Text, acceptedNames :: [Text]} + | CRNameDeclined {user :: User, nameOneTimeAddr :: Text} + | CRNameKeyExported {user :: User, nameOneTimeAddr :: Text, nameOneTimeKey :: Text} + | CRNameRescanned {user :: User, rescanFound :: Int} | CRCustomChatResponse {user_ :: Maybe User, response :: Text} deriving (Show) @@ -1360,6 +1422,39 @@ data SwitchProgress = SwitchProgress } deriving (Show) +-- | How a profile should get its wallet the first time it needs one. +-- +-- The default is 'WSExistingSeed': one recovery key covers every profile, so +-- there is one thing to write down. The alternatives exist because a profile +-- kept separate on purpose should be able to have keys that are not derivable +-- from the others, and because a restored key has to be able to arrive without +-- displacing anything already stored. +data WalletSetup + = -- | Derive a new account from the seed already in this database. + WSExistingSeed + | -- | Generate a new seed for this profile alone. + WSNewSeed + | -- | Import a recovery key. Always stored alongside existing seeds, never + -- over them. + WSImportSeed {setupPhrase :: Text} + deriving (Show) + +-- | A name this profile holds, with enough to show its state without a second +-- round trip per name. +data OwnedName = OwnedName + { onFqdn :: Text, + onExpires :: Int + } + deriving (Show) + +-- | A name sitting at a one-time address, not yet accepted. Named fields +-- rather than a tuple so typed clients decode it without positional guessing. +data IncomingName = IncomingName + { inAddress :: Text, + inNames :: [Text] + } + deriving (Show) + data RatchetSyncProgress = RatchetSyncProgress { ratchetSyncStatus :: RatchetSyncState, connectionStats :: ConnectionStats @@ -1827,6 +1922,12 @@ $(JQ.deriveJSON defaultJSON ''NtfMsgAckInfo) $(JQ.deriveJSON defaultJSON ''SwitchProgress) +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "WS") ''WalletSetup) + +$(JQ.deriveJSON defaultJSON ''OwnedName) + +$(JQ.deriveJSON defaultJSON ''IncomingName) + $(JQ.deriveJSON defaultJSON ''RatchetSyncProgress) $(JQ.deriveJSON defaultJSON ''DeletedRcvQueue) diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index c382a6dc8e..e321670ddd 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -158,7 +158,7 @@ createActiveUser cc CoreChatOpts {chatRelay, headless} createBot_ userDisplayNam loop = do displayName <- T.pack <$> withPrompt "display name: " getLine createUser loop False $ mkProfile displayName - mkProfile displayName = Profile {displayName, fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing, contactDomain = Nothing} + mkProfile displayName = Profile {displayName, fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing, contactDomain = Nothing, metaAddress = Nothing} createUser onError clientService p = execChatCommand' (CreateActiveUser NewUser {profile = Just p, pastTimestamp = False, userChatRelay = BoolDef chatRelay, clientService = BoolDef clientService}) 0 `runReaderT` cc >>= \case Right (CRActiveUser user) -> pure user diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 88cb4532ef..16e4f107c7 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -58,6 +58,15 @@ import qualified Data.UUID.V4 as V4 import Simplex.Chat.Library.Subscriber import Simplex.Chat.Badges (BadgeCredential (..), LocalBadge (..), maxXFTPFileSize, mkBadgeStatus, verifyCredential) import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim) +import Simplex.Chat.Names.Service +import Simplex.Chat.Names.Service.Default (nameDeployment, namesService) +import Simplex.Chat.Names.Snrc +import qualified Simplex.Chat.Wallet as W +import Simplex.Chat.Wallet.Stealth +import qualified Simplex.Chat.Store.Wallets as WS +import qualified Simplex.Messaging.Eth.Stealth as St +import qualified Simplex.Messaging.Crypto.BIP39 as B39 +import Simplex.Messaging.Eth.Address (Address, checksumAddress, parseAddress) import Simplex.Chat.Call import Simplex.Chat.Controller import Simplex.Chat.Delivery (DeliveryJobScope (..), DeliveryJobSpec (..), DeliveryWorkerScope (..)) @@ -1036,6 +1045,7 @@ processChatCommand cxt nm = \case MCFile t -> t /= "" MCReport {} -> True MCChat {} -> True + MCAssetTransfer {} -> True MCUnknown {} -> True -- TODO [knocking] forward from / to scope APIForwardChatItems toChat@(ChatRef toCType toChatId toScope) sendAsGroup fromChat@(ChatRef fromCType fromChatId _fromScope) itemIds itemTTL -> withUser $ \user -> case toCType of @@ -2381,6 +2391,269 @@ processChatCommand cxt nm = \case _ -> throwError e connectWithPlan user incognito ccLink planSimplexName otherSimplexName plan Connect _ Nothing -> throwChatError CEInvalidConnReq + APINameSetupWallet userId setup -> withUserId userId $ \user -> do + existing <- withStore' $ \db -> WS.boundAccount db user + case existing of + -- Never silently re-point a profile that already has keys: doing so is + -- what made an import discard the imported seed and orphan the names the + -- profile already owned. + Just _ -> throwCmdError "this profile already has a recovery key" + Nothing -> do + g <- asks random + w <- case setup of + WSExistingSeed -> + withStore' (\db -> WS.getWalletSeeds db) >>= \case + (s : _) -> pure s + [] -> withStore' . flip WS.createWalletSeed =<< liftIO (atomically $ W.newSeed B39.MS128 g) + WSNewSeed -> withStore' . flip WS.createWalletSeed =<< liftIO (atomically $ W.newSeed B39.MS128 g) + -- Additive: a new row alongside whatever is stored, never over it. + WSImportSeed phrase -> do + seed <- nameEither . W.importRecoveryKey $ encodeUtf8 phrase + withStore' $ \db -> WS.createWalletSeed db seed + r <- withStore' $ \db -> WS.bindNewAccountOnSeed db user w + -- Contacts need the new address before they can send anything to it. + void $ publishMetaAddress user + pure $ CRNameStatus user True (W.wsBackedUp w) True + APINameStatus userId -> withUserId userId $ \user -> do + ref <- withStore' $ \db -> WS.getAccountRef db user + saved <- case ref of + Nothing -> pure False + Just r -> maybe False W.wsBackedUp <$> withStore' (\db -> WS.getWalletSeed db (W.arSeedId r)) + anySeed <- not . null <$> withStore' WS.getWalletSeeds + pure $ CRNameStatus user (isJust ref) saved anySeed + APINameAddress userId -> withUserId userId $ \user -> do + -- Asking to see your address is an explicit act, so publishing here is + -- fine - it is how someone can receive a name before buying one. What must + -- not happen is a screen calling this on open, which would create a wallet + -- and notify every contact for a user who did nothing. + (_, pk) <- userWalletAccount user + user' <- publishMetaAddress user + ks <- userStealthKeys user' + pure $ + CRNameAddress + user' + (nameAddrText $ W.accountAddress pk) + (fromIntegral . W.arIndex $ W.waRef pk) + (safeDecodeUtf8 . metaAddressHex $ W.accountMetaAddress ks) + APINameRecoveryKey userId -> withUserId userId $ \user -> do + (w, _) <- userWalletAccount user + phrase <- nameEither $ W.recoveryKeyPhrase w + pure $ CRNameRecoveryKey user (safeDecodeUtf8 phrase) (W.wsBackedUp w) + APINameRecoveryKeyImport userId phrase -> withUserId userId $ \user -> + -- Routed through the same explicit setup as everything else, so an import + -- can only ever add a seed alongside what is stored and can never re-point + -- a profile that already has keys. + processChatCommand cxt nm $ APINameSetupWallet userId (WSImportSeed phrase) + APINameRecoveryKeySaved userId -> withUserId userId $ \user -> do + (w, _) <- userWalletAccount user + withStore' $ \db -> WS.setSeedBackedUp db (W.wsId w) True + phrase <- nameEither $ W.recoveryKeyPhrase w + pure $ CRNameRecoveryKey user (safeDecodeUtf8 phrase) True + APINameQuote userId label -> withUserId userId $ \user -> do + q <- nameSvc $ quoteName namesService (encodeUtf8 label) + pure $ CRNameQuoted user label (nqAvailable q) (nqPriceCents q) + APINameBuy userId label years payToken link_ -> withUserId userId $ \user -> do + (_, pk) <- userWalletAccount user + -- The proof comes from the client, which is where the store receipt is + -- obtained. The service validates it; nothing here interprets it. + let req = + BuyRequest + { brLabel = encodeUtf8 label, + brOwner = W.accountAddress pk, + brYears = years, + brPayment = PPRedeemCode (encodeUtf8 payToken), + brContactLink = encodeUtf8 <$> link_, + brChannelLink = Nothing + } + pid <- nameSvc $ buyName namesService req + reg <- namePoll pid (20 :: Int) + case reg of + RegConfirmed {rsTxHash} -> do + -- The wallet now genuinely exists, so contacts are told how to send to + -- it. Doing this on first purchase rather than on first screen view is + -- what keeps seed creation lazy. + void $ publishMetaAddress user + let fqdn = label <> ".simplex" + rec' <- nameSvc $ resolveName namesService (encodeUtf8 fqdn) + unless (nrvOwner rec' == W.accountAddress pk) $ throwCmdError "registered name is not owned by this profile" + pure $ CRNameRegistered user fqdn (safeDecodeUtf8 rsTxHash) + RegFailed e -> throwCmdError $ "registration failed: " <> B.unpack e + RegPending -> throwCmdError "registration is still pending, try again" + APINameList userId -> withUserId userId $ \user -> do + (_, pk) <- userWalletAccount user + -- A name accepted from someone else sits at a one-time address, not the + -- main account. Listing only the main account would hide every gift the + -- user accepted, which is where they would look for it. + accepted <- withStore' $ \db -> WS.getAcceptedAddresses db user W.ChainEth + let addrs = W.accountAddress pk : map WS.otaAddress accepted + ns <- concat <$> mapM (\a -> nameSvc $ namesOwnedBy namesService a) addrs + -- Resolve each so the list can show expiry without the UI asking per name. + owned <- forM ns $ \n -> do + rec' <- nameSvc $ resolveName namesService n + pure OwnedName {onFqdn = safeDecodeUtf8 n, onExpires = fromIntegral (nrvExpires rec')} + pure $ CRNamesOwned user owned + APINameInfo userId fqdn -> withUserId userId $ \user -> do + r <- nameSvc $ resolveName namesService (encodeUtf8 fqdn) + pure $ + CRNameInfo + user + fqdn + (nameAddrText $ nrvOwner r) + (map safeDecodeUtf8 $ nrvContact r) + (map safeDecodeUtf8 $ nrvChannel r) + (fromIntegral $ nrvExpires r) + (fromIntegral $ nrvEditCredits r) + APINameRenew userId fqdn years payToken -> withUserId userId $ \user -> do + (_, pk) <- userWalletAccount user + let label = fromMaybe fqdn $ T.stripSuffix ".simplex" fqdn + payment = PPRedeemCode (encodeUtf8 payToken) + -- Decide before paying, and then make exactly one paid call. Trying to + -- extend and falling back to buying would submit the same receipt twice, + -- and a real store receipt is consumed by the first call. + rec_ <- liftIO $ resolveName namesService (encodeUtf8 fqdn) + case rec_ of + Right r | nrvOwner r /= W.accountAddress pk -> do + -- Someone else holds it now. Extending would pay to renew their + -- registration and report it as the user's own. + accepted <- withStore' $ \db -> WS.getAcceptedAddresses db user W.ChainEth + if nrvOwner r `elem` map WS.otaAddress accepted + then renewOwned label years payment fqdn user + else throwCmdError "this name now belongs to someone else" + Right _ -> renewOwned label years payment fqdn user + -- No registration at all: past grace, or never existed. Buying is the + -- only path, and it fails by itself if someone else has taken it. + Left SENotFound -> do + let req = + BuyRequest + { brLabel = encodeUtf8 label, + brOwner = W.accountAddress pk, + brYears = years, + brPayment = payment, + brContactLink = Nothing, + brChannelLink = Nothing + } + pid <- nameSvc $ buyName namesService req + namePoll pid (20 :: Int) >>= \case + RegConfirmed {rsExpires} -> pure $ CRNameRenewed user fqdn (fromIntegral rsExpires) True + RegFailed e -> throwCmdError $ "could not register the name again: " <> B.unpack e + RegPending -> throwCmdError "registration is taking too long, try again" + Left e -> throwCmdError . B.unpack $ serviceErrorText e + APINameSetLink userId fqdn newLink -> withUserId userId $ \user -> do + -- Sign with whatever key owns this name. A name received as a gift is held + -- by a one-time address, not the profile's main account, so signing with + -- the main key would be rejected as not-the-owner and a gifted name could + -- never be pointed anywhere. + pk <- nameSigningKey user fqdn + n <- nameSvc $ currentNonce namesService (W.accountAddress pk) + tx <- + nameRelay pk $ + SetTextRecord + { sxName = encodeUtf8 fqdn, + sxKey = contactRecordKey, + sxValue = encodeUtf8 newLink, + sxNonce = n, + sxDeadline = nameDeadline + } + pure $ CRNameIntentRelayed user "link" fqdn tx + APINameGift userId label recipient -> withUserId userId $ \user -> do + (_, pk) <- userWalletAccount user + -- The recipient is a published meta-address, not an address: sending to a + -- plain address would link them to the name for every chain observer. The + -- destination is derived here, once, and the ephemeral key rides the + -- transfer so they can rediscover it from their recovery phrase alone. + -- + -- @name takes it from the contact's profile, which is the whole point of + -- publishing it there: no handshake, nothing to paste. + (ma, ct_) <- case T.stripPrefix "@" recipient of + Just cName -> do + ct@Contact {profile = LocalProfile {metaAddress = ma_}} <- withFastStore $ \db -> getContactByName db cxt user cName + case ma_ of + Nothing -> throwCmdError "that contact cannot receive names yet - they need a newer app version" + Just ma' -> (,Just ct) <$> nameEither (parseMetaAddressHex $ encodeUtf8 ma') + -- A raw meta-address has no contact to message, so the recipient finds it + -- by scanning the announcement instead. + Nothing -> (,Nothing) <$> nameEither (parseMetaAddressHex $ encodeUtf8 recipient) + g <- asks random + dest <- nameEither =<< liftIO (giftDestination g ma) + n <- nameSvc $ currentNonce namesService (W.accountAddress pk) + tx <- + nameRelayAnnouncing pk (Just $ announcementOf dest) $ + TransferName + { tiFrom = W.accountAddress pk, + tiTo = St.sdAddress dest, + tiLabel = encodeUtf8 label, + tiNonce = n, + tiDeadline = nameDeadline + } + let fqdn = label <> ".simplex" + ephHex = safeDecodeUtf8 . bytesHex $ St.sdEphemeralPubKey dest + -- Tell the recipient, in a form their app understands. The ephemeral key + -- travels with it, so their client records the destination on arrival + -- instead of scanning the chain for it. Sent from here rather than from a + -- client so every client behaves the same, and via sendDirectContactMessage + -- rather than a nested command, which would emit this command's response + -- twice. + forM_ ct_ $ \ct -> do + let mc = MCAssetTransfer {text = "You were given the SimpleX name " <> fqdn, transfer = AssetTransfer {kind = "simplexName", asset = fqdn, ephemeralPubKey = Just ephHex}} + -- Best-effort: the transfer already landed on chain above, so a failed + -- notification must not fail the command and report the gift as failed + -- for a name that has already moved. Protocol message only; the sender's + -- bubble is the client's business. + (void (sendDirectContactMessage user ct $ XMsgNew $ mcSimple mc)) `catchAllErrors` \_ -> pure () + -- The profile must stop advertising a name it no longer owns, or contacts + -- keep seeing it and the user's own list reports it as not managed here. + let User {profile = LocalProfile {contactDomain}} = user + claimed = safeDecodeUtf8 . strEncode . claimDomain <$> contactDomain + when (claimed == Just fqdn) . void . processChatCommand cxt nm $ APISetUserDomain userId Nothing + pure $ CRNameGifted user fqdn tx ephHex + APINameIncoming userId -> withUserId userId $ \user -> do + rows <- withStore' $ \db -> WS.getIncomingAddresses db user W.ChainEth + ns <- forM rows $ \r -> IncomingName (nameAddrText $ WS.otaAddress r) <$> namesAt (WS.otaAddress r) + pure $ CRNamesIncoming user ns + APINameAccept userId addrText -> withUserId userId $ \user -> do + addr <- nameEither $ parseAddress (encodeUtf8 addrText) + _ <- oneTimeAccountFor user addr + ns <- namesAt addr + -- Accepting is the act that links this profile to the name on chain. The + -- record rewrite and the edit-credit top-up that pay for it are Workstream + -- A and D; until those exist this records the decision only. + withStore' $ \db -> WS.acceptOneTimeAddress db user W.ChainEth addr + pure $ CRNameAccepted user (nameAddrText addr) ns + APINameDecline userId addrText -> withUserId userId $ \user -> do + addr <- nameEither $ parseAddress (encodeUtf8 addrText) + withStore' $ \db -> WS.declineOneTimeAddress db user W.ChainEth addr + pure $ CRNameDeclined user (nameAddrText addr) + APINameExportKey userId addrText -> withUserId userId $ \user -> do + addr <- nameEither $ parseAddress (encodeUtf8 addrText) + ota <- oneTimeAccountFor user addr + pure $ CRNameKeyExported user (nameAddrText addr) (safeDecodeUtf8 $ exportOneTimeKey ota) + APINameRescan userId -> withUserId userId $ \user -> do + ks <- userStealthKeys user + cursor <- withStore' $ \db -> WS.getScannedTo db user + (as, cursor') <- nameSvc $ announcementsFrom namesService cursor + let found = scanAnnouncements ks as + forM_ found $ \(an, addr) -> + withStore' $ \db -> WS.recordOneTimeAddress db user W.ChainEth addr (anEphemeralPubKey an) + withStore' $ \db -> WS.setScannedTo db user cursor' + pure $ CRNameRescanned user (length found) + NameAddress -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameAddress userId + NameStatus -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameStatus userId + NameSetup setup -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameSetupWallet userId setup + NameRenew n y -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameRenew userId n y "dev-cli-payment" + NameRecoveryKey -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameRecoveryKey userId + NameRecoveryKeyImport phrase -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameRecoveryKeyImport userId phrase + NameRecoveryKeySaved -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameRecoveryKeySaved userId + NameQuoteCmd l -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameQuote userId l + NameBuy l y t lnk -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameBuy userId l y t lnk + NameList -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameList userId + NameInfo n -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameInfo userId n + NameSetLink n l -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameSetLink userId n l + NameGift l r -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameGift userId l r + NameIncoming -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameIncoming userId + NameAccept a -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameAccept userId a + NameDecline a -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameDecline userId a + NameExportKey a -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameExportKey userId a + NameRescan -> withUser $ \User {userId} -> processChatCommand cxt nm $ APINameRescan userId APIVerifyContactDomain contactId -> withUser $ \user -> do ct@Contact {profile = LocalProfile {contactDomain}, preparedContact} <- withFastStore $ \db -> getContact db cxt user contactId let connLink_ = preparedContact >>= \PreparedContact {connLinkToConnect = ACCL m (CCLink _ sLnk_)} -> ACSL m <$> sLnk_ @@ -3959,6 +4232,24 @@ processChatCommand cxt nm = \case pure fileSize updateProfile :: User -> Profile -> CM ChatResponse updateProfile user p' = updateProfile_ user p' True $ withFastStore $ \db -> updateUserProfile db user p' + -- | Put this profile's stealth meta-address into the profile, so contacts + -- can send it a name with no handshake. Idempotent, and a no-op unless the + -- value changed - which it does when a different recovery key is imported, + -- and that change must reach contacts or gifts land at an address this + -- device can no longer find. + -- + -- Incognito profiles are unaffected: they are generated per connection by + -- 'Simplex.Chat.ProfileGenerator' and never carry a meta-address. + publishMetaAddress :: User -> CM User + publishMetaAddress user@User {profile = lp} = do + ks <- userStealthKeys user + let ma = Just . safeDecodeUtf8 . metaAddressHex $ W.accountMetaAddress ks + p@Profile {metaAddress = published} = fromLocalProfile lp + if published == ma + then pure user + else do + _ <- updateProfile user (p {metaAddress = ma} :: Profile) + fromMaybe user <$> (asks currentUser >>= readTVarIO) updateProfile_ :: User -> Profile -> Bool -> CM User -> CM ChatResponse updateProfile_ user@User {profile = p@LocalProfile {displayName = n}} p'@Profile {displayName = n', image = img'} shouldUpdateAddressData updateUser | p' == fromLocalProfile p = pure $ CRUserProfileNoChange user @@ -5701,6 +5992,42 @@ chatCommandP = ("/connect" <|> "/c") *> (AddContact <$> incognitoP), ("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeTill isSpace $> Nothing)), "/_verify domain @" *> (APIVerifyContactDomain <$> A.decimal), + "/_name address " *> (APINameAddress <$> A.decimal), + "/_name status " *> (APINameStatus <$> A.decimal), + "/_name setup " *> (APINameSetupWallet <$> A.decimal <* A.space <*> walletSetupP), + "/_name renew " *> (APINameRenew <$> A.decimal <* A.space <*> nameWordP <* A.space <*> A.decimal <* A.space <*> (safeDecodeUtf8 <$> A.takeTill (== ' '))), + "/_name key import " *> (APINameRecoveryKeyImport <$> A.decimal <* A.space <*> textP), + "/_name key saved " *> (APINameRecoveryKeySaved <$> A.decimal), + "/_name key " *> (APINameRecoveryKey <$> A.decimal), + "/_name quote " *> (APINameQuote <$> A.decimal <* A.space <*> nameWordP), + "/_name buy " *> (APINameBuy <$> A.decimal <* A.space <*> nameWordP <* A.space <*> A.decimal <* A.space <*> (safeDecodeUtf8 <$> A.takeTill (== ' ')) <*> optional (A.space *> textP)), + "/_name list " *> (APINameList <$> A.decimal), + "/_name info " *> (APINameInfo <$> A.decimal <* A.space <*> nameWordP), + "/_name link " *> (APINameSetLink <$> A.decimal <* A.space <*> nameWordP <* A.space <*> textP), + "/_name gift " *> (APINameGift <$> A.decimal <* A.space <*> nameWordP <* A.space <*> textP), + "/_name incoming " *> (APINameIncoming <$> A.decimal), + "/_name accept " *> (APINameAccept <$> A.decimal <* A.space <*> textP), + "/_name decline " *> (APINameDecline <$> A.decimal <* A.space <*> textP), + "/_name export " *> (APINameExportKey <$> A.decimal <* A.space <*> textP), + "/_name rescan " *> (APINameRescan <$> A.decimal), + "/names address" $> NameAddress, + "/names status" $> NameStatus, + "/names setup " *> (NameSetup <$> walletSetupP), + "/names renew " *> (NameRenew <$> nameWordP <*> (A.space *> A.decimal <|> pure 1)), + "/names key import " *> (NameRecoveryKeyImport <$> textP), + "/names key saved" $> NameRecoveryKeySaved, + "/names key" $> NameRecoveryKey, + "/names quote " *> (NameQuoteCmd <$> nameWordP), + "/names buy " *> (NameBuy <$> nameWordP <*> (A.space *> A.decimal <|> pure 1) <*> pure "dev-cli-payment" <*> optional (A.space *> textP)), + "/names list" $> NameList, + "/names info " *> (NameInfo <$> nameWordP), + "/names link " *> (NameSetLink <$> nameWordP <* A.space <*> textP), + "/names gift " *> (NameGift <$> nameWordP <* A.space <*> textP), + "/names incoming" $> NameIncoming, + "/names accept " *> (NameAccept <$> textP), + "/names decline " *> (NameDecline <$> textP), + "/names export " *> (NameExportKey <$> textP), + "/names rescan" $> NameRescan, "/_verify domain #" *> (APIVerifyGroupDomain <$> A.decimal), ForwardMessage <$> chatNameP <* " <- @" <*> displayNameP <* A.space <*> msgTextP, ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayNameP <* A.space <* A.char '@' <*> (Just <$> displayNameP) <* A.space <*> msgTextP, @@ -5906,7 +6233,7 @@ chatCommandP = newUserP relay = do (cName, shortDescr) <- profileNameDescr service <- (" service=" *> onOffP) <|> pure False - let profile = Just Profile {displayName = cName, fullName = "", shortDescr, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing, contactDomain = Nothing} + let profile = Just Profile {displayName = cName, fullName = "", shortDescr, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing, contactDomain = Nothing, metaAddress = Nothing} pure NewUser {profile, pastTimestamp = False, userChatRelay = BoolDef relay, clientService = BoolDef service} newBotUserP = do files_ <- optional $ "files=" *> onOffP <* A.space @@ -5915,7 +6242,7 @@ chatCommandP = let preferences = case files_ of Just True -> Nothing _ -> Just (emptyChatPrefs :: Preferences) {files = Just FilesPreference {allow = FANo}} - profile = Just Profile {displayName = cName, fullName = "", shortDescr, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences, badge = Nothing, contactDomain = Nothing} + profile = Just Profile {displayName = cName, fullName = "", shortDescr, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences, badge = Nothing, contactDomain = Nothing, metaAddress = Nothing} pure NewUser {profile, pastTimestamp = False, userChatRelay = BoolDef False, clientService = BoolDef service} jsonP :: J.FromJSON a => Parser a jsonP = J.eitherDecodeStrict' <$?> A.takeByteString @@ -5937,6 +6264,11 @@ chatCommandP = descr <- A.takeWhile1 isSpace *> (T.dropWhileEnd isSpace <$> textP) <|> pure "" pure $ if T.null descr then Nothing else Just $ T.take 160 descr textP = safeDecodeUtf8 <$> A.takeByteString + walletSetupP = + ("existing" $> WSExistingSeed) + <|> ("new" $> WSNewSeed) + <|> ("import " *> (WSImportSeed <$> textP)) + nameWordP = safeDecodeUtf8 <$> A.takeWhile1 (not . isSpace) pwdP = jsonP <|> (UserPwd . safeDecodeUtf8 <$> A.takeTill (== ' ')) verifyCodeP = safeDecodeUtf8 <$> A.takeWhile (\c -> isDigit c || c == ' ') msgTextP = jsonP <|> textP @@ -6099,3 +6431,97 @@ mkValidName = dropWhileEnd isSpace . take 50 . reverse . fst3 . foldl' addChar ( validFirstNameChar = isLetter c || cat == DecimalNumber || cat == OtherSymbol validFirstChar = validFirstNameChar || cat == CurrencySymbol || cat == MathSymbol prohibited = ".,;/\\#@'\"`~" :: String + +-- SimpleX names helpers ------------------------------------------------------- +-- +-- The service is the mock today (see Simplex.Chat.Names.Service.Default); these +-- helpers do not know that, so swapping in the SMP-backed client changes only +-- that module. + +-- | The profile's derived key, creating the seed and binding on first use. +-- Single-seed by construction: the binding reuses the database's first wallet. +userWalletAccount :: User -> CM (W.WalletSeed, W.WalletAccount) +userWalletAccount user = do + g <- asks random + (w, r) <- withStore' $ \db -> WS.getOrCreateAccountRef db user (atomically $ W.newSeed B39.MS128 g) + pk <- nameEither $ W.deriveAccount w (W.arIndex r) + pure (w, pk) + +nameEither :: Either String a -> CM a +nameEither = either throwCmdError pure + +nameSvc :: IO (Either ServiceError a) -> CM a +nameSvc act = liftIO act >>= either (throwCmdError . B.unpack . serviceErrorText) pure + +-- | Poll registration to completion, standing in for the commit-reveal wait. +namePoll :: PurchaseId -> Int -> CM RegistrationStatus +namePoll pid n + | n <= 0 = pure RegPending + | otherwise = + nameSvc (registrationStatus namesService pid) >>= \case + RegPending -> liftIO (threadDelay 50000) >> namePoll pid (n - 1) + r -> pure r + +-- | The key that owns a name: the profile's main account, or the one-time +-- account it was received at. +nameSigningKey :: User -> Text -> CM W.WalletAccount +nameSigningKey user fqdn = do + (_, pk) <- userWalletAccount user + rec' <- nameSvc $ resolveName namesService (encodeUtf8 fqdn) + if nrvOwner rec' == W.accountAddress pk + then pure pk + else do + ota <- oneTimeAccountFor user (nrvOwner rec') + pure W.WalletAccount {W.waRef = W.waRef pk, W.waKey = otaKey ota} + +-- | Extend a registration the user holds. +renewOwned :: Text -> Int -> PaymentProof -> Text -> User -> CM ChatResponse +renewOwned label years payment fqdn user = + liftIO (renewName namesService (encodeUtf8 label) years payment) >>= \case + Right expires -> pure $ CRNameRenewed user fqdn (fromIntegral expires) False + Left e -> throwCmdError . B.unpack $ serviceErrorText e + +-- | Sign an intent with the profile key and hand it to the relayer. +nameRelay :: W.WalletAccount -> Intent -> CM Text +nameRelay pk = nameRelayAnnouncing pk Nothing + +nameRelayAnnouncing :: W.WalletAccount -> Maybe Announcement -> Intent -> CM Text +nameRelayAnnouncing pk announce intent = do + digest <- nameEither $ intentDigest nameDeployment intent + sig <- nameEither $ W.signDigest pk digest + safeDecodeUtf8 <$> nameSvc (relayIntent namesService SignedIntent {siIntent = intent, siSignature = sig} announce) + +-- | The profile's stealth keys, on the same seed and account index as its +-- main address. +userStealthKeys :: User -> CM W.StealthKeys +userStealthKeys user = do + g <- asks random + (w, r) <- withStore' $ \db -> WS.getOrCreateAccountRef db user (atomically $ W.newSeed B39.MS128 g) + nameEither $ W.deriveStealthKeys w W.ChainEth (W.arIndex r) + +-- | Re-derive the key for a destination this profile has recorded. Fails if it +-- was never seen: the ephemeral key is what makes the address reachable, and it +-- is not recoverable from the address itself. +oneTimeAccountFor :: User -> Address -> CM OneTimeAccount +oneTimeAccountFor user addr = do + row <- withStore' $ \db -> WS.getOneTimeAddress db user W.ChainEth addr + case row of + Nothing -> throwCmdError "no received name at that address - try /names rescan" + Just r -> do + ks <- userStealthKeys user + nameEither $ oneTimeAccount ks (WS.otaEphemeralPubKey r) + +announcementOf :: St.StealthDestination -> Announcement +announcementOf d = Announcement {anEphemeralPubKey = St.sdEphemeralPubKey d, anViewTag = St.sdViewTag d} + +namesAt :: Address -> CM [Text] +namesAt addr = map safeDecodeUtf8 <$> nameSvc (namesOwnedBy namesService addr) + + + +nameAddrText :: Address -> Text +nameAddrText = safeDecodeUtf8 . checksumAddress + +-- | Intents expire; the mock's clock is fixed, so this is a fixed horizon. +nameDeadline :: Integer +nameDeadline = 1786000000 + 3600 diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index ca6440d155..7491d88eb1 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -332,6 +332,8 @@ quoteContent mc qmc ciFile_ MCVoice {} -> False MCReport {} -> False MCChat {} -> True + -- a quote of a transfer is just its fallback text, nothing large + MCAssetTransfer {} -> False MCUnknown {} -> True qText = msgContentText qmc getFileName :: CIFile d -> String @@ -1257,8 +1259,13 @@ memberInfo g m@GroupMember {memberId, memberRole, memberProfile, memberPubKey, a } redactedMemberProfile :: GroupInfo -> GroupMember -> Profile -> Profile -redactedMemberProfile g m Profile {displayName, fullName, shortDescr, description, image, contactLink = lnk, peerType, badge, contactDomain} = - Profile {displayName, fullName, shortDescr = removeSimplexLink True =<< shortDescr, description = removeSimplexLink False =<< description, image, contactLink, preferences = Nothing, peerType, badge, contactDomain = redactedDomain} +redactedMemberProfile g m Profile {displayName, fullName, shortDescr, description, image, contactLink = lnk, peerType, badge, contactDomain, metaAddress} = + -- metaAddress is passed through to group members deliberately. It is a public + -- key pair, not an address: holding it lets someone send this member a name + -- and nothing else - it cannot locate what was sent, nor link two gifts to + -- each other, since that needs the private viewing key. Redacting it would + -- only break gifting for people known through a group. + Profile {displayName, fullName, shortDescr = removeSimplexLink True =<< shortDescr, description = removeSimplexLink False =<< description, image, contactLink, preferences = Nothing, peerType, badge, contactDomain = redactedDomain, metaAddress} where contactLink = if allowSimplexLinks then lnk else Nothing redactedDomain = if allowDirect then (\d -> d {proof = Nothing} :: SimplexDomainClaim) <$> contactDomain else Nothing @@ -3210,6 +3217,7 @@ simplexTeamContactProfile = image = Just simplexChatImage, contactLink = Just $ CLFull adminContactReq, peerType = Nothing, + metaAddress = Nothing, preferences = Nothing, badge = Nothing, contactDomain = Nothing diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index b3f3a0fbe6..fcd656a4d9 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -39,7 +39,7 @@ import qualified Data.Set as S import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime) import Data.Time.Format (defaultTimeLocale, formatTime) import qualified Data.UUID as UUID @@ -50,6 +50,9 @@ import Simplex.Chat.Controller import Simplex.Chat.Delivery import Simplex.Chat.Files (getChatTempDirectory) import Simplex.Chat.Library.Internal +import qualified Simplex.Chat.Store.Wallets as WS +import qualified Simplex.Chat.Wallet as W +import Simplex.Chat.Wallet.Stealth (oneTimeAccount, otaAddress, parseHexBytes) import Simplex.Chat.Web (channelContentChanged, channelProfileUpdated, channelRemoved) import Simplex.Chat.Messages import Simplex.Chat.Messages.Batch (batchDeliveryTasks1, batchProfiles, batchProfilesWithBody, encodeBinaryBatch, encodeFwdElement, maxBatchElementSize) @@ -1862,10 +1865,33 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = messageError :: Text -> CM () messageError = toView . CEvtMessageError user "error" + -- | Record a destination handed over in a message, so it is usable at once. + -- + -- The sender's ephemeral key is enough to derive the one-time address, so a + -- gift appears under "names sent to you" on arrival instead of waiting for + -- the recipient to scan the chain. The on-chain announcement carries the + -- same key and covers the case where this message never arrives, or the + -- device is restored from the recovery key alone. + -- + -- Best effort throughout: anything unrecognised leaves the message as an + -- ordinary one rather than failing delivery. + recordAssetTransfer :: AssetTransfer -> CM () + recordAssetTransfer AssetTransfer {kind, ephemeralPubKey} + | kind /= "simplexName" = pure () + | otherwise = forM_ ephemeralPubKey $ \ephHex -> + forM_ (eitherToMaybe . parseHexBytes $ encodeUtf8 ephHex) $ \eph -> do + ref_ <- withStore' $ \db -> WS.getAccountRef db user + forM_ ref_ $ \ref -> do + w_ <- withStore' $ \db -> WS.getWalletSeed db (W.arSeedId ref) + forM_ w_ $ \w -> + forM_ (eitherToMaybe $ W.deriveStealthKeys w W.ChainEth (W.arIndex ref) >>= (`oneTimeAccount` eph)) $ \ota -> + withStore' $ \db -> WS.recordOneTimeAddress db user W.ChainEth (otaAddress ota) eph + newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM () newContentMessage ct mc msg@RcvMessage {sharedMsgId_} msgMeta = do let MsgContainer {content = c, file = fInv_} = mc content <- case c of + MCAssetTransfer {transfer} -> recordAssetTransfer transfer $> c MCChat {text, chatLink, ownerSig = Just LinkOwnerSig {chatBinding = B64UrlByteString binding}} -> do keepSig <- case contactConn ct of Nothing -> pure False diff --git a/src/Simplex/Chat/Names/Service.hs b/src/Simplex/Chat/Names/Service.hs new file mode 100644 index 0000000000..898e257eba --- /dev/null +++ b/src/Simplex/Chat/Names/Service.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | The client's view of the SimpleX names service. +-- +-- The service is reached over an ordinary SimpleX connection, so this is a +-- plain request/response interface with no chain access of its own: the app +-- never builds a transaction, reads a nonce or broadcasts anything. It quotes, +-- pays, hands over signed intents, and independently confirms the result by +-- resolving the name. +-- +-- 'NamesService' is a record of operations rather than a class so that the mock +-- and the real SMP-backed client are interchangeable at the call site. +module Simplex.Chat.Names.Service + ( NamesService (..), + PaymentProof (..), + BuyRequest (..), + NameQuote (..), + PurchaseId (..), + RegistrationStatus (..), + NameRecordView (..), + ServiceError (..), + serviceErrorText, + ) +where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Simplex.Chat.Names.Snrc (SignedIntent) +import Simplex.Chat.Wallet.Stealth (Announcement) +import Simplex.Messaging.Eth.Address (Address) + +-- | Proof that the store (or a web checkout) was paid. Mirrors the shape +-- already sketched by 'Simplex.Chat.Badges.BadgePurchase', so the two can share +-- a validator server-side. +data PaymentProof + = PPAppleReceipt ByteString + | PPGoogleToken ByteString + | PPStripeSession ByteString + | PPRedeemCode ByteString + deriving (Eq, Show) + +data BuyRequest = BuyRequest + { brLabel :: ByteString, -- ^ the label only, without the TLD + brOwner :: Address, -- ^ the profile's derived address + -- | 1-10 years, bought outright. There is no subscription: extension is + -- another purchase. + brYears :: Int, + brPayment :: PaymentProof, + brContactLink :: Maybe ByteString, + brChannelLink :: Maybe ByteString + } + deriving (Eq, Show) + +data NameQuote = NameQuote + { nqLabel :: ByteString, + nqAvailable :: Bool, + nqPriceCents :: Int, + nqYears :: Int + } + deriving (Eq, Show) + +newtype PurchaseId = PurchaseId ByteString + deriving (Eq, Ord, Show) + +data RegistrationStatus + = -- | committed on-chain, waiting out minCommitmentAge + RegPending + | RegConfirmed {rsTxHash :: ByteString, rsExpires :: Integer} + | RegFailed ByteString + deriving (Eq, Show) + +-- | What resolution returns — the same fields the SMP @RSLV@ path already +-- carries, which is how the app confirms a purchase without trusting the +-- service. +data NameRecordView = NameRecordView + { nrvName :: ByteString, + nrvOwner :: Address, + nrvContact :: [ByteString], + nrvChannel :: [ByteString], + nrvExpires :: Integer, + -- | Relayed record edits still available on this name. Granted at + -- registration and renewal, consumed only by the sponsored path. + nrvEditCredits :: Integer + } + deriving (Eq, Show) + +data ServiceError + = SEUnavailable ByteString + | SENameTaken + | SENameInvalid ByteString + | SEPaymentRejected ByteString + | SEBadSignature + | SENotOwner + | SEBadNonce + | SEExpiredIntent + | SENotFound + | -- | The relayer has no registration credits left. A hard service stop: + -- only the beneficiary multisig can grant more. + SENoRegistrarCredits + | -- | This name's relayed-edit allowance is exhausted until renewal. + SENoEditCredits + | -- | @transferWithSig@ rejects @to == from@: a self-transfer would emit an + -- announcement for the cost of gas alone, which is how the scan set stays + -- bounded by real gifts. + SESelfTransfer + deriving (Eq, Show) + +serviceErrorText :: ServiceError -> ByteString +serviceErrorText = \case + SEUnavailable e -> "service unavailable: " <> e + SENameTaken -> "that name is already taken" + SENameInvalid e -> "invalid name: " <> e + SEPaymentRejected e -> "payment rejected: " <> e + SEBadSignature -> "signature did not verify" + SENotOwner -> "not the owner of that name" + SEBadNonce -> "wrong nonce, refresh and retry" + SEExpiredIntent -> "the signed request expired" + SENotFound -> "name not found" + SENoRegistrarCredits -> "the registration service is out of credits, please report this" + SENoEditCredits -> "no record changes left for this name until you extend it" + SESelfTransfer -> "cannot send a name to the address that already owns it" + +data NamesService = NamesService + { quoteName :: ByteString -> IO (Either ServiceError NameQuote), + buyName :: BuyRequest -> IO (Either ServiceError PurchaseId), + registrationStatus :: PurchaseId -> IO (Either ServiceError RegistrationStatus), + -- | Hand a user-signed intent to the relayer, which pays the gas. + -- + -- The announcement rides a transfer rather than travelling separately: it + -- is what lets the recipient rediscover a gifted name from the recovery + -- phrase alone. It is not covered by the signature — the contract takes it + -- as a plain argument — so a hostile relayer can drop or corrupt it. That + -- costs discoverability by scan, not the name, and the sender's chat + -- message carries the same ephemeral key anyway. + relayIntent :: SignedIntent -> Maybe Announcement -> IO (Either ServiceError ByteString), + -- | Announcement ranges for a recovery scan, from an opaque cursor. + -- + -- The service serves the raw range and the client does the matching: a + -- viewing key never leaves the device, so there is no delegated-scanning + -- trade to make. + announcementsFrom :: Maybe Text -> IO (Either ServiceError ([Announcement], Text)), + -- | Independent confirmation path; in production this is SMP @RSLV@. + resolveName :: ByteString -> IO (Either ServiceError NameRecordView), + -- | Owner to names, for recovery-key import. Advisory: each name is + -- confirmed with 'resolveName', so a lying service can withhold names but + -- cannot invent them. + namesOwnedBy :: Address -> IO (Either ServiceError [ByteString]), + -- | Extend a registration. Works while the name is live and through the + -- grace period after it expires. Past grace it fails with 'SENotFound': + -- the registration is gone and the name has to be bought again, which is + -- the same act for the user but a different one on chain. + -- + -- Ungated, mirroring the contract: anyone may renew anyone's name. Credits + -- are therefore added, never set, so a stranger's renewal cannot shrink an + -- owner's allowance. + renewName :: ByteString -> Int -> PaymentProof -> IO (Either ServiceError Integer), + currentNonce :: Address -> IO (Either ServiceError Integer), + -- | Relayed edits left on a name, for display before the user tries one. + editCreditsFor :: ByteString -> IO (Either ServiceError Integer) + } diff --git a/src/Simplex/Chat/Names/Service/Default.hs b/src/Simplex/Chat/Names/Service/Default.hs new file mode 100644 index 0000000000..1eed01a0ff --- /dev/null +++ b/src/Simplex/Chat/Names/Service/Default.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The single place the names service is wired in. +-- +-- Right now it resolves to the in-memory mock, so the whole names UX is +-- exercisable from the terminal CLI with no store payment, no relayer and no +-- chain — while still producing and verifying real signatures. +-- +-- When the SMP-backed client lands this binding is what changes; nothing in +-- "Simplex.Chat.Library.Commands" needs to know which implementation it has. +-- The process-wide mock state is a deliberate development shortcut and is the +-- reason this module is separate: it is the seam to delete. +module Simplex.Chat.Names.Service.Default + ( namesService, + nameDeployment, + devMockChain, + ) +where + +import Simplex.Chat.Names.Service (NamesService) +import Simplex.Chat.Names.Service.Mock (MockChain, mockDeployment, mockNamesService, newMockChain) +import Simplex.Chat.Names.Snrc (SnrcDeployment) +import System.IO.Unsafe (unsafePerformIO) + +-- | Process-wide mock chain. Development only. +devMockChain :: MockChain +devMockChain = unsafePerformIO newMockChain +{-# NOINLINE devMockChain #-} + +namesService :: NamesService +namesService = mockNamesService devMockChain + +-- | The deployment the client signs against. Must match the service. +nameDeployment :: SnrcDeployment +nameDeployment = mockDeployment diff --git a/src/Simplex/Chat/Names/Service/Mock.hs b/src/Simplex/Chat/Names/Service/Mock.hs new file mode 100644 index 0000000000..40dd7b8443 --- /dev/null +++ b/src/Simplex/Chat/Names/Service/Mock.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | An in-memory stand-in for the names service, the relayer and the chain. +-- +-- It is a mock in that nothing is persisted and no transaction is broadcast, +-- but it is deliberately *not* a stub: every relayed intent has its EIP-712 +-- digest recomputed and its signer recovered from the signature, and is +-- rejected unless the recovered address is the current owner and the nonce and +-- deadline check out. That is the same rule @transferWithSig@ and +-- @setTextWithSig@ enforce on-chain, so a client that satisfies this mock is +-- producing signatures the contracts would accept. +-- +-- It also models the rc2 funding design: registration consumes a __registrar +-- credit__ granted by the beneficiary rather than paying a fee, and relayed +-- record edits consume a per-name __edit credit__ granted at registration. Both +-- are enforced here the way the contracts would enforce them, so running out of +-- either surfaces in development rather than in production. +-- +-- Not modelled: gas, reorgs, expiry sweeps, the Dutch-auction premium, and +-- commit-reveal timing beyond a settable pending-poll count. +module Simplex.Chat.Names.Service.Mock + ( MockChain, + newMockChain, + mockNamesService, + mockDeployment, + chainOwnerOf, + chainRecords, + setPendingRounds, + advanceClock, + gracePeriod, + setPaymentValidator, + setRegistrarCredits, + registrarCredits, + editCreditsPerYear, + linkSeparator, + ) +where + +import Control.Concurrent.STM +import Control.Monad (forM_) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Data.Char (isDigit) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Simplex.Chat.Names.Service +import Simplex.Chat.Names.Snrc +import Simplex.Chat.Wallet (recoverSigner) +import Simplex.Chat.Wallet.Stealth (Announcement) +import Text.Read (readMaybe) +import Simplex.Messaging.Eth.Address (Address, mkAddress) +import Simplex.Messaging.Eth.Keccak (keccak256) + +data NameEntry = NameEntry + { neOwner :: Address, + neRecords :: Map ByteString ByteString, + neExpires :: Integer, + neEditCredits :: Integer + } + +data Pending = Pending + { pReq :: BuyRequest, + pRoundsLeft :: Int + } + +data MockChain = MockChain + { mcNames :: TVar (Map ByteString NameEntry), + mcNonces :: TVar (Map Address Integer), + mcPending :: TVar (Map ByteString Pending), + mcSeq :: TVar Int, + mcNow :: TVar Integer, + mcPendingRounds :: TVar Int, + mcValidatePayment :: TVar (PaymentProof -> Either ByteString ()), + -- | Registration credits held by the relayer, granted by the beneficiary. + mcRegistrarCredits :: TVar Integer, + -- | The announcement log, in order. Stands in for the registrar's + -- 'StealthNameTransfer' events, which is the only place a recipient + -- restoring from the phrase alone can find an ephemeral key. + mcAnnouncements :: TVar [Announcement] + } + +-- | Relayed record edits granted per year of registration. AB's figure: ten a +-- year is plenty, and it is what bounds the relayer's gas exposure per name. +-- | How long after expiry a name is still the owner's to renew. Matches the +-- registrar's grace period; past it, anyone may register the name. +gracePeriod :: Integer +gracePeriod = 90 * 86400 + +editCreditsPerYear :: Integer +editCreditsPerYear = 10 + +-- | Multiple links in one text record are separated by @;@ — this follows +-- @scripts/resolver/snrc-resolve.py@ (@LINK_SEPARATOR@), which is what the +-- deployed resolver actually parses. Note the namespace repo's CLAUDE.md +-- describes them as comma-separated; the code is authoritative and the doc +-- looks stale. +linkSeparator :: Char +linkSeparator = ';' + +-- | A deployment description matching the mock. The contract addresses are +-- arbitrary but fixed — what matters is that client and mock agree, since the +-- EIP-712 domain binds them. +mockDeployment :: SnrcDeployment +mockDeployment = + SnrcDeployment + { sdTld = "simplex", + sdChainId = 1, + sdRegistrar = fixedAddr 0xB1, + sdResolver = fixedAddr 0xB2 + } + where + fixedAddr b = either error id . mkAddress $ B.replicate 19 0 <> B.singleton b + +newMockChain :: IO MockChain +newMockChain = do + mcNames <- newTVarIO M.empty + mcNonces <- newTVarIO M.empty + mcPending <- newTVarIO M.empty + mcSeq <- newTVarIO 0 + mcNow <- newTVarIO 1786000000 + mcPendingRounds <- newTVarIO 1 + mcValidatePayment <- newTVarIO (const $ Right ()) + mcRegistrarCredits <- newTVarIO 100 + mcAnnouncements <- newTVarIO [] + pure MockChain {mcNames, mcNonces, mcPending, mcSeq, mcNow, mcPendingRounds, mcValidatePayment, mcRegistrarCredits, mcAnnouncements} + +-- | How many status polls a registration stays pending, standing in for the +-- 60-second commit-reveal wait. 0 makes registration immediate. +setPendingRounds :: MockChain -> Int -> IO () +setPendingRounds c n = atomically $ writeTVar (mcPendingRounds c) n + +-- | Move the mock's clock forward, to reach expiry and grace boundaries. +advanceClock :: MockChain -> Integer -> IO () +advanceClock c d = atomically $ modifyTVar' (mcNow c) (+ d) + +-- | Swap in a validator that rejects some payments, to exercise the failure UI. +setPaymentValidator :: MockChain -> (PaymentProof -> Either ByteString ()) -> IO () +setPaymentValidator c f = atomically $ writeTVar (mcValidatePayment c) f + +-- | Stand-in for the beneficiary multisig calling @setRegistrarCredits@. Set it +-- to 0 to exercise the exhausted-credits path. +setRegistrarCredits :: MockChain -> Integer -> IO () +setRegistrarCredits c n = atomically $ writeTVar (mcRegistrarCredits c) n + +registrarCredits :: MockChain -> IO Integer +registrarCredits c = readTVarIO (mcRegistrarCredits c) + +chainOwnerOf :: MockChain -> ByteString -> IO (Maybe Address) +chainOwnerOf c name = atomically $ fmap neOwner . M.lookup name <$> readTVar (mcNames c) + +chainRecords :: MockChain -> ByteString -> IO (Map ByteString ByteString) +chainRecords c name = atomically $ maybe M.empty neRecords . M.lookup name <$> readTVar (mcNames c) + +fqdn :: ByteString -> ByteString +fqdn label = label <> "." <> sdTld mockDeployment + +-- | Matches SimplexController: 6+ characters, plus the [a-z0-9-] label grammar +-- the app already enforces client-side, plus the two reserved names. +validLabel :: ByteString -> Either ServiceError () +validLabel l + | B.length l < 6 = Left $ SENameInvalid "names must be at least 6 characters" + | not (BC.all lowerAlnumHyphen l) = Left $ SENameInvalid "only lowercase letters, digits and hyphens" + | "-" `B.isPrefixOf` l || "-" `B.isSuffixOf` l = Left $ SENameInvalid "cannot start or end with a hyphen" + | l `elem` reserved = Left $ SENameInvalid "that name is reserved" + | otherwise = Right () + where + lowerAlnumHyphen ch = isDigit ch || (ch >= 'a' && ch <= 'z') || ch == '-' + reserved = ["simplex", "simplex-chat"] + +-- | The .simplex curve: $128 / $32 / $8 / $1 per year for 3 / 4 / 5 / 6+ chars. +priceCents :: ByteString -> Int -> Int +priceCents l years = years * perYear + where + perYear = case B.length l of + 3 -> 12800 + 4 -> 3200 + 5 -> 800 + _ -> 100 + +mockNamesService :: MockChain -> NamesService +mockNamesService c = + NamesService + { quoteName = quote, + buyName = buy, + registrationStatus = status, + relayIntent = relay, + announcementsFrom = anns, + resolveName = resolve, + namesOwnedBy = ownedBy, + renewName = renew, + currentNonce = nonceOf, + editCreditsFor = editCredits + } + where + quote label = case validLabel label of + Left e -> pure $ Left e + Right () -> do + -- Same rule as buy: a name in its grace period is still its owner's. + taken <- atomically $ do + names <- readTVar (mcNames c) + now <- readTVar (mcNow c) + pure $ case M.lookup (fqdn label) names of + Nothing -> False + Just e -> neExpires e + gracePeriod > now + pure . Right $ + NameQuote {nqLabel = label, nqAvailable = not taken, nqPriceCents = priceCents label 1, nqYears = 1} + + buy req@BuyRequest {brLabel, brPayment} = case validLabel brLabel of + Left e -> pure $ Left e + Right () -> do + validate <- readTVarIO (mcValidatePayment c) + case validate brPayment of + Left e -> pure $ Left (SEPaymentRejected e) + Right () -> atomically $ do + names <- readTVar (mcNames c) + credits <- readTVar (mcRegistrarCredits c) + now <- readTVar (mcNow c) + let taken = case M.lookup (fqdn brLabel) names of + Nothing -> False + Just e -> neExpires e + gracePeriod > now + if taken + then pure $ Left SENameTaken + else if credits <= 0 + then pure $ Left SENoRegistrarCredits + else do + -- One credit per register call. No fee is transferred: the + -- beneficiary granted the allowance up front instead. + writeTVar (mcRegistrarCredits c) (credits - 1) + n <- stateTVar (mcSeq c) $ \i -> (i + 1, i + 1) + rounds <- readTVar (mcPendingRounds c) + let pid = "purchase-" <> BC.pack (show n) + modifyTVar' (mcPending c) $ M.insert pid Pending {pReq = req, pRoundsLeft = rounds} + pure . Right $ PurchaseId pid + + status (PurchaseId pid) = atomically $ do + pend <- readTVar (mcPending c) + case M.lookup pid pend of + Nothing -> pure $ Left SENotFound + Just p + | pRoundsLeft p > 0 -> do + modifyTVar' (mcPending c) $ M.insert pid p {pRoundsLeft = pRoundsLeft p - 1} + pure $ Right RegPending + | otherwise -> do + let BuyRequest {brLabel, brOwner, brYears, brContactLink, brChannelLink} = pReq p + name = fqdn brLabel + recs = + M.fromList $ + [(contactRecordKey, l) | Just l <- [brContactLink]] + <> [(channelRecordKey, l) | Just l <- [brChannelLink]] + now <- readTVar (mcNow c) + let expires = now + fromIntegral brYears * 31536000 + -- Owner and records are written together, as + -- SimplexController.register does via the resolver data[] array. + modifyTVar' (mcNames c) $ + M.insert + name + NameEntry + { neOwner = brOwner, + neRecords = recs, + neExpires = expires, + neEditCredits = editCreditsPerYear * fromIntegral brYears + } + modifyTVar' (mcPending c) $ M.delete pid + pure . Right $ RegConfirmed {rsTxHash = txHash ("register:" <> name), rsExpires = expires} + + resolve name = atomically $ do + names <- readTVar (mcNames c) + pure $ case M.lookup name names of + Nothing -> Left SENotFound + Just NameEntry {neOwner, neRecords, neExpires, neEditCredits} -> + Right + NameRecordView + { nrvName = name, + nrvOwner = neOwner, + nrvContact = maybe [] splitLinks $ M.lookup contactRecordKey neRecords, + nrvChannel = maybe [] splitLinks $ M.lookup channelRecordKey neRecords, + nrvExpires = neExpires, + nrvEditCredits = neEditCredits + } + + -- After expiry a name is still the owner's for this long; only past it can + -- anyone else take it. + renew label years payment = do + validate <- readTVarIO (mcValidatePayment c) + case validate payment of + Left e -> pure $ Left (SEPaymentRejected e) + Right () -> atomically $ do + names <- readTVar (mcNames c) + now <- readTVar (mcNow c) + case M.lookup (fqdn label) names of + Nothing -> pure $ Left SENotFound + Just e + | neExpires e + gracePeriod <= now -> pure $ Left SENotFound + | otherwise -> do + -- Extend from the later of now and the current expiry, so + -- renewing early adds time rather than throwing it away, and + -- renewing in grace does not backdate the new term. + let expires' = max now (neExpires e) + fromIntegral years * 31536000 + modifyTVar' (mcNames c) $ + M.insert + (fqdn label) + e {neExpires = expires', neEditCredits = neEditCredits e + editCreditsPerYear * fromIntegral years} + pure $ Right expires' + + ownedBy owner = atomically $ do + names <- readTVar (mcNames c) + pure . Right . M.keys $ M.filter ((== owner) . neOwner) names + + nonceOf owner = Right . M.findWithDefault 0 owner <$> readTVarIO (mcNonces c) + + editCredits name = atomically $ do + names <- readTVar (mcNames c) + pure $ maybe (Left SENotFound) (Right . neEditCredits) (M.lookup name names) + + -- The heart of the mock: recompute the digest, recover the signer, and + -- apply the same authorisation rules the contracts do. + -- Announcement ranges for a recovery scan. The cursor is an opaque + -- position in the log; the client stores it and never interprets it. + anns from = do + as <- readTVarIO (mcAnnouncements c) + let start = maybe 0 (fromMaybe 0 . readMaybe . T.unpack) from + rest = drop start as + pure $ Right (rest, T.pack . show $ start + length rest) + + relay SignedIntent {siIntent, siSignature} announce = do + now <- readTVarIO (mcNow c) + case intentDigest mockDeployment siIntent of + Left e -> pure . Left $ SEUnavailable (BC.pack e) + Right digest -> case recoverSigner siSignature digest of + Left _ -> pure $ Left SEBadSignature + Right signer -> atomically $ do + names <- readTVar (mcNames c) + nonces <- readTVar (mcNonces c) + let expected = M.findWithDefault 0 signer nonces + bump = modifyTVar' (mcNonces c) $ M.insert signer (expected + 1) + case siIntent of + TransferName {tiFrom, tiTo, tiLabel, tiNonce, tiDeadline} + | tiDeadline < now -> pure $ Left SEExpiredIntent + | tiNonce /= expected -> pure $ Left SEBadNonce + -- transferWithSig requires to != from, so an announcement + -- always costs a real transfer to another party + | tiTo == tiFrom -> pure $ Left SESelfTransfer + | otherwise -> + let name = fqdn tiLabel + in case M.lookup name names of + Nothing -> pure $ Left SENotFound + Just e + -- ownerOf reverts once expired, so transfer is refused + | neOwner e /= signer || tiFrom /= signer || neExpires e <= now -> pure $ Left SENotOwner + | otherwise -> do + modifyTVar' (mcNames c) $ M.insert name e {neOwner = tiTo} + bump + forM_ announce $ \a -> modifyTVar' (mcAnnouncements c) (<> [a]) + pure . Right $ txHash ("transfer:" <> name) + SetTextRecord {sxName, sxKey, sxValue, sxNonce, sxDeadline} + | sxDeadline < now -> pure $ Left SEExpiredIntent + | sxNonce /= expected -> pure $ Left SEBadNonce + | otherwise -> case M.lookup sxName names of + Nothing -> pure $ Left SENotFound + Just e + | neOwner e /= signer -> pure $ Left SENotOwner + -- Only the sponsored path is metered. An owner paying + -- their own gas is never charged a credit. + | neEditCredits e <= 0 -> pure $ Left SENoEditCredits + | otherwise -> do + modifyTVar' (mcNames c) $ + M.insert + sxName + e + { neRecords = M.insert sxKey sxValue (neRecords e), + neEditCredits = neEditCredits e - 1 + } + bump + pure . Right $ txHash ("setText:" <> sxName <> ":" <> sxKey) + +splitLinks :: ByteString -> [ByteString] +splitLinks = filter (not . B.null) . map trim . BC.split linkSeparator + where + trim = BC.dropWhile (== ' ') . BC.reverse . BC.dropWhile (== ' ') . BC.reverse + +txHash :: ByteString -> ByteString +txHash = ("0x" <>) . BC.pack . concatMap byteHex . B.unpack . keccak256 + where + byteHex w = [hexDigit (w `div` 16), hexDigit (w `mod` 16)] + hexDigit n = "0123456789abcdef" !! fromIntegral n diff --git a/src/Simplex/Chat/Names/Snrc.hs b/src/Simplex/Chat/Names/Snrc.hs new file mode 100644 index 0000000000..d77a19538c --- /dev/null +++ b/src/Simplex/Chat/Names/Snrc.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | The SNRC contract surface as the client sees it: name hashing, and the +-- EIP-712 intents the user signs for the relayer to submit. +-- +-- The type strings here must match the contracts byte for byte, in EIP-712 +-- canonical form (no spaces after commas). They are the client half of +-- @transferWithSig@ on @BaseRegistrarImplementation@ and @setTextWithSig@ on +-- @SimplexResolver@. +module Simplex.Chat.Names.Snrc + ( SnrcDeployment (..), + Intent (..), + SignedIntent (..), + labelHash, + nameHash, + tokenId, + intentDigest, + transferTypeString, + setTextTypeString, + contactRecordKey, + channelRecordKey, + ) +where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Simplex.Chat.Wallet (EthSignature) +import Simplex.Messaging.Eth.Address (Address) +import Simplex.Messaging.Eth.EIP712 +import Simplex.Messaging.Eth.Keccak (keccak256) + +-- | Where a TLD is deployed. One of these per TLD; the verifying contract +-- differs per intent kind, so both are carried. +data SnrcDeployment = SnrcDeployment + { sdTld :: ByteString, -- ^ e.g. @"simplex"@, without the dot + sdChainId :: Integer, + sdRegistrar :: Address, -- ^ verifying contract for transfers + sdResolver :: Address -- ^ verifying contract for record writes + } + deriving (Eq, Show) + +data Intent + = -- | Gift a name to another address. + TransferName {tiFrom :: Address, tiTo :: Address, tiLabel :: ByteString, tiNonce :: Integer, tiDeadline :: Integer} + | -- | Repoint a name at a different link. + SetTextRecord {sxName :: ByteString, sxKey :: ByteString, sxValue :: ByteString, sxNonce :: Integer, sxDeadline :: Integer} + deriving (Eq, Show) + +data SignedIntent = SignedIntent + { siIntent :: Intent, + siSignature :: EthSignature + } + deriving (Eq, Show) + +-- | ENS text record keys carrying SimpleX links. +contactRecordKey, channelRecordKey :: ByteString +contactRecordKey = "simplex.contact" +channelRecordKey = "simplex.channel" + +transferTypeString :: ByteString +transferTypeString = "TransferName(address from,address to,uint256 tokenId,uint256 nonce,uint256 deadline)" + +setTextTypeString :: ByteString +setTextTypeString = "SetText(bytes32 node,string key,string value,uint256 nonce,uint256 deadline)" + +labelHash :: ByteString -> ByteString +labelHash = keccak256 + +-- | ENS namehash of a fully-qualified name, e.g. @alice.simplex@. +nameHash :: ByteString -> ByteString +nameHash name + | B.null name = B.replicate 32 0 + | otherwise = foldr step (B.replicate 32 0) (BC.split '.' name) + where + step lbl node = keccak256 (node <> labelHash lbl) + +-- | @BaseRegistrar@ token id: @uint256(keccak256(label))@. +tokenId :: ByteString -> Integer +tokenId = B.foldl' (\acc w -> acc * 256 + fromIntegral w) 0 . labelHash + +-- | The 32-byte digest the user signs. +intentDigest :: SnrcDeployment -> Intent -> Either String ByteString +intentDigest d = \case + TransferName {tiFrom, tiTo, tiLabel, tiNonce, tiDeadline} -> + hashTypedData + (domain "SimplexNames" (sdRegistrar d)) + transferTypeString + [VAddress tiFrom, VAddress tiTo, VUint (tokenId tiLabel), VUint tiNonce, VUint tiDeadline] + SetTextRecord {sxName, sxKey, sxValue, sxNonce, sxDeadline} -> + hashTypedData + (domain "SimplexResolver" (sdResolver d)) + setTextTypeString + [VFixedBytes (nameHash sxName), VString sxKey, VString sxValue, VUint sxNonce, VUint sxDeadline] + where + domain n c = Eip712Domain {edName = n, edVersion = "1", edChainId = sdChainId d, edVerifyingContract = c} diff --git a/src/Simplex/Chat/ProfileGenerator.hs b/src/Simplex/Chat/ProfileGenerator.hs index b460a73d3d..ac16d0ef2b 100644 --- a/src/Simplex/Chat/ProfileGenerator.hs +++ b/src/Simplex/Chat/ProfileGenerator.hs @@ -10,7 +10,7 @@ generateRandomProfile :: IO Profile generateRandomProfile = do adjective <- pick adjectives noun <- pickNoun adjective 2 - pure $ Profile {displayName = adjective <> noun, fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing, contactDomain = Nothing} + pure $ Profile {displayName = adjective <> noun, fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing, contactDomain = Nothing, metaAddress = Nothing} where pick :: [a] -> IO a pick xs = (xs !!) <$> randomRIO (0, length xs - 1) diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 8d9c8ecfcc..5db0f89ab5 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -631,6 +631,7 @@ data MsgContentTag | MCVoice_ | MCFile_ | MCReport_ + | MCAssetTransfer_ | MCChat_ | MCUnknown_ Text deriving (Eq, Show) @@ -644,6 +645,7 @@ instance StrEncoding MsgContentTag where MCFile_ -> "file" MCVoice_ -> "voice" MCReport_ -> "report" + MCAssetTransfer_ -> "assetTransfer" MCChat_ -> "chat" MCUnknown_ t -> encodeUtf8 t strDecode = \case @@ -654,6 +656,7 @@ instance StrEncoding MsgContentTag where "voice" -> Right MCVoice_ "file" -> Right MCFile_ "report" -> Right MCReport_ + "assetTransfer" -> Right MCAssetTransfer_ "chat" -> Right MCChat_ t -> Right . MCUnknown_ $ safeDecodeUtf8 t strP = strDecode <$?> A.takeTill (== ' ') @@ -723,10 +726,29 @@ data MsgContent | MCVoice {text :: Text, duration :: Int} | MCFile {text :: Text} | MCReport {text :: Text, reason :: ReportReason} + | -- | Something was handed over in-app: a name now, a token later. The app + -- renders this from 'transfer', so the wording is localised by the reader + -- rather than sent in the sender's language; 'text' is only the fallback + -- shown by clients too old to know this type. + MCAssetTransfer {text :: Text, transfer :: AssetTransfer} | MCChat {text :: Text, chatLink :: MsgChatLink, ownerSig :: Maybe LinkOwnerSig} | MCUnknown {tag :: Text, text :: Text, json :: J.Object} deriving (Eq, Show) +-- | What was handed over. 'kind' selects the wording and the screen to open, so +-- adding a token transfer later is a new kind rather than a new message type. +-- +-- 'ephemeralPubKey' is what makes the transfer usable immediately: with it the +-- recipient derives the destination on receipt and never has to scan. The +-- on-chain announcement carries the same value and exists for the case where +-- this message is lost, or the device is restored from the recovery key alone. +data AssetTransfer = AssetTransfer + { kind :: Text, + asset :: Text, + ephemeralPubKey :: Maybe Text + } + deriving (Eq, Show) + data MsgChatLink = MCLContact {connLink :: ShortLinkContact, profile :: Profile, business :: Bool} | MCLInvitation {invLink :: ShortLinkInvitation, profile :: Profile} @@ -756,6 +778,7 @@ msgContentText = \case where msg = "report " <> safeDecodeUtf8 (strEncode reason) MCChat {text} -> text + MCAssetTransfer {text} -> text MCUnknown {text} -> text durationText :: Int -> Text @@ -787,6 +810,7 @@ isMedia = \case isReport :: MsgContent -> Bool isReport = \case MCReport {} -> True + MCAssetTransfer {} -> True _ -> False msgContentTag :: MsgContent -> MsgContentTag @@ -798,6 +822,7 @@ msgContentTag = \case MCVoice {} -> MCVoice_ MCFile {} -> MCFile_ MCReport {} -> MCReport_ + MCAssetTransfer {} -> MCAssetTransfer_ MCChat {} -> MCChat_ MCUnknown {tag} -> MCUnknown_ tag @@ -811,6 +836,8 @@ $(JQ.deriveJSON defaultJSON ''InlineFileInvitation) $(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "MCL") ''MsgChatLink) +$(JQ.deriveJSON defaultJSON ''AssetTransfer) + $(JQ.deriveJSON defaultJSON ''LinkOwnerSig) $(JQ.deriveJSON defaultJSON ''MsgMention) @@ -852,6 +879,10 @@ instance FromJSON MsgContent where duration <- v .: "duration" pure MCVoice {text, duration} MCFile_ -> MCFile <$> v .: "text" + MCAssetTransfer_ -> do + text <- v .: "text" + transfer <- v .: "transfer" + pure MCAssetTransfer {text, transfer} MCReport_ -> do text <- v .: "text" reason <- v .: "reason" @@ -883,6 +914,7 @@ instance ToJSON MsgContent where MCVoice {text, duration} -> J.object ["type" .= MCVoice_, "text" .= text, "duration" .= duration] MCFile t -> J.object ["type" .= MCFile_, "text" .= t] MCReport {text, reason} -> J.object ["type" .= MCReport_, "text" .= text, "reason" .= reason] + MCAssetTransfer {text, transfer} -> J.object ["type" .= MCAssetTransfer_, "text" .= text, "transfer" .= transfer] MCChat {text, chatLink, ownerSig} -> J.object $ ("ownerSig" .=? ownerSig) ["type" .= MCChat_, "text" .= text, "chatLink" .= chatLink] toEncoding = \case MCUnknown {json} -> JE.value $ J.Object json @@ -893,6 +925,7 @@ instance ToJSON MsgContent where MCVoice {text, duration} -> J.pairs $ "type" .= MCVoice_ <> "text" .= text <> "duration" .= duration MCFile t -> J.pairs $ "type" .= MCFile_ <> "text" .= t MCReport {text, reason} -> J.pairs $ "type" .= MCReport_ <> "text" .= text <> "reason" .= reason + MCAssetTransfer {text, transfer} -> J.pairs $ "type" .= MCAssetTransfer_ <> "text" .= text <> "transfer" .= transfer MCChat {text, chatLink, ownerSig} -> J.pairs $ "type" .= MCChat_ <> "text" .= text <> "chatLink" .= chatLink <> maybe mempty ("ownerSig" .=) ownerSig $(JQ.deriveJSON defaultJSON ''MsgContainer) diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index fe7539fad7..b3c4284a7b 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -117,7 +117,7 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do c.contact_group_member_id, c.contact_grp_inv_sent, c.grp_direct_inv_link, c.grp_direct_inv_from_group_id, c.grp_direct_inv_from_group_member_id, c.grp_direct_inv_from_member_conn_id, c.grp_direct_inv_started_connection, c.ui_themes, c.chat_deleted, c.custom_data, c.chat_item_ttl, p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, - p.contact_domain, p.contact_domain_proof, p.contact_domain_verified + p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, p.meta_address FROM contacts c JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id LEFT JOIN contact_requests cr2 ON cr2.contact_request_id = c.contact_request_id @@ -126,7 +126,7 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do (userId, contactId, CSActive) toContact' :: UTCTime -> Int64 -> Connection -> [ChatTagId] -> ContactRow' -> Contact toContact' currentTs contactId conn chatTags ((profileId, localDisplayName, displayName, fullName, shortDescr, description, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, rejectionSupported_, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL) :. badgeRow :. domainRow) = - let profile = LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, contactDomain = rowToContactDomain domainRow, contactDomainVerified = rowToDomainVerified domainRow, peerType, localBadge = rowToBadge currentTs badgeRow, preferences, localAlias} + let profile = LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, contactDomain = rowToContactDomain domainRow, contactDomainVerified = rowToDomainVerified domainRow, metaAddress = rowToMetaAddress domainRow, peerType, localBadge = rowToBadge currentTs badgeRow, preferences, localAlias} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite} mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn activeConn = Just conn @@ -159,13 +159,13 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, -- GroupInfo {membership = GroupMember {memberProfile}} pu.display_name, pu.full_name, pu.short_descr, pu.description, pu.image, pu.contact_link, pu.chat_peer_type, pu.local_alias, pu.preferences, - pu.badge_proof, pu.badge_pres_header, pu.badge_expiry, pu.badge_type, pu.badge_verified, pu.badge_extra, pu.badge_master_key, pu.badge_signature, pu.badge_key_idx, pu.contact_domain, pu.contact_domain_proof, pu.contact_domain_verified, + pu.badge_proof, pu.badge_pres_header, pu.badge_expiry, pu.badge_type, pu.badge_verified, pu.badge_extra, pu.badge_master_key, pu.badge_signature, pu.badge_key_idx, pu.contact_domain, pu.contact_domain_proof, pu.contact_domain_verified, pu.meta_address, mu.created_at, mu.updated_at, mu.support_chat_ts, mu.support_chat_items_unread, mu.support_chat_items_member_attention, mu.support_chat_items_mentions, mu.support_chat_last_msg_from_member_ts, mu.member_pub_key, mu.relay_link, mu.member_security_code, mu.member_security_code_verified_at, -- from GroupMember m.group_member_id, m.group_id, m.index_in_group, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.description, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, p.meta_address, m.created_at, m.updated_at, m.support_chat_ts, m.support_chat_items_unread, m.support_chat_items_member_attention, m.support_chat_items_mentions, m.support_chat_last_msg_from_member_ts, m.member_pub_key, m.relay_link, m.member_security_code, m.member_security_code_verified_at FROM group_members m diff --git a/src/Simplex/Chat/Store/ContactRequest.hs b/src/Simplex/Chat/Store/ContactRequest.hs index 146f957947..6ef860e6dc 100644 --- a/src/Simplex/Chat/Store/ContactRequest.hs +++ b/src/Simplex/Chat/Store/ContactRequest.hs @@ -118,7 +118,7 @@ createOrUpdateContactRequest cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.conn_full_link_to_connect, ct.conn_short_link_to_connect, ct.welcome_shared_msg_id, ct.request_shared_msg_id, ct.contact_request_id, cr2.rejection_supported, ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.grp_direct_inv_link, ct.grp_direct_inv_from_group_id, ct.grp_direct_inv_from_group_member_id, ct.grp_direct_inv_from_member_conn_id, ct.grp_direct_inv_started_connection, ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl, - cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, cp.badge_key_idx, cp.contact_domain, cp.contact_domain_proof, cp.contact_domain_verified, + cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, cp.badge_key_idx, cp.contact_domain, cp.contact_domain_proof, cp.contact_domain_verified, cp.meta_address, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.xcontact_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter, @@ -155,7 +155,7 @@ createOrUpdateContactRequest cr.pq_support, cr.welcome_shared_msg_id, cr.request_shared_msg_id, p.preferences, cr.created_at, cr.updated_at, cr.peer_chat_min_version, cr.peer_chat_max_version, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, p.meta_address FROM contact_requests cr JOIN contact_profiles p USING (contact_profile_id) WHERE cr.user_id = ? diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index 7ddcc08a58..edf3ff093d 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -326,7 +326,7 @@ getContactByConnReqHash db cxt user@User {userId} cReqHash1 cReqHash2 = do ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.grp_direct_inv_link, ct.grp_direct_inv_from_group_id, ct.grp_direct_inv_from_group_member_id, ct.grp_direct_inv_from_member_conn_id, ct.grp_direct_inv_started_connection, ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl, cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, cp.badge_key_idx, - cp.contact_domain, cp.contact_domain_proof, cp.contact_domain_verified, + cp.contact_domain, cp.contact_domain_proof, cp.contact_domain_verified, cp.meta_address, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.xcontact_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter, @@ -732,17 +732,17 @@ updateContactProfile_ db userId profileId profile badgeVerified = do updateContactProfile_' db userId profileId profile badgeVerified currentTs updateContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> UTCTime -> IO () -updateContactProfile_' db userId profileId Profile {displayName, fullName, shortDescr, description, image, contactLink, contactDomain, preferences, peerType, badge} badgeVerified updatedAt = +updateContactProfile_' db userId profileId Profile {displayName, fullName, shortDescr, description, image, contactLink, contactDomain, metaAddress, preferences, peerType, badge} badgeVerified updatedAt = DB.execute db [sql| UPDATE contact_profiles SET display_name = ?, full_name = ?, short_descr = ?, description = ?, image = ?, contact_link = ?, preferences = ?, chat_peer_type = ?, updated_at = ?, badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ?, badge_key_idx = ?, - contact_domain = ?, contact_domain_proof = ? + contact_domain = ?, contact_domain_proof = ?, meta_address = ? WHERE user_id = ? AND contact_profile_id = ? |] - ((displayName, fullName, shortDescr, description, image, contactLink, preferences, peerType, updatedAt) :. badgeToRow badge badgeVerified :. contactDomainToRow contactDomain :. (userId, profileId)) + ((displayName, fullName, shortDescr, description, image, contactLink, preferences, peerType, updatedAt) :. badgeToRow badge badgeVerified :. contactDomainToRow contactDomain :. Only metaAddress :. (userId, profileId)) -- update only member profile fields (when member doesn't have associated contact - we can reset contactLink and prefs) updateMemberContactProfileReset_ :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> IO () @@ -751,17 +751,17 @@ updateMemberContactProfileReset_ db userId profileId profile badgeVerified = do updateMemberContactProfileReset_' db userId profileId profile badgeVerified currentTs updateMemberContactProfileReset_' :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> UTCTime -> IO () -updateMemberContactProfileReset_' db userId profileId Profile {displayName, fullName, shortDescr, description, image, contactDomain, badge} badgeVerified updatedAt = +updateMemberContactProfileReset_' db userId profileId Profile {displayName, fullName, shortDescr, description, image, contactDomain, metaAddress, badge} badgeVerified updatedAt = DB.execute db [sql| UPDATE contact_profiles SET display_name = ?, full_name = ?, short_descr = ?, description = ?, image = ?, contact_link = NULL, preferences = NULL, updated_at = ?, badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ?, badge_key_idx = ?, - contact_domain = ?, contact_domain_proof = ? + contact_domain = ?, contact_domain_proof = ?, meta_address = ? WHERE user_id = ? AND contact_profile_id = ? |] - ((displayName, fullName, shortDescr, description, image, updatedAt) :. badgeToRow badge badgeVerified :. contactDomainToRow contactDomain :. (userId, profileId)) + ((displayName, fullName, shortDescr, description, image, updatedAt) :. badgeToRow badge badgeVerified :. contactDomainToRow contactDomain :. Only metaAddress :. (userId, profileId)) -- update only member profile fields (when member has associated contact - we keep contactLink and prefs) updateMemberContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> IO () @@ -770,17 +770,17 @@ updateMemberContactProfile_ db userId profileId profile badgeVerified = do updateMemberContactProfile_' db userId profileId profile badgeVerified currentTs updateMemberContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> UTCTime -> IO () -updateMemberContactProfile_' db userId profileId Profile {displayName, fullName, shortDescr, description, image, contactDomain, badge} badgeVerified updatedAt = +updateMemberContactProfile_' db userId profileId Profile {displayName, fullName, shortDescr, description, image, contactDomain, metaAddress, badge} badgeVerified updatedAt = DB.execute db [sql| UPDATE contact_profiles SET display_name = ?, full_name = ?, short_descr = ?, description = ?, image = ?, updated_at = ?, badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ?, badge_key_idx = ?, - contact_domain = ?, contact_domain_proof = ? + contact_domain = ?, contact_domain_proof = ?, meta_address = ? WHERE user_id = ? AND contact_profile_id = ? |] - ((displayName, fullName, shortDescr, description, image, updatedAt) :. badgeToRow badge badgeVerified :. contactDomainToRow contactDomain :. (userId, profileId)) + ((displayName, fullName, shortDescr, description, image, updatedAt) :. badgeToRow badge badgeVerified :. contactDomainToRow contactDomain :. Only metaAddress :. (userId, profileId)) updateContactLDN_ :: DB.Connection -> User -> Int64 -> ContactName -> ContactName -> UTCTime -> IO () updateContactLDN_ db user@User {userId} contactId displayName newName updatedAt = do @@ -855,7 +855,7 @@ contactRequestQuery = cr.created_at, cr.updated_at, cr.peer_chat_min_version, cr.peer_chat_max_version, p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, - p.contact_domain, p.contact_domain_proof, p.contact_domain_verified + p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, p.meta_address FROM contact_requests cr JOIN contact_profiles p USING (contact_profile_id) |] @@ -977,7 +977,7 @@ getContact_ db cxt user@User {userId} contactId deleted = do ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.grp_direct_inv_link, ct.grp_direct_inv_from_group_id, ct.grp_direct_inv_from_group_member_id, ct.grp_direct_inv_from_member_conn_id, ct.grp_direct_inv_started_connection, ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl, cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, cp.badge_key_idx, - cp.contact_domain, cp.contact_domain_proof, cp.contact_domain_verified, + cp.contact_domain, cp.contact_domain_proof, cp.contact_domain_verified, cp.meta_address, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.xcontact_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter, diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 773d9c1f32..ee5e75360b 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -722,7 +722,7 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe m.group_member_id, m.group_id, m.index_in_group, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.description, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, p.meta_address, m.created_at, m.updated_at, m.support_chat_ts, m.support_chat_items_unread, m.support_chat_items_member_attention, m.support_chat_items_mentions, m.support_chat_last_msg_from_member_ts, m.member_pub_key, m.relay_link, m.member_security_code, m.member_security_code_verified_at FROM group_members m @@ -1146,7 +1146,7 @@ getContactRequestChatPreviews_ db User {userId} pagination clq = do cr.pq_support, cr.welcome_shared_msg_id, cr.request_shared_msg_id, p.preferences, cr.created_at, cr.updated_at, cr.peer_chat_min_version, cr.peer_chat_max_version, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, p.meta_address FROM contact_requests cr JOIN contact_profiles p ON p.contact_profile_id = cr.contact_profile_id JOIN user_contact_links uc ON uc.user_contact_link_id = cr.user_contact_link_id @@ -3092,7 +3092,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do m.group_member_id, m.group_id, m.index_in_group, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.description, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, p.meta_address, m.created_at, m.updated_at, m.support_chat_ts, m.support_chat_items_unread, m.support_chat_items_member_attention, m.support_chat_items_mentions, m.support_chat_last_msg_from_member_ts, m.member_pub_key, m.relay_link, m.member_security_code, m.member_security_code_verified_at, -- quoted ChatItem @@ -3101,14 +3101,14 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do rm.group_member_id, rm.group_id, rm.index_in_group, rm.member_id, rm.peer_chat_min_version, rm.peer_chat_max_version, rm.member_role, rm.member_category, rm.member_status, rm.show_messages, rm.member_restriction, rm.invited_by, rm.invited_by_group_member_id, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, rp.display_name, rp.full_name, rp.short_descr, rp.description, rp.image, rp.contact_link, rp.chat_peer_type, rp.local_alias, rp.preferences, - rp.badge_proof, rp.badge_pres_header, rp.badge_expiry, rp.badge_type, rp.badge_verified, rp.badge_extra, rp.badge_master_key, rp.badge_signature, rp.badge_key_idx, rp.contact_domain, rp.contact_domain_proof, rp.contact_domain_verified, + rp.badge_proof, rp.badge_pres_header, rp.badge_expiry, rp.badge_type, rp.badge_verified, rp.badge_extra, rp.badge_master_key, rp.badge_signature, rp.badge_key_idx, rp.contact_domain, rp.contact_domain_proof, rp.contact_domain_verified, rp.meta_address, rm.created_at, rm.updated_at, rm.support_chat_ts, rm.support_chat_items_unread, rm.support_chat_items_member_attention, rm.support_chat_items_mentions, rm.support_chat_last_msg_from_member_ts, rm.member_pub_key, rm.relay_link, rm.member_security_code, rm.member_security_code_verified_at, -- deleted by GroupMember dbm.group_member_id, dbm.group_id, dbm.index_in_group, dbm.member_id, dbm.peer_chat_min_version, dbm.peer_chat_max_version, dbm.member_role, dbm.member_category, dbm.member_status, dbm.show_messages, dbm.member_restriction, dbm.invited_by, dbm.invited_by_group_member_id, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, dbp.display_name, dbp.full_name, dbp.short_descr, dbp.description, dbp.image, dbp.contact_link, dbp.chat_peer_type, dbp.local_alias, dbp.preferences, - dbp.badge_proof, dbp.badge_pres_header, dbp.badge_expiry, dbp.badge_type, dbp.badge_verified, dbp.badge_extra, dbp.badge_master_key, dbp.badge_signature, dbp.badge_key_idx, dbp.contact_domain, dbp.contact_domain_proof, dbp.contact_domain_verified, + dbp.badge_proof, dbp.badge_pres_header, dbp.badge_expiry, dbp.badge_type, dbp.badge_verified, dbp.badge_extra, dbp.badge_master_key, dbp.badge_signature, dbp.badge_key_idx, dbp.contact_domain, dbp.contact_domain_proof, dbp.contact_domain_verified, dbp.meta_address, dbm.created_at, dbm.updated_at, dbm.support_chat_ts, dbm.support_chat_items_unread, dbm.support_chat_items_member_attention, dbm.support_chat_items_mentions, dbm.support_chat_last_msg_from_member_ts, dbm.member_pub_key, dbm.relay_link, dbm.member_security_code, dbm.member_security_code_verified_at FROM chat_items i diff --git a/src/Simplex/Chat/Store/Postgres/Migrations.hs b/src/Simplex/Chat/Store/Postgres/Migrations.hs index 19c07edbf8..c46d03fe5a 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations.hs @@ -39,6 +39,8 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260531_member_removed_at import Simplex.Chat.Store.Postgres.Migrations.M20260601_relay_sent_web_domain import Simplex.Chat.Store.Postgres.Migrations.M20260602_group_roster import Simplex.Chat.Store.Postgres.Migrations.M20260603_simplex_name +import Simplex.Chat.Store.Postgres.Migrations.M20260806_wallet_seeds +import Simplex.Chat.Store.Postgres.Migrations.M20260807_profile_meta_address import Simplex.Chat.Store.Postgres.Migrations.M20260629_roster_catchup import Simplex.Chat.Store.Postgres.Migrations.M20260707_file_digest import Simplex.Chat.Store.Postgres.Migrations.M20260714_member_security_code @@ -91,7 +93,9 @@ schemaMigrations = ("20260715_profile_description", m20260715_profile_description, Just down_m20260715_profile_description), ("20260716_signed_history", m20260716_signed_history, Just down_m20260716_signed_history), ("20260720_server_roles", m20260720_server_roles, Just down_m20260720_server_roles), - ("20260723_contact_request_rejection", m20260723_contact_request_rejection, Just down_m20260723_contact_request_rejection) + ("20260723_contact_request_rejection", m20260723_contact_request_rejection, Just down_m20260723_contact_request_rejection), + ("20260806_wallet_seeds", m20260806_wallet_seeds, Just down_m20260806_wallet_seeds), + ("20260807_profile_meta_address", m20260807_profile_meta_address, Just down_m20260807_profile_meta_address) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260806_wallet_seeds.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260806_wallet_seeds.hs new file mode 100644 index 0000000000..1f831c8b76 --- /dev/null +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260806_wallet_seeds.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.Postgres.Migrations.M20260806_wallet_seeds where + +import Data.Text (Text) +import Text.RawString.QQ (r) + +m20260806_wallet_seeds :: Text +m20260806_wallet_seeds = + [r| +CREATE TABLE wallet_seeds ( + wallet_seed_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY, + seed BYTEA NOT NULL, + created_at TIMESTAMPTZ NOT NULL DEFAULT now(), + backed_up SMALLINT NOT NULL DEFAULT 0, + -- High-water mark for account allocation; see the SQLite migration for why + -- this cannot be derived from MAX(users.wallet_account_index). + next_account_index BIGINT NOT NULL DEFAULT 0 +); + +ALTER TABLE users ADD COLUMN wallet_seed_id BIGINT REFERENCES wallet_seeds ON DELETE RESTRICT; +ALTER TABLE users ADD COLUMN wallet_account_index BIGINT; +ALTER TABLE users ADD COLUMN wallet_scanned_to TEXT; + +CREATE INDEX idx_users_wallet_seed_id ON users(wallet_seed_id); + +CREATE TABLE wallet_one_time_addresses ( + wallet_one_time_address_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY, + user_id BIGINT NOT NULL REFERENCES users ON DELETE CASCADE, + chain TEXT NOT NULL, + address BYTEA NOT NULL, + ephemeral_pub_key BYTEA NOT NULL, + discovered_at TIMESTAMPTZ NOT NULL DEFAULT now(), + accepted_at TIMESTAMPTZ, + UNIQUE (user_id, chain, address) +); + +CREATE INDEX idx_wallet_one_time_addresses_user ON wallet_one_time_addresses(user_id, chain); +|] + +down_m20260806_wallet_seeds :: Text +down_m20260806_wallet_seeds = + [r| +DROP INDEX idx_wallet_one_time_addresses_user; + +DROP TABLE wallet_one_time_addresses; + +DROP INDEX idx_users_wallet_seed_id; + +ALTER TABLE users DROP COLUMN wallet_scanned_to; +ALTER TABLE users DROP COLUMN wallet_account_index; +ALTER TABLE users DROP COLUMN wallet_seed_id; + +DROP TABLE wallet_seeds; +|] diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260807_profile_meta_address.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260807_profile_meta_address.hs new file mode 100644 index 0000000000..2e591c37ab --- /dev/null +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260807_profile_meta_address.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.Postgres.Migrations.M20260807_profile_meta_address where + +import Data.Text (Text) +import Text.RawString.QQ (r) + +-- | See the SQLite migration for what this holds and why it is safe to publish. +m20260807_profile_meta_address :: Text +m20260807_profile_meta_address = + [r| +ALTER TABLE contact_profiles ADD COLUMN meta_address TEXT; +|] + +down_m20260807_profile_meta_address :: Text +down_m20260807_profile_meta_address = + [r| +ALTER TABLE contact_profiles DROP COLUMN meta_address; +|] diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index ce6a8c4c9f..71cdd8e747 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -163,7 +163,7 @@ createUserRecordAt db (AgentUserId auId) userChatRelay clientService Profile {di (profileId, displayName, userId, BI True, currentTs, currentTs, currentTs) contactId <- insertedRowId db DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId) - pure $ toUser currentTs $ (userId, auId, contactId, profileId, BI activeUser, order) :. (displayName, fullName, shortDescr, description, image, Nothing, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, Nothing, Nothing, Nothing, BI userChatRelay, BI clientService, Nothing) :. localBadgeToRow Nothing :. (Nothing, Nothing, Nothing) + pure $ toUser currentTs $ (userId, auId, contactId, profileId, BI activeUser, order) :. (displayName, fullName, shortDescr, description, image, Nothing, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, Nothing, Nothing, Nothing, BI userChatRelay, BI clientService, Nothing) :. localBadgeToRow Nothing :. (Nothing, Nothing, Nothing, Nothing) -- TODO [mentions] getUsersInfo :: DB.Connection -> IO [UserInfo] @@ -424,7 +424,7 @@ getUserContactProfiles db User {userId} = (Only userId) where toContactProfile :: (ContactName, Text, Maybe Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe SimplexDomain, Maybe Preferences) -> Profile - toContactProfile (displayName, fullName, shortDescr, description, image, contactLink, peerType, domain_, preferences) = Profile {displayName, fullName, shortDescr, description, image, contactLink, contactDomain = mkDomainClaim <$> domain_, peerType, preferences, badge = Nothing} + toContactProfile (displayName, fullName, shortDescr, description, image, contactLink, peerType, domain_, preferences) = Profile {displayName, fullName, shortDescr, description, image, contactLink, contactDomain = mkDomainClaim <$> domain_, metaAddress = Nothing, peerType, preferences, badge = Nothing} createUserContactLink :: DB.Connection -> User -> ConnId -> CreatedLinkContact -> SubscriptionMode -> C.PrivateKeyEd25519 -> ExceptT StoreError IO () createUserContactLink db User {userId} agentConnId (CCLink cReq shortLink) subMode linkPrivSigKey = diff --git a/src/Simplex/Chat/Store/SQLite/Migrations.hs b/src/Simplex/Chat/Store/SQLite/Migrations.hs index a4e7ab04a2..8169fc93e0 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations.hs @@ -169,6 +169,8 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260715_profile_description import Simplex.Chat.Store.SQLite.Migrations.M20260716_signed_history import Simplex.Chat.Store.SQLite.Migrations.M20260720_server_roles import Simplex.Chat.Store.SQLite.Migrations.M20260723_contact_request_rejection +import Simplex.Chat.Store.SQLite.Migrations.M20260806_wallet_seeds +import Simplex.Chat.Store.SQLite.Migrations.M20260807_profile_meta_address import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -337,7 +339,9 @@ schemaMigrations = ("20260715_profile_description", m20260715_profile_description, Just down_m20260715_profile_description), ("20260716_signed_history", m20260716_signed_history, Just down_m20260716_signed_history), ("20260720_server_roles", m20260720_server_roles, Just down_m20260720_server_roles), - ("20260723_contact_request_rejection", m20260723_contact_request_rejection, Just down_m20260723_contact_request_rejection) + ("20260723_contact_request_rejection", m20260723_contact_request_rejection, Just down_m20260723_contact_request_rejection), + ("20260806_wallet_seeds", m20260806_wallet_seeds, Just down_m20260806_wallet_seeds), + ("20260807_profile_meta_address", m20260807_profile_meta_address, Just down_m20260807_profile_meta_address) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260806_wallet_seeds.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260806_wallet_seeds.hs new file mode 100644 index 0000000000..63615cf437 --- /dev/null +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260806_wallet_seeds.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.SQLite.Migrations.M20260806_wallet_seeds where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +-- | Wallet seeds: BIP-39 entropy, one or more per database. +-- +-- The schema allows several seeds per database, with each chat profile bound to +-- exactly one of them plus its own BIP-44 account index. Only the single-seed +-- case is reachable from the UI today — profiles all share one seed and differ +-- by account index — but modelling it this way now means importing a second +-- recovery key later is a UI change, not a migration of live key material. +m20260806_wallet_seeds :: Query +m20260806_wallet_seeds = + [sql| +CREATE TABLE wallet_seeds ( + wallet_seed_id INTEGER PRIMARY KEY AUTOINCREMENT, + seed BLOB NOT NULL, -- BIP-39 entropy, 16-32 bytes + created_at TEXT NOT NULL DEFAULT (datetime('now')), + backed_up INTEGER NOT NULL DEFAULT 0, -- user acknowledged saving the recovery key + -- High-water mark for account allocation. Deliberately not derived from + -- MAX(users.wallet_account_index): after recovery from the phrase alone that + -- table is empty while accounts 0..N already hold names on chain, so a new + -- profile would silently reuse a recovered account's keys and meta-address. + -- The recovery probe raises this before any profile is created. + next_account_index INTEGER NOT NULL DEFAULT 0 +) STRICT; + +ALTER TABLE users ADD COLUMN wallet_seed_id INTEGER REFERENCES wallet_seeds ON DELETE RESTRICT; +ALTER TABLE users ADD COLUMN wallet_account_index INTEGER; +-- Position of the last recovery scan, so a repeat scan resumes. Not a live +-- watermark: incoming names are learned from a chat message, not by scanning. +ALTER TABLE users ADD COLUMN wallet_scanned_to TEXT; + +CREATE INDEX idx_users_wallet_seed_id ON users(wallet_seed_id); + +-- Destinations learned from a sender's message, or rediscovered by a recovery +-- scan. Holds no private key: the key is re-derived from the seed and the +-- ephemeral public key on demand, so this table is a cache and losing it costs +-- a rescan rather than an asset. +-- +-- 'chain' is carried from the first migration so that adding Bitcoin or Monero +-- later is new rows, not a schema change. +CREATE TABLE wallet_one_time_addresses ( + wallet_one_time_address_id INTEGER PRIMARY KEY AUTOINCREMENT, + user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, + chain TEXT NOT NULL, -- 'eth' today; 'btc', 'xmr' later + address BLOB NOT NULL, + ephemeral_pub_key BLOB NOT NULL, -- compressed secp256k1 point, 33 bytes + discovered_at TEXT NOT NULL DEFAULT (datetime('now')), + accepted_at TEXT, -- NULL = received but not accepted + UNIQUE (user_id, chain, address) +) STRICT; + +CREATE INDEX idx_wallet_one_time_addresses_user ON wallet_one_time_addresses(user_id, chain); +|] + +down_m20260806_wallet_seeds :: Query +down_m20260806_wallet_seeds = + [sql| +DROP INDEX idx_wallet_one_time_addresses_user; + +DROP TABLE wallet_one_time_addresses; + +DROP INDEX idx_users_wallet_seed_id; + +ALTER TABLE users DROP COLUMN wallet_scanned_to; +ALTER TABLE users DROP COLUMN wallet_account_index; +ALTER TABLE users DROP COLUMN wallet_seed_id; + +DROP TABLE wallet_seeds; +|] diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260807_profile_meta_address.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260807_profile_meta_address.hs new file mode 100644 index 0000000000..cef03fb467 --- /dev/null +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260807_profile_meta_address.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.SQLite.Migrations.M20260807_profile_meta_address where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +-- | The stealth meta-address a profile publishes, as hex. +-- +-- Two compressed secp256k1 public keys: a spending key and a viewing key. It is +-- how a contact sends a name without a handshake — they derive a one-time +-- destination from it, and only the holder of the viewing key can find what +-- lands there. +-- +-- Safe to distribute widely, which is why it rides the profile rather than +-- needing its own exchange: it is not an address, never appears on chain, and +-- holding it confers only the ability to send. Locating a destination derived +-- from it requires either the sender's ephemeral secret or the recipient's +-- private viewing key, and a meta-address is neither. +-- +-- Incognito profiles must leave this NULL: an incognito profile carrying the +-- user's meta-address would hand the contact a correlator straight back to +-- their main identity. +m20260807_profile_meta_address :: Query +m20260807_profile_meta_address = + [sql| +ALTER TABLE contact_profiles ADD COLUMN meta_address TEXT; +|] + +down_m20260807_profile_meta_address :: Query +down_m20260807_profile_meta_address = + [sql| +ALTER TABLE contact_profiles DROP COLUMN meta_address; +|] diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql index cfbcf70599..c2192af72c 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql @@ -32,7 +32,8 @@ CREATE TABLE contact_profiles( contact_domain TEXT, contact_domain_proof TEXT, contact_domain_verified INTEGER, - description TEXT + description TEXT, + meta_address TEXT ) STRICT; CREATE TABLE users( user_id INTEGER PRIMARY KEY, @@ -53,7 +54,10 @@ CREATE TABLE users( active_order INTEGER NOT NULL DEFAULT 0, auto_accept_member_contacts INTEGER NOT NULL DEFAULT 0, is_user_chat_relay INTEGER NOT NULL DEFAULT 0, - client_service INTEGER NOT NULL DEFAULT 0, -- 1 for active user + client_service INTEGER NOT NULL DEFAULT 0, + wallet_seed_id INTEGER REFERENCES wallet_seeds ON DELETE RESTRICT, + wallet_account_index INTEGER, + wallet_scanned_to TEXT, -- 1 for active user FOREIGN KEY(user_id, local_display_name) REFERENCES display_names(user_id, local_display_name) ON DELETE RESTRICT @@ -845,6 +849,29 @@ CREATE TABLE rcv_roster_transfers( created_at TEXT NOT NULL DEFAULT(datetime('now')), updated_at TEXT NOT NULL DEFAULT(datetime('now')) ) STRICT; +CREATE TABLE wallet_seeds( + wallet_seed_id INTEGER PRIMARY KEY AUTOINCREMENT, + seed BLOB NOT NULL, -- BIP-39 entropy, 16-32 bytes + created_at TEXT NOT NULL DEFAULT(datetime('now')), + backed_up INTEGER NOT NULL DEFAULT 0, -- user acknowledged saving the recovery key + -- High-water mark for account allocation. Deliberately not derived from + -- MAX(users.wallet_account_index): after recovery from the phrase alone that + -- table is empty while accounts 0..N already hold names on chain, so a new + -- profile would silently reuse a recovered account's keys and meta-address. +-- The recovery probe raises this before any profile is created. + next_account_index INTEGER NOT NULL DEFAULT 0 +) STRICT; +CREATE TABLE wallet_one_time_addresses( + wallet_one_time_address_id INTEGER PRIMARY KEY AUTOINCREMENT, + user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, + chain TEXT NOT NULL, -- 'eth' today; 'btc', + 'xmr' later + address BLOB NOT NULL, + ephemeral_pub_key BLOB NOT NULL, -- compressed secp256k1 point, 33 bytes + discovered_at TEXT NOT NULL DEFAULT(datetime('now')), + accepted_at TEXT, -- NULL = received but not accepted + UNIQUE(user_id, chain, address) +) STRICT; CREATE INDEX contact_profiles_index ON contact_profiles( display_name, full_name @@ -1379,6 +1406,11 @@ CREATE INDEX idx_files_roster_transfer_id ON files(roster_transfer_id); CREATE INDEX idx_chat_items_item_signed_by_group_member_id ON chat_items( item_signed_by_group_member_id ); +CREATE INDEX idx_users_wallet_seed_id ON users(wallet_seed_id); +CREATE INDEX idx_wallet_one_time_addresses_user ON wallet_one_time_addresses( + user_id, + chain +); CREATE TRIGGER on_group_members_insert_update_summary AFTER INSERT ON group_members FOR EACH ROW diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index 6516b3cc66..03b67612ae 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -415,13 +415,13 @@ createContact db cxt user profile = do void $ createContact_ db cxt user profile emptyChatPrefs Nothing "" currentTs createContact_ :: DB.Connection -> StoreCxt -> User -> Profile -> Preferences -> Maybe (ACreatedConnLink, Maybe SharedMsgId) -> LocalAlias -> UTCTime -> ExceptT StoreError IO ContactId -createContact_ db cxt User {userId} Profile {displayName, fullName, shortDescr, description, image, contactLink, contactDomain, peerType, badge, preferences} ctUserPreferences prepared localAlias currentTs = +createContact_ db cxt User {userId} Profile {displayName, fullName, shortDescr, description, image, contactLink, contactDomain, metaAddress, peerType, badge, preferences} ctUserPreferences prepared localAlias currentTs = ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do badgeVerified <- verifyBadge_ (badgeKeys cxt) badge DB.execute db - "INSERT INTO contact_profiles (display_name, full_name, short_descr, description, image, contact_link, chat_peer_type, user_id, local_alias, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature, badge_key_idx, contact_domain, contact_domain_proof) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" - ((displayName, fullName, shortDescr, description, image, contactLink, peerType) :. (userId, localAlias, preferences, currentTs, currentTs) :. badgeToRow badge badgeVerified :. contactDomainToRow contactDomain) + "INSERT INTO contact_profiles (display_name, full_name, short_descr, description, image, contact_link, chat_peer_type, user_id, local_alias, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature, badge_key_idx, contact_domain, contact_domain_proof, meta_address) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" + ((displayName, fullName, shortDescr, description, image, contactLink, peerType) :. (userId, localAlias, preferences, currentTs, currentTs) :. badgeToRow badge badgeVerified :. contactDomainToRow contactDomain :. Only metaAddress) profileId <- insertedRowId db DB.execute db @@ -492,11 +492,14 @@ type ContactRow' = (ProfileId, ContactName, ContactName, Text, Maybe Text, Maybe type ContactRow = Only ContactId :. ContactRow' -type ContactDomainRow = (Maybe SimplexDomain, Maybe SimplexDomainProof, Maybe BoolInt) +-- Trailing profile columns read together: the domain claim and its verification +-- state, plus the published stealth meta-address. Grouped as one row shape +-- because every profile SELECT carries them together. +type ContactDomainRow = (Maybe SimplexDomain, Maybe SimplexDomainProof, Maybe BoolInt, Maybe Text) toContact :: UTCTime -> StoreCxt -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact toContact now cxt user chatTags ((Only contactId :. (profileId, localDisplayName, displayName, fullName, shortDescr, description, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, rejectionSupported_, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL) :. badgeRow :. domainRow) :. connRow) = - let profile = LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, contactDomain = rowToContactDomain domainRow, contactDomainVerified = rowToDomainVerified domainRow, peerType, localBadge = rowToBadge now badgeRow, preferences, localAlias} + let profile = LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, contactDomain = rowToContactDomain domainRow, contactDomainVerified = rowToDomainVerified domainRow, metaAddress = rowToMetaAddress domainRow, peerType, localBadge = rowToBadge now badgeRow, preferences, localAlias} activeConn = toMaybeConnection cxt connRow chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite} incognito = maybe False connIncognito activeConn @@ -507,10 +510,13 @@ toContact now cxt user chatTags ((Only contactId :. (profileId, localDisplayName in Contact {contactId, localDisplayName, profile, activeConn, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, preparedContact, contactRequestId, contactRequest, contactGroupMemberId, contactGrpInvSent, groupDirectInv, chatTags, chatItemTTL, uiThemes, chatDeleted, customData} rowToContactDomain :: ContactDomainRow -> Maybe SimplexDomainClaim -rowToContactDomain (domain_, domainProof_, _) = (`SimplexDomainClaim` domainProof_) . StrJSON <$> domain_ +rowToContactDomain (domain_, domainProof_, _, _) = (`SimplexDomainClaim` domainProof_) . StrJSON <$> domain_ rowToDomainVerified :: ContactDomainRow -> Maybe Bool -rowToDomainVerified (_, _, domainVerification_) = unBI <$> domainVerification_ +rowToDomainVerified (_, _, domainVerification_, _) = unBI <$> domainVerification_ + +rowToMetaAddress :: ContactDomainRow -> Maybe Text +rowToMetaAddress (_, _, _, metaAddress_) = metaAddress_ contactDomainToRow :: Maybe SimplexDomainClaim -> (Maybe SimplexDomain, Maybe SimplexDomainProof) contactDomainToRow d = (claimDomain <$> d, proof =<< d) @@ -539,7 +545,7 @@ getProfileById db userId profileId = do db [sql| SELECT cp.contact_profile_id, cp.display_name, cp.full_name, cp.short_descr, cp.description, cp.image, cp.contact_link, cp.chat_peer_type, cp.local_alias, cp.preferences, -- , ct.user_preferences - cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, cp.badge_key_idx, cp.contact_domain, cp.contact_domain_proof, cp.contact_domain_verified + cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, cp.badge_key_idx, cp.contact_domain, cp.contact_domain_proof, cp.contact_domain_verified, cp.meta_address FROM contact_profiles cp WHERE cp.user_id = ? AND cp.contact_profile_id = ? |] @@ -549,7 +555,7 @@ type ContactRequestRow = (Int64, ContactName, AgentInvId, Maybe ContactId, Maybe toContactRequest :: UTCTime -> ContactRequestRow -> UserContactRequest toContactRequest now ((contactRequestId, localDisplayName, agentInvitationId, contactId_, businessGroupId_, userContactLinkId_, BI rejectionSupported) :. (profileId, displayName, fullName, shortDescr, description, image, contactLink, peerType, localAlias) :. (xContactId, pqSupport, welcomeSharedMsgId, requestSharedMsgId, preferences, createdAt, updatedAt, minVer, maxVer) :. badgeRow :. domainRow) = do - let profile = LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, contactDomain = rowToContactDomain domainRow, contactDomainVerified = rowToDomainVerified domainRow, peerType, preferences, localBadge = rowToBadge now badgeRow, localAlias} + let profile = LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, contactDomain = rowToContactDomain domainRow, contactDomainVerified = rowToDomainVerified domainRow, metaAddress = rowToMetaAddress domainRow, peerType, preferences, localBadge = rowToBadge now badgeRow, localAlias} cReqChatVRange = fromMaybe (versionToRange maxVer) $ safeVersionRange minVer maxVer in UserContactRequest {contactRequestId, agentInvitationId, contactId_, businessGroupId_, userContactLinkId_, cReqChatVRange, localDisplayName, profileId, profile, xContactId, pqSupport, welcomeSharedMsgId, requestSharedMsgId, createdAt, updatedAt, rejectionSupported} @@ -558,7 +564,7 @@ userQuery = [sql| SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.description, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences, u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes, - ucp.badge_proof, ucp.badge_pres_header, ucp.badge_expiry, ucp.badge_type, ucp.badge_verified, ucp.badge_extra, ucp.badge_master_key, ucp.badge_signature, ucp.badge_key_idx, ucp.contact_domain, ucp.contact_domain_proof, ucp.contact_domain_verified + ucp.badge_proof, ucp.badge_pres_header, ucp.badge_expiry, ucp.badge_type, ucp.badge_verified, ucp.badge_extra, ucp.badge_master_key, ucp.badge_signature, ucp.badge_key_idx, ucp.contact_domain, ucp.contact_domain_proof, ucp.contact_domain_verified, ucp.meta_address FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id @@ -568,7 +574,7 @@ toUser :: UTCTime -> (UserId, UserId, ContactId, ProfileId, BoolInt, Int64) :. ( toUser now ((userId, auId, userContactId, profileId, BI activeUser, activeOrder) :. (displayName, fullName, shortDescr, description, image, contactLink, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, viewPwdHash_, viewPwdSalt_, userMemberProfileUpdatedAt, BI userChatRelay, BI clientService, uiThemes) :. badgeRow :. domainRow) = User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, activeOrder, fullPreferences, showNtfs, sendRcptsContacts, sendRcptsSmallGroups, autoAcceptMemberContacts, viewPwdHash, userMemberProfileUpdatedAt, userChatRelay = BoolDef userChatRelay, clientService = BoolDef clientService, uiThemes} where - profile = LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, contactDomain = rowToContactDomain domainRow, contactDomainVerified = rowToDomainVerified domainRow, peerType, localBadge = rowToBadge now badgeRow, preferences = userPreferences, localAlias = ""} + profile = LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, contactDomain = rowToContactDomain domainRow, contactDomainVerified = rowToDomainVerified domainRow, metaAddress = rowToMetaAddress domainRow, peerType, localBadge = rowToBadge now badgeRow, preferences = userPreferences, localAlias = ""} fullPreferences = fullPreferences' userPreferences viewPwdHash = UserPwdHash <$> viewPwdHash_ <*> viewPwdSalt_ @@ -765,7 +771,7 @@ groupMemberQuery = SELECT m.group_member_id, m.group_id, m.index_in_group, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.description, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.contact_domain, p.contact_domain_proof, p.contact_domain_verified, p.meta_address, m.created_at, m.updated_at, m.support_chat_ts, m.support_chat_items_unread, m.support_chat_items_member_attention, m.support_chat_items_mentions, m.support_chat_last_msg_from_member_ts, m.member_pub_key, m.relay_link, m.member_security_code, m.member_security_code_verified_at, c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.xcontact_id, c.custom_user_profile_id, @@ -783,7 +789,7 @@ toContactMember now cxt User {userContactId} (memberRow :. connRow) = rowToLocalProfile :: UTCTime -> ProfileRow -> LocalProfile rowToLocalProfile now ((profileId, displayName, fullName, shortDescr, description, image, contactLink, peerType, localAlias, preferences) :. badgeRow :. domainRow) = - LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, contactDomain = rowToContactDomain domainRow, contactDomainVerified = rowToDomainVerified domainRow, peerType, localBadge = rowToBadge now badgeRow, localAlias, preferences} + LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, contactDomain = rowToContactDomain domainRow, contactDomainVerified = rowToDomainVerified domainRow, metaAddress = rowToMetaAddress domainRow, peerType, localBadge = rowToBadge now badgeRow, localAlias, preferences} toBusinessChatInfo :: Maybe SimplexDomainClaim -> BusinessChatInfoRow -> Maybe BusinessChatInfo toBusinessChatInfo businessDomain (Just chatType, Just businessId, Just customerId) = Just BusinessChatInfo {chatType, businessId, customerId, businessDomain} @@ -810,7 +816,7 @@ groupInfoQueryFields = mu.group_member_id, mu.group_id, mu.index_in_group, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.short_descr, pu.description, pu.image, pu.contact_link, pu.chat_peer_type, pu.local_alias, pu.preferences, - pu.badge_proof, pu.badge_pres_header, pu.badge_expiry, pu.badge_type, pu.badge_verified, pu.badge_extra, pu.badge_master_key, pu.badge_signature, pu.badge_key_idx, pu.contact_domain, pu.contact_domain_proof, pu.contact_domain_verified, + pu.badge_proof, pu.badge_pres_header, pu.badge_expiry, pu.badge_type, pu.badge_verified, pu.badge_extra, pu.badge_master_key, pu.badge_signature, pu.badge_key_idx, pu.contact_domain, pu.contact_domain_proof, pu.contact_domain_verified, pu.meta_address, mu.created_at, mu.updated_at, mu.support_chat_ts, mu.support_chat_items_unread, mu.support_chat_items_member_attention, mu.support_chat_items_mentions, mu.support_chat_last_msg_from_member_ts, mu.member_pub_key, mu.relay_link, mu.member_security_code, mu.member_security_code_verified_at |] diff --git a/src/Simplex/Chat/Store/Wallets.hs b/src/Simplex/Chat/Store/Wallets.hs new file mode 100644 index 0000000000..4a768aa0f9 --- /dev/null +++ b/src/Simplex/Chat/Store/Wallets.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Persistence for wallet seeds and per-profile accounts. +-- +-- The schema holds several seeds and binds each chat profile to one of them +-- plus its own account index. Only the single-seed case is reachable from the +-- UI: 'getOrCreateAccountRef' reuses the database's first seed and allocates the +-- next free account index. +module Simplex.Chat.Store.Wallets + ( getWalletSeeds, + getWalletSeed, + createWalletSeed, + setSeedBackedUp, + getAccountRef, + getOrCreateAccountRef, + boundAccount, + bindNewAccountOnSeed, + bindAccount, + getNextAccountIndex, + reserveAccounts, + OneTimeAddress (..), + recordOneTimeAddress, + getIncomingAddresses, + getAcceptedAddresses, + getOneTimeAddress, + acceptOneTimeAddress, + declineOneTimeAddress, + getScannedTo, + setScannedTo, + ) +where + +import Control.Monad (join, when) +import Control.Monad.IO.Class (liftIO) +import Data.ByteString (ByteString) +import Data.Either (rights) +import Data.Int (Int64) +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Simplex.Chat.Store.Shared (insertedRowId) +import Simplex.Chat.Types (User (..)) +import Simplex.Chat.Wallet (AccountIndex, AccountRef (..), Chain, SeedId (..), WalletSeed (..), chainText, parseChain) +import Simplex.Messaging.Agent.Store.AgentStore (maybeFirstRow) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Eth.Address (Address, mkAddress, unAddress) + +#if defined(dbPostgres) +import Database.PostgreSQL.Simple (Only (..)) +import Database.PostgreSQL.Simple.SqlQQ (sql) +#else +import Database.SQLite.Simple (Only (..)) +import Database.SQLite.Simple.QQ (sql) +#endif + +toSeed :: (Int64, ByteString, Bool) -> WalletSeed +toSeed (sId, seed, backedUp) = WalletSeed {wsId = SeedId sId, wsEntropy = seed, wsBackedUp = backedUp} + +getWalletSeeds :: DB.Connection -> IO [WalletSeed] +getWalletSeeds db = + map toSeed + <$> DB.query_ db "SELECT wallet_seed_id, seed, backed_up FROM wallet_seeds ORDER BY wallet_seed_id" + +getWalletSeed :: DB.Connection -> SeedId -> IO (Maybe WalletSeed) +getWalletSeed db (SeedId sId) = + maybeFirstRow toSeed $ + DB.query db "SELECT wallet_seed_id, seed, backed_up FROM wallet_seeds WHERE wallet_seed_id = ?" (Only sId) + +-- | Insert a seed. Callers generate the entropy; this module never does, so the +-- DRG stays with the agent. +createWalletSeed :: DB.Connection -> ByteString -> IO WalletSeed +createWalletSeed db seed = do + DB.execute db "INSERT INTO wallet_seeds (seed) VALUES (?)" (Only seed) + sId <- insertedRowId db + pure WalletSeed {wsId = SeedId sId, wsEntropy = seed, wsBackedUp = False} + +setSeedBackedUp :: DB.Connection -> SeedId -> Bool -> IO () +setSeedBackedUp db (SeedId sId) backedUp = + DB.execute db "UPDATE wallet_seeds SET backed_up = ? WHERE wallet_seed_id = ?" (backedUp, sId) + +getAccountRef :: DB.Connection -> User -> IO (Maybe AccountRef) +getAccountRef db User {userId} = do + r <- + maybeFirstRow id $ + DB.query db "SELECT wallet_seed_id, wallet_account_index FROM users WHERE user_id = ?" (Only userId) + pure $ case r of + Just (Just sId, Just ix) -> Just AccountRef {arSeedId = SeedId sId, arIndex = fromIntegral (ix :: Int64)} + _ -> Nothing + +bindAccount :: DB.Connection -> User -> AccountRef -> IO () +bindAccount db User {userId} AccountRef {arSeedId = SeedId sId, arIndex} = + DB.execute + db + "UPDATE users SET wallet_seed_id = ?, wallet_account_index = ? WHERE user_id = ?" + (sId, fromIntegral arIndex :: Int64, userId) + +-- | The seed and account this profile is bound to, or Nothing if it has never +-- used the wallet. Creates nothing: callers that need a wallet ask the user +-- first, so a profile is never given keys as a side effect of reading. +boundAccount :: DB.Connection -> User -> IO (Maybe (WalletSeed, AccountRef)) +boundAccount db user = + getAccountRef db user >>= \case + Nothing -> pure Nothing + Just r -> fmap (\s -> (s, r)) <$> getWalletSeed db (arSeedId r) + +-- | Bind this profile to an existing seed at a fresh account index. +-- +-- Additive by construction: it inserts nothing into @wallet_seeds@ and rewrites +-- only this profile's row, so no other profile's binding and no stored seed can +-- be affected. The index comes from the seed's high-water mark, so two profiles +-- on one seed can never share an account. +bindNewAccountOnSeed :: DB.Connection -> User -> WalletSeed -> IO AccountRef +bindNewAccountOnSeed db user s = do + ix <- takeAccountIndex db (wsId s) + let r = AccountRef {arSeedId = wsId s, arIndex = ix} + bindAccount db user r + pure r + +-- | Bind this profile to a seed, creating one from @mkSeed@ if the database has +-- none yet, and allocating the next free account index. +-- +-- Single-seed by construction: it always picks the first existing seed. When +-- multiple seeds become selectable this is the one function that changes. +getOrCreateAccountRef :: DB.Connection -> User -> IO ByteString -> IO (WalletSeed, AccountRef) +getOrCreateAccountRef db user mkSeed = do + existing <- getAccountRef db user + -- Load the seed this profile is actually bound to. Picking the first row in + -- the table instead would silently re-bind a profile whenever a second seed + -- exists - which is exactly what importing a recovery key creates - throwing + -- away the imported key and moving the profile to a new account index, so + -- the names it already owned stop being derivable too. + bound <- case existing of + Just r -> fmap (\s -> (r, s)) <$> getWalletSeed db (arSeedId r) + Nothing -> pure Nothing + case bound of + Just (r, s) -> pure (s, r) + Nothing -> do + seeds <- getWalletSeeds db + s <- case listToMaybe seeds of + Just s -> pure s + Nothing -> liftIO mkSeed >>= createWalletSeed db + ix <- takeAccountIndex db (wsId s) + let r = AccountRef {arSeedId = wsId s, arIndex = ix} + bindAccount db user r + pure (s, r) + +-- | Take the next account index and advance the seed's high-water mark. +-- +-- The mark is stored rather than computed as @MAX(users.wallet_account_index)@, +-- because after recovery from the phrase alone the @users@ table is empty while +-- accounts @0..N@ already hold names on chain. Computing it would hand the first +-- newly created profile index 0 and, with it, a recovered account's keys and +-- published meta-address. 'reserveAccounts' is what the recovery probe calls to +-- raise the mark past everything it found. +takeAccountIndex :: DB.Connection -> SeedId -> IO AccountIndex +takeAccountIndex db sId@(SeedId sId') = do + ix <- getNextAccountIndex db sId + DB.execute db "UPDATE wallet_seeds SET next_account_index = ? WHERE wallet_seed_id = ?" (fromIntegral ix + 1 :: Int64, sId') + pure ix + +getNextAccountIndex :: DB.Connection -> SeedId -> IO AccountIndex +getNextAccountIndex db (SeedId sId) = + maybe 0 (fromIntegral :: Int64 -> AccountIndex) + <$> ( maybeFirstRow fromOnly $ + DB.query db "SELECT next_account_index FROM wallet_seeds WHERE wallet_seed_id = ?" (Only sId) + ) + +-- | Raise the high-water mark so that @count@ accounts are treated as taken. +-- Called by recovery once the probe has established how many were in use; never +-- lowers it. +reserveAccounts :: DB.Connection -> SeedId -> AccountIndex -> IO () +reserveAccounts db sId@(SeedId sId') count = do + cur <- getNextAccountIndex db sId + when (count > cur) $ + DB.execute db "UPDATE wallet_seeds SET next_account_index = ? WHERE wallet_seed_id = ?" (fromIntegral count :: Int64, sId') + +-- One-time addresses. +-- +-- Rows are created when a sender's message arrives, or when a recovery scan +-- rediscovers one. They hold no private key: 'ephemeral_pub_key' plus the seed +-- re-derives it, so this table is a cache and losing it costs a rescan rather +-- than an asset. +-- +-- 'accepted_at' is NULL until the user accepts. An unaccepted row must never be +-- shown as a name the user owns: accepting is what creates the on-chain link +-- between them and the name, and it is theirs to decline. + +data OneTimeAddress = OneTimeAddress + { otaChain :: Chain, + otaAddress :: Address, + otaEphemeralPubKey :: ByteString, + otaAccepted :: Bool + } + deriving (Eq, Show) + +toOneTimeAddress :: (Text, ByteString, ByteString, Maybe Text) -> Either String OneTimeAddress +toOneTimeAddress (chain, addr, eph, acceptedAt) = do + c <- maybe (Left $ "unknown chain: " <> T.unpack chain) Right $ parseChain chain + a <- mkAddress addr + pure OneTimeAddress {otaChain = c, otaAddress = a, otaEphemeralPubKey = eph, otaAccepted = isJust acceptedAt} + +-- | Record a destination. Idempotent: the same announcement may arrive by +-- message and again by rescan. +recordOneTimeAddress :: DB.Connection -> User -> Chain -> Address -> ByteString -> IO () +recordOneTimeAddress db User {userId} c addr eph = + DB.execute + db + [sql| + INSERT INTO wallet_one_time_addresses (user_id, chain, address, ephemeral_pub_key) + VALUES (?, ?, ?, ?) + ON CONFLICT (user_id, chain, address) DO NOTHING + |] + (userId, chainText c, unAddress addr, eph) + +-- | Destinations awaiting a decision. +getIncomingAddresses :: DB.Connection -> User -> Chain -> IO [OneTimeAddress] +getIncomingAddresses db User {userId} c = + rights . map toOneTimeAddress + <$> DB.query + db + [sql| + SELECT chain, address, ephemeral_pub_key, accepted_at + FROM wallet_one_time_addresses + WHERE user_id = ? AND chain = ? AND accepted_at IS NULL + ORDER BY wallet_one_time_address_id + |] + (userId, chainText c) + +-- | Destinations the user accepted. These hold names they own just as much as +-- the main account does, so anything listing "your names" must include them. +getAcceptedAddresses :: DB.Connection -> User -> Chain -> IO [OneTimeAddress] +getAcceptedAddresses db User {userId} c = + rights . map toOneTimeAddress + <$> DB.query + db + [sql| + SELECT chain, address, ephemeral_pub_key, accepted_at + FROM wallet_one_time_addresses + WHERE user_id = ? AND chain = ? AND accepted_at IS NOT NULL + ORDER BY wallet_one_time_address_id + |] + (userId, chainText c) + +getOneTimeAddress :: DB.Connection -> User -> Chain -> Address -> IO (Maybe OneTimeAddress) +getOneTimeAddress db User {userId} c addr = do + r <- + maybeFirstRow id $ + DB.query + db + [sql| + SELECT chain, address, ephemeral_pub_key, accepted_at + FROM wallet_one_time_addresses + WHERE user_id = ? AND chain = ? AND address = ? + |] + (userId, chainText c, unAddress addr) + pure $ either (const Nothing) Just . toOneTimeAddress =<< r + +-- | Accepting is deliberate and, on chain, irreversible in its effect: it is +-- what links this profile to the name. +acceptOneTimeAddress :: DB.Connection -> User -> Chain -> Address -> IO () +acceptOneTimeAddress db User {userId} c addr = + DB.execute + db + [sql| + UPDATE wallet_one_time_addresses SET accepted_at = CURRENT_TIMESTAMP + WHERE user_id = ? AND chain = ? AND address = ? AND accepted_at IS NULL + |] + (userId, chainText c, unAddress addr) + +-- | Declining touches no chain state, so it is a local delete. A rescan would +-- surface the same destination again, which is correct: the name really is +-- still sitting there. +declineOneTimeAddress :: DB.Connection -> User -> Chain -> Address -> IO () +declineOneTimeAddress db User {userId} c addr = + DB.execute + db + "DELETE FROM wallet_one_time_addresses WHERE user_id = ? AND chain = ? AND address = ? AND accepted_at IS NULL" + (userId, chainText c, unAddress addr) + +-- | Where the last recovery scan reached, so a repeat scan resumes. +getScannedTo :: DB.Connection -> User -> IO (Maybe Text) +getScannedTo db User {userId} = + join <$> maybeFirstRow fromOnly (DB.query db "SELECT wallet_scanned_to FROM users WHERE user_id = ?" (Only userId)) + +setScannedTo :: DB.Connection -> User -> Text -> IO () +setScannedTo db User {userId} cursor = + DB.execute db "UPDATE users SET wallet_scanned_to = ? WHERE user_id = ?" (cursor, userId) diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 7bccd04b71..75fedd6ead 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -711,7 +711,13 @@ data Profile = Profile preferences :: Maybe Preferences, peerType :: Maybe ChatPeerType, badge :: Maybe BadgeProof, - contactDomain :: Maybe SimplexDomainClaim + contactDomain :: Maybe SimplexDomainClaim, + -- | Published stealth meta-address, hex. Lets a contact send a name with no + -- handshake; holding it confers only the ability to send, never the ability + -- to find what was sent (see the 20260807 migration). Always NULL on + -- incognito profiles, which would otherwise carry a correlator straight + -- back to the user's main identity. + metaAddress :: Maybe Text -- fields that should not be read into this data type to prevent sending them as part of profile to contacts: -- - contact_profile_id -- - incognito @@ -747,7 +753,7 @@ instance TextEncoding ChatPeerType where profileFromName :: ContactName -> Profile profileFromName displayName = - Profile {displayName, fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, preferences = Nothing, peerType = Nothing, badge = Nothing, contactDomain = Nothing} + Profile {displayName, fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, preferences = Nothing, peerType = Nothing, badge = Nothing, contactDomain = Nothing, metaAddress = Nothing} -- check if profiles match ignoring preferences profilesMatch :: LocalProfile -> LocalProfile -> Bool @@ -801,7 +807,8 @@ data LocalProfile = LocalProfile localBadge :: Maybe LocalBadge, localAlias :: LocalAlias, contactDomain :: Maybe SimplexDomainClaim, - contactDomainVerified :: Maybe Bool + contactDomainVerified :: Maybe Bool, + metaAddress :: Maybe Text } deriving (Eq, Show) @@ -809,15 +816,15 @@ localProfileId :: LocalProfile -> ProfileId localProfileId LocalProfile {profileId} = profileId toLocalProfile :: ProfileId -> Profile -> LocalAlias -> UTCTime -> Maybe Bool -> Maybe Bool -> LocalProfile -toLocalProfile profileId Profile {displayName, fullName, shortDescr, description, image, contactLink, preferences, peerType, badge, contactDomain} localAlias now badgeVerified contactDomainVerified = - LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, preferences, peerType, localBadge, localAlias, contactDomain, contactDomainVerified} +toLocalProfile profileId Profile {displayName, fullName, shortDescr, description, image, contactLink, preferences, peerType, badge, contactDomain, metaAddress} localAlias now badgeVerified contactDomainVerified = + LocalProfile {profileId, displayName, fullName, shortDescr, description, image, contactLink, preferences, peerType, localBadge, localAlias, contactDomain, contactDomainVerified, metaAddress} where localBadge = (\b@(BadgeProof _ _ _ info) -> PeerBadge b (mkBadgeStatus now badgeVerified info)) <$> badge fromLocalProfile :: LocalProfile -> Profile -fromLocalProfile LocalProfile {displayName, fullName, shortDescr, description, image, contactLink, preferences, peerType, localBadge, contactDomain} = +fromLocalProfile LocalProfile {displayName, fullName, shortDescr, description, image, contactLink, preferences, peerType, localBadge, contactDomain, metaAddress} = -- the name proof is re-signed on each send - Profile {displayName, fullName, shortDescr, description, image, contactLink, preferences, peerType, badge = localBadge >>= wireBadge, contactDomain = (\d -> d {proof = Nothing} :: SimplexDomainClaim) <$> contactDomain} + Profile {displayName, fullName, shortDescr, description, image, contactLink, preferences, peerType, badge = localBadge >>= wireBadge, contactDomain = (\d -> d {proof = Nothing} :: SimplexDomainClaim) <$> contactDomain, metaAddress} where wireBadge :: LocalBadge -> Maybe BadgeProof wireBadge = \case diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 5894d12fd3..9940b60af8 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -34,6 +34,7 @@ import Data.Text.Encoding (decodeLatin1) import Data.Time (LocalTime (..), TimeOfDay (..), TimeZone (..), utcToLocalTime) import Data.Time.Calendar (addDays) import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Time.Format (defaultTimeLocale, formatTime) import qualified Data.Version as V import qualified Network.HTTP.Types as Q @@ -149,6 +150,68 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te CRGroupMemberRatchetSyncStarted {} -> ["connection synchronization started"] CRConnectionVerified u verified code -> ttyUser u [plain $ if verified then "connection verified" else "connection not verified, current code is " <> code] CRContactDomainVerified u (Contact {profile = LocalProfile {contactDomain}}) result -> ttyUser u $ viewDomainVerified NTContact (claimDomain <$> contactDomain) result + CRNameAddress u addr acct meta -> + ttyUser + u + [ "name address (account " <> sShow acct <> "): " <> plain addr, + "meta-address (share this to be sent names): " <> plain meta + ] + CRNameGifted u fqdn tx _eph -> ttyUser u ["gift " <> plain fqdn <> " done", "tx " <> plain tx] + CRNameRenewed u fqdn expires reReg -> + ttyUser u [(if reReg then "registered again: " else "renewed: ") <> plain fqdn, "expires " <> sShow expires] + CRNameStatus u hasWallet keySaved _anySeed -> + ttyUser u [if hasWallet then (if keySaved then "wallet ready, recovery key saved" else "wallet ready, recovery key NOT saved") else "no wallet yet - people cannot send you names"] + CRNamesIncoming u ns + | null ns -> ttyUser u ["no names have been sent to you"] + | otherwise -> + ttyUser u $ + "names sent to you, not yet accepted:" + : map (\IncomingName {inAddress, inNames} -> " " <> plain (T.intercalate ", " inNames) <> " at " <> plain inAddress) ns + <> ["", "accepting links this profile to the name on chain; declining leaves no trace"] + CRNameAccepted u addr names -> + ttyUser u ["accepted " <> plain (T.intercalate ", " names) <> " at " <> plain addr] + CRNameDeclined u addr -> ttyUser u ["declined the name at " <> plain addr <> " - nothing was written on chain"] + CRNameKeyExported u addr key -> + ttyUser + u + [ "private key for " <> plain addr <> ":", + "", + plain key, + "", + "this key controls that one address and nothing else - not your other names, not your recovery key" + ] + CRNameRescanned u found -> + ttyUser u [if found == 0 then "no new names found" else "found " <> sShow found <> " name(s) sent to you - see /names incoming"] + CRNameRecoveryKey u phrase saved -> + ttyUser u $ + [ "name recovery key:", + "", + plain phrase, + "" + ] + <> if saved + then ["you marked this as saved"] + else ["write this down and keep it offline - it is the only way to recover your names", "then run /names key saved"] + CRNameQuoted u label avail cents -> + ttyUser u + [ plain label <> ".simplex: " + <> (if avail then "available" else "taken") + <> ", " <> plain (moneyText cents) <> "/year" + ] + CRNameRegistered u name tx -> ttyUser u ["registered " <> plain name, "tx " <> plain tx] + CRNamesOwned u [] -> ttyUser u ["you own no names"] + CRNamesOwned u ns -> ttyUser u $ "your names:" : map (\OwnedName {onFqdn, onExpires} -> " " <> plain onFqdn <> " (expires " <> sShow onExpires <> ")") ns + CRNameInfo u name owner contact channel expires credits -> + ttyUser u $ + [ plain name, + " owner " <> plain owner, + " expires " <> plain (expiryText expires), + " changes " <> sShow credits <> " relayed record changes left" + ] + <> [" contact " <> plain l | l <- contact] + <> [" channel " <> plain l | l <- channel] + CRNameIntentRelayed u action name tx -> + ttyUser u [plain action <> " " <> plain name <> " done", "tx " <> plain tx] CRGroupDomainVerified u g result -> ttyUser u $ viewDomainVerified NTPublicGroup (groupSimplexDomain g) result CRContactCode u ct code -> ttyUser u $ viewContactCode ct code testView CRGroupMemberCode u g m code -> ttyUser u $ viewGroupMemberCode g m code testView @@ -1146,6 +1209,14 @@ groupSimplexDomain :: GroupInfo -> Maybe SimplexDomain groupSimplexDomain GroupInfo {groupProfile = GroupProfile {publicGroup}} = claimDomain <$> (publicGroup >>= publicGroupAccess >>= groupDomainClaim) +expiryText :: Int -> Text +expiryText t = T.pack . formatTime defaultTimeLocale "%Y-%m-%d" . posixSecondsToUTCTime $ fromIntegral t + +moneyText :: Int -> Text +moneyText cents = T.pack $ "$" <> show (cents `div` 100) <> "." <> pad (cents `mod` 100) + where + pad n = let str = show n in if length str < 2 then '0' : str else str + viewDomainVerified :: SimplexNameType -> Maybe SimplexDomain -> Maybe Text -> [StyledString] viewDomainVerified nameType domain_ result = let nameStr = maybe "name" (\d -> "SimpleX name " <> shortNameInfoStr (SimplexNameInfo nameType d)) domain_ @@ -1969,12 +2040,15 @@ viewSwitchPhase = \case SPCompleted -> "changed address" viewUserProfileUpdated :: Profile -> Profile -> UserProfileUpdateSummary -> [StyledString] -viewUserProfileUpdated Profile {displayName = n, fullName, shortDescr, description, image, contactLink, preferences} Profile {displayName = n', fullName = fullName', shortDescr = shortDescr', description = description', image = image', contactLink = contactLink', preferences = prefs'} summary = +viewUserProfileUpdated Profile {displayName = n, fullName, shortDescr, description, image, contactLink, preferences, metaAddress = ma} Profile {displayName = n', fullName = fullName', shortDescr = shortDescr', description = description', image = image', contactLink = contactLink', preferences = prefs', metaAddress = ma'} summary = profileUpdated <> viewPrefsUpdated preferences prefs' where UserProfileUpdateSummary {updateSuccesses = s, updateFailures = f} = summary profileUpdated - | n == n' && fullName == fullName' && shortDescr == shortDescr' && description == description' && image == image' && contactLink == contactLink' = [] + | n == n' && fullName == fullName' && shortDescr == shortDescr' && description == description' && image == image' && contactLink == contactLink' = + -- Publishing a meta-address changes nothing a reader would notice, so + -- say so explicitly rather than reporting an empty update. + ["meta-address published, contacts can now send you names" <> notified | ma /= ma'] | n == n' && fullName == fullName' && shortDescr == shortDescr' && description == description' && image == image' = [if isNothing contactLink' then "contact address removed" else "new contact address set"] | n == n' && fullName == fullName' && shortDescr == shortDescr' && description == description' = [if isNothing image' then "profile image removed" else "profile image updated"] | n == n' && fullName == fullName' && shortDescr == shortDescr' = ["user description " <> (if maybe True T.null description' then "removed" else "changed to " <> maybe "" plain description') <> notified] diff --git a/src/Simplex/Chat/Wallet.hs b/src/Simplex/Chat/Wallet.hs new file mode 100644 index 0000000000..22cd55e89f --- /dev/null +++ b/src/Simplex/Chat/Wallet.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The wallet: BIP-39 seeds, and the per-chat-profile accounts derived from +-- them. +-- +-- Three distinct things, three names, used consistently in code, DB and UI: +-- +-- * __seed__ — BIP-39 entropy. Generic and profile-scoped, /not/ name-specific: +-- if a general wallet feature is added later it uses this same seed. +-- * __account__ — a profile's slot in a seed, index @i@. It holds a key per +-- chain, not one key: a main address that owns the names the profile buys, +-- and a stealth spend\/view pair whose public halves are published as a +-- meta-address. One account can own many names. +-- * __wallet__ — this module: creation, derivation, storage and signing. +-- +-- Names are a /consumer/ of the wallet, which is why this sits at +-- "Simplex.Chat.Wallet" rather than under "Simplex.Chat.Names". +-- +-- The schema allows several seeds; a profile binds to exactly one plus its own +-- account index. Only the single-seed case is reachable from the UI. Modelling +-- the extra dimension now means importing a second recovery key later is a UI +-- change rather than a migration of live key material. +-- +-- This module is pure. Persistence lives in "Simplex.Chat.Store.Wallets". +module Simplex.Chat.Wallet + ( SeedId (..), + WalletSeed (..), + AccountIndex, + AccountRef (..), + WalletAccount (..), + EthSignature (..), + Chain (..), + chainText, + parseChain, + StealthKeys (..), + newSeed, + importRecoveryKey, + recoveryKeyPhrase, + deriveAccount, + accountAddress, + deriveStealthKeys, + accountMetaAddress, + mainPath, + stealthSpendPath, + stealthViewPath, + signDigest, + ethSignatureBytes, + recoverSigner, + ) +where + +import Control.Concurrent.STM +import Crypto.Random (ChaChaDRG) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Int (Int64) +import Data.Text (Text) +import Data.Word (Word32, Word8) +import Simplex.Messaging.Crypto.BIP32 (hardened) +import qualified Simplex.Messaging.Crypto.BIP32 as B32 +import qualified Simplex.Messaging.Crypto.BIP39 as B39 +import qualified Simplex.Messaging.Crypto.Secp256k1 as S +import Simplex.Messaging.Eth.Address (Address, addressFromPrivateKey, addressFromPublicKey, ethereumPath) +import qualified Simplex.Messaging.Eth.Stealth as St + +newtype SeedId = SeedId Int64 + deriving (Eq, Ord, Show) + +-- | BIP-44 account index within a seed. One per chat profile. +type AccountIndex = Word32 + +-- | The chains an account can hold keys on. +-- +-- Present in full from the first migration although only 'ChainEth' is +-- implemented, so that adding Bitcoin or Monero later changes no type signature +-- and no stored row — see the layout note above 'mainPath'. +data Chain = ChainEth | ChainBtc | ChainXmr + deriving (Eq, Ord, Show) + +-- | Wire and database form. Stable: these strings are stored in +-- @wallet_one_time_addresses.chain@. +chainText :: Chain -> Text +chainText = \case + ChainEth -> "eth" + ChainBtc -> "btc" + ChainXmr -> "xmr" + +parseChain :: Text -> Maybe Chain +parseChain = \case + "eth" -> Just ChainEth + "btc" -> Just ChainBtc + "xmr" -> Just ChainXmr + _ -> Nothing + +-- | A seed, held as BIP-39 entropy. Stored in the chat database so it rides the +-- existing archive export and Migrate-to-another-device flows. +-- +-- 'Show' is redacting: this is the root secret behind every name it owns. +data WalletSeed = WalletSeed + { wsId :: SeedId, + wsEntropy :: ByteString, + wsBackedUp :: Bool + } + deriving (Eq) + +instance Show WalletSeed where + show s = "WalletSeed " <> show (wsId s) <> " " + +-- | What a chat profile stores: which seed, and which account index within it. +data AccountRef = AccountRef + { arSeedId :: SeedId, + arIndex :: AccountIndex + } + deriving (Eq, Show) + +-- | A derived account: the reference plus the key it resolves to. +data WalletAccount = WalletAccount + { waRef :: AccountRef, + waKey :: S.PrivateKey + } + deriving (Eq) + +instance Show WalletAccount where + show a = "WalletAccount " <> show (waRef a) <> " " + +-- | An Ethereum signature: @r || s || v@, 65 bytes, with @v = recId + 27@. +data EthSignature = EthSignature + { esR :: ByteString, + esS :: ByteString, + esV :: Word8 + } + deriving (Eq, Show) + +ethSignatureBytes :: EthSignature -> ByteString +ethSignatureBytes s = esR s <> esS s <> B.singleton (esV s) + +-- | Fresh seed entropy. Lazy by design: called only when the user buys their +-- first name. The id is assigned on insert. +newSeed :: B39.MnemonicStrength -> TVar ChaChaDRG -> STM ByteString +newSeed strength g = B39.mnemonicToEntropy <$> B39.randomMnemonic strength g + +-- | Import from a recovery phrase, validating the wordlist and BIP-39 checksum. +importRecoveryKey :: ByteString -> Either String ByteString +importRecoveryKey phrase = B39.mnemonicToEntropy <$> B39.parseMnemonic phrase + +-- | The phrase to show the user under "recovery key". +recoveryKeyPhrase :: WalletSeed -> Either String ByteString +recoveryKeyPhrase s = B39.mnemonicPhrase <$> B39.entropyToMnemonic (wsEntropy s) + +-- | The BIP-32 master key for a seed. +-- +-- BIP-39 seed derivation uses an empty passphrase: a 25th-word passphrase would +-- be a second secret to back up, and losing it would be indistinguishable from +-- losing the phrase. +seedMaster :: WalletSeed -> Either String B32.ExtendedKey +seedMaster s = do + m <- B39.entropyToMnemonic (wsEntropy s) + B32.masterKey (B39.mnemonicToSeed m "") + +-- Derivation layout. +-- +-- These paths are the one part of the wallet that can never change: altering +-- them after a user holds a name means moving assets, and there is no safe +-- migration. They live here rather than in the crypto library because the +-- layout is a product decision; the library holds only standard paths. +-- +-- @ +-- seed (BIP-39) +-- └── account i one per chat profile +-- ├── ETH m\/44'\/60'\/i'\/0\/0 main — names bought by this profile +-- │ m\/5564'\/60'\/i'\/0'\/0 stealth spend +-- │ m\/5564'\/60'\/i'\/1'\/0 stealth view +-- ├── BTC m\/352'\/0'\/i'\/0'\/0 silent-payment spend (BIP-352) +-- │ m\/352'\/0'\/i'\/1'\/0 silent-payment scan +-- └── XMR m\/44'\/128'\/i'\/0' then SHA3 + sc_reduce32, native subaddresses +-- @ +-- +-- The @0'@ = spend, @1'@ = view convention is BIP-352's, reused across chains so +-- there is one layout to remember. Purpose 5564 is ours: ERC-5564 has no +-- registered BIP-43 purpose, so this number is defined here once and never +-- changed. + +-- | Main account path: the ordinary address, which owns names this profile buys. +mainPath :: Chain -> AccountIndex -> Either String [Word32] +mainPath c ix = case c of + ChainEth -> Right $ ethereumPath ix + ChainBtc -> Left "wallet: bitcoin is not implemented" + ChainXmr -> Left "wallet: monero is not implemented" + +-- | Stealth spending key path. The recipient's private half of the meta-address. +stealthSpendPath :: Chain -> AccountIndex -> Either String [Word32] +stealthSpendPath c ix = case c of + ChainEth -> Right [hardened 5564, hardened 60, hardened ix, hardened 0, 0] + ChainBtc -> Right [hardened 352, hardened 0, hardened ix, hardened 0, 0] + ChainXmr -> Left "wallet: monero derives stealth keys natively, not on this path" + +-- | Stealth viewing key path. Finds one-time addresses; cannot spend from them. +stealthViewPath :: Chain -> AccountIndex -> Either String [Word32] +stealthViewPath c ix = case c of + ChainEth -> Right [hardened 5564, hardened 60, hardened ix, hardened 1, 0] + ChainBtc -> Right [hardened 352, hardened 0, hardened ix, hardened 1, 0] + ChainXmr -> Left "wallet: monero derives stealth keys natively, not on this path" + +-- | Derive a profile's main account. +deriveAccount :: WalletSeed -> AccountIndex -> Either String WalletAccount +deriveAccount s ix = do + master <- seedMaster s + path <- mainPath ChainEth ix + xk <- B32.derivePath master path + pure WalletAccount {waRef = AccountRef {arSeedId = wsId s, arIndex = ix}, waKey = B32.xkKey xk} + +accountAddress :: WalletAccount -> Address +accountAddress = addressFromPrivateKey . waKey + +-- | The stealth pair for an account: spending and viewing keys. +-- +-- Both derive from the same seed at fixed paths, so publishing a meta-address +-- adds nothing to back up — the recovery phrase already covers it. +-- +-- 'Show' is redacting: the spending key controls every name sent to this profile. +data StealthKeys = StealthKeys + { skSpend :: S.PrivateKey, + skView :: S.PrivateKey + } + deriving (Eq) + +instance Show StealthKeys where + show _ = "StealthKeys " + +deriveStealthKeys :: WalletSeed -> Chain -> AccountIndex -> Either String StealthKeys +deriveStealthKeys s c ix = do + master <- seedMaster s + spendPath <- stealthSpendPath c ix + viewPath <- stealthViewPath c ix + spend <- B32.derivePath master spendPath + view <- B32.derivePath master viewPath + pure StealthKeys {skSpend = B32.xkKey spend, skView = B32.xkKey view} + +-- | The account's published meta-address. +-- +-- The encoding is ERC-5564's and lives in "Simplex.Messaging.Eth.Stealth"; what +-- belongs here is only which keys go into it. Not an address and never +-- on-chain, which is what makes it safe to put in a SimpleX profile: holding it +-- lets someone send to this profile and nothing else, since deriving a one-time +-- address needs either the sender's ephemeral secret or the private viewing key. +accountMetaAddress :: StealthKeys -> St.StealthMetaAddress +accountMetaAddress ks = St.metaAddress (skSpend ks) (skView ks) + +-- | Sign a 32-byte digest (an EIP-712 @hashTypedData@ result). +signDigest :: WalletAccount -> ByteString -> Either String EthSignature +signDigest a digest = do + sig <- S.signRecoverable (waKey a) digest + let compact = S.rsCompact sig + pure + EthSignature + { esR = B.take 32 compact, + esS = B.drop 32 compact, + esV = fromIntegral (S.rsRecId sig) + 27 + } + +-- | Recover the address that produced a signature over a digest. This is what a +-- verifier does — the relayer, and the contracts on-chain. +recoverSigner :: EthSignature -> ByteString -> Either String Address +recoverSigner s digest + | esV s < 27 || esV s > 30 = Left "signature: v out of range" + | otherwise = do + let sig = S.RecoverableSignature {S.rsCompact = esR s <> esS s, S.rsRecId = fromIntegral (esV s) - 27} + addressFromPublicKey <$> S.recoverPublicKey sig digest diff --git a/src/Simplex/Chat/Wallet/Stealth.hs b/src/Simplex/Chat/Wallet/Stealth.hs new file mode 100644 index 0000000000..ede4f66743 --- /dev/null +++ b/src/Simplex/Chat/Wallet/Stealth.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Stealth addressing bound to wallet accounts. +-- +-- "Simplex.Messaging.Eth.Stealth" holds the ERC-5564 scheme itself. This module +-- is the part that knows about profiles: it generates the sender's ephemeral +-- key, scans a batch of announcements on behalf of an account, and turns a +-- match into a key that can sign. +-- +-- Discovery in normal use is a chat message from the sender, not a scan: the +-- sender can only derive a destination if they hold the recipient's +-- meta-address, which reaches them through the profile over an established +-- connection. Scanning exists so that a recovery phrase alone is sufficient — +-- restore on a clean device and there is no message to read, so the ephemeral +-- key must also be recoverable from the chain. +module Simplex.Chat.Wallet.Stealth + ( Announcement (..), + OneTimeAccount (..), + giftDestination, + scanAnnouncements, + oneTimeAccount, + exportOneTimeKey, + metaAddressHex, + parseMetaAddressHex, + bytesHex, + parseHexBytes, + ) +where + +import Control.Concurrent.STM +import Control.Monad ((<=<)) +import Crypto.Random (ChaChaDRG) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Maybe (mapMaybe) +import Simplex.Chat.Wallet (StealthKeys (..)) +import qualified Simplex.Messaging.Crypto as C +import qualified Simplex.Messaging.Crypto.Secp256k1 as S +import Simplex.Messaging.Eth.Address (Address, addressFromPrivateKey) +import qualified Simplex.Messaging.Eth.Stealth as St + +-- | One entry of what the registrar announced: the sender's ephemeral public +-- key and the view tag that lets it be discarded cheaply. +data Announcement = Announcement + { anEphemeralPubKey :: ByteString, + anViewTag :: St.ViewTag + } + deriving (Eq, Show) + +-- | A destination this account controls. Not an 'Simplex.Chat.Wallet.AccountRef': +-- it has no account index, and is reached only through the seed plus the +-- ephemeral key that produced it. +-- +-- 'Show' is redacting. +data OneTimeAccount = OneTimeAccount + { otaAddress :: Address, + otaEphemeralPubKey :: ByteString, + otaKey :: S.PrivateKey + } + deriving (Eq) + +instance Show OneTimeAccount where + show a = "OneTimeAccount " <> show (otaAddress a) <> " " + +-- | Sender side: a fresh destination for a recipient's published meta-address. +-- +-- The ephemeral key is generated here and immediately discarded — only its +-- public half is kept, in the returned destination. Reusing one across +-- recipients would let them link the destinations, so there is no way to supply +-- it. +giftDestination :: TVar ChaChaDRG -> St.StealthMetaAddress -> IO (Either String St.StealthDestination) +giftDestination g ma = go (10 :: Int) + where + go 0 = pure $ Left "stealth: could not generate an ephemeral key" + go n = do + bs <- atomically $ C.randomBytes S.privateKeySize g + case S.mkPrivateKey bs of + -- A uniform 32 bytes is out of range with probability about 2^-128; + -- retrying is simpler to reason about than reducing mod n. + Left _ -> go (n - 1) + Right eph -> pure $ St.stealthDestination eph ma + +-- | Recipient side: which of these announcements are ours. +-- +-- The view tag is checked first, inside 'St.stealthMatch', so a non-match costs +-- one point multiplication and one hash rather than a full derivation. +-- Announcements that fail to parse are skipped rather than failing the batch: a +-- scan runs over whatever the chain holds, including entries written by other +-- software. +scanAnnouncements :: StealthKeys -> [Announcement] -> [(Announcement, Address)] +scanAnnouncements ks = mapMaybe match + where + spend = S.publicKey (skSpend ks) + match an = case St.stealthMatch (skView ks) spend (anEphemeralPubKey an) (anViewTag an) of + Right (Just addr) -> Just (an, addr) + _ -> Nothing + +-- | The account for a destination: its address and the key that signs for it. +oneTimeAccount :: StealthKeys -> ByteString -> Either String OneTimeAccount +oneTimeAccount ks ephemeralPubKey = do + key <- St.stealthPrivateKey (skSpend ks) (skView ks) ephemeralPubKey + pure + OneTimeAccount + { otaAddress = addressFromPrivateKey key, + otaEphemeralPubKey = ephemeralPubKey, + otaKey = key + } + +-- | The meta-address as hex, which is how it travels in a profile field and +-- how a user pastes it into @\/names gift@. +metaAddressHex :: St.StealthMetaAddress -> ByteString +metaAddressHex = toHex . St.metaAddressBytes + +parseMetaAddressHex :: ByteString -> Either String St.StealthMetaAddress +parseMetaAddressHex = St.parseMetaAddress <=< fromHex + +-- | Hex for values that travel as text: the ephemeral key in a transfer +-- message, and the exported one-time key. +bytesHex :: ByteString -> ByteString +bytesHex = toHex + +toHex :: ByteString -> ByteString +toHex = B.concatMap $ \w -> B.pack [hexDigit (w `div` 16), hexDigit (w `mod` 16)] + where + hexDigit n + | n < 10 = 0x30 + n + | otherwise = 0x57 + n + +-- | Decode hex that arrived as text, e.g. an ephemeral key in a message. +parseHexBytes :: ByteString -> Either String ByteString +parseHexBytes = fromHex + +fromHex :: ByteString -> Either String ByteString +fromHex bs + | odd (B.length bs) = Left "expected an even number of hex digits" + | otherwise = B.pack <$> mapM pair (chunk $ B.unpack bs) + where + chunk (a : b : rest) = (a, b) : chunk rest + chunk _ = [] + pair (a, b) = (\h l -> h * 16 + l) <$> digit a <*> digit b + digit w + | w >= 0x30 && w <= 0x39 = Right (w - 0x30) + | w >= 0x61 && w <= 0x66 = Right (w - 0x57) + | w >= 0x41 && w <= 0x46 = Right (w - 0x37) + | otherwise = Left "not a hex digit" + +-- | The raw private key for one received name, as hex. +-- +-- This is the escape hatch that keeps a received name non-custodial: an +-- ordinary secp256k1 key any wallet will import. It discloses that one address +-- and nothing else — not the seed, not the other names, not the meta-address — +-- which is why it is safe to offer per name. +exportOneTimeKey :: OneTimeAccount -> ByteString +exportOneTimeKey = toHex . S.unPrivateKey . otaKey diff --git a/tests/Bots/BroadcastTests.hs b/tests/Bots/BroadcastTests.hs index 9edbb3cb73..83125de6d8 100644 --- a/tests/Bots/BroadcastTests.hs +++ b/tests/Bots/BroadcastTests.hs @@ -33,7 +33,7 @@ withBroadcastBot opts test = bot = simplexChatCore testCfg (mkChatOpts opts) $ broadcastBot opts broadcastBotProfile :: Profile -broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadcast Bot", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing} +broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadcast Bot", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing, metaAddress = Nothing} mkBotOpts :: TestParams -> [KnownContact] -> BroadcastBotOpts mkBotOpts ps publishers = diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index ad5fb6c8a4..b5a01c90bd 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -107,7 +107,7 @@ directoryNameTests = do it "should mark an inconsistent SimpleX name as not verified" testDirectoryChannelNameNotVerified directoryProfile :: Profile -directoryProfile = Profile {displayName = "SimpleX Directory", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing} +directoryProfile = Profile {displayName = "SimpleX Directory", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing, metaAddress = Nothing} mkDirectoryOpts :: TestParams -> [KnownContact] -> Maybe KnownGroup -> Maybe FilePath -> DirectoryOpts mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder = diff --git a/tests/ChatTests/Names.hs b/tests/ChatTests/Names.hs index 46b62801fe..95bad67c5a 100644 --- a/tests/ChatTests/Names.hs +++ b/tests/ChatTests/Names.hs @@ -26,6 +26,8 @@ chatNamesTests = do it "connect by name resolving to channel (primary) and direct contact" testConnectByNameChannelAndContact it "connect by name resolving to direct contact (primary) and channel" testConnectByNameContactAndChannel it "connect by name resolving to business (primary) and channel" testConnectByNameBusinessAndChannel + it "gift a name to a contact by name, using their published meta-address" testGiftByContactName + it "gift to a raw address is found by scanning, with no message" testGiftByMetaAddress testConnectByName :: HasCallStack => TestParams -> IO () testConnectByName ps = withSmpServerAndNames $ \reg -> @@ -308,3 +310,66 @@ testConnectByNameBusinessAndChannel ps = withSmpServerAndNames $ \reg -> bob <## "SimpleX name: @biz.simplex (verified)" where bizName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "biz" []) + +-- | The point of putting the meta-address in the profile: the sender pastes +-- nothing and no handshake happens beyond the connection they already have. +-- +-- Bob publishes his meta-address, it travels to Alice with his profile, and she +-- gifts him a name by contact name alone. He then finds it by scanning the +-- announcement, having received no message about it at all. +testGiftByContactName :: HasCallStack => TestParams -> IO () +testGiftByContactName ps = withSmpServerAndNames $ \_reg -> + testChat2 aliceProfile bobProfile test ps + where + test alice bob = do + -- publishing is what /names address does; it updates the profile + -- publishing puts the meta-address in bob's profile, which then travels + -- to alice with it when they connect - nothing extra is exchanged + bob ##> "/names address" + bob <##. "name address" + bob <##. "meta-address (" + connectUsers alice bob + alice ##> "/names buy alicechat" + alice <## "registered alicechat.simplex" + alice <##. "tx " + alice ##> "/names gift alicechat @bob" + alice <## "gift alicechat.simplex done" + alice <##. "tx " + -- bob is told, and his client records the destination from the message + bob <# "alice> You were given the SimpleX name alicechat.simplex" + -- The transfer message carries the ephemeral key, so bob's client records + -- the destination on arrival. No rescan. + bob ##> "/names incoming" + bob <## "names sent to you, not yet accepted:" + bob <##. " alicechat.simplex at 0x" + bob <## "" + bob <## "accepting links this profile to the name on chain; declining leaves no trace" + +-- | The other half of discovery: a gift to a raw address sends no message, so +-- the recipient finds it only by scanning the chain announcement. This is the +-- path a restored device takes, where there is no message to read. +testGiftByMetaAddress :: HasCallStack => TestParams -> IO () +testGiftByMetaAddress ps = withSmpServerAndNames $ \_reg -> + testChat2 aliceProfile bobProfile test ps + where + test alice bob = do + bob ##> "/names address" + bob <##. "name address" + metaLine <- getTermLine bob + let meta = reverse . takeWhile (/= ' ') . reverse $ metaLine + alice ##> "/names buy scanchat" + alice <## "registered scanchat.simplex" + alice <##. "tx " + alice ##> ("/names gift scanchat " <> meta) + alice <## "gift scanchat.simplex done" + alice <##. "tx " + -- No contact, so no message: bob has been told nothing at all. + bob ##> "/names incoming" + bob <## "no names have been sent to you" + bob ##> "/names rescan" + bob <## "found 1 name(s) sent to you - see /names incoming" + bob ##> "/names incoming" + bob <## "names sent to you, not yet accepted:" + bob <##. " scanchat.simplex at 0x" + bob <## "" + bob <## "accepting links this profile to the name on chain; declining leaves no trace" diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index c65306474c..4bab9dced6 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -613,7 +613,7 @@ testMultiWordProfileNames = aliceProfile' = baseProfile {displayName = "Alice Jones"} bobProfile' = baseProfile {displayName = "Bob James"} cathProfile' = baseProfile {displayName = "Cath Johnson"} - baseProfile = Profile {displayName = "", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs, badge = Nothing, contactDomain = Nothing} + baseProfile = Profile {displayName = "", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs, badge = Nothing, contactDomain = Nothing, metaAddress = Nothing} testUserContactLink :: HasCallStack => TestParams -> IO () testUserContactLink = diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index dfcf76f761..f766a9c98a 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -89,7 +89,7 @@ serviceProfile :: Profile serviceProfile = mkProfile "service_user" "Service user" Nothing mkProfile :: T.Text -> T.Text -> Maybe ImageData -> Profile -mkProfile displayName descr image = Profile {displayName, fullName = "", shortDescr = Just descr, description = Nothing, image, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs, badge = Nothing, contactDomain = Nothing} +mkProfile displayName descr image = Profile {displayName, fullName = "", shortDescr = Just descr, description = Nothing, image, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs, badge = Nothing, contactDomain = Nothing, metaAddress = Nothing} it :: HasCallStack => String -> (ps -> Expectation) -> SpecWith (Arg (ps -> Expectation)) it name test = diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 63dbea549f..017bda3581 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -108,7 +108,7 @@ testGroupPreferences :: Maybe GroupPreferences testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, reactions = Just ReactionsGroupPreference {enable = FEOn}, voice = Just VoiceGroupPreference {enable = FEOn, role = Nothing}, files = Nothing, fullDelete = Nothing, simplexLinks = Nothing, history = Nothing, reports = Nothing, support = Nothing, sessions = Nothing, comments = Nothing, signMessages = Nothing, commands = Nothing} testProfile :: Profile -testProfile = Profile {displayName = "alice", fullName = "Alice", shortDescr = Nothing, description = Nothing, image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII="), peerType = Nothing, contactLink = Nothing, preferences = testChatPreferences, badge = Nothing, contactDomain = Nothing} +testProfile = Profile {displayName = "alice", fullName = "Alice", shortDescr = Nothing, description = Nothing, image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII="), peerType = Nothing, contactLink = Nothing, preferences = testChatPreferences, badge = Nothing, contactDomain = Nothing, metaAddress = Nothing} testGroupProfile :: GroupProfile testGroupProfile = GroupProfile {displayName = "team", fullName = "Team", description = Nothing, shortDescr = Nothing, image = Nothing, publicGroup = Nothing, groupPreferences = testGroupPreferences, memberAdmission = Nothing} @@ -242,7 +242,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do #==# XInfo testProfile it "x.info with empty full name" $ "{\"v\":\"9\",\"event\":\"x.info\",\"params\":{\"profile\":{\"fullName\":\"\",\"displayName\":\"alice\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}" - #==# XInfo Profile {displayName = "alice", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = testChatPreferences, badge = Nothing, contactDomain = Nothing} + #==# XInfo Profile {displayName = "alice", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = testChatPreferences, badge = Nothing, contactDomain = Nothing, metaAddress = Nothing} it "x.contact with xContactId" $ "{\"v\":\"9\",\"event\":\"x.contact\",\"params\":{\"contactReqId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}" #==# XContact testProfile (Just $ XContactId "\1\2\3\4") Nothing Nothing diff --git a/tests/Test.hs b/tests/Test.hs index 84a019c21c..138c891703 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -25,6 +25,7 @@ import Test.Hspec hiding (it) import UnliftIO.Temporary (withTempDirectory) import ValidNames import ViewTests +import WalletTests #if defined(dbPostgres) import Control.Exception (bracket_) import PostgresSchemaDump @@ -69,6 +70,7 @@ main = do describe "SimpleX chat view" viewTests describe "SimpleX chat protocol" protocolTests describe "Valid names" validNameTests + describe "Wallet derivation" walletTests describe "Message batching" batchingTests describe "Operators" operatorTests describe "Random servers" randomServersTests diff --git a/tests/WalletTests.hs b/tests/WalletTests.hs new file mode 100644 index 0000000000..2f1e8b783d --- /dev/null +++ b/tests/WalletTests.hs @@ -0,0 +1,363 @@ +{-# 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}