mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-09-27 20:08:34 +00:00
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.
This commit is contained in:
Alain Brenzikofer
@@ -87,3 +87,5 @@ website/test/stubs-layout-cache/_includes/*.js
|
||||
apps/android/app/release
|
||||
apps/multiplatform/.kotlin/sessions
|
||||
|
||||
.idea/
|
||||
cabal.project.dev
|
||||
@@ -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
|
||||
+1
-1
@@ -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
|
||||
|
||||
@@ -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";
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
}
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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}
|
||||
@@ -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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 = ?
|
||||
|
||||
@@ -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,
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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;
|
||||
|]
|
||||
@@ -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;
|
||||
|]
|
||||
@@ -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 =
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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;
|
||||
|]
|
||||
@@ -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;
|
||||
|]
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|]
|
||||
|
||||
@@ -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)
|
||||
@@ -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
|
||||
|
||||
@@ -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]
|
||||
|
||||
@@ -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) <> " <redacted, backedUp=" <> show (wsBackedUp 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) <> " <redacted>"
|
||||
|
||||
-- | 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 <redacted>"
|
||||
|
||||
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
|
||||
@@ -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) <> " <redacted>"
|
||||
|
||||
-- | 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
|
||||
@@ -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 =
|
||||
|
||||
@@ -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 =
|
||||
|
||||
@@ -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"
|
||||
|
||||
@@ -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 =
|
||||
|
||||
@@ -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 =
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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}
|
||||
Reference in New Issue
Block a user