diff --git a/.gitignore b/.gitignore index 035d24c6cd..becb0d9c78 100644 --- a/.gitignore +++ b/.gitignore @@ -87,3 +87,5 @@ website/test/stubs-layout-cache/_includes/*.js apps/android/app/release apps/multiplatform/.kotlin/sessions +.idea/ +cabal.project.dev \ No newline at end of file diff --git a/apps/simplex-names-demo/Main.hs b/apps/simplex-names-demo/Main.hs new file mode 100644 index 0000000000..aa51350cab --- /dev/null +++ b/apps/simplex-names-demo/Main.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | End-to-end walkthrough of the SimpleX names UX against a mocked service. +-- +-- The periphery is mocked — no store payment, no relayer, no chain — but the +-- crypto is real: every intent is signed with the profile's derived key, and the +-- mock recovers the signer from the signature and applies the same rules the +-- contracts do. A step that prints OK here is a step the contracts would accept. +-- +-- Run: cabal run simplex-names-demo +module Main (main) where + +import Control.Concurrent.STM +import Control.Monad (forM_, unless) +import Crypto.Random (drgNew) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BC +import Data.Word (Word32) +import Simplex.Chat.Names.Service +import Simplex.Chat.Names.Service.Mock +import Simplex.Chat.Names.Snrc +import Simplex.Chat.Wallet +import qualified Simplex.Messaging.Crypto.BIP39 as B39 +import System.Exit (exitFailure) + +main :: IO () +main = do + g <- newTVarIO =<< drgNew + chain <- newMockChain + let svc = mockNamesService chain + setPendingRounds chain 2 -- stand in for the 60s commit-reveal wait + + section "1. First purchase creates the seed, lazily" + entropy <- atomically $ newSeed B39.MS128 g + let wallet = WalletSeed {wsId = SeedId 1, wsEntropy = entropy, wsBackedUp = False} + phrase <- expect "recovery key" $ recoveryKeyPhrase wallet + say $ " seed created, id " <> bshow (wsId wallet) + say $ " recovery key: " <> phrase + say " (shown once after purchase; a reminder persists until acknowledged)" + + section "2. Each chat profile derives its own address from that one seed" + alice <- expect "alice key" $ deriveAccount wallet 0 + bob <- expect "bob key" $ deriveAccount wallet 1 + say $ " profile 0 (personal) -> " <> bshow (accountAddress alice) + say $ " profile 1 (anonymous) -> " <> bshow (accountAddress bob) + unless (accountAddress alice /= accountAddress bob) $ die "profiles must not share an address" + say " different addresses, so names under the two are unlinked on-chain" + + section "3. Quote a name" + checkQuote svc "ab" "too short is rejected" + checkQuote svc "simplex" "reserved name is rejected" + q <- expectIO "quote" $ quoteName svc "alicechat" + say $ " alicechat.simplex available=" <> bshow (nqAvailable q) <> " price=" <> money (nqPriceCents q) <> "/yr" + + section "4. Pay and register (payment proof mocked, registration sponsored)" + let contactLink = "https://smp16.simplex.im/a#alice-contact" + pid <- + expectIO "purchase" $ + buyName + svc + BuyRequest + { brLabel = "alicechat", + brOwner = accountAddress alice, + brYears = 1, + brPayment = PPAppleReceipt "mock-storekit-jws", + brContactLink = Just contactLink, + brChannelLink = Nothing + } + say $ " purchase accepted: " <> bshow pid + reg <- pollUntilConfirmed svc pid + say $ " registered, tx " <> BC.take 18 (rsTxHash reg) <> "..." + + section "5. The app confirms independently by resolving the name" + rec1 <- expectIO "resolve" $ resolveName svc "alicechat.simplex" + say $ " owner " <> bshow (nrvOwner rec1) + say $ " contact " <> bshow (nrvContact rec1) + unless (nrvOwner rec1 == accountAddress alice) $ die "owner is not our derived address" + say " owner matches our key -> the name is ours; profile claim can now be set" + + section "6. Repoint the name after rotating the contact address" + let newLink = "https://smp11.simplex.im/a#alice-rotated" + n0 <- expectIO "nonce" $ currentNonce svc (accountAddress alice) + txSet <- + relaySigned svc alice $ + SetTextRecord + { sxName = "alicechat.simplex", + sxKey = contactRecordKey, + sxValue = newLink, + sxNonce = n0, + sxDeadline = farFuture + } + say $ " relayed setTextWithSig, tx " <> BC.take 18 txSet <> "..." + rec2 <- expectIO "resolve" $ resolveName svc "alicechat.simplex" + unless (nrvContact rec2 == [newLink]) $ die "record did not change" + say $ " contact now " <> bshow (nrvContact rec2) + + section "7. Forgery and replay are rejected" + -- Bob signs an intent over Alice's name. Use *Bob's* nonce so the request is + -- otherwise well-formed and the ownership check is what actually rejects it — + -- signing with Alice's nonce would trip the nonce check first and prove nothing. + nBob <- expectIO "nonce" $ currentNonce svc (accountAddress bob) + let forged = + SetTextRecord + { sxName = "alicechat.simplex", + sxKey = contactRecordKey, + sxValue = "https://evil.example/a#hijack", + sxNonce = nBob, + sxDeadline = farFuture + } + relaySignedRaw svc bob forged >>= \case + Left SENotOwner -> say " forged by another key: rejected as not the owner" + Left e -> die $ "expected SENotOwner, got: " <> serviceErrorText e + Right _ -> die "a forged intent was accepted" + -- Alice replaying her own already-used nonce. + nAlice <- expectIO "nonce" $ currentNonce svc (accountAddress alice) + relaySignedRaw svc alice forged {sxNonce = nAlice - 1} >>= \case + Left SEBadNonce -> say " replayed nonce: rejected" + Left e -> die $ "expected SEBadNonce, got: " <> serviceErrorText e + Right _ -> die "a replayed nonce was accepted" + -- An expired deadline. + relaySignedRaw svc alice forged {sxNonce = nAlice, sxDeadline = 0} >>= \case + Left SEExpiredIntent -> say " expired deadline: rejected" + Left e -> die $ "expected SEExpiredIntent, got: " <> serviceErrorText e + Right _ -> die "an expired intent was accepted" + + section "8. Gift the name to a contact" + say $ " recipient address " <> bshow (accountAddress bob) <> " (how this is learned is the open decision in the plan)" + n2 <- expectIO "nonce" $ currentNonce svc (accountAddress alice) + txXfer <- + relaySigned svc alice $ + TransferName + { tiFrom = accountAddress alice, + tiTo = accountAddress bob, + tiLabel = "alicechat", + tiNonce = n2, + tiDeadline = farFuture + } + say $ " relayed transferWithSig, tx " <> BC.take 18 txXfer <> "..." + rec3 <- expectIO "resolve" $ resolveName svc "alicechat.simplex" + unless (nrvOwner rec3 == accountAddress bob) $ die "transfer did not move ownership" + say $ " owner now " <> bshow (nrvOwner rec3) + say $ " records carried over: " <> bshow (nrvContact rec3) + + section "9. The previous owner can no longer touch it" + n3 <- expectIO "nonce" $ currentNonce svc (accountAddress alice) + afterGift <- + relaySignedRaw svc alice $ + SetTextRecord + { sxName = "alicechat.simplex", + sxKey = contactRecordKey, + sxValue = "https://smp16.simplex.im/a#taken-back", + sxNonce = n3, + sxDeadline = farFuture + } + case afterGift of + Left SENotOwner -> say " rejected: no longer the owner" + Left e -> say $ " rejected: " <> serviceErrorText e + Right _ -> die "the old owner could still write records" + + section "10. Recovery: wipe the device, re-import the recovery key" + imported <- expect "import" $ importRecoveryKey phrase + let restored = WalletSeed {wsId = SeedId 1, wsEntropy = imported, wsBackedUp = True} + forM_ [(0 :: Word32, "personal"), (1, "anonymous")] $ \(i, label) -> do + pk <- expect "derive" $ deriveAccount restored i + owned <- expectIO "ownedBy" $ namesOwnedBy svc (accountAddress pk) + say $ " profile " <> bshow i <> " (" <> label <> ") " <> bshow (accountAddress pk) <> " owns " <> bshow owned + restoredAlice <- expect "derive" $ deriveAccount restored 0 + unless (accountAddress restoredAlice == accountAddress alice) $ die "recovery derived a different address" + say " same addresses recovered from the phrase alone" + + putStrLn "" + putStrLn "ALL STEPS OK" + +-- helpers + +farFuture :: Integer +farFuture = 1786000000 + 3600 + +section :: ByteString -> IO () +section t = putStrLn "" >> BC.putStrLn t + +say :: ByteString -> IO () +say = BC.putStrLn + +bshow :: Show a => a -> ByteString +bshow = BC.pack . show + +money :: Int -> ByteString +money cents = BC.pack $ "$" <> show (cents `div` 100) <> "." <> pad (cents `mod` 100) + where + pad n = let s = show n in if length s < 2 then '0' : s else s + +die :: ByteString -> IO a +die msg = BC.putStrLn ("FAILED: " <> msg) >> exitFailure + +expect :: ByteString -> Either String a -> IO a +expect what = either (\e -> die (what <> ": " <> BC.pack e)) pure + +expectIO :: ByteString -> IO (Either ServiceError a) -> IO a +expectIO what act = act >>= either (\e -> die (what <> ": " <> serviceErrorText e)) pure + +checkQuote :: NamesService -> ByteString -> ByteString -> IO () +checkQuote svc label why = + quoteName svc label >>= \case + Left e -> say $ " " <> why <> " (" <> serviceErrorText e <> ")" + Right _ -> die $ "expected rejection: " <> label + +pollUntilConfirmed :: NamesService -> PurchaseId -> IO RegistrationStatus +pollUntilConfirmed svc pid = go (10 :: Int) + where + go 0 = die "registration never confirmed" + go n = + expectIO "status" (registrationStatus svc pid) >>= \case + RegPending -> say " waiting for commit-reveal..." >> go (n - 1) + RegFailed e -> die $ "registration failed: " <> e + r@RegConfirmed {} -> pure r + +-- | Sign an intent with a profile key and hand it to the relayer. +relaySigned :: NamesService -> WalletAccount -> Intent -> IO ByteString +relaySigned svc pk intent = + relaySignedRaw svc pk intent >>= either (\e -> die ("relay: " <> serviceErrorText e)) pure + +relaySignedRaw :: NamesService -> WalletAccount -> Intent -> IO (Either ServiceError ByteString) +relaySignedRaw svc pk intent = do + digest <- expect "digest" $ intentDigest mockDeployment intent + sig <- expect "sign" $ signDigest pk digest + relayIntent svc SignedIntent {siIntent = intent, siSignature = sig} diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 4447d5d4c8..caa95e0c3a 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -41,7 +41,11 @@ library Simplex.Chat.Badges Simplex.Chat.Badges.CLI Simplex.Chat.Names - Simplex.Chat.Names.Wallet + Simplex.Chat.Names.Service + Simplex.Chat.Names.Service.Default + Simplex.Chat.Names.Service.Mock + Simplex.Chat.Names.Snrc + Simplex.Chat.Wallet Simplex.Chat.Call Simplex.Chat.Controller Simplex.Chat.Delivery @@ -83,6 +87,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 @@ -154,6 +159,7 @@ 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 else exposed-modules: Simplex.Chat.Archive @@ -324,6 +330,7 @@ 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 other-modules: Paths_simplex_chat hs-source-dirs: @@ -397,6 +404,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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index af20d97bee..574546cb15 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -544,6 +544,16 @@ 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} + | APINameRecoveryKey {userId :: UserId} + | APINameRecoveryKeyImport {userId :: UserId, recoveryPhrase :: Text} + | APINameRecoveryKeySaved {userId :: UserId} + | APINameQuote {userId :: UserId, nameLabel :: Text} + | APINameBuy {userId :: UserId, nameLabel :: 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} | APIVerifyGroupDomain {groupId :: GroupId} | APIConnectContactViaAddress UserId IncognitoEnabled ContactId | ConnectSimplex IncognitoEnabled -- UserId (not used in UI) @@ -923,6 +933,13 @@ data ChatResponse | CRAgentSubsDetails {agentSubs :: SubscriptionsInfo} | CRAgentQueuesInfo {agentQueuesInfo :: AgentQueuesInfo} | CRAppSettings {appSettings :: AppSettings} + | CRNameAddress {user :: User, nameAddress :: Text, nameAccount :: Int} + | 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 :: [Text]} + | CRNameInfo {user :: User, nameFqdn :: Text, nameOwner :: Text, nameContact :: [Text], nameChannel :: [Text], nameExpires :: Int, nameEditCredits :: Int} + | CRNameIntentRelayed {user :: User, nameAction :: Text, nameFqdn :: Text, nameTxHash :: Text} | CRCustomChatResponse {user_ :: Maybe User, response :: Text} deriving (Show) diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 88cb4532ef..7fd39693d1 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -58,6 +58,13 @@ 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 qualified Simplex.Chat.Store.Wallets as WS +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 (..)) @@ -2381,6 +2388,90 @@ processChatCommand cxt nm = \case _ -> throwError e connectWithPlan user incognito ccLink planSimplexName otherSimplexName plan Connect _ Nothing -> throwChatError CEInvalidConnReq + APINameAddress userId -> withUserId userId $ \user -> do + (_, pk) <- userWalletAccount user + pure $ CRNameAddress user (nameAddrText $ W.accountAddress pk) (fromIntegral . W.arIndex $ W.waRef pk) + 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 -> do + seed <- nameEither . W.importRecoveryKey $ encodeUtf8 phrase + w <- withStore' $ \db -> WS.createWalletSeed db seed + let r = W.AccountRef {W.arSeedId = W.wsId w, W.arIndex = 0} + withStore' $ \db -> WS.bindAccount db user r + pure $ CRNameRecoveryKey user phrase (W.wsBackedUp w) + 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 link_ -> withUserId userId $ \user -> do + (_, pk) <- userWalletAccount user + let req = + BuyRequest + { brLabel = encodeUtf8 label, + brOwner = W.accountAddress pk, + brYears = 1, + brPayment = PPRedeemCode "dev-mock-payment", + brContactLink = encodeUtf8 <$> link_, + brChannelLink = Nothing + } + pid <- nameSvc $ buyName namesService req + reg <- namePoll pid (20 :: Int) + case reg of + RegConfirmed {rsTxHash} -> do + 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 + ns <- nameSvc $ namesOwnedBy namesService (W.accountAddress pk) + pure $ CRNamesOwned user (map safeDecodeUtf8 ns) + 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) + APINameSetLink userId fqdn newLink -> withUserId userId $ \user -> do + (_, pk) <- userWalletAccount user + 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 + to <- nameEither $ parseAddress (encodeUtf8 recipient) + n <- nameSvc $ currentNonce namesService (W.accountAddress pk) + tx <- + nameRelay pk $ + TransferName + { tiFrom = W.accountAddress pk, + tiTo = to, + tiLabel = encodeUtf8 label, + tiNonce = n, + tiDeadline = nameDeadline + } + pure $ CRNameIntentRelayed user "gift" (label <> ".simplex") tx 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_ @@ -5701,6 +5792,26 @@ 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 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 <*> 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), + "/names address" $> APINameAddress 1, + "/names key import " *> (APINameRecoveryKeyImport 1 <$> textP), + "/names key saved" $> APINameRecoveryKeySaved 1, + "/names key" $> APINameRecoveryKey 1, + "/names quote " *> (APINameQuote 1 <$> nameWordP), + "/names buy " *> (APINameBuy 1 <$> nameWordP <*> optional (A.space *> textP)), + "/names list" $> APINameList 1, + "/names info " *> (APINameInfo 1 <$> nameWordP), + "/names link " *> (APINameSetLink 1 <$> nameWordP <* A.space <*> textP), + "/names gift " *> (APINameGift 1 <$> nameWordP <* A.space <*> textP), "/_verify domain #" *> (APIVerifyGroupDomain <$> A.decimal), ForwardMessage <$> chatNameP <* " <- @" <*> displayNameP <* A.space <*> msgTextP, ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayNameP <* A.space <* A.char '@' <*> (Just <$> displayNameP) <* A.space <*> msgTextP, @@ -5937,6 +6048,7 @@ 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 + 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 +6211,47 @@ 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 + +-- | Sign an intent with the profile key and hand it to the relayer. +nameRelay :: W.WalletAccount -> Intent -> CM Text +nameRelay pk intent = do + digest <- nameEither $ intentDigest nameDeployment intent + sig <- nameEither $ W.signDigest pk digest + safeDecodeUtf8 <$> nameSvc (relayIntent namesService SignedIntent {siIntent = intent, siSignature = sig}) + +nameAddrText :: Address -> Text +nameAddrText = safeDecodeUtf8 . checksumAddress + +-- | Intents expire; the mock's clock is fixed, so this is a fixed horizon. +nameDeadline :: Integer +nameDeadline = 1786000000 + 3600 diff --git a/src/Simplex/Chat/Names/Service.hs b/src/Simplex/Chat/Names/Service.hs new file mode 100644 index 0000000000..85cc99c3f8 --- /dev/null +++ b/src/Simplex/Chat/Names/Service.hs @@ -0,0 +1,132 @@ +{-# 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 Simplex.Chat.Names.Snrc (SignedIntent) +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 + 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" + +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. + relayIntent :: SignedIntent -> IO (Either ServiceError ByteString), + -- | 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]), + currentNonce :: Address -> IO (Either ServiceError Integer), + -- | Relayed edits left on a name, for display before the user tries one. + editCreditsFor :: ByteString -> IO (Either ServiceError Integer) + } diff --git a/src/Simplex/Chat/Names/Service/Default.hs b/src/Simplex/Chat/Names/Service/Default.hs new file mode 100644 index 0000000000..1eed01a0ff --- /dev/null +++ b/src/Simplex/Chat/Names/Service/Default.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The single place the names service is wired in. +-- +-- Right now it resolves to the in-memory mock, so the whole names UX is +-- exercisable from the terminal CLI with no store payment, no relayer and no +-- chain — while still producing and verifying real signatures. +-- +-- When the SMP-backed client lands this binding is what changes; nothing in +-- "Simplex.Chat.Library.Commands" needs to know which implementation it has. +-- The process-wide mock state is a deliberate development shortcut and is the +-- reason this module is separate: it is the seam to delete. +module Simplex.Chat.Names.Service.Default + ( namesService, + nameDeployment, + devMockChain, + ) +where + +import Simplex.Chat.Names.Service (NamesService) +import Simplex.Chat.Names.Service.Mock (MockChain, mockDeployment, mockNamesService, newMockChain) +import Simplex.Chat.Names.Snrc (SnrcDeployment) +import System.IO.Unsafe (unsafePerformIO) + +-- | Process-wide mock chain. Development only. +devMockChain :: MockChain +devMockChain = unsafePerformIO newMockChain +{-# NOINLINE devMockChain #-} + +namesService :: NamesService +namesService = mockNamesService devMockChain + +-- | The deployment the client signs against. Must match the service. +nameDeployment :: SnrcDeployment +nameDeployment = mockDeployment diff --git a/src/Simplex/Chat/Names/Service/Mock.hs b/src/Simplex/Chat/Names/Service/Mock.hs new file mode 100644 index 0000000000..8948148459 --- /dev/null +++ b/src/Simplex/Chat/Names/Service/Mock.hs @@ -0,0 +1,322 @@ +{-# 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, + setPaymentValidator, + setRegistrarCredits, + registrarCredits, + editCreditsPerYear, + linkSeparator, + ) +where + +import Control.Concurrent.STM +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 Simplex.Chat.Names.Service +import Simplex.Chat.Names.Snrc +import Simplex.Chat.Wallet (recoverSigner) +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 + } + +-- | 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. +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 + pure MockChain {mcNames, mcNonces, mcPending, mcSeq, mcNow, mcPendingRounds, mcValidatePayment, mcRegistrarCredits} + +-- | 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 + +-- | 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, + resolveName = resolve, + namesOwnedBy = ownedBy, + currentNonce = nonceOf, + editCreditsFor = editCredits + } + where + quote label = case validLabel label of + Left e -> pure $ Left e + Right () -> do + taken <- atomically $ M.member (fqdn label) <$> readTVar (mcNames c) + 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) + if M.member (fqdn brLabel) names + 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 + } + + 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. + relay SignedIntent {siIntent, siSignature} = 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 + | 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 + pure . Right $ txHash ("transfer:" <> name) + SetTextRecord {sxName, sxKey, sxValue, sxNonce, sxDeadline} + | sxDeadline < now -> pure $ Left SEExpiredIntent + | sxNonce /= expected -> pure $ Left SEBadNonce + | otherwise -> case M.lookup sxName names of + Nothing -> pure $ Left SENotFound + Just e + | neOwner e /= signer -> pure $ Left SENotOwner + -- Only the sponsored path is metered. An owner paying + -- their own gas is never charged a credit. + | neEditCredits e <= 0 -> pure $ Left SENoEditCredits + | otherwise -> do + modifyTVar' (mcNames c) $ + M.insert + sxName + e + { neRecords = M.insert sxKey sxValue (neRecords e), + neEditCredits = neEditCredits e - 1 + } + bump + pure . Right $ txHash ("setText:" <> sxName <> ":" <> sxKey) + +splitLinks :: ByteString -> [ByteString] +splitLinks = filter (not . B.null) . map trim . BC.split linkSeparator + where + trim = BC.dropWhile (== ' ') . BC.reverse . BC.dropWhile (== ' ') . BC.reverse + +txHash :: ByteString -> ByteString +txHash = ("0x" <>) . BC.pack . concatMap byteHex . B.unpack . keccak256 + where + byteHex w = [hexDigit (w `div` 16), hexDigit (w `mod` 16)] + hexDigit n = "0123456789abcdef" !! fromIntegral n diff --git a/src/Simplex/Chat/Names/Snrc.hs b/src/Simplex/Chat/Names/Snrc.hs new file mode 100644 index 0000000000..d77a19538c --- /dev/null +++ b/src/Simplex/Chat/Names/Snrc.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | The SNRC contract surface as the client sees it: name hashing, and the +-- EIP-712 intents the user signs for the relayer to submit. +-- +-- The type strings here must match the contracts byte for byte, in EIP-712 +-- canonical form (no spaces after commas). They are the client half of +-- @transferWithSig@ on @BaseRegistrarImplementation@ and @setTextWithSig@ on +-- @SimplexResolver@. +module Simplex.Chat.Names.Snrc + ( SnrcDeployment (..), + Intent (..), + SignedIntent (..), + labelHash, + nameHash, + tokenId, + intentDigest, + transferTypeString, + setTextTypeString, + contactRecordKey, + channelRecordKey, + ) +where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Simplex.Chat.Wallet (EthSignature) +import Simplex.Messaging.Eth.Address (Address) +import Simplex.Messaging.Eth.EIP712 +import Simplex.Messaging.Eth.Keccak (keccak256) + +-- | Where a TLD is deployed. One of these per TLD; the verifying contract +-- differs per intent kind, so both are carried. +data SnrcDeployment = SnrcDeployment + { sdTld :: ByteString, -- ^ e.g. @"simplex"@, without the dot + sdChainId :: Integer, + sdRegistrar :: Address, -- ^ verifying contract for transfers + sdResolver :: Address -- ^ verifying contract for record writes + } + deriving (Eq, Show) + +data Intent + = -- | Gift a name to another address. + TransferName {tiFrom :: Address, tiTo :: Address, tiLabel :: ByteString, tiNonce :: Integer, tiDeadline :: Integer} + | -- | Repoint a name at a different link. + SetTextRecord {sxName :: ByteString, sxKey :: ByteString, sxValue :: ByteString, sxNonce :: Integer, sxDeadline :: Integer} + deriving (Eq, Show) + +data SignedIntent = SignedIntent + { siIntent :: Intent, + siSignature :: EthSignature + } + deriving (Eq, Show) + +-- | ENS text record keys carrying SimpleX links. +contactRecordKey, channelRecordKey :: ByteString +contactRecordKey = "simplex.contact" +channelRecordKey = "simplex.channel" + +transferTypeString :: ByteString +transferTypeString = "TransferName(address from,address to,uint256 tokenId,uint256 nonce,uint256 deadline)" + +setTextTypeString :: ByteString +setTextTypeString = "SetText(bytes32 node,string key,string value,uint256 nonce,uint256 deadline)" + +labelHash :: ByteString -> ByteString +labelHash = keccak256 + +-- | ENS namehash of a fully-qualified name, e.g. @alice.simplex@. +nameHash :: ByteString -> ByteString +nameHash name + | B.null name = B.replicate 32 0 + | otherwise = foldr step (B.replicate 32 0) (BC.split '.' name) + where + step lbl node = keccak256 (node <> labelHash lbl) + +-- | @BaseRegistrar@ token id: @uint256(keccak256(label))@. +tokenId :: ByteString -> Integer +tokenId = B.foldl' (\acc w -> acc * 256 + fromIntegral w) 0 . labelHash + +-- | The 32-byte digest the user signs. +intentDigest :: SnrcDeployment -> Intent -> Either String ByteString +intentDigest d = \case + TransferName {tiFrom, tiTo, tiLabel, tiNonce, tiDeadline} -> + hashTypedData + (domain "SimplexNames" (sdRegistrar d)) + transferTypeString + [VAddress tiFrom, VAddress tiTo, VUint (tokenId tiLabel), VUint tiNonce, VUint tiDeadline] + SetTextRecord {sxName, sxKey, sxValue, sxNonce, sxDeadline} -> + hashTypedData + (domain "SimplexResolver" (sdResolver d)) + setTextTypeString + [VFixedBytes (nameHash sxName), VString sxKey, VString sxValue, VUint sxNonce, VUint sxDeadline] + where + domain n c = Eip712Domain {edName = n, edVersion = "1", edChainId = sdChainId d, edVerifyingContract = c} diff --git a/src/Simplex/Chat/Names/Wallet.hs b/src/Simplex/Chat/Names/Wallet.hs deleted file mode 100644 index 1e9e9882dc..0000000000 --- a/src/Simplex/Chat/Names/Wallet.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | The name wallet: one BIP-39 seed per chat database, one Ethereum key per --- chat profile. --- --- Keys derive at @m\/44'\/60'\/i'\/0\/0@ where @i@ is the profile's account --- index, so names bought under different chat profiles are owned by different --- addresses and are not linked to each other on-chain — while still recovering --- from a single phrase. --- --- This module is pure: seed persistence, the account-index allocation and the --- chat commands are separate concerns and are not implemented here yet. --- --- The user never holds ETH and this is not a wallet in the product sense: the --- key exists only to own names and to sign EIP-712 intents that SimpleX relays --- and pays for. Nothing here constructs or broadcasts a transaction. -module Simplex.Chat.Names.Wallet - ( NameWallet, - ProfileKey (..), - newNameWallet, - nameWalletEntropy, - importRecoveryKey, - recoveryKeyPhrase, - profileKey, - profileAddress, - signTypedData, - EthSignature (..), - ethSignatureBytes, - ) -where - -import Control.Concurrent.STM -import Crypto.Random (ChaChaDRG) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Word (Word32, Word8) -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, ethereumPath) -import Simplex.Messaging.Eth.EIP712 (Eip712Domain, Value, hashTypedData) - --- | The root secret, 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 single secret behind every name the user --- owns. -newtype NameWallet = NameWallet {nameWalletEntropy :: ByteString} - deriving (Eq) - -instance Show NameWallet where - show _ = "NameWallet " - --- | A profile's derived key and its BIP-44 account index. -data ProfileKey = ProfileKey - { pkAccount :: Word32, - pkKey :: S.PrivateKey - } - deriving (Eq) - -instance Show ProfileKey where - show pk = "ProfileKey " <> show (pkAccount pk) <> " " - --- | 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) - --- | Create a wallet with fresh entropy. Lazy by design: called only when the --- user buys their first name. -newNameWallet :: B39.MnemonicStrength -> TVar ChaChaDRG -> STM NameWallet -newNameWallet strength g = NameWallet . B39.mnemonicToEntropy <$> B39.randomMnemonic strength g - --- | Import from a recovery phrase, validating the wordlist and BIP-39 checksum. -importRecoveryKey :: ByteString -> Either String NameWallet -importRecoveryKey phrase = NameWallet . B39.mnemonicToEntropy <$> B39.parseMnemonic phrase - --- | The phrase to show the user under "name recovery key". -recoveryKeyPhrase :: NameWallet -> Either String ByteString -recoveryKeyPhrase (NameWallet ent) = B39.mnemonicPhrase <$> B39.entropyToMnemonic ent - --- | Derive the key for a chat profile's account index. --- --- BIP-39 seed derivation uses an empty passphrase: the 25th-word passphrase --- would be a second secret to back up, and losing it would be indistinguishable --- from losing the phrase. -profileKey :: NameWallet -> Word32 -> Either String ProfileKey -profileKey (NameWallet ent) account = do - m <- B39.entropyToMnemonic ent - master <- B32.masterKey (B39.mnemonicToSeed m "") - xk <- B32.derivePath master (ethereumPath account) - pure ProfileKey {pkAccount = account, pkKey = B32.xkKey xk} - -profileAddress :: ProfileKey -> Address -profileAddress = addressFromPrivateKey . pkKey - --- | Sign an EIP-712 intent. The type string must match the contract's exactly, --- in EIP-712 canonical form. -signTypedData :: ProfileKey -> Eip712Domain -> ByteString -> [Value] -> Either String EthSignature -signTypedData pk domain typeString members = do - digest <- hashTypedData domain typeString members - sig <- S.signRecoverable (pkKey pk) digest - let compact = S.rsCompact sig - pure - EthSignature - { esR = B.take 32 compact, - esS = B.drop 32 compact, - esV = fromIntegral (S.rsRecId sig) + 27 - } diff --git a/src/Simplex/Chat/Store/Postgres/Migrations.hs b/src/Simplex/Chat/Store/Postgres/Migrations.hs index 19c07edbf8..8d59ff228a 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations.hs @@ -39,6 +39,7 @@ 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.M20260629_roster_catchup import Simplex.Chat.Store.Postgres.Migrations.M20260707_file_digest import Simplex.Chat.Store.Postgres.Migrations.M20260714_member_security_code @@ -91,7 +92,8 @@ 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) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260806_wallet_seeds.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260806_wallet_seeds.hs new file mode 100644 index 0000000000..d8e6fc8318 --- /dev/null +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260806_wallet_seeds.hs @@ -0,0 +1,34 @@ +{-# 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 +); + +ALTER TABLE users ADD COLUMN wallet_seed_id BIGINT REFERENCES wallet_seeds ON DELETE RESTRICT; +ALTER TABLE users ADD COLUMN wallet_account_index BIGINT; + +CREATE INDEX idx_users_wallet_seed_id ON users(wallet_seed_id); +|] + +down_m20260806_wallet_seeds :: Text +down_m20260806_wallet_seeds = + [r| +DROP INDEX idx_users_wallet_seed_id; + +ALTER TABLE users DROP COLUMN wallet_account_index; +ALTER TABLE users DROP COLUMN wallet_seed_id; + +DROP TABLE wallet_seeds; +|] diff --git a/src/Simplex/Chat/Store/SQLite/Migrations.hs b/src/Simplex/Chat/Store/SQLite/Migrations.hs index a4e7ab04a2..f301b0a957 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations.hs @@ -169,6 +169,7 @@ 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.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -337,7 +338,8 @@ 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) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260806_wallet_seeds.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260806_wallet_seeds.hs new file mode 100644 index 0000000000..8e1d9d8cc8 --- /dev/null +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260806_wallet_seeds.hs @@ -0,0 +1,40 @@ +{-# 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 +); + +ALTER TABLE users ADD COLUMN wallet_seed_id INTEGER REFERENCES wallet_seeds ON DELETE RESTRICT; +ALTER TABLE users ADD COLUMN wallet_account_index INTEGER; + +CREATE INDEX idx_users_wallet_seed_id ON users(wallet_seed_id); +|] + +down_m20260806_wallet_seeds :: Query +down_m20260806_wallet_seeds = + [sql| +DROP INDEX idx_users_wallet_seed_id; + +ALTER TABLE users DROP COLUMN wallet_account_index; +ALTER TABLE users DROP COLUMN wallet_seed_id; + +DROP TABLE wallet_seeds; +|] diff --git a/src/Simplex/Chat/Store/Wallets.hs b/src/Simplex/Chat/Store/Wallets.hs new file mode 100644 index 0000000000..22fcc50f99 --- /dev/null +++ b/src/Simplex/Chat/Store/Wallets.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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, + bindAccount, + ) +where + +import Control.Monad.IO.Class (liftIO) +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Maybe (fromMaybe, listToMaybe) +import Simplex.Chat.Store.Shared (insertedRowId) +import Simplex.Chat.Types (User (..)) +import Simplex.Chat.Wallet (AccountIndex, AccountRef (..), SeedId (..), WalletSeed (..)) +import Simplex.Messaging.Agent.Store.AgentStore (maybeFirstRow) +import qualified Simplex.Messaging.Agent.Store.DB as DB + +#if defined(dbPostgres) +import Database.PostgreSQL.Simple (Only (..)) +#else +import Database.SQLite.Simple (Only (..)) +#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) + +-- | 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 + seeds <- getWalletSeeds db + s <- case listToMaybe seeds of + Just s -> pure s + Nothing -> liftIO mkSeed >>= createWalletSeed db + case existing of + Just r | arSeedId r == wsId s -> pure (s, r) + _ -> do + ix <- nextAccountIndex db (wsId s) + let r = AccountRef {arSeedId = wsId s, arIndex = ix} + bindAccount db user r + pure (s, r) + +nextAccountIndex :: DB.Connection -> SeedId -> IO AccountIndex +nextAccountIndex db (SeedId sId) = do + used <- + maybeFirstRow fromOnly $ + DB.query db "SELECT MAX(wallet_account_index) FROM users WHERE wallet_seed_id = ?" (Only sId) + pure $ maybe 0 (\m -> fromIntegral (m :: Int64) + 1) (fromMaybe Nothing used) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 5894d12fd3..53edc50e21 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -34,6 +34,7 @@ import Data.Text.Encoding (decodeLatin1) import Data.Time (LocalTime (..), TimeOfDay (..), TimeZone (..), utcToLocalTime) import Data.Time.Calendar (addDays) import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Time.Format (defaultTimeLocale, formatTime) import qualified Data.Version as V import qualified Network.HTTP.Types as Q @@ -149,6 +150,37 @@ 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 -> ttyUser u ["name address (account " <> sShow acct <> "): " <> plain addr] + 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 ((" " <>) . plain) 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 +1178,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_ diff --git a/src/Simplex/Chat/Wallet.hs b/src/Simplex/Chat/Wallet.hs new file mode 100644 index 0000000000..44e4577c62 --- /dev/null +++ b/src/Simplex/Chat/Wallet.hs @@ -0,0 +1,149 @@ +{-# 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 derived key at @m\/44'\/60'\/i'\/0\/0@, where @i@ +-- is the profile's account index. Its address is what owns names. 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 (..), + newSeed, + importRecoveryKey, + recoveryKeyPhrase, + deriveAccount, + accountAddress, + 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.Word (Word32, Word8) +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) + +newtype SeedId = SeedId Int64 + deriving (Eq, Ord, Show) + +-- | BIP-44 account index within a seed. One per chat profile. +type AccountIndex = Word32 + +-- | A seed, held as BIP-39 entropy. Stored in the chat database so it rides the +-- existing archive export and Migrate-to-another-device flows. +-- +-- 'Show' is redacting: this is the root secret behind every name it owns. +data WalletSeed = WalletSeed + { wsId :: SeedId, + wsEntropy :: ByteString, + wsBackedUp :: Bool + } + deriving (Eq) + +instance Show WalletSeed where + show s = "WalletSeed " <> show (wsId s) <> " " + +-- | What a chat profile stores: which seed, and which account index within it. +data AccountRef = AccountRef + { arSeedId :: SeedId, + arIndex :: AccountIndex + } + deriving (Eq, Show) + +-- | A derived account: the reference plus the key it resolves to. +data WalletAccount = WalletAccount + { waRef :: AccountRef, + waKey :: S.PrivateKey + } + deriving (Eq) + +instance Show WalletAccount where + show a = "WalletAccount " <> show (waRef a) <> " " + +-- | An Ethereum signature: @r || s || v@, 65 bytes, with @v = recId + 27@. +data EthSignature = EthSignature + { esR :: ByteString, + esS :: ByteString, + esV :: Word8 + } + deriving (Eq, Show) + +ethSignatureBytes :: EthSignature -> ByteString +ethSignatureBytes s = esR s <> esS s <> B.singleton (esV s) + +-- | Fresh seed entropy. Lazy by design: called only when the user buys their +-- first name. The id is assigned on insert. +newSeed :: B39.MnemonicStrength -> TVar ChaChaDRG -> STM ByteString +newSeed strength g = B39.mnemonicToEntropy <$> B39.randomMnemonic strength g + +-- | Import from a recovery phrase, validating the wordlist and BIP-39 checksum. +importRecoveryKey :: ByteString -> Either String ByteString +importRecoveryKey phrase = B39.mnemonicToEntropy <$> B39.parseMnemonic phrase + +-- | The phrase to show the user under "recovery key". +recoveryKeyPhrase :: WalletSeed -> Either String ByteString +recoveryKeyPhrase s = B39.mnemonicPhrase <$> B39.entropyToMnemonic (wsEntropy s) + +-- | Derive a profile's account. +-- +-- 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. +deriveAccount :: WalletSeed -> AccountIndex -> Either String WalletAccount +deriveAccount s ix = do + m <- B39.entropyToMnemonic (wsEntropy s) + master <- B32.masterKey (B39.mnemonicToSeed m "") + xk <- B32.derivePath master (ethereumPath ix) + pure WalletAccount {waRef = AccountRef {arSeedId = wsId s, arIndex = ix}, waKey = B32.xkKey xk} + +accountAddress :: WalletAccount -> Address +accountAddress = addressFromPrivateKey . waKey + +-- | 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