core: /_wallet bind, and name the other profiles instead of numbering them

Restoring a chat database older than the key loses which account each
profile had, and the keys are still there, so /_wallet bind <account> sets
it by hand. The counter moves past an account bound this way, and an
account another profile holds is refused.

/_wallet now shows the paths of the active profile only, and names the
other profiles on the key. Their account indexes were the gap that showed
a hidden profile exists.

Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01Rvc3HbiWBTqbAvRT45G5oX

bots/src/API/Docs/Commands.hs

@@ -451,6 +451,7 @@ undocumentedCommands =
     "APIVerifyGroupMember",
     "APIVerifyToken",
     "APIWallet",
+    "APIWalletBind",
     "APIWalletCreate",
     "APIWalletDelete",
     "APIWalletExportDerivedSecret",

src/Simplex/Chat/Controller.hs

@@ -418,6 +418,7 @@ data ChatCommand
   | 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
+  | APIWalletBind {accountIndex :: AccountIndex}
   | APIWalletCreate
   | APIWalletImport {recoveryPhrase :: Text}
   | APIWalletExportSeedMnemonic
@@ -749,6 +750,7 @@ allowRemoteCommand = \case
   ExecChatStoreSQL _ -> False
   ExecAgentStoreSQL _ -> False
   APIWallet -> False
+  APIWalletBind {} -> False
   APIWalletCreate -> False
   APIWalletImport _ -> False
   APIWalletExportSeedMnemonic -> False
@@ -855,7 +857,7 @@ 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, walletAccounts :: [(Text, AccountIndex, Bool, [(Text, Text)])]}
+  | CRWallet {user :: User, walletKeyExists :: Bool, walletKeyPaths :: [(Text, Text)], walletProfiles :: [Text]}
   | CRWalletSeedMnemonic {user :: User, recoveryPhrase :: Text}
   | CRWalletDerivedSecret {user :: User, keyPath :: Text, address :: Text, derivedSecret :: Text}
   | CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact}

src/Simplex/Chat/Library/Commands.hs

@@ -58,7 +58,7 @@ 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 (deleteSeed, getDeviceSeed, getOrCreateAccountRef, getSeedAccounts, importSeed)
+import Simplex.Chat.Store.Wallets (bindAccountIndex, deleteSeed, getAccountIndex, getDeviceSeed, getOrCreateAccountRef, getSeedProfiles, importSeed)
 import Simplex.Chat.Wallet (NameIndex, WalletSeed (..), accountAddress, accountSecret, deriveNameKey, importRecoveryKey, newSeed, recoveryKeyPhrase, renderNameKeyPath)
 import Simplex.Chat.Call
 import Simplex.Chat.Controller
@@ -1492,28 +1492,30 @@ processChatCommand cxt nm = \case
     connId <- withAgent $ \a -> sendServiceReplyAsync a "" (aUserId user) invId (LB.toStrict $ J.encode responseData)
     pure $ CRServiceReplyAccepted user (AgentConnId connId)
   APIWallet -> withUser $ \user -> do
-    seed_ <- withFastStore' getDeviceSeed
-    accs <- case seed_ of
-      Nothing -> pure []
+    withFastStore' getDeviceSeed >>= \case
+      Nothing -> pure $ CRWallet user False [] []
       Just seed -> do
-        -- hidden profiles are left out, as they are by /users, but the gap in
-        -- account indexes still shows that one exists
-        as <- filter (\(_, _, active, hidden) -> active || not hidden) <$> withFastStore' (\db -> getSeedAccounts db (wsId seed))
-        forM as $ \(n, acct, active, _) -> do
-          keys <- forM [0 .. walletNamesShown - 1] $ \k -> do
-            acc <- either (throwCmdError . ("wallet: " <>)) pure $ deriveNameKey seed acct k
-            pure (renderNameKeyPath acct k, tshow (accountAddress acc))
-          pure (n, acct, active, keys)
-    pure $ CRWallet user (isJust seed_) accs
+        -- other profiles are named but not numbered, so a hidden one leaves no gap
+        acct_ <- withFastStore' (`getAccountIndex` user)
+        paths <- forM (maybe [] (\acct -> map ((,) acct) [0 .. walletNamesShown - 1]) acct_) $ \(acct, k) -> do
+          acc <- either (throwCmdError . ("wallet: " <>)) pure $ deriveNameKey seed acct k
+          pure (renderNameKeyPath acct k, tshow $ accountAddress acc)
+        profiles <- withFastStore' $ \db -> getSeedProfiles db (wsId seed) user
+        pure $ CRWallet user True paths profiles
+  APIWalletBind acct -> withUser $ \user -> do
+    seed <- withFastStore' getDeviceSeed >>= maybe (throwCmdError noKeyError) pure
+    bound <- withFastStore' $ \db -> bindAccountIndex db user (wsId seed) acct
+    unless bound $ throwCmdError "another profile uses this account"
+    processChatCommand cxt nm APIWallet
   APIWalletCreate -> withUser $ \user -> do
     g <- asks random
     entropy <- atomically $ newSeed MS256 g
-    void $ withFastStore' $ \db -> getOrCreateAccountRef db user entropy
+    withFastStore' $ \db -> getOrCreateAccountRef db user entropy
     processChatCommand cxt nm APIWallet
   APIWalletImport phrase -> withUser $ \user -> do
     entropy <- either (const $ throwCmdError "bad recovery phrase") pure $ importRecoveryKey (encodeUtf8 phrase)
-    r <- withFastStore' $ \db -> importSeed db user entropy
-    when (isNothing r) $ throwCmdError "this device already has a wallet key"
+    imported <- withFastStore' $ \db -> importSeed db user entropy
+    unless imported $ throwCmdError "this device already has a wallet key"
     processChatCommand cxt nm APIWallet
   APIWalletExportSeedMnemonic -> withUser $ \user -> do
     seed <- withFastStore' getDeviceSeed >>= maybe (throwCmdError noKeyError) pure
@@ -5588,6 +5590,7 @@ 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 bind " *> (APIWalletBind <$> keyIndexP),
       "/_wallet create" $> APIWalletCreate,
       "/_wallet import " *> (APIWalletImport <$> textP),
       "/_wallet export " *> (APIWalletExportDerivedSecret <$> keyIndexP <* A.space <*> keyIndexP),

src/Simplex/Chat/Store/Wallets.hs

@@ -6,22 +6,22 @@
 
 module Simplex.Chat.Store.Wallets
   ( getDeviceSeed,
-    getSeedAccounts,
+    getAccountIndex,
+    getSeedProfiles,
     getOrCreateAccountRef,
     importSeed,
+    bindAccountIndex,
     deleteSeed,
   )
 where
 
 import Data.ByteString (ByteString)
 import Data.Int (Int64)
-import Data.Maybe (isJust)
 import Data.Text (Text)
 import Simplex.Chat.Store.Shared (insertedRowId)
 import Simplex.Chat.Types (User (..))
-import Simplex.Chat.Wallet (AccountIndex, AccountRef (..), SeedId (..), WalletSeed (..))
+import Simplex.Chat.Wallet (AccountIndex, SeedId (..), WalletSeed (..))
 import Simplex.Messaging.Agent.Store.AgentStore (maybeFirstRow)
-import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 
 #if defined(dbPostgres)
@@ -40,65 +40,69 @@ getDeviceSeed db =
   maybeFirstRow toSeed $
     DB.query_ db "SELECT wallet_seed_id, seed FROM wallet_seeds ORDER BY wallet_seed_id LIMIT 1"
 
-getWalletSeed :: DB.Connection -> SeedId -> IO (Maybe WalletSeed)
-getWalletSeed db (SeedId sId) =
-  maybeFirstRow toSeed $
-    DB.query db "SELECT wallet_seed_id, seed FROM wallet_seeds WHERE wallet_seed_id = ?" (Only sId)
-
-getAccountRef :: DB.Connection -> User -> IO (Maybe AccountRef)
-getAccountRef db User {userId} = do
+getAccountIndex :: DB.Connection -> User -> IO (Maybe AccountIndex)
+getAccountIndex db User {userId} = do
   r <-
-    maybeFirstRow id $
-      DB.query db "SELECT wallet_seed_id, wallet_account_index FROM users WHERE user_id = ?" (Only userId)
+    maybeFirstRow fromOnly $
+      DB.query db "SELECT 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)}
+    Just (Just ix) -> Just $ 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)
-
-getBoundAccount :: DB.Connection -> User -> IO (Maybe (WalletSeed, AccountRef))
-getBoundAccount db user =
-  getAccountRef db user >>= \case
-    Nothing -> pure Nothing
-    Just r -> fmap (\s -> (s, r)) <$> getWalletSeed db (arSeedId r)
-
-getSeedAccounts :: DB.Connection -> SeedId -> IO [(Text, AccountIndex, Bool, Bool)]
-getSeedAccounts db (SeedId sId) =
-  map toRow
+-- | Hidden profiles are left out, as they are by /users.
+getSeedProfiles :: DB.Connection -> SeedId -> User -> IO [Text]
+getSeedProfiles db (SeedId sId) User {userId} =
+  map fromOnly
     <$> DB.query
       db
       [sql|
-        SELECT local_display_name, wallet_account_index, active_user, view_pwd_hash
-        FROM users WHERE wallet_seed_id = ? ORDER BY wallet_account_index
+        SELECT local_display_name FROM users
+        WHERE wallet_seed_id = ? AND user_id != ? AND view_pwd_hash IS NULL
+        ORDER BY local_display_name
       |]
-      (Only sId)
-  where
-    toRow (n, ix, BI active, pwdHash) = (n, fromIntegral (ix :: Int64), active, isJust (pwdHash :: Maybe ByteString))
+      (sId, userId)
 
-getOrCreateAccountRef :: DB.Connection -> User -> ByteString -> IO (WalletSeed, AccountRef)
+bindAccount :: DB.Connection -> User -> SeedId -> AccountIndex -> IO ()
+bindAccount db User {userId} (SeedId sId) acct =
+  DB.execute
+    db
+    "UPDATE users SET wallet_seed_id = ?, wallet_account_index = ? WHERE user_id = ?"
+    (sId, fromIntegral acct :: Int64, userId)
+
+getOrCreateAccountRef :: DB.Connection -> User -> ByteString -> IO ()
 getOrCreateAccountRef db user entropy =
-  getBoundAccount db user >>= \case
-    Just bound -> pure bound
+  getAccountIndex db user >>= \case
+    Just _ -> pure ()
     Nothing -> getDeviceSeed db >>= maybe (createWalletSeed db entropy) pure >>= bindNewAccount db user
 
--- | Nothing if the device already has a key.
-importSeed :: DB.Connection -> User -> ByteString -> IO (Maybe (WalletSeed, AccountRef))
+-- | False if the device already has a key.
+importSeed :: DB.Connection -> User -> ByteString -> IO Bool
 importSeed db user entropy =
   getDeviceSeed db >>= \case
-    Just _ -> pure Nothing
-    Nothing -> Just <$> (createWalletSeed db entropy >>= bindNewAccount db user)
+    Just _ -> pure False
+    Nothing -> True <$ (createWalletSeed db entropy >>= bindNewAccount db user)
 
-bindNewAccount :: DB.Connection -> User -> WalletSeed -> IO (WalletSeed, AccountRef)
-bindNewAccount db user s = do
-  ix <- takeAccountIndex db (wsId s)
-  let r = AccountRef {arSeedId = wsId s, arIndex = ix}
-  bindAccount db user r
-  pure (s, r)
+-- | False if another profile holds the account. The counter moves past it, so
+-- the next profile is not handed the same one.
+bindAccountIndex :: DB.Connection -> User -> SeedId -> AccountIndex -> IO Bool
+bindAccountIndex db user sId@(SeedId sId') acct = do
+  taken <- maybeFirstRow fromOnly $
+    DB.query
+      db
+      "SELECT 1 FROM users WHERE wallet_seed_id = ? AND wallet_account_index = ? AND user_id != ?"
+      (sId', fromIntegral acct :: Int64, userId user)
+  case (taken :: Maybe Int64) of
+    Just _ -> pure False
+    Nothing -> do
+      bindAccount db user sId acct
+      DB.execute
+        db
+        "UPDATE wallet_seeds SET next_account_index = ? WHERE wallet_seed_id = ? AND next_account_index <= ?"
+        (fromIntegral acct + 1 :: Int64, sId', fromIntegral acct :: Int64)
+      pure True
+
+bindNewAccount :: DB.Connection -> User -> WalletSeed -> IO ()
+bindNewAccount db user s = takeAccountIndex db (wsId s) >>= bindAccount db user (wsId s)
 
 createWalletSeed :: DB.Connection -> ByteString -> IO WalletSeed
 createWalletSeed db entropy = do

src/Simplex/Chat/View.hs

@@ -188,17 +188,14 @@ 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 accs
+  CRWallet u exists paths profiles
     | not exists -> ttyUser u ["no wallet key"]
-    | otherwise ->
-        ttyUser u $
-          concatMap accountRows accs
-            <> ["this profile has no wallet key" | not (any (\(_, _, active, _) -> active) accs)]
+    | otherwise -> ttyUser u $ keyRows <> [plain $ "also on this key: " <> T.intercalate ", " profiles | not (null profiles)]
     where
-      accountRows (n, acct, active, keys) =
-        plain ("account " <> tshow acct <> " (" <> n <> (if active then ", active" else "") <> ")")
-          : zipWith nameRow [0 :: Int ..] keys
-      nameRow k (path, addr) = plain $ "  name " <> tshow k <> "  " <> path <> "  " <> addr
+      keyRows
+        | null paths = ["this profile has no wallet key"]
+        | otherwise = zipWith nameRow [0 :: Int ..] paths
+      nameRow k (path, addr) = plain $ "name " <> tshow k <> "  " <> path <> "  " <> addr
   CRWalletSeedMnemonic u phrase -> ttyUser u [plain phrase]
   CRWalletDerivedSecret u path addr secret -> ttyUser u [plain $ path <> "  " <> addr <> "  " <> secret]
   CRGroupCreated u g -> ttyUser u $ viewGroupCreated g testView

tests/WalletTests.hs

@@ -52,11 +52,10 @@ walletTests = do
   it "imports a phrase, exports it, and refuses a second import" testWalletImport
   it "exports the secret of any name key" testWalletExportDerivedSecret
   it "deletes the key, and a key can be imported again" testWalletDelete
+  it "binds a profile to the account it had" testWalletBind
 
-accountRows :: HasCallStack => TestCC -> String -> Int -> IO [(String, String)]
-accountRows cc profile acct = do
-  cc <## ("account " <> show acct <> " (" <> profile <> ")")
-  mapM (\_ -> nameRow <$> getTermLine cc) [0 .. 1 :: Int]
+nameRows :: HasCallStack => TestCC -> IO [(String, String)]
+nameRows cc = mapM (\_ -> nameRow <$> getTermLine cc) [0 .. 1 :: Int]
   where
     nameRow l = case words l of
       ["name", _, path, addr] -> (path, addr)
@@ -72,7 +71,7 @@ testWalletCreate ps = withNewTestChat ps "alice" aliceProfile $ \alice -> do
   alice ##> "/_wallet export"
   alice <## "bad chat command: no wallet key on this device"
   alice ##> "/_wallet create"
-  rows <- accountRows alice "alice, active" 0
+  rows <- nameRows alice
   map fst rows `shouldBe` ["m/44'/60'/0'/0/0", "m/44'/60'/0'/0/1"]
   length (nub $ map snd rows) `shouldBe` 2
 
@@ -80,38 +79,39 @@ testWalletPersists :: HasCallStack => TestParams -> IO ()
 testWalletPersists ps = do
   rows <- withNewTestChat ps "alice" aliceProfile $ \alice -> do
     alice ##> "/_wallet create"
-    accountRows alice "alice, active" 0
+    nameRows alice
   -- same database, new session: a name bought at that address must stay reachable
   withTestChat ps "alice" $ \alice -> do
     alice ##> "/_wallet"
-    rows' <- accountRows alice "alice, active" 0
+    rows' <- nameRows alice
     rows' `shouldBe` rows
 
 testWalletSecondProfile :: HasCallStack => TestParams -> IO ()
 testWalletSecondProfile ps = withNewTestChat ps "alice" aliceProfile $ \alice -> do
   alice ##> "/_wallet create"
-  rows <- accountRows alice "alice, active" 0
+  rows <- nameRows alice
   alice ##> "/_wallet export"
   phrase <- getTermLine alice
   alice ##> "/create user alisa"
   showActiveUser alice "alisa"
+  -- other profiles are named, never numbered
   alice ##> "/_wallet"
-  _ <- accountRows alice "alice" 0
   alice <## "this profile has no wallet key"
+  alice <## "also on this key: alice"
   -- the key belongs to the device, so a profile without an account exports it too
   alice ##> "/_wallet export"
   alice <## phrase
   alice ##> "/_wallet create"
-  _ <- accountRows alice "alice" 0
-  rows' <- accountRows alice "alisa, active" 1
+  rows' <- nameRows alice
+  alice <## "also on this key: alice"
+  map fst rows' `shouldBe` ["m/44'/60'/1'/0/0", "m/44'/60'/1'/0/1"]
   null (map snd rows `intersect` map snd rows') `shouldBe` True
 
 testWalletImport :: HasCallStack => TestParams -> IO ()
 testWalletImport ps = withNewTestChat ps "alice" aliceProfile $ \alice -> do
   alice ##> ("/_wallet import " <> B.unpack testPhrase)
-  alice <## "account 0 (alice, active)"
-  alice <## "  name 0  m/44'/60'/0'/0/0  0x9858EfFD232B4033E47d90003D41EC34EcaEda94"
-  alice <## "  name 1  m/44'/60'/0'/0/1  0x6Fac4D18c912343BF86fa7049364Dd4E424Ab9C0"
+  alice <## "name 0  m/44'/60'/0'/0/0  0x9858EfFD232B4033E47d90003D41EC34EcaEda94"
+  alice <## "name 1  m/44'/60'/0'/0/1  0x6Fac4D18c912343BF86fa7049364Dd4E424Ab9C0"
   alice ##> "/_wallet export"
   alice <## B.unpack testPhrase
   alice ##> ("/_wallet import " <> B.unpack testPhrase)
@@ -123,7 +123,7 @@ testWalletImport ps = withNewTestChat ps "alice" aliceProfile $ \alice -> do
 testWalletExportDerivedSecret :: HasCallStack => TestParams -> IO ()
 testWalletExportDerivedSecret ps = withNewTestChat ps "alice" aliceProfile $ \alice -> do
   alice ##> ("/_wallet import " <> B.unpack testPhrase)
-  _ <- accountRows alice "alice, active" 0
+  _ <- nameRows alice
   alice ##> "/_wallet export 0 0"
   alice <## "m/44'/60'/0'/0/0  0x9858EfFD232B4033E47d90003D41EC34EcaEda94  0x1ab42cc412b618bdea3a599e3c9bae199ebf030895b039e9db1e30dafb12b727"
   -- an index BIP-32 cannot harden is rejected, not wrapped into another account
@@ -142,10 +142,29 @@ testWalletExportDerivedSecret ps = withNewTestChat ps "alice" aliceProfile $ \al
 testWalletDelete :: HasCallStack => TestParams -> IO ()
 testWalletDelete ps = withNewTestChat ps "alice" aliceProfile $ \alice -> do
   alice ##> ("/_wallet import " <> B.unpack testPhrase)
-  _ <- accountRows alice "alice, active" 0
+  _ <- nameRows alice
   alice ##> "/_wallet delete"
   alice <## "no wallet key"
   -- deleting unbinds the profile, so a key can be imported again
   alice ##> ("/_wallet import " <> B.unpack testPhrase)
-  _ <- accountRows alice "alice, active" 0
+  _ <- nameRows alice
   pure ()
+
+-- | Restoring a chat database older than the key rebinds profiles in the order
+-- they ask, so the account a profile had is set by hand.
+testWalletBind :: HasCallStack => TestParams -> IO ()
+testWalletBind ps = withNewTestChat ps "alice" aliceProfile $ \alice -> do
+  alice ##> ("/_wallet import " <> B.unpack testPhrase)
+  _ <- nameRows alice
+  alice ##> "/_wallet bind 3"
+  rows <- nameRows alice
+  map fst rows `shouldBe` ["m/44'/60'/3'/0/0", "m/44'/60'/3'/0/1"]
+  alice ##> "/create user alisa"
+  showActiveUser alice "alisa"
+  alice ##> "/_wallet bind 3"
+  alice <## "bad chat command: another profile uses this account"
+  -- the counter moved past the account bound by hand
+  alice ##> "/_wallet create"
+  rows' <- nameRows alice
+  alice <## "also on this key: alice"
+  map fst rows' `shouldBe` ["m/44'/60'/4'/0/0", "m/44'/60'/4'/0/1"]