/goal iteration 4 - unconfirmed

src/Simplex/Chat/Controller.hs

@@ -43,9 +43,7 @@ import Data.Set (Set)
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe)
 import Data.String
-import Data.List (foldl')
 import Data.Text (Text)
-import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1)
 import Data.Time (NominalDiffTime, UTCTime)
 import Data.Time.Clock.System (SystemTime (..), systemToUTCTime)
@@ -70,7 +68,7 @@ import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences
 import Simplex.Chat.Types.Shared
 import Simplex.Chat.Types.UITheme
-import Simplex.Chat.Wallet (NameIndex)
+import Simplex.Chat.Wallet (AccountIndex, WalletAddress, WalletError)
 import Simplex.Chat.Util (liftIOEither)
 import Simplex.FileTransfer.Description (FileDescriptionURI)
 import Simplex.Messaging.Server.Information (ServerPublicInfo)
@@ -419,11 +417,13 @@ data ChatCommand
   | APIRejectContact {contactReqId :: Int64, notify :: Bool}
   | APISendServiceRequest {userId :: UserId, sendTarget :: ConnectTarget 'CMContact, requestTimeout :: Maybe NominalDiffTime, signKey :: Maybe (C.StoredPrivateKey 'C.Ed25519), request :: J.Object}
   | APISendServiceResponse {userId :: UserId, requestId :: AgentInvId, responseData :: J.Object}
-  | APIWallet
-  | APIWalletCreate {recoveryPhrase :: Maybe Text}
-  | APIWalletExportSeedMnemonic
-  | APIWalletExportNameSecret {nameIndex :: NameIndex}
-  | APIWalletDelete
+  | APIGetWallet
+  | APICreateWallet {mnemonic :: Maybe Text}
+  | APIBindWalletAccount {accountIndex_ :: Maybe AccountIndex}
+  | APIGetWalletAddress {accountIndex_ :: Maybe AccountIndex}
+  | APIExportWalletMnemonic
+  | APIExportWalletAccount {accountIndex :: AccountIndex}
+  | APIDeleteWallet
   | APISendCallInvitation ContactId CallType
   | SendCallInvitation ContactName CallType
   | APIRejectCall ContactId
@@ -751,16 +751,6 @@ allowRemoteCommand = \case
   ExecAgentStoreSQL _ -> False
   _ -> True
 
--- | Command text for a log, with any secret blanked. A secret is the last
--- argument and takes the rest of the line, so blanking from its name is enough.
-redactedCommand :: Text -> Text
-redactedCommand s = foldl' blank s ["mnemonic=", "secret="]
-  where
-    blank t p = case T.breakOn p t of
-      (before, after)
-        | T.null after -> t
-        | otherwise -> before <> p <> "<redacted>"
-
 data RelayConnectionResult = RelayConnectionResult
   { relayMember :: GroupMember,
     relayError :: Maybe ChatError
@@ -860,9 +850,10 @@ data ChatResponse
   | CRContactRequestRejected {user :: User, contactRequest :: UserContactRequest, contact_ :: Maybe Contact}
   | CRServiceResponse {user :: User, responseData :: J.Object}
   | CRServiceReplyAccepted {user :: User, connectionId :: AgentConnId}
-  | CRWallet {user :: User, walletKeyExists :: Bool, walletKeyPaths :: [(Text, Text)]}
-  | CRWalletSeedMnemonic {user :: User, recoveryPhrase :: Text}
-  | CRWalletDerivedSecret {user :: User, keyPath :: Text, address :: Text, derivedSecret :: Text}
+  | CRWallet {user :: User, accountIndexes_ :: Maybe [AccountIndex]}
+  | CRWalletMnemonic {user :: User, mnemonic :: Text}
+  | CRWalletAddress {user :: User, walletAddress :: WalletAddress}
+  | CRWalletAccountSecret {user :: User, walletAddress :: WalletAddress, secret :: Text}
   | CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact}
   | CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], withMessages :: Bool, msgSigned :: Bool}
   | CRGroupsList {user :: User, groups :: [GroupInfo]}
@@ -1491,6 +1482,7 @@ data ChatErrorType
   | CEChatStoreChanged
   | CEInvalidConnReq
   | CESimplexDomainNotReady {simplexDomain :: SimplexDomain, simplexDomainError :: SimplexDomainError}
+  | CEWallet {walletError :: WalletError}
   | CENotResolvedLocally -- a name or link is not a known chat in the local store and online resolution is off (PRMNever)
   | CEUnsupportedConnReq
   | CEInvalidChatMessage {connection :: Connection, msgMeta :: Maybe MsgMetaJSON, messageData :: Text, message :: String}

src/Simplex/Chat/Library/Commands.hs

@@ -58,8 +58,8 @@ import qualified Data.UUID.V4 as V4
 import Simplex.Chat.Library.Subscriber
 import Simplex.Chat.Badges (BadgeCredential (..), LocalBadge (..), badgeServerCredential, maxXFTPFileSize, mkBadgeStatus, verifyCredential)
 import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim)
-import Simplex.Chat.Store.Wallets (createSeed, deleteSeed, getDeviceSeed, getNextNameIndex)
-import Simplex.Chat.Wallet (NameIndex, WalletSeed (..), deriveNameKey, importRecoveryKey, nameKeySecret, newSeed, recoveryKeyPhrase, renderNameKeyPath, seedMaster)
+import Simplex.Chat.Store.Wallets (accountHeldByOther, bindAccount, createWalletSeed, deleteWalletSeed, getNextAccountIndex, getUserAccounts, getWalletSeed)
+import Simplex.Chat.Wallet (AccountIndex, AccountKey, WalletAddress (..), WalletError (..), WalletSeed (..), accountSecret, checkAccountIndex, deriveAccountKey, entropyFromMnemonic, newSeedEntropy, renderAccountPath, seedMaster, seedMnemonic)
 import Simplex.Messaging.Eth.Address (addressFromPrivateKey)
 import Simplex.Chat.Call
 import Simplex.Chat.Controller
@@ -107,7 +107,6 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Agent.Store.Interface (getCurrentMigrations)
 import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..), NetworkTimeout (..), SMPWebPortServers (..), SocksMode (SMAlways), pattern NRMInteractive, textToHostMode)
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.BIP39 (MnemonicStrength (..))
 import qualified Simplex.Messaging.Crypto.ShortLink as SL
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
 import qualified Simplex.Messaging.Crypto.File as CF
@@ -1492,30 +1491,39 @@ processChatCommand cxt nm = \case
     let AgentInvId invId = requestId
     connId <- withAgent $ \a -> sendServiceReplyAsync a "" (aUserId user) invId (LB.toStrict $ J.encode responseData)
     pure $ CRServiceReplyAccepted user (AgentConnId connId)
-  APIWallet -> withUser $ \user -> do
-    withFastStore' getDeviceSeed >>= \case
-      Nothing -> pure $ CRWallet user False []
-      Just seed -> do
-        next <- withFastStore' $ \db -> getNextNameIndex db (wsId seed)
-        CRWallet user True <$> nameKeyRows seed next
-  APIWalletCreate phrase_ -> withUser $ \_ -> do
-    entropy <- case phrase_ of
-      Nothing -> asks random >>= atomically . newSeed MS256
-      Just phrase -> either (const $ throwCmdError "bad recovery phrase") pure $ importRecoveryKey (encodeUtf8 phrase)
-    created <- withFastStore' $ \db -> createSeed db entropy
-    unless created $ throwCmdError "this device already has a wallet key"
-    processChatCommand cxt nm APIWallet
-  APIWalletExportSeedMnemonic -> withUser $ \user -> do
-    seed <- deviceSeed
-    phrase <- either throwCmdError pure $ recoveryKeyPhrase seed
-    pure $ CRWalletSeedMnemonic user (safeDecodeUtf8 phrase)
-  APIWalletExportNameSecret nameIdx -> withUser $ \user -> do
-    seed <- deviceSeed
-    k <- either throwCmdError pure $ seedMaster seed >>= \m -> deriveNameKey m nameIdx
-    pure $ CRWalletDerivedSecret user (renderNameKeyPath nameIdx) (decodeLatin1 . strEncode $ addressFromPrivateKey k) (safeDecodeUtf8 $ nameKeySecret k)
-  APIWalletDelete -> withUser $ \_ -> do
-    seed <- deviceSeed
-    withFastStore' $ \db -> deleteSeed db (wsId seed)
+  APIGetWallet -> withUser $ \user@User {userId} ->
+    CRWallet user <$> withFastStore' (\db -> getWalletSeed db $>>= \WalletSeed {wsId} -> Just <$> getUserAccounts db wsId userId)
+  APICreateWallet mnemonic_ -> withUser $ \_ -> do
+    -- a generated seed has taken no accounts; an imported one does not say how
+    -- many it has taken, and only a scan of the chain can tell
+    (entropy, nextAccount) <- case mnemonic_ of
+      Nothing -> (,Just 0) <$> (asks random >>= atomically . newSeedEntropy)
+      Just phrase -> (,Nothing) <$> liftWallet (entropyFromMnemonic $ encodeUtf8 phrase)
+    created <- withFastStore' $ \db -> createWalletSeed db entropy nextAccount
+    unless created $ throwWalletError WEMasterExists
+    processChatCommand cxt nm APIGetWallet
+  APIBindWalletAccount accountIdx_ -> withUser $ \User {userId, viewPwdHash} -> do
+    seed <- walletSeed
+    when (isJust viewPwdHash) $ throwWalletError WEHiddenProfile
+    _ <- liftWallet =<< withFastStore' (\db -> bindAccount db (wsId seed) userId accountIdx_)
+    processChatCommand cxt nm APIGetWallet
+  APIGetWalletAddress accountIdx_ -> withUser $ \user -> do
+    seed <- walletSeed
+    n <- resolveAccount seed accountIdx_
+    CRWalletAddress user . accountAddress n <$> accountKey seed n
+  APIExportWalletMnemonic -> withUser $ \user ->
+    CRWalletMnemonic user <$> (liftWallet . seedMnemonic =<< walletSeed)
+  APIExportWalletAccount accountIdx -> withUser $ \user@User {userId} -> do
+    seed <- walletSeed
+    n <- resolveAccount seed (Just accountIdx)
+    -- a key another profile holds is not this profile's to hand out
+    heldByOther <- withFastStore' $ \db -> accountHeldByOther db (wsId seed) userId n
+    when heldByOther $ throwWalletError WEAccountBound
+    k <- accountKey seed n
+    pure $ CRWalletAccountSecret user (accountAddress n k) (accountSecret k)
+  APIDeleteWallet -> withUser $ \_ -> do
+    seed <- walletSeed
+    withFastStore' $ \db -> deleteWalletSeed db (wsId seed)
     ok_
   APISendCallInvitation contactId callType -> withUser $ \user -> do
     -- party initiating call
@@ -5453,17 +5461,32 @@ withExpirationDate globalTTL chatItemTTL action = do
   let ttl = fromMaybe globalTTL chatItemTTL
   when (ttl > 0) $ action $ addUTCTime (-1 * fromIntegral ttl) currentTs
 
-walletNamesShown :: Int
-walletNamesShown = 2
+walletSeed :: CM WalletSeed
+walletSeed = withFastStore' getWalletSeed >>= maybe (throwWalletError WENoMaster) pure
 
-deviceSeed :: CM WalletSeed
-deviceSeed = withFastStore' getDeviceSeed >>= maybe (throwCmdError "no wallet key on this device") pure
+throwWalletError :: WalletError -> CM a
+throwWalletError = throwChatError . CEWallet
 
-nameKeyRows :: WalletSeed -> NameIndex -> CM [(Text, Text)]
-nameKeyRows seed next = either throwCmdError pure $ do
-  master <- seedMaster seed
-  forM (take walletNamesShown [next ..]) $ \nm ->
-    (renderNameKeyPath nm,) . decodeLatin1 . strEncode . addressFromPrivateKey <$> deriveNameKey master nm
+liftWallet :: Either WalletError a -> CM a
+liftWallet = either throwWalletError pure
+
+-- | The account a command names, or the next free one when it names none.
+-- Refuses any index BIP-32 cannot harden, the counter's included.
+resolveAccount :: WalletSeed -> Maybe AccountIndex -> CM AccountIndex
+resolveAccount seed accountIdx_ = do
+  n <- maybe nextFreeAccount pure accountIdx_
+  n <$ liftWallet (checkAccountIndex n)
+  where
+    nextFreeAccount =
+      withFastStore' (\db -> getNextAccountIndex db (wsId seed))
+        >>= maybe (throwWalletError WECounterUnknown) pure
+
+accountKey :: WalletSeed -> AccountIndex -> CM AccountKey
+accountKey seed n = liftWallet $ seedMaster seed >>= (`deriveAccountKey` n)
+
+accountAddress :: AccountIndex -> AccountKey -> WalletAddress
+accountAddress n k =
+  WalletAddress {accountIndex = n, keyPath = renderAccountPath n, address = decodeLatin1 . strEncode $ addressFromPrivateKey k}
 
 chatCommandP :: Parser ChatCommand
 chatCommandP =
@@ -5583,12 +5606,16 @@ chatCommandP =
       "/_reject " *> (APIRejectContact <$> A.decimal <*> (" notify=" *> onOffP <|> pure False)),
       "/_service_request " *> (APISendServiceRequest <$> A.decimal <* A.space <*> strP <*> optional (" timeout=" *> (realToFrac <$> A.double)) <*> optional (" sign_key=" *> strP) <* A.space <*> jsonP),
       "/_service_response " *> (APISendServiceResponse <$> A.decimal <* A.space <*> strP <* A.space <*> jsonP),
-      "/_wallet create new" $> APIWalletCreate Nothing,
-      "/_wallet create mnemonic=" *> (APIWalletCreate . Just <$> textP),
-      "/_wallet export name " *> (APIWalletExportNameSecret <$> keyIndexP),
-      "/_wallet export" $> APIWalletExportSeedMnemonic,
-      "/_wallet delete" $> APIWalletDelete,
-      "/_wallet" $> APIWallet,
+      "/_wallet create new" $> APICreateWallet Nothing,
+      "/_wallet create mnemonic=" *> (APICreateWallet . Just <$> textP),
+      "/_wallet bind account=" *> (APIBindWalletAccount . Just <$> accountIndexP),
+      "/_wallet bind" $> APIBindWalletAccount Nothing,
+      "/_wallet address account=" *> (APIGetWalletAddress . Just <$> accountIndexP),
+      "/_wallet address" $> APIGetWalletAddress Nothing,
+      "/_wallet export master" $> APIExportWalletMnemonic,
+      "/_wallet export account " *> (APIExportWalletAccount <$> accountIndexP),
+      "/_wallet delete" $> APIDeleteWallet,
+      "/_wallet" $> APIGetWallet,
       "/_call invite @" *> (APISendCallInvitation <$> A.decimal <* A.space <*> jsonP),
       "/call " *> char_ '@' *> (SendCallInvitation <$> displayNameP <*> pure defaultCallType),
       "/_call reject @" *> (APIRejectCall <$> A.decimal),
@@ -6129,12 +6156,12 @@ chatCommandP =
     quotedP = safeDecodeUtf8 <$> (A.char '"' *> A.takeTill (== '"') <* A.char '"')
     text1P = safeDecodeUtf8 <$> A.takeTill (== ' ')
     char_ = optional . A.char
-    -- BIP-32 hardens at 2^31, and Word32 would wrap. Digits are counted before
-    -- they are read, as reading a very long number is not free.
-    keyIndexP = do
+    -- Digits are counted before they are read, as reading a very long number is
+    -- not free. The hardening bound is a typed error when the command runs.
+    accountIndexP = do
       ds <- A.takeWhile1 isDigit
       let i = read (B.unpack ds) :: Integer
-      if B.length ds <= 10 && i < 0x80000000 then pure (fromIntegral i) else fail "key index too large"
+      if B.length ds <= 10 && i <= toInteger (maxBound :: AccountIndex) then pure (fromIntegral i) else fail "account index too large"
 
 displayNameP :: Parser Text
 displayNameP = safeDecodeUtf8 <$> displayNameP_

src/Simplex/Chat/Remote.hs

@@ -552,7 +552,9 @@ liftRC = liftError (ChatErrorRemoteCtrl . RCEProtocolError)
 
 handleSend :: (ByteString -> Int -> CM' (Either ChatError ChatResponse)) -> Text -> Int -> CM' RemoteResponse
 handleSend execCC command retryNum = do
-  logDebug $ "Send: " <> tshow (redactedCommand command)
+  -- only the verb: the rest of the line can carry a mnemonic, and blanking it by
+  -- substring was guesswork
+  logDebug $ "Send: " <> T.takeWhile (/= ' ') command
   -- execCC is execChatCommand CSRemoteCtrl, which checks allowRemoteCommand
   -- convert errors thrown in execCC into error responses to prevent aborting the protocol wrapper
   RRChatResponse . eitherToResult <$> execCC (encodeUtf8 command) retryNum

src/Simplex/Chat/Store/Postgres/Migrations/M20260908_wallet_seeds.hs

@@ -11,20 +11,34 @@ m20260908_wallet_seeds =
   [r|
 CREATE TABLE wallet_seeds (
   wallet_seed_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY,
-  entropy BYTEA NOT NULL,
+  entropy BYTEA NOT NULL CHECK (length(entropy) = 32),
   -- see the SQLite migration
-  next_name_index BIGINT NOT NULL DEFAULT 1,
-  -- one seed per device for now
+  next_account_index BIGINT CHECK (next_account_index BETWEEN 0 AND 2147483648),
   single_seed SMALLINT NOT NULL DEFAULT 1
 );
 
+CREATE TABLE wallet_accounts (
+  wallet_account_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY,
+  wallet_seed_id BIGINT NOT NULL REFERENCES wallet_seeds ON DELETE CASCADE,
+  account_index BIGINT CHECK (account_index BETWEEN 0 AND 2147483647),
+  user_id BIGINT REFERENCES users ON DELETE SET NULL
+);
+
 CREATE UNIQUE INDEX idx_wallet_seeds_single_seed ON wallet_seeds(single_seed);
+CREATE UNIQUE INDEX idx_wallet_accounts_index ON wallet_accounts(wallet_seed_id, account_index);
+CREATE INDEX idx_wallet_accounts_user ON wallet_accounts(user_id);
 |]
 
 down_m20260908_wallet_seeds :: Text
 down_m20260908_wallet_seeds =
   [r|
+DROP INDEX idx_wallet_accounts_user;
+
+DROP INDEX idx_wallet_accounts_index;
+
 DROP INDEX idx_wallet_seeds_single_seed;
 
+DROP TABLE wallet_accounts;
+
 DROP TABLE wallet_seeds;
 |]

src/Simplex/Chat/Store/SQLite/Migrations/M20260908_wallet_seeds.hs

@@ -10,21 +10,33 @@ m20260908_wallet_seeds =
   [sql|
 CREATE TABLE wallet_seeds (
   wallet_seed_id INTEGER PRIMARY KEY AUTOINCREMENT,
-  entropy BLOB NOT NULL,
-  -- known issue: after an import this starts at 1, so it can hand out a name
-  -- key at a path that already owns a name
-  next_name_index INTEGER NOT NULL DEFAULT 1,
-  -- one seed per device for now
+  entropy BLOB NOT NULL CHECK (length(entropy) = 32), -- BIP-39 entropy, 24 words
+  next_account_index INTEGER CHECK (next_account_index BETWEEN 0 AND 2147483648),
   single_seed INTEGER NOT NULL DEFAULT 1
 ) STRICT;
 
+CREATE TABLE wallet_accounts (
+  wallet_account_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  wallet_seed_id INTEGER NOT NULL REFERENCES wallet_seeds ON DELETE CASCADE,
+  account_index INTEGER CHECK (account_index BETWEEN 0 AND 2147483647),
+  user_id INTEGER REFERENCES users ON DELETE SET NULL
+) STRICT;
+
 CREATE UNIQUE INDEX idx_wallet_seeds_single_seed ON wallet_seeds(single_seed);
+CREATE UNIQUE INDEX idx_wallet_accounts_index ON wallet_accounts(wallet_seed_id, account_index);
+CREATE INDEX idx_wallet_accounts_user ON wallet_accounts(user_id);
 |]
 
 down_m20260908_wallet_seeds :: Query
 down_m20260908_wallet_seeds =
   [sql|
+DROP INDEX idx_wallet_accounts_user;
+
+DROP INDEX idx_wallet_accounts_index;
+
 DROP INDEX idx_wallet_seeds_single_seed;
 
+DROP TABLE wallet_accounts;
+
 DROP TABLE wallet_seeds;
 |]

src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql

@@ -854,13 +854,16 @@ CREATE TABLE rcv_roster_transfers(
 ) STRICT;
 CREATE TABLE wallet_seeds(
   wallet_seed_id INTEGER PRIMARY KEY AUTOINCREMENT,
-  entropy BLOB NOT NULL,
-  -- known issue: after an import this starts at 1, so it can hand out a name
-  -- key at a path that already owns a name
-  next_name_index INTEGER NOT NULL DEFAULT 1,
-  -- one seed per device for now
+  entropy BLOB NOT NULL CHECK(length(entropy) = 32), -- BIP-39 entropy, 24 words
+  next_account_index INTEGER CHECK(next_account_index BETWEEN 0 AND 2147483648),
   single_seed INTEGER NOT NULL DEFAULT 1
 ) STRICT;
+CREATE TABLE wallet_accounts(
+  wallet_account_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  wallet_seed_id INTEGER NOT NULL REFERENCES wallet_seeds ON DELETE CASCADE,
+  account_index INTEGER CHECK(account_index BETWEEN 0 AND 2147483647),
+  user_id INTEGER REFERENCES users ON DELETE SET NULL
+) STRICT;
 CREATE INDEX contact_profiles_index ON contact_profiles(
   display_name,
   full_name
@@ -1396,6 +1399,11 @@ CREATE INDEX idx_chat_items_item_signed_by_group_member_id ON chat_items(
   item_signed_by_group_member_id
 );
 CREATE UNIQUE INDEX idx_wallet_seeds_single_seed ON wallet_seeds(single_seed);
+CREATE UNIQUE INDEX idx_wallet_accounts_index ON wallet_accounts(
+  wallet_seed_id,
+  account_index
+);
+CREATE INDEX idx_wallet_accounts_user ON wallet_accounts(user_id);
 CREATE TRIGGER on_group_members_insert_update_summary
 AFTER INSERT ON group_members
 FOR EACH ROW

src/Simplex/Chat/Store/Wallets.hs

@@ -1,49 +1,147 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeApplications #-}
 
+-- | The device seed, and which chat profile each account belongs to.
 module Simplex.Chat.Store.Wallets
-  ( getDeviceSeed,
-    getNextNameIndex,
-    createSeed,
-    deleteSeed,
+  ( getWalletSeed,
+    createWalletSeed,
+    deleteWalletSeed,
+    getNextAccountIndex,
+    getUserAccounts,
+    accountHeldByOther,
+    bindAccount,
   )
 where
 
+import Control.Monad (join, when)
+import Control.Monad.Except
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
 import Data.Int (Int64)
-import Simplex.Chat.Wallet (NameIndex, SeedId, WalletSeed (..))
+import Simplex.Chat.Wallet (AccountIndex, SeedId, WalletError (..), WalletSeed (..), checkAccountIndex)
+import Simplex.Messaging.Agent.Protocol (UserId)
 import Simplex.Messaging.Agent.Store.AgentStore (maybeFirstRow)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 
 #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) -> WalletSeed
-toSeed (sId, seed) = WalletSeed {wsId = sId, wsEntropy = seed}
+toSeed (sId, entropy) = WalletSeed {wsId = sId, wsEntropy = BA.convert entropy}
 
-getDeviceSeed :: DB.Connection -> IO (Maybe WalletSeed)
-getDeviceSeed db =
+getWalletSeed :: DB.Connection -> IO (Maybe WalletSeed)
+getWalletSeed db =
   maybeFirstRow toSeed $
     DB.query_ db "SELECT wallet_seed_id, entropy FROM wallet_seeds ORDER BY wallet_seed_id LIMIT 1"
 
--- | The index the next name bought on this device takes.
-getNextNameIndex :: DB.Connection -> SeedId -> IO NameIndex
-getNextNameIndex db sId =
-  maybe 1 (fromIntegral :: Int64 -> NameIndex)
-    <$> ( maybeFirstRow fromOnly $
-            DB.query db "SELECT next_name_index FROM wallet_seeds WHERE wallet_seed_id = ?" (Only sId)
-        )
-
--- | False if the device already has a seed.
-createSeed :: DB.Connection -> ByteString -> IO Bool
-createSeed db entropy =
-  getDeviceSeed db >>= \case
+-- | False if the device already has a seed. The counter is 'Nothing' for an
+-- imported phrase, which does not say how many accounts it has been used for.
+createWalletSeed :: DB.Connection -> BA.ScrubbedBytes -> Maybe AccountIndex -> IO Bool
+createWalletSeed db entropy nextAccount =
+  getWalletSeed db >>= \case
     Just _ -> pure False
-    Nothing -> True <$ DB.execute db "INSERT INTO wallet_seeds (entropy) VALUES (?)" (Only $ DB.Binary entropy)
+    Nothing ->
+      True
+        <$ DB.execute
+          db
+          "INSERT INTO wallet_seeds (entropy, next_account_index) VALUES (?, ?)"
+          (DB.Binary (BA.convert entropy :: ByteString), accountIndexCol <$> nextAccount)
 
-deleteSeed :: DB.Connection -> SeedId -> IO ()
-deleteSeed db sId = DB.execute db "DELETE FROM wallet_seeds WHERE wallet_seed_id = ?" (Only sId)
+deleteWalletSeed :: DB.Connection -> SeedId -> IO ()
+deleteWalletSeed db sId = DB.execute db "DELETE FROM wallet_seeds WHERE wallet_seed_id = ?" (Only sId)
+
+-- | The index the next account takes. Nothing after an import, where the phrase
+-- does not say how many accounts it has been used for.
+getNextAccountIndex :: DB.Connection -> SeedId -> IO (Maybe AccountIndex)
+getNextAccountIndex db sId =
+  fmap (fromIntegral @Int64) . join
+    <$> maybeFirstRow fromOnly (DB.query db "SELECT next_account_index FROM wallet_seeds WHERE wallet_seed_id = ?" (Only sId))
+
+-- | The accounts a profile holds, in index order. A profile holds as many as it
+-- owns names.
+getUserAccounts :: DB.Connection -> SeedId -> UserId -> IO [AccountIndex]
+getUserAccounts db sId userId =
+  map (fromIntegral @Int64 . fromOnly)
+    <$> DB.query
+      db
+      [sql|
+        SELECT account_index FROM wallet_accounts
+        WHERE wallet_seed_id = ? AND user_id = ? AND account_index IS NOT NULL
+        ORDER BY account_index
+      |]
+      (sId, userId)
+
+-- | Which profile holds an account: 'Nothing' when the device does not know the
+-- account at all, @Just Nothing@ when it knows it and no profile holds it.
+accountUser :: DB.Connection -> SeedId -> AccountIndex -> IO (Maybe (Maybe Int64))
+accountUser db sId n =
+  maybeFirstRow (fromOnly @(Maybe Int64)) $
+    DB.query db "SELECT user_id FROM wallet_accounts WHERE wallet_seed_id = ? AND account_index = ?" (sId, accountIndexCol n)
+
+-- | True when a profile other than this one holds the account, which is what
+-- keeps one profile from exporting another profile's key. An account no profile
+-- holds is not another profile's.
+heldByOther :: UserId -> Maybe (Maybe Int64) -> Bool
+heldByOther userId = \case
+  Just (Just heldBy) -> heldBy /= userId
+  _ -> False
+
+accountHeldByOther :: DB.Connection -> SeedId -> UserId -> AccountIndex -> IO Bool
+accountHeldByOther db sId userId n = heldByOther userId <$> accountUser db sId n
+
+-- | Bind an account to a profile: one the device already knows about, one a
+-- scan found, or the next free one when no index is given. Reading the counter
+-- and taking the account happen in one transaction, so two binds racing cannot
+-- both take it.
+bindAccount :: DB.Connection -> SeedId -> UserId -> Maybe AccountIndex -> IO (Either WalletError AccountIndex)
+bindAccount db sId userId accountIdx_ = runExceptT $ do
+  n <- maybe nextFreeAccount pure accountIdx_
+  liftEither $ checkAccountIndex n
+  held <- liftIO $ accountUser db sId n
+  when (heldByOther userId held) $ throwError WEAccountBound
+  liftIO $ do
+    case held of
+      Just (Just _) -> pure () -- already this profile's
+      Just Nothing -> setAccountUser db sId userId n
+      Nothing -> insertAccount db sId userId n
+    raiseNextAccount db sId n
+  pure n
+  where
+    nextFreeAccount = ExceptT $ maybe (Left WECounterUnknown) Right <$> getNextAccountIndex db sId
+
+setAccountUser :: DB.Connection -> SeedId -> UserId -> AccountIndex -> IO ()
+setAccountUser db sId userId n =
+  DB.execute
+    db
+    [sql| UPDATE wallet_accounts SET user_id = ? WHERE wallet_seed_id = ? AND account_index = ? |]
+    (userId, sId, accountIndexCol n)
+
+-- | Keep the counter a high-water mark, so an account taken by index is not
+-- handed out again as the next free one. Never lowers it, and never gives a
+-- value to the imported phrase that has none.
+raiseNextAccount :: DB.Connection -> SeedId -> AccountIndex -> IO ()
+raiseNextAccount db sId n =
+  DB.execute
+    db
+    [sql|
+      UPDATE wallet_seeds SET next_account_index = ?
+      WHERE wallet_seed_id = ? AND next_account_index IS NOT NULL AND next_account_index <= ?
+    |]
+    (accountIndexCol n + 1, sId, accountIndexCol n)
+
+insertAccount :: DB.Connection -> SeedId -> UserId -> AccountIndex -> IO ()
+insertAccount db sId userId n =
+  DB.execute db "INSERT INTO wallet_accounts (wallet_seed_id, account_index, user_id) VALUES (?, ?, ?)" (sId, accountIndexCol n, userId)
+
+-- | How an account index is stored: the column is a signed integer.
+accountIndexCol :: AccountIndex -> Int64
+accountIndexCol = fromIntegral

src/Simplex/Chat/View.hs

@@ -57,6 +57,7 @@ import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences
 import Simplex.Chat.Types.Shared
 import Simplex.Chat.Types.UITheme
+import Simplex.Chat.Wallet (WalletAddress (..), WalletError (..))
 import qualified Simplex.FileTransfer.Transport as XFTP
 import Simplex.Messaging.Agent (DatabaseDiff (..))
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..))
@@ -188,11 +189,13 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
   CRContactRequestRejected u UserContactRequest {localDisplayName = c} _ct_ -> ttyUser u [ttyContact c <> ": contact request rejected"]
   CRServiceResponse u resp -> ttyUser u ["service response: " <> viewJSON resp]
   CRServiceReplyAccepted u (AgentConnId cId) -> ttyUser u [plain $ "service reply accepted, connection id: " <> safeDecodeUtf8 (strEncode cId)]
-  CRWallet u exists paths -> ttyUser u $ if exists then map nameRow paths else ["no wallet key"]
-    where
-      nameRow (path, addr) = plain $ path <> "  " <> addr
-  CRWalletSeedMnemonic u phrase -> ttyUser u [plain phrase]
-  CRWalletDerivedSecret u path addr secret -> ttyUser u [plain $ path <> "  " <> addr <> "  " <> secret]
+  CRWallet u accounts_ -> ttyUser u $ case accounts_ of
+    Nothing -> ["no wallet on this device"]
+    Just [] -> ["wallet, no accounts for this profile"]
+    Just accounts -> [plain $ "accounts: " <> T.intercalate ", " (map tshow accounts)]
+  CRWalletMnemonic u mnemonic -> ttyUser u [plain mnemonic]
+  CRWalletAddress u a -> ttyUser u [walletAddressRow a]
+  CRWalletAccountSecret u a secret -> ttyUser u [walletAddressRow a <> "  " <> plain secret]
   CRGroupCreated u g -> ttyUser u $ viewGroupCreated g testView
   CRPublicGroupCreated u g _groupLink _relays -> ttyUser u $ viewGroupCreated g testView
   CRPublicGroupCreationFailed u results -> ttyUser u $ viewPublicGroupCreationFailed results
@@ -1098,6 +1101,21 @@ viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of
   ContactConnection _ -> []
   CInfoInvalidJSON {} -> []
 
+walletAddressRow :: WalletAddress -> StyledString
+walletAddressRow WalletAddress {accountIndex, keyPath, address} =
+  plain $ tshow accountIndex <> "  " <> keyPath <> "  " <> address
+
+walletErrorText :: WalletError -> Text
+walletErrorText = \case
+  WENoMaster -> "this device has no wallet"
+  WEMasterExists -> "this device already has a wallet"
+  WEBadMnemonic -> "not a valid 24 word recovery phrase"
+  WEHiddenProfile -> "a hidden profile cannot own an account"
+  WEAccountBound -> "another profile holds this account"
+  WECounterUnknown -> "unknown how many accounts this phrase has used, a scan of the chain has to run first"
+  WEIndexTooLarge -> "account index is too large to harden"
+  WEDerivation e -> "derivation failed: " <> T.pack e
+
 viewContactsList :: [Contact] -> [StyledString]
 viewContactsList =
   let getLDN :: Contact -> ContactName
@@ -2740,6 +2758,7 @@ viewChatError isCmd logLevel testView = \case
             SDENoValidLink -> "has no valid connection link"
             SDEUnknownDomain -> "is not included in the connection link's profile"
        in [plain $ "SimpleX name " <> strEncode domain <> " " <> reason]
+    CEWallet walletErr -> [plain $ "wallet: " <> walletErrorText walletErr]
     CENotResolvedLocally -> ["no matching chat found, name resolution is disabled"]
     CEUnsupportedConnReq -> [ "", "Connection link is not supported by the your app version, please ugrade it.", plain updateStr]
     CEInvalidChatMessage Connection {connId} msgMeta_ msg e ->

src/Simplex/Chat/Wallet.hs

@@ -1,25 +1,36 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 
--- | BIP-39 seeds and the keys derived from them.
+-- | The device wallet: one BIP-39 seed, and the accounts derived from it.
 --
--- One key per name. A name's secret is a leaf, so exporting it hands over that
--- name only.
+-- An account is a hardened BIP-44 account, @m\/44'\/60'\/n'\/0\/0@, which is how
+-- Ledger Live lays out an Ethereum wallet. The account level is hardened, so an
+-- exported account key hands over that account and reaches no other.
+--
+-- Nothing here knows about chat profiles. Which profile an account belongs to is
+-- a mapping in "Simplex.Chat.Store.Wallets".
 module Simplex.Chat.Wallet
   ( SeedId,
+    AccountIndex,
+    AccountKey,
     WalletSeed (..),
-    NameIndex,
-    newSeed,
-    importRecoveryKey,
-    recoveryKeyPhrase,
+    WalletAddress (..),
+    WalletError (..),
+    newSeedEntropy,
+    entropyFromMnemonic,
+    seedMnemonic,
     seedMaster,
-    deriveNameKey,
-    renderNameKeyPath,
-    nameKeySecret,
+    renderAccountPath,
+    deriveAccountKey,
+    accountSecret,
+    checkAccountIndex,
   )
 where
 
 import Control.Concurrent.STM
 import Crypto.Random (ChaChaDRG)
+import qualified Data.Aeson.TH as JQ
+import qualified Data.ByteArray as BA
 import qualified Data.ByteArray.Encoding as BAE
 import Data.ByteString (ByteString)
 import Data.Int (Int64)
@@ -30,44 +41,99 @@ 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 (ethereumPath)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
 
 type SeedId = Int64
 
--- | BIP-44 address index, one per name. Names sit in account 0, from index 1:
--- account 0 index 0 is left for the profile accounts to start beside.
-type NameIndex = Word32
+-- | BIP-44 account index. One account owns one thing on chain, one name to
+-- begin with.
+type AccountIndex = Word32
 
+-- | The key at an account index. It owns whatever that account owns.
+type AccountKey = S.PrivateKey
+
+-- | The device seed. The entropy is 'BA.ScrubbedBytes', so a derived 'Show'
+-- does not print it. Copies made for BIP-39 are plain 'ByteString' and are not
+-- wiped.
 data WalletSeed = WalletSeed
   { wsId :: SeedId,
-    wsEntropy :: ByteString
+    wsEntropy :: BA.ScrubbedBytes
   }
-  deriving (Eq)
+  deriving (Eq, Show)
 
-instance Show WalletSeed where
-  show s = "WalletSeed " <> show (wsId s) <> " <redacted>"
+-- | One derived address, with the index it came from, so a caller that left the
+-- index out knows what it got.
+data WalletAddress = WalletAddress
+  { accountIndex :: AccountIndex,
+    keyPath :: Text,
+    address :: Text
+  }
+  deriving (Show)
 
--- | No 25th-word passphrase: it would be a second secret to back up.
-newSeed :: B39.MnemonicStrength -> TVar ChaChaDRG -> STM ByteString
-newSeed strength g = B39.mnemonicToEntropy <$> B39.randomMnemonic strength g
+data WalletError
+  = WENoMaster -- the device has no master entropy
+  | WEMasterExists -- create, when it already has one
+  | WEBadMnemonic -- wrong word count, wrong word, or bad checksum
+  | WEHiddenProfile -- bind, on a profile the app hides
+  | WEAccountBound -- bind or export account, on an account another profile holds
+  | WECounterUnknown -- no counter to read yet, after an import
+  | WEIndexTooLarge -- at or above 2^31
+  | WEDerivation {derivationError :: String} -- BIP-32 or BIP-39 said no
+  deriving (Eq, Show)
 
-importRecoveryKey :: ByteString -> Either String ByteString
-importRecoveryKey phrase = B39.mnemonicToEntropy <$> B39.parseMnemonic phrase
+-- | BIP-32 hardens an index by adding 2^31, so an index at or above it is
+-- already a hardened component and derives the same key as the index it wraps
+-- onto. Refusing it is what keeps one account index to one key.
+checkAccountIndex :: AccountIndex -> Either WalletError ()
+checkAccountIndex n = if n >= B32.hardenedOffset then Left WEIndexTooLarge else Right ()
 
-recoveryKeyPhrase :: WalletSeed -> Either String ByteString
-recoveryKeyPhrase s = B39.mnemonicPhrase <$> B39.entropyToMnemonic (wsEntropy s)
+-- | 24 words. No 25th-word passphrase: it would be a second secret to back up,
+-- and losing it would look exactly like losing the phrase.
+masterStrength :: B39.MnemonicStrength
+masterStrength = B39.MS256
+
+newSeedEntropy :: TVar ChaChaDRG -> STM BA.ScrubbedBytes
+newSeedEntropy g = BA.convert . B39.mnemonicToEntropy <$> B39.randomMnemonic masterStrength g
+
+entropyFromMnemonic :: ByteString -> Either WalletError BA.ScrubbedBytes
+entropyFromMnemonic phrase = case B39.parseMnemonic phrase of
+  Right m | length (B39.mnemonicWords m) == B39.strengthWordCount masterStrength ->
+    Right . BA.convert $ B39.mnemonicToEntropy m
+  _ -> Left WEBadMnemonic
+
+seedMnemonic :: WalletSeed -> Either WalletError Text
+seedMnemonic s =
+  bipError . fmap (decodeLatin1 . B39.mnemonicPhrase) . B39.entropyToMnemonic $ entropyBytes s
 
 -- | Deriving this runs PBKDF2, so it is done once per command.
-seedMaster :: WalletSeed -> Either String B32.ExtendedKey
+seedMaster :: WalletSeed -> Either WalletError B32.ExtendedKey
 seedMaster s = do
-  m <- B39.entropyToMnemonic (wsEntropy s)
-  B32.masterKey (B39.mnemonicToSeed m "")
+  m <- bipError . B39.entropyToMnemonic $ entropyBytes s
+  bipError . B32.masterKey $ B39.mnemonicToSeed m ""
 
-renderNameKeyPath :: NameIndex -> Text
-renderNameKeyPath nm = decodeLatin1 . B32.renderPath $ ethereumPath 0 nm
+accountPath :: AccountIndex -> [Word32]
+accountPath n = ethereumPath n 0
 
-deriveNameKey :: B32.ExtendedKey -> NameIndex -> Either String S.PrivateKey
-deriveNameKey master nm = B32.xkKey <$> B32.derivePath master (ethereumPath 0 nm)
+renderAccountPath :: AccountIndex -> Text
+renderAccountPath = decodeLatin1 . B32.renderPath . accountPath
+
+deriveAccountKey :: B32.ExtendedKey -> AccountIndex -> Either WalletError AccountKey
+deriveAccountKey master n = B32.xkKey <$> bipError (B32.derivePath master $ accountPath n)
 
 -- | As wallets take it when a key is imported on its own.
-nameKeySecret :: S.PrivateKey -> ByteString
-nameKeySecret k = "0x" <> BAE.convertToBase BAE.Base16 (S.unPrivateKey k)
+accountSecret :: AccountKey -> Text
+accountSecret k = "0x" <> decodeLatin1 (BAE.convertToBase BAE.Base16 $ S.unPrivateKey k)
+
+entropyBytes :: WalletSeed -> ByteString
+entropyBytes = BA.convert . wsEntropy
+
+-- | The BIP-32 and BIP-39 functions report failure as a string. For entropy
+-- this module produced only 'B32.masterKey' and 'B32.derivePath' can fail at
+-- all, with a negligible probability, and nothing here retries, so the whole
+-- family shares one constructor.
+bipError :: Either String a -> Either WalletError a
+bipError = either (Left . WEDerivation) Right
+
+$(JQ.deriveJSON defaultJSON ''WalletAddress)
+
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "WE") ''WalletError)