diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 64e934872e..107ebbf4fd 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -17,30 +17,54 @@ import Control.Logger.Simple import Control.Monad import qualified Data.Aeson as J import qualified Data.Aeson.KeyMap as KM +import Data.ByteString (ByteString) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) import qualified Data.Text as T +import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime) import Simplex.Chat.Badges.Service (BadgeServiceErrorCode (..)) import Simplex.Chat.Bot (initializeBotAddress') import Simplex.Chat.Controller import Simplex.Chat.Core (sendChatCmd, simplexChatCore) +import Simplex.Chat.Names.Protocol import Simplex.Chat.Options (printDbOpts) import Simplex.Chat.Terminal (terminalChatConfig) import Simplex.Chat.Terminal.Main (simplexChatCLI') import Simplex.Chat.Types (AgentInvId (..), User (..)) import Simplex.Messaging.Encoding.String (strEncode) +import Simplex.Messaging.Eth.Address (Address) +import Simplex.Messaging.Eth.Keccak (keccak256) import Simplex.Messaging.Util (raceAny_, safeDecodeUtf8, tshow) import System.Directory (getAppUserDataDirectory) import System.Exit (exitFailure) data ServiceState = ServiceState { serviceCC :: TMVar ChatController, - serviceRequestQ :: TQueue (User, AgentInvId, J.Object) + serviceRequestQ :: TQueue (User, AgentInvId, J.Object), + serviceNamesChain :: TVar NamesChain } newServiceState :: IO ServiceState newServiceState = do serviceCC <- newEmptyTMVarIO serviceRequestQ <- newTQueueIO - pure ServiceState {serviceCC, serviceRequestQ} + serviceNamesChain <- newTVarIO emptyNamesChain + pure ServiceState {serviceCC, serviceRequestQ, serviceNamesChain} + +-- | In-memory mock of the name registry chain: committed hashes and registered +-- names. Stands in for a deployed SNRC; swap for a relayer to make it real. +data NamesChain = NamesChain + { chainCommitments :: Set ByteString, + chainNames :: Map Text NameEntry + } + +data NameEntry = NameEntry {neOwner :: Address, neSimplexLink :: Text, neExpiry :: UTCTime} + +emptyNamesChain :: NamesChain +emptyNamesChain = NamesChain S.empty M.empty welcomeGetOpts :: IO BadgeServiceOpts welcomeGetOpts = do @@ -65,7 +89,7 @@ badgeService opts cfg = do (_, event) <- atomically . readTBQueue $ outputQ cc case event of -- TODO enforce _sigKey == BadgeServiceRequest.purchaseKey (docs/protocol/badges-rpc.md). - Right (CEvtServiceRequest u reqId _sigKey reqData) -> handleServiceRequest cc u reqId reqData + Right (CEvtServiceRequest u reqId _sigKey reqData) -> handleServiceRequest cc (serviceNamesChain env) u reqId reqData _ -> pure () badgeServiceCLI :: BadgeServiceOpts -> IO () @@ -93,7 +117,7 @@ processQueuedRequests env = do cc <- atomically $ readTMVar $ serviceCC env forever $ do (u, reqId, reqData) <- atomically $ readTQueue $ serviceRequestQ env - handleServiceRequest cc u reqId reqData + handleServiceRequest cc (serviceNamesChain env) u reqId reqData badgePreStartHook :: BadgeServiceOpts -> ChatController -> IO () badgePreStartHook opts ChatController {config, chatStore} = @@ -110,11 +134,48 @@ badgePostStartHook BadgeServiceOpts {noAddress, testing} env cc = do unless noAddress $ initializeBotAddress' (not testing) (Just True) False cc void $ atomically $ tryPutTMVar (serviceCC env) cc -handleServiceRequest :: ChatController -> User -> AgentInvId -> J.Object -> IO () -handleServiceRequest cc User {userId} reqId _reqData = do +handleServiceRequest :: ChatController -> TVar NamesChain -> User -> AgentInvId -> J.Object -> IO () +handleServiceRequest cc chain User {userId} reqId reqData = do let reqIdT = safeDecodeUtf8 (strEncode reqId) - respObj = KM.fromList [("type", J.String "error"), ("code", J.toJSON BSEUnsupportedVersion)] - logInfo $ "badge service request " <> reqIdT + logInfo $ "service request " <> reqIdT + respObj <- case J.fromJSON (J.Object reqData) of + J.Success req -> handleNamesRequest chain req + -- Non-names request: badge dispatch is still a stub. + J.Error _ -> pure $ KM.fromList [("type", J.String "error"), ("code", J.toJSON BSEUnsupportedVersion)] sendChatCmd cc (APISendServiceResponse userId reqId respObj) >>= \case Right _ -> pure () - Left e -> logError $ "badge service response failed for " <> reqIdT <> ": " <> tshow e + Left e -> logError $ "service response failed for " <> reqIdT <> ": " <> tshow e + +-- | Commit\/reveal against the chain mock. Commit stores the commitment and is +-- idempotent; reveal registers the name only if it was committed and is not +-- already registered — a second reveal of a live name fails with @name_taken@. +handleNamesRequest :: TVar NamesChain -> NamesRequest -> IO J.Object +handleNamesRequest chain NamesRequest {nrVersion, nrRequest} + | nrVersion /= currentNamesVersion = pure $ respObj $ NRPError NECUnsupportedVersion Nothing Nothing + | otherwise = case nrRequest of + NRCommit {nrCommitment} -> do + atomically $ modifyTVar' chain $ \c -> + c {chainCommitments = S.insert (unCommitment nrCommitment) (chainCommitments c)} + pure $ respObj $ NRPCommitted (mockTxHash "commit" $ unCommitment nrCommitment) + NRReveal {nrName, nrOwner, nrSecret, nrTtl, nrLink} -> do + now <- getCurrentTime + let commitment = unCommitment (mkCommitment nrName nrOwner nrSecret nrTtl) + expiry = addUTCTime (fromIntegral nrTtl) now + atomically $ do + c <- readTVar chain + if not (S.member commitment (chainCommitments c)) + then pure $ respObj $ NRPError NECBadRequest (Just "no matching commitment") Nothing + else case M.lookup nrName (chainNames c) of + -- A registered name is taken, including by you: re-registering is not + -- an update, and edits need signing (out of scope). Retry-idempotency + -- cannot be inferred from matching fields — it needs a request key, + -- which arrives with retries themselves. + Just _ -> pure $ respObj $ NRPError NECNameTaken Nothing Nothing + Nothing -> do + writeTVar chain c {chainNames = M.insert nrName (NameEntry nrOwner nrLink expiry) (chainNames c)} + pure $ respObj $ NRPRegistered nrName expiry (mockTxHash "reveal" commitment) + where + -- A NamesResponse always encodes to a JSON object. + respObj r = case J.toJSON r of J.Object o -> o; _ -> KM.empty + -- commit and reveal are distinct chain writes, so their hashes differ + mockTxHash tag = TxHash . keccak256 . (tag <>) diff --git a/bots/src/API/Docs/Commands.hs b/bots/src/API/Docs/Commands.hs index 09ae1faa5b..4508e5c8de 100644 --- a/bots/src/API/Docs/Commands.hs +++ b/bots/src/API/Docs/Commands.hs @@ -393,6 +393,7 @@ undocumentedCommands = "APIHideUser", "APIImportArchive", "APIMuteUser", + "APINameRegister", "APIPlanForwardChatItems", "APIPrepareContact", "APIPrepareGroup", diff --git a/bots/src/API/Docs/Events.hs b/bots/src/API/Docs/Events.hs index 1590ad54d5..f551621f1f 100644 --- a/bots/src/API/Docs/Events.hs +++ b/bots/src/API/Docs/Events.hs @@ -196,6 +196,7 @@ undocumentedEvents = "CEvtGroupMemberRatchetSync", "CEvtGroupMemberSwitch", "CEvtServiceSubStatus", + "CEvtNameRegistrationProgress", "CEvtNewRemoteHost", "CEvtNoMemberContactCreating", "CEvtNtfMessage", diff --git a/bots/src/API/Docs/Responses.hs b/bots/src/API/Docs/Responses.hs index 76f1ddb76b..eb66a0c733 100644 --- a/bots/src/API/Docs/Responses.hs +++ b/bots/src/API/Docs/Responses.hs @@ -177,6 +177,7 @@ undocumentedResponses = "CRMemberSupportChatRead", "CRMemberSupportChatDeleted", "CRMemberSupportChats", + "CRNameRegistered", "CRNetworkConfig", "CRNewMemberContact", "CRNewMemberContactSentInv", diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 6a5bfc2d26..8e426c349e 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -43,6 +43,9 @@ library Simplex.Chat.Badges.Service Simplex.Chat.Badges.Types Simplex.Chat.Names + Simplex.Chat.Names.Protocol + Simplex.Chat.Store.Wallets + Simplex.Chat.Wallet Simplex.Chat.Call Simplex.Chat.Controller Simplex.Chat.Delivery @@ -158,6 +161,7 @@ library Simplex.Chat.Store.Postgres.Migrations.M20260720_server_roles Simplex.Chat.Store.Postgres.Migrations.M20260723_contact_request_rejection Simplex.Chat.Store.Postgres.Migrations.M20260731_user_badges + Simplex.Chat.Store.Postgres.Migrations.M20260806_wallet_seeds else exposed-modules: Simplex.Chat.Archive @@ -329,6 +333,7 @@ library Simplex.Chat.Store.SQLite.Migrations.M20260720_server_roles Simplex.Chat.Store.SQLite.Migrations.M20260723_contact_request_rejection Simplex.Chat.Store.SQLite.Migrations.M20260731_user_badges + Simplex.Chat.Store.SQLite.Migrations.M20260806_wallet_seeds other-modules: Paths_simplex_chat hs-source-dirs: @@ -420,12 +425,14 @@ executable simplex-badge-service build-depends: aeson ==2.2.* , base >=4.7 && <5 + , containers ==0.6.* , directory ==1.3.* , optparse-applicative >=0.15 && <0.17 , simple-logger ==0.1.* , simplex-chat , simplexmq >=6.3 , stm ==2.5.* + , time ==1.12.* default-language: Haskell2010 if flag(client_postgres) other-modules: @@ -677,6 +684,7 @@ test-suite simplex-chat-test BadgeService.Service BadgeService.Store.Migrate Bots.BadgeServiceTests + Bots.NamesServiceTests Broadcast.Bot Broadcast.Options Directory.BlockedWords diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 6cf5453fd8..f3d60419b2 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -48,7 +48,7 @@ import Data.Text.Encoding (decodeLatin1) import Data.Time (NominalDiffTime, UTCTime) import Data.Time.Clock.System (SystemTime (..), systemToUTCTime) import Data.Version (showVersion) -import Data.Word (Word16) +import Data.Word (Word16, Word32) import Language.Haskell.TH (Exp, Q, runIO) import Network.Socket (HostName) import Numeric.Natural @@ -64,6 +64,7 @@ import Simplex.Chat.Remote.AppVersion import Simplex.Chat.Remote.Types import Simplex.Chat.Stats (PresentedServersSummary) import Simplex.Chat.Store (AddressSettings, ChatLockEntity, GroupLinkInfo, StoreError (..), UserContactLink, UserMsgReceiptSettings) +import Simplex.Chat.Names.Protocol (NameRegPhase, TxHash) import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared @@ -413,6 +414,7 @@ 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} + | APINameRegister {sendTarget :: ConnectTarget 'CMContact, regName :: Text, registerLink :: Text} | APISendCallInvitation ContactId CallType | SendCallInvitation ContactName CallType | APIRejectCall ContactId @@ -839,6 +841,7 @@ data ChatResponse | CRContactRequestRejected {user :: User, contactRequest :: UserContactRequest, contact_ :: Maybe Contact} | CRServiceResponse {user :: User, responseData :: J.Object} | CRServiceReplyAccepted {user :: User, connectionId :: AgentConnId} + | CRNameRegistered {user :: User, regName :: Text, regOwner :: Text, regExpiry :: UTCTime, regTxHash :: TxHash} | CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact} | CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], withMessages :: Bool, msgSigned :: Bool} | CRGroupsList {user :: User, groups :: [GroupInfo]} @@ -956,6 +959,7 @@ data ChatEvent | CEvtReceivedContactRequest {user :: User, contactRequest :: UserContactRequest, chat_ :: Maybe AChat} | CEvtServiceRequest {user :: User, requestId :: AgentInvId, signerKey :: Maybe C.PublicKeyEd25519, requestData :: J.Object} | CEvtServiceReplySent {connectionId :: AgentConnId} + | CEvtNameRegistrationProgress {user :: User, regName :: Text, regPhase :: NameRegPhase, waitMs :: Maybe Word32} | CEvtContactRequestRejected {user :: User, contact :: Contact, rejectionReason :: Maybe ContactRejectionReason} | CEvtAcceptingContactRequest {user :: User, contact :: Contact} -- there is the same command response | CEvtAcceptingBusinessRequest {user :: User, groupInfo :: GroupInfo} diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 336474880f..4f7605f109 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -33,6 +33,7 @@ import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Word (Word32) import Data.Char import Data.Constraint (Dict (..)) import Data.Either (fromRight, partitionEithers, rights) @@ -58,6 +59,9 @@ 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.Protocol +import Simplex.Chat.Store.Wallets (getOrCreateAccountRef) +import Simplex.Chat.Wallet (AccountRef (..), accountAddress, deriveAccount, newSeed) import Simplex.Chat.Call import Simplex.Chat.Controller import Simplex.Chat.Delivery (DeliveryJobScope (..), DeliveryJobSpec (..), DeliveryWorkerScope (..)) @@ -104,6 +108,7 @@ 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 @@ -1455,25 +1460,47 @@ processChatCommand cxt nm = \case pure ct_ pure $ CRContactRequestRejected user cReq ct_ APISendServiceRequest userId sendTarget requestTimeout signKey request -> withUserId userId $ \user -> do - cReq <- resolveServiceTarget user sendTarget + cReq <- resolveServiceTarget nm user sendTarget respData <- withAgent $ \a -> sendServiceRequestAsync a (aUserId user) cReq requestTimeout (C.unStored <$> signKey) (LB.toStrict $ J.encode request) resp <- either (const $ throwCmdError "invalid service response") pure $ J.eitherDecodeStrict' respData pure $ CRServiceResponse user resp + APINameRegister sendTarget nm' sLink -> withUser $ \user -> do + owner <- deriveNameOwner user + cReq <- resolveServiceTarget nm user sendTarget + g <- asks random + secret <- NameSecret <$> atomically (C.randomBytes 32 g) + let ttl = defaultNameTtl + commitment = mkCommitment nm' owner secret ttl + sendNames c = do + let req = NamesRequest currentNamesVersion c + respData <- withAgent $ \a -> sendServiceRequestAsync a (aUserId user) cReq Nothing Nothing (LB.toStrict $ J.encode req) + either (const $ throwCmdError "invalid names response") pure $ J.eitherDecodeStrict' respData + progress phase waitMs = toView $ CEvtNameRegistrationProgress user nm' phase waitMs + progress NRPhaseCommitting Nothing + sendNames (NRCommit commitment) >>= \case + NRPCommitted {} -> pure () + NRPError {nrCode, nrMessage} -> throwCmdError $ nameRegError nrCode nrMessage + _ -> throwCmdError "unexpected commit response" + progress NRPhaseCommitted (Just commitWaitMs) + liftIO $ threadDelay $ fromIntegral commitWaitMs * 1000 + progress NRPhaseRevealing Nothing + (expiry', txHash') <- + sendNames (NRReveal nm' owner secret ttl sLink) >>= \case + NRPRegistered {nrExpiry, nrTxHash} -> pure (nrExpiry, nrTxHash) + NRPError {nrCode, nrMessage} -> throwCmdError $ nameRegError nrCode nrMessage + _ -> throwCmdError "unexpected reveal response" + progress NRPhaseRegistered Nothing + pure $ CRNameRegistered user nm' (tshow owner) expiry' txHash' where - resolveServiceTarget user = \case - CTFullContact cReq -> pure cReq - CTShortContact (CTLink sLnk) -> resolveShortLink sLnk - CTShortContact (CTName SimplexNameInfo {nameType, nameDomain}) -> case nameType of - NTContact -> resolveDomain nameDomain - _ -> throwCmdError "service request target must be a contact" - CTDomain d -> resolveDomain d - where - resolveDomain d = do - nr <- withAgent $ \a -> resolveSimplexName a nm (aUserId user) d - case firstNameLink CCTContact (nrSimplexContact nr) of - Just sLnk -> resolveShortLink sLnk - Nothing -> throwChatError $ CESimplexDomainNotReady d SDENoValidLink - resolveShortLink sLnk = (\(_, _, cReq) -> cReq) <$> getShortLinkConnReq nm user sLnk + -- The seed is created on first registration and persisted, so the owner + -- address survives restart — a name whose key we cannot re-derive is lost. + deriveNameOwner user = do + g <- asks random + (seed, AccountRef {arIndex}) <- + withFastStore' $ \db -> getOrCreateAccountRef db user (atomically $ newSeed MS256 g) + either (throwCmdError . ("wallet: " <>)) (pure . accountAddress) $ deriveAccount seed arIndex + nameRegError code message = + "name registration failed: " <> T.unpack (textEncode code) <> maybe "" ((": " <>) . T.unpack) message APISendServiceResponse userId requestId responseData -> withUserId userId $ \user -> do let AgentInvId invId = requestId connId <- withAgent $ \a -> sendServiceReplyAsync a "" (aUserId user) invId (LB.toStrict $ J.encode responseData) @@ -5021,6 +5048,32 @@ processChatCommand cxt nm = \case gVar <- asks random liftIO $ SharedMsgId <$> encodedRandomBytes gVar 12 +-- | Resolve a service connect target to a contact connection request, shared by +-- the service-request and name-registration commands. +resolveServiceTarget :: NetworkRequestMode -> User -> ConnectTarget 'CMContact -> CM ConnReqContact +resolveServiceTarget nm user = \case + CTFullContact cReq -> pure cReq + CTShortContact (CTLink sLnk) -> resolveShortLink sLnk + CTShortContact (CTName SimplexNameInfo {nameType, nameDomain}) -> case nameType of + NTContact -> resolveDomain nameDomain + _ -> throwCmdError "service request target must be a contact" + CTDomain d -> resolveDomain d + where + resolveDomain d = do + nr <- withAgent $ \a -> resolveSimplexName a nm (aUserId user) d + case firstNameLink CCTContact (nrSimplexContact nr) of + Just sLnk -> resolveShortLink sLnk + Nothing -> throwChatError $ CESimplexDomainNotReady d SDENoValidLink + resolveShortLink sLnk = (\(_, _, cReq) -> cReq) <$> getShortLinkConnReq nm user sLnk + +-- | Default name lifetime (365 days). Real min-commitment-age enforcement deferred. +defaultNameTtl :: NameTtl +defaultNameTtl = 31536000 + +-- | Hardcoded commit→reveal wait in ms, standing in for the on-chain minimum commitment age. +commitWaitMs :: Word32 +commitWaitMs = 1000 + firstNameLink :: ContactConnType -> [Text] -> Maybe (ConnShortLink 'CMContact) firstNameLink ctType = foldr (\t r -> nameLink t <|> r) Nothing where @@ -5527,6 +5580,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), + "/name register " *> (APINameRegister <$> strP <* A.space <*> displayNameP <* A.space <*> textP), "/_call invite @" *> (APISendCallInvitation <$> A.decimal <* A.space <*> jsonP), "/call " *> char_ '@' *> (SendCallInvitation <$> displayNameP <*> pure defaultCallType), "/_call reject @" *> (APIRejectCall <$> A.decimal), diff --git a/src/Simplex/Chat/Names/Protocol.hs b/src/Simplex/Chat/Names/Protocol.hs new file mode 100644 index 0000000000..c426b8b874 --- /dev/null +++ b/src/Simplex/Chat/Names/Protocol.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Wire protocol for name registration over the badge service-RPC transport. +-- +-- A 'NamesRequest' travels in @APISendServiceRequest.request@ and a +-- 'NamesResponse' comes back in @CRServiceResponse.responseData@ — one response +-- per request. The envelope and both command\/response sums are @type@-tagged +-- JSON objects, the same shape the badge service decodes. +-- +-- Registration is commit-then-reveal (see the MVP plan): 'NRCommit' publishes +-- only @H(name, owner, secret, ttl)@ so the service cannot tell which name it +-- is; 'NRReveal' submits the plaintext once the aged commitment already binds +-- the name to /this/ owner address, so the service cannot front-run it. +module Simplex.Chat.Names.Protocol + ( NamesVersion, + currentNamesVersion, + NameTtl, + NamesRequest (..), + NamesCommand (..), + NamesResponse (..), + NamesErrorCode (..), + Commitment (..), + NameSecret (..), + TxHash (..), + NameRegPhase (..), + mkCommitment, + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=)) +import qualified Data.Aeson as J +import qualified Data.Aeson.Types as JT +import Control.Applicative (optional) +import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteArray.Encoding as BAE +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Char (isHexDigit) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (UTCTime) +import Data.Word (Word16, Word32) +import qualified Data.Aeson.TH as JQ +import Simplex.Messaging.Encoding (smpEncode) +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (enumJSON) +import Simplex.Messaging.Eth.Address (Address, checksumAddress, parseAddress, unAddress) +import Simplex.Messaging.Eth.Keccak (keccak256) +import Simplex.Messaging.Util (safeDecodeUtf8) + +-- | Protocol version, negotiated the way the badge service version is. +type NamesVersion = Word16 + +currentNamesVersion :: NamesVersion +currentNamesVersion = 1 + +-- | Name lifetime in seconds. Real min-commitment-age enforcement is deferred. +type NameTtl = Word32 + +-- | @H(name, owner, secret, ttl)@ — the only thing a commit reveals. +newtype Commitment = Commitment {unCommitment :: ByteString} + deriving (Eq, Show) + +-- | Per-registration nonce, kept secret until reveal so the commitment is opaque. +newtype NameSecret = NameSecret {unSecret :: ByteString} + deriving (Eq, Show) + +-- | A mock transaction hash. Returned now so block-inclusion checks (out of +-- scope) need no protocol change later. +newtype TxHash = TxHash {unTxHash :: ByteString} + deriving (Eq, Show) + +-- | All three are on-chain byte values, so they are encoded the way Ethereum +-- writes them — @0x@-prefixed hex — not base64. +hexEncode :: ByteString -> ByteString +hexEncode = ("0x" <>) . BAE.convertToBase BAE.Base16 + +hexP :: Parser ByteString +hexP = do + _ <- optional (A.string "0x") + s <- A.takeWhile1 isHexDigit + either fail pure $ BAE.convertFromBase BAE.Base16 s + +instance StrEncoding Commitment where + strEncode = hexEncode . unCommitment + strP = Commitment <$> hexP + +instance StrEncoding NameSecret where + strEncode = hexEncode . unSecret + strP = NameSecret <$> hexP + +instance StrEncoding TxHash where + strEncode = hexEncode . unTxHash + strP = TxHash <$> hexP + +instance ToJSON Commitment where toJSON = strToJSON; toEncoding = strToJEncoding + +instance FromJSON Commitment where parseJSON = strParseJSON "Commitment" + +instance ToJSON NameSecret where toJSON = strToJSON; toEncoding = strToJEncoding + +instance FromJSON NameSecret where parseJSON = strParseJSON "NameSecret" + +instance ToJSON TxHash where toJSON = strToJSON; toEncoding = strToJEncoding + +instance FromJSON TxHash where parseJSON = strParseJSON "TxHash" + +-- | Bind a name to an owner address with a secret and a TTL. Uses keccak256, so +-- the commitment matches what an Ethereum registrar would hash. +mkCommitment :: Text -> Address -> NameSecret -> NameTtl -> Commitment +mkCommitment name owner (NameSecret secret) ttl = + Commitment . keccak256 $ B.concat [encodeUtf8 name, unAddress owner, secret, smpEncode ttl] + +-- | @{ version, request }@ — the outer envelope. Fields are @nr@-prefixed so +-- they do not shadow local bindings where this module is imported unqualified. +data NamesRequest = NamesRequest + { nrVersion :: NamesVersion, + nrRequest :: NamesCommand + } + deriving (Eq, Show) + +data NamesCommand + = NRCommit {nrCommitment :: Commitment} + | NRReveal + { nrName :: Text, + nrOwner :: Address, + nrSecret :: NameSecret, + nrTtl :: NameTtl, + nrLink :: Text + } + deriving (Eq, Show) + +data NamesResponse + = NRPCommitted {nrTxHash :: TxHash} + | NRPRegistered {nrName :: Text, nrExpiry :: UTCTime, nrTxHash :: TxHash} + | NRPError {nrCode :: NamesErrorCode, nrMessage :: Maybe Text, nrRetryAfter :: Maybe Word32} + deriving (Eq, Show) + +data NamesErrorCode + = NECNameTaken + | NECBadRequest + | NECUnsupportedVersion + | NECInternal + | NECUnknown Text -- forwards-compatible: service may be ahead of clients + deriving (Eq, Show) + +instance TextEncoding NamesErrorCode where + textEncode = \case + NECNameTaken -> "name_taken" + NECBadRequest -> "bad_request" + NECUnsupportedVersion -> "unsupported_version" + NECInternal -> "internal" + NECUnknown t -> t + textDecode = Just . \case + "name_taken" -> NECNameTaken + "bad_request" -> NECBadRequest + "unsupported_version" -> NECUnsupportedVersion + "internal" -> NECInternal + t -> NECUnknown t + +instance ToJSON NamesErrorCode where + toJSON = textToJSON + toEncoding = textToEncoding + +instance FromJSON NamesErrorCode where + parseJSON = textParseJSON "NamesErrorCode" + +instance ToJSON NamesRequest where + toJSON NamesRequest {nrVersion, nrRequest} = J.object ["version" .= nrVersion, "request" .= nrRequest] + +instance FromJSON NamesRequest where + parseJSON = J.withObject "NamesRequest" $ \o -> + NamesRequest <$> o .: "version" <*> o .: "request" + +instance ToJSON NamesCommand where + toJSON = \case + NRCommit {nrCommitment} -> + J.object ["type" .= ("commit" :: Text), "commitment" .= nrCommitment] + NRReveal {nrName, nrOwner, nrSecret, nrTtl, nrLink} -> + J.object + [ "type" .= ("reveal" :: Text), + "name" .= nrName, + "owner" .= addressJSON nrOwner, + "secret" .= nrSecret, + "ttl" .= nrTtl, + "simplex_link" .= nrLink + ] + +instance FromJSON NamesCommand where + parseJSON = J.withObject "NamesCommand" $ \o -> + (o .: "type") >>= \case + "commit" -> NRCommit <$> o .: "commitment" + "reveal" -> + NRReveal + <$> o .: "name" + <*> (o .: "owner" >>= parseAddressJSON) + <*> o .: "secret" + <*> o .: "ttl" + <*> o .: "simplex_link" + t -> fail $ "unknown names command: " <> T.unpack (t :: Text) + +instance ToJSON NamesResponse where + toJSON = \case + NRPCommitted {nrTxHash} -> + J.object ["type" .= ("committed" :: Text), "txHash" .= nrTxHash] + NRPRegistered {nrName, nrExpiry, nrTxHash} -> + J.object ["type" .= ("registered" :: Text), "name" .= nrName, "expiry" .= nrExpiry, "txHash" .= nrTxHash] + NRPError {nrCode, nrMessage, nrRetryAfter} -> + J.object $ + ["type" .= ("error" :: Text), "code" .= nrCode] + <> ["message" .= m | Just m <- [nrMessage]] + <> ["retryAfter" .= r | Just r <- [nrRetryAfter]] + +instance FromJSON NamesResponse where + parseJSON = J.withObject "NamesResponse" $ \o -> + (o .: "type") >>= \case + "committed" -> NRPCommitted <$> o .: "txHash" + "registered" -> NRPRegistered <$> o .: "name" <*> o .: "expiry" <*> o .: "txHash" + "error" -> NRPError <$> o .: "code" <*> o .:? "message" <*> o .:? "retryAfter" + t -> fail $ "unknown names response: " <> T.unpack (t :: Text) + +-- | EIP-55 checksummed hex, the form a user pastes into a block explorer. +addressJSON :: Address -> J.Value +addressJSON = J.String . safeDecodeUtf8 . checksumAddress + +parseAddressJSON :: J.Value -> JT.Parser Address +parseAddressJSON = J.withText "Address" $ either fail pure . parseAddress . encodeUtf8 + +-- | Progress phases streamed from core to the UI as registration advances. +-- Not part of the wire protocol — carried in @CEvtNameRegistrationProgress@. +-- | 'NRPhaseCommitted' carries @waitMs@: the commit→reveal wait starts as soon +-- as it is emitted, so it needs no phase of its own. +data NameRegPhase + = NRPhaseCommitting + | NRPhaseCommitted + | NRPhaseRevealing + | NRPhaseRegistered + deriving (Eq, Show) + +$(JQ.deriveJSON (enumJSON $ \case "NRPhaseCommitting" -> "committing"; "NRPhaseCommitted" -> "committed"; "NRPhaseRevealing" -> "revealing"; "NRPhaseRegistered" -> "registered"; s -> s) ''NameRegPhase) diff --git a/src/Simplex/Chat/Store/Postgres/Migrations.hs b/src/Simplex/Chat/Store/Postgres/Migrations.hs index 19c07edbf8..214a9ee093 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations.hs @@ -46,6 +46,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260715_profile_description import Simplex.Chat.Store.Postgres.Migrations.M20260716_signed_history import Simplex.Chat.Store.Postgres.Migrations.M20260720_server_roles import Simplex.Chat.Store.Postgres.Migrations.M20260723_contact_request_rejection +import Simplex.Chat.Store.Postgres.Migrations.M20260806_wallet_seeds import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Text, Maybe Text)] @@ -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..1f831c8b76 --- /dev/null +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260806_wallet_seeds.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.Postgres.Migrations.M20260806_wallet_seeds where + +import Data.Text (Text) +import Text.RawString.QQ (r) + +m20260806_wallet_seeds :: Text +m20260806_wallet_seeds = + [r| +CREATE TABLE wallet_seeds ( + wallet_seed_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY, + seed BYTEA NOT NULL, + created_at TIMESTAMPTZ NOT NULL DEFAULT now(), + backed_up SMALLINT NOT NULL DEFAULT 0, + -- High-water mark for account allocation; see the SQLite migration for why + -- this cannot be derived from MAX(users.wallet_account_index). + next_account_index BIGINT NOT NULL DEFAULT 0 +); + +ALTER TABLE users ADD COLUMN wallet_seed_id BIGINT REFERENCES wallet_seeds ON DELETE RESTRICT; +ALTER TABLE users ADD COLUMN wallet_account_index BIGINT; +ALTER TABLE users ADD COLUMN wallet_scanned_to TEXT; + +CREATE INDEX idx_users_wallet_seed_id ON users(wallet_seed_id); + +CREATE TABLE wallet_one_time_addresses ( + wallet_one_time_address_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY, + user_id BIGINT NOT NULL REFERENCES users ON DELETE CASCADE, + chain TEXT NOT NULL, + address BYTEA NOT NULL, + ephemeral_pub_key BYTEA NOT NULL, + discovered_at TIMESTAMPTZ NOT NULL DEFAULT now(), + accepted_at TIMESTAMPTZ, + UNIQUE (user_id, chain, address) +); + +CREATE INDEX idx_wallet_one_time_addresses_user ON wallet_one_time_addresses(user_id, chain); +|] + +down_m20260806_wallet_seeds :: Text +down_m20260806_wallet_seeds = + [r| +DROP INDEX idx_wallet_one_time_addresses_user; + +DROP TABLE wallet_one_time_addresses; + +DROP INDEX idx_users_wallet_seed_id; + +ALTER TABLE users DROP COLUMN wallet_scanned_to; +ALTER TABLE users DROP COLUMN wallet_account_index; +ALTER TABLE users DROP COLUMN wallet_seed_id; + +DROP TABLE wallet_seeds; +|] diff --git a/src/Simplex/Chat/Store/SQLite/Migrations.hs b/src/Simplex/Chat/Store/SQLite/Migrations.hs index a4e7ab04a2..deb1805b40 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)] @@ -325,6 +326,7 @@ schemaMigrations = ("20260514_relay_request_group_link_index", m20260514_relay_request_group_link_index, Just down_m20260514_relay_request_group_link_index), ("20260515_public_group_access", m20260515_public_group_access, Just down_m20260515_public_group_access), ("20260516_supporter_badges", m20260516_supporter_badges, Just down_m20260516_supporter_badges), + ("20260806_wallet_seeds", m20260806_wallet_seeds, Just down_m20260806_wallet_seeds), ("20260529_delivery_job_senders", m20260529_delivery_job_senders, Just down_m20260529_delivery_job_senders), ("20260530_client_services", m20260530_client_services, Just down_m20260530_client_services), ("20260531_member_removed_at", m20260531_member_removed_at, Just down_m20260531_member_removed_at), diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260806_wallet_seeds.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260806_wallet_seeds.hs new file mode 100644 index 0000000000..63615cf437 --- /dev/null +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260806_wallet_seeds.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.SQLite.Migrations.M20260806_wallet_seeds where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +-- | Wallet seeds: BIP-39 entropy, one or more per database. +-- +-- The schema allows several seeds per database, with each chat profile bound to +-- exactly one of them plus its own BIP-44 account index. Only the single-seed +-- case is reachable from the UI today — profiles all share one seed and differ +-- by account index — but modelling it this way now means importing a second +-- recovery key later is a UI change, not a migration of live key material. +m20260806_wallet_seeds :: Query +m20260806_wallet_seeds = + [sql| +CREATE TABLE wallet_seeds ( + wallet_seed_id INTEGER PRIMARY KEY AUTOINCREMENT, + seed BLOB NOT NULL, -- BIP-39 entropy, 16-32 bytes + created_at TEXT NOT NULL DEFAULT (datetime('now')), + backed_up INTEGER NOT NULL DEFAULT 0, -- user acknowledged saving the recovery key + -- High-water mark for account allocation. Deliberately not derived from + -- MAX(users.wallet_account_index): after recovery from the phrase alone that + -- table is empty while accounts 0..N already hold names on chain, so a new + -- profile would silently reuse a recovered account's keys and meta-address. + -- The recovery probe raises this before any profile is created. + next_account_index INTEGER NOT NULL DEFAULT 0 +) STRICT; + +ALTER TABLE users ADD COLUMN wallet_seed_id INTEGER REFERENCES wallet_seeds ON DELETE RESTRICT; +ALTER TABLE users ADD COLUMN wallet_account_index INTEGER; +-- Position of the last recovery scan, so a repeat scan resumes. Not a live +-- watermark: incoming names are learned from a chat message, not by scanning. +ALTER TABLE users ADD COLUMN wallet_scanned_to TEXT; + +CREATE INDEX idx_users_wallet_seed_id ON users(wallet_seed_id); + +-- Destinations learned from a sender's message, or rediscovered by a recovery +-- scan. Holds no private key: the key is re-derived from the seed and the +-- ephemeral public key on demand, so this table is a cache and losing it costs +-- a rescan rather than an asset. +-- +-- 'chain' is carried from the first migration so that adding Bitcoin or Monero +-- later is new rows, not a schema change. +CREATE TABLE wallet_one_time_addresses ( + wallet_one_time_address_id INTEGER PRIMARY KEY AUTOINCREMENT, + user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, + chain TEXT NOT NULL, -- 'eth' today; 'btc', 'xmr' later + address BLOB NOT NULL, + ephemeral_pub_key BLOB NOT NULL, -- compressed secp256k1 point, 33 bytes + discovered_at TEXT NOT NULL DEFAULT (datetime('now')), + accepted_at TEXT, -- NULL = received but not accepted + UNIQUE (user_id, chain, address) +) STRICT; + +CREATE INDEX idx_wallet_one_time_addresses_user ON wallet_one_time_addresses(user_id, chain); +|] + +down_m20260806_wallet_seeds :: Query +down_m20260806_wallet_seeds = + [sql| +DROP INDEX idx_wallet_one_time_addresses_user; + +DROP TABLE wallet_one_time_addresses; + +DROP INDEX idx_users_wallet_seed_id; + +ALTER TABLE users DROP COLUMN wallet_scanned_to; +ALTER TABLE users DROP COLUMN wallet_account_index; +ALTER TABLE users DROP COLUMN wallet_seed_id; + +DROP TABLE wallet_seeds; +|] diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql index cfbcf70599..fa25ff5306 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql @@ -53,7 +53,10 @@ CREATE TABLE users( active_order INTEGER NOT NULL DEFAULT 0, auto_accept_member_contacts INTEGER NOT NULL DEFAULT 0, is_user_chat_relay INTEGER NOT NULL DEFAULT 0, - client_service INTEGER NOT NULL DEFAULT 0, -- 1 for active user + client_service INTEGER NOT NULL DEFAULT 0, + wallet_seed_id INTEGER REFERENCES wallet_seeds ON DELETE RESTRICT, + wallet_account_index INTEGER, + wallet_scanned_to TEXT, -- 1 for active user FOREIGN KEY(user_id, local_display_name) REFERENCES display_names(user_id, local_display_name) ON DELETE RESTRICT @@ -845,6 +848,29 @@ CREATE TABLE rcv_roster_transfers( created_at TEXT NOT NULL DEFAULT(datetime('now')), updated_at TEXT NOT NULL DEFAULT(datetime('now')) ) STRICT; +CREATE TABLE wallet_seeds( + wallet_seed_id INTEGER PRIMARY KEY AUTOINCREMENT, + seed BLOB NOT NULL, -- BIP-39 entropy, 16-32 bytes + created_at TEXT NOT NULL DEFAULT(datetime('now')), + backed_up INTEGER NOT NULL DEFAULT 0, -- user acknowledged saving the recovery key + -- High-water mark for account allocation. Deliberately not derived from + -- MAX(users.wallet_account_index): after recovery from the phrase alone that + -- table is empty while accounts 0..N already hold names on chain, so a new + -- profile would silently reuse a recovered account's keys and meta-address. +-- The recovery probe raises this before any profile is created. + next_account_index INTEGER NOT NULL DEFAULT 0 +) STRICT; +CREATE TABLE wallet_one_time_addresses( + wallet_one_time_address_id INTEGER PRIMARY KEY AUTOINCREMENT, + user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, + chain TEXT NOT NULL, -- 'eth' today; 'btc', + 'xmr' later + address BLOB NOT NULL, + ephemeral_pub_key BLOB NOT NULL, -- compressed secp256k1 point, 33 bytes + discovered_at TEXT NOT NULL DEFAULT(datetime('now')), + accepted_at TEXT, -- NULL = received but not accepted + UNIQUE(user_id, chain, address) +) STRICT; CREATE INDEX contact_profiles_index ON contact_profiles( display_name, full_name @@ -1379,6 +1405,11 @@ CREATE INDEX idx_files_roster_transfer_id ON files(roster_transfer_id); CREATE INDEX idx_chat_items_item_signed_by_group_member_id ON chat_items( item_signed_by_group_member_id ); +CREATE INDEX idx_users_wallet_seed_id ON users(wallet_seed_id); +CREATE INDEX idx_wallet_one_time_addresses_user ON wallet_one_time_addresses( + user_id, + chain +); CREATE TRIGGER on_group_members_insert_update_summary AFTER INSERT ON group_members FOR EACH ROW diff --git a/src/Simplex/Chat/Store/Wallets.hs b/src/Simplex/Chat/Store/Wallets.hs new file mode 100644 index 0000000000..c053f24cb0 --- /dev/null +++ b/src/Simplex/Chat/Store/Wallets.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | 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, + getAccountRef, + bindAccount, + getOrCreateAccountRef, + getNextAccountIndex, + ) +where + +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Maybe (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} + +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 + -- Load the seed this profile is actually bound to. Picking the first row in + -- the table instead would silently re-bind a profile whenever a second seed + -- exists - which is exactly what importing a recovery key creates - throwing + -- away the imported key and moving the profile to a new account index, so + -- the names it already owned stop being derivable too. + bound <- case existing of + Just r -> fmap (\s -> (r, s)) <$> getWalletSeed db (arSeedId r) + Nothing -> pure Nothing + case bound of + Just (r, s) -> pure (s, r) + Nothing -> do + seeds <- getWalletSeeds db + s <- case listToMaybe seeds of + Just s -> pure s + Nothing -> mkSeed >>= createWalletSeed db + ix <- takeAccountIndex db (wsId s) + let r = AccountRef {arSeedId = wsId s, arIndex = ix} + bindAccount db user r + pure (s, r) + +-- | Take the next account index and advance the seed's high-water mark. +-- +-- The mark is stored rather than computed as @MAX(users.wallet_account_index)@, +-- because after recovery from the phrase alone the @users@ table is empty while +-- accounts @0..N@ already hold names on chain. Computing it would hand the first +-- newly created profile index 0 and, with it, a recovered account's keys. +takeAccountIndex :: DB.Connection -> SeedId -> IO AccountIndex +takeAccountIndex db sId@(SeedId sId') = do + ix <- getNextAccountIndex db sId + DB.execute db "UPDATE wallet_seeds SET next_account_index = ? WHERE wallet_seed_id = ?" (fromIntegral ix + 1 :: Int64, sId') + pure ix + +getNextAccountIndex :: DB.Connection -> SeedId -> IO AccountIndex +getNextAccountIndex db (SeedId sId) = + maybe 0 (fromIntegral :: Int64 -> AccountIndex) + <$> ( maybeFirstRow fromOnly $ + DB.query db "SELECT next_account_index FROM wallet_seeds WHERE wallet_seed_id = ?" (Only sId) + ) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 72631dc3f8..c9218edd41 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -53,6 +53,7 @@ import Simplex.Chat.Remote.Types import Simplex.Chat.Store (AddressSettings (..), AutoAccept (..), StoreError (..), UserContactLink (..)) import Simplex.Chat.Styled import Simplex.Chat.Names (SimplexDomainClaim (..), claimDomain) +import Simplex.Chat.Names.Protocol (NameRegPhase (..)) import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared @@ -188,6 +189,8 @@ 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)] + CRNameRegistered u nm owner expiry txHash -> + ttyUser u [plain $ "name registered: " <> nm <> " -> " <> owner <> " (expires " <> tshow expiry <> ", tx " <> safeDecodeUtf8 (strEncode txHash) <> ")"] 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 @@ -474,6 +477,14 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView} <> maybe [] (\k -> [plain $ "signed by " <> safeDecodeUtf8 (strEncode k)]) sigKey_ <> ["request: " <> viewJSON req] CEvtServiceReplySent (AgentConnId cId) -> [plain $ "service reply sent, connection id: " <> safeDecodeUtf8 (strEncode cId)] + CEvtNameRegistrationProgress u nm regPhase waitMs -> + ttyUser u [plain $ "name " <> nm <> ": " <> phaseText] + where + phaseText = case regPhase of + NRPhaseCommitting -> "committing" + NRPhaseCommitted -> "committed" <> maybe "" (\ms -> ". waiting " <> tshow (ms `div` 1000) <> "s before revealing") waitMs + NRPhaseRevealing -> "revealing" + NRPhaseRegistered -> "registered" CEvtContactRequestRejected u Contact {localDisplayName = c} _reason -> ttyUser u [ttyContact c <> ": contact request rejected"] CEvtRcvFileStart u ci -> ttyUser u $ receivingFile_' hu testView "started" ci CEvtRcvFileComplete u ci -> ttyUser u $ receivingFile_' hu testView "completed" ci diff --git a/src/Simplex/Chat/Wallet.hs b/src/Simplex/Chat/Wallet.hs new file mode 100644 index 0000000000..d407c4f3ee --- /dev/null +++ b/src/Simplex/Chat/Wallet.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The wallet: BIP-39 seeds, and the per-chat-profile accounts derived from +-- them. +-- +-- * __seed__ — BIP-39 entropy. Generic and profile-scoped, /not/ name-specific. +-- * __account__ — a profile's slot in a seed, index @i@, holding the main +-- address that owns the names the profile registers. +-- * __wallet__ — this module: creation and derivation. +-- +-- Names are a /consumer/ of the wallet, which is why this sits here 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 today. +-- +-- This module is pure. Persistence lives in "Simplex.Chat.Store.Wallets". +-- +-- This is the read-only subset needed to register a name: no signing, no +-- stealth keys, no recovery-phrase import or export. Those are additive — +-- the types here match the full wallet, so adding them changes no signature. +module Simplex.Chat.Wallet + ( SeedId (..), + WalletSeed (..), + AccountIndex, + AccountRef (..), + WalletAccount (..), + newSeed, + deriveAccount, + accountAddress, + ) +where + +import Control.Concurrent.STM +import Crypto.Random (ChaChaDRG) +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Word (Word32) +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) + +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) <> " " + +-- | Fresh seed entropy. The caller stores it; this module never persists. +-- A 25th-word passphrase is deliberately not used — 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 + +-- | Derive the account at @m\/44'\/60'\/i'\/0\/0@. +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} + +-- | The Ethereum address that owns names registered by this account. +accountAddress :: WalletAccount -> Address +accountAddress = addressFromPrivateKey . waKey diff --git a/tests/Bots/NamesServiceTests.hs b/tests/Bots/NamesServiceTests.hs new file mode 100644 index 0000000000..5bebc9270f --- /dev/null +++ b/tests/Bots/NamesServiceTests.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PostfixOperators #-} + +module Bots.NamesServiceTests where + +import Bots.BadgeServiceTests (badgeProfile, mkBadgeServiceOpts, runBadgeService, serviceDbPrefix, withBadgeService) +import ChatClient +import ChatTests.DBUtils +import ChatTests.Utils +import Data.List (isPrefixOf) +import qualified Data.Aeson as J +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Char (isHexDigit) +import Simplex.Chat.Names.Protocol +import Simplex.Messaging.Encoding.String (strEncode) +import Simplex.Messaging.Eth.Address (parseAddress) +import Simplex.Messaging.Eth.Keccak (keccak256) +import Test.Hspec hiding (it) +import qualified Test.Hspec as Hspec + +namesServiceTests :: SpecWith TestParams +namesServiceTests = do + it "registers a name via commit/reveal and rejects a taken name" testNamesRegister + it "derives the same owner address after restart" testSeedPersists + +-- | Pins the wire format. The end-to-end test cannot catch a key renamed on +-- both sides at once, so the encodings are asserted literally here. +namesProtocolTests :: Spec +namesProtocolTests = do + Hspec.it "encodes commit and reveal requests" $ do + -- on-chain byte values are 0x-prefixed hex, as Ethereum writes them + encodes (NamesRequest 1 (NRCommit $ Commitment "0123456789abcdef")) $ + "{\"version\":1,\"request\":{\"type\":\"commit\",\"commitment\":\"0x30313233343536373839616263646566\"}}" + encodes (NamesRequest 1 (NRReveal "alice.simplex" testOwner (NameSecret "s") 3600 "simplex:/contact#/x")) $ + "{\"version\":1,\"request\":{\"type\":\"reveal\",\"name\":\"alice.simplex\"" + <> ",\"owner\":\"0x520110C7b1CE17f8C0a2778B41AB2F23D10B70B0\",\"secret\":\"0x73\"" + <> ",\"ttl\":3600,\"simplex_link\":\"simplex:/contact#/x\"}}" + encodes (NRPError NECNameTaken Nothing Nothing) "{\"type\":\"error\",\"code\":\"name_taken\"}" + Hspec.it "roundtrips requests and responses" $ do + roundtrips $ NamesRequest 1 (NRCommit $ Commitment "0123456789abcdef") + roundtrips $ NamesRequest 1 (NRReveal "alice.simplex" testOwner (NameSecret "s") 3600 "simplex:/contact#/x") + roundtrips $ NRPCommitted (TxHash "tx") + roundtrips $ NRPError NECNameTaken Nothing Nothing + roundtrips $ NRPError (NECUnknown "future_code") (Just "why") (Just 30) + Hspec.it "renders a 32-byte hash as 0x + 64 hex digits" $ do + let h = strEncode $ TxHash (keccak256 "reveal") + B.length h `shouldBe` 66 + B.take 2 h `shouldBe` "0x" + B.all (\c -> isHexDigit (toEnum $ fromIntegral c)) (B.drop 2 h) `shouldBe` True + Hspec.it "binds the commitment to every field" $ do + let c = mkCommitment "alice.simplex" testOwner (NameSecret "s") 3600 + -- the service recomputes it at reveal, so it must be deterministic + c `shouldBe` mkCommitment "alice.simplex" testOwner (NameSecret "s") 3600 + c `shouldNotBe` mkCommitment "bob.simplex" testOwner (NameSecret "s") 3600 + c `shouldNotBe` mkCommitment "alice.simplex" testOwner (NameSecret "s2") 3600 + c `shouldNotBe` mkCommitment "alice.simplex" testOwner (NameSecret "s") 7200 + where + testOwner = either error id $ parseAddress "0x520110C7b1CE17f8C0a2778B41AB2F23D10B70B0" + -- compares parsed values, so the assertion does not depend on key order + encodes :: J.ToJSON a => a -> LB.ByteString -> Expectation + encodes x s = Just (J.toJSON x) `shouldBe` J.decode s + roundtrips :: (Eq a, Show a, J.ToJSON a, J.FromJSON a) => a -> Expectation + roundtrips x = J.eitherDecode' (J.encode x) `shouldBe` Right x + +-- | End-to-end: @/name register@ streams the commit → wait → reveal phases and +-- resolves to the owner address derived from the wallet seed; a second +-- registration of the same name fails with name_taken. +testNamesRegister :: HasCallStack => TestParams -> IO () +testNamesRegister ps = + withBadgeService ps $ \client bsLink -> do + client ##> ("/name register " <> bsLink <> " alice.simplex simplex:/contact#/first") + commitPhases client + -- the final progress event and the command response arrive on separate channels + client + <### [ ConsoleString "name alice.simplex: registered", + StartsWith "name registered: alice.simplex -> 0x" + ] + -- re-running the identical command is rejected too, not silently accepted: + -- the owner is the same within a session, so this is the duplicate a user hits. + client ##> ("/name register " <> bsLink <> " alice.simplex simplex:/contact#/first") + commitPhases client + client <## "bad chat command: name registration failed: name_taken" + -- and the same name pointed at a different link is equally rejected + client ##> ("/name register " <> bsLink <> " alice.simplex simplex:/contact#/second") + commitPhases client + client <## "bad chat command: name registration failed: name_taken" + where + commitPhases client = do + client <## "name alice.simplex: committing" + client <## "name alice.simplex: committed. waiting 1s before revealing" + client <## "name alice.simplex: revealing" + +-- | The seed is persisted, so a name registered in one session is still owned by +-- an address the next session can derive. Without this the key is unrecoverable +-- after restart and the name is orphaned. +testSeedPersists :: HasCallStack => TestParams -> IO () +testSeedPersists ps = do + let opts = mkBadgeServiceOpts ps + withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure () + runBadgeService testCfg opts (pure ()) + bsLink <- withTestChat ps serviceDbPrefix $ \bs -> do + bs <## "subscribed 1 connections on server localhost" + bs ##> "/sa" + (sLink, _) <- getContactLinks bs False + bs <## "auto_accept off" + pure sLink + runBadgeService testCfg opts $ do + owner1 <- withNewTestChatCfg ps testCfg "client" bobProfile $ \client -> do + client ##> ("/name register " <> bsLink <> " first.simplex simplex:/contact#/x") + ownerOf client "first.simplex" + -- same database, new session: the seed has to come back from the DB + owner2 <- withTestChat ps "client" $ \client -> do + client ##> ("/name register " <> bsLink <> " second.simplex simplex:/contact#/y") + ownerOf client "second.simplex" + owner2 `shouldBe` owner1 + where + -- Reads past startup and progress lines to the registration result, and + -- keeps reading until the final progress event has arrived too — it races + -- with the command response and would otherwise be left unconsumed. + ownerOf client nm = go (40 :: Int) Nothing False + where + pfx = "name registered: " <> nm <> " -> " + lastEvt = "name " <> nm <> ": registered" + go _ (Just a) True = pure a + go 0 _ _ = error $ "no registration line for " <> nm + go n addr seen = do + l <- getTermLine client + let addr' = if pfx `isPrefixOf` l then Just (takeWhile (/= ' ') $ drop (length pfx) l) else addr + go (n - 1) addr' (seen || l == lastEvt) + diff --git a/tests/Test.hs b/tests/Test.hs index 6d0e299273..f95b110039 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -5,6 +5,7 @@ import Bots.BadgeServiceTests import Bots.BroadcastTests +import Bots.NamesServiceTests (namesProtocolTests, namesServiceTests) import Bots.DirectoryTests import ChatClient import ChatTests @@ -66,6 +67,7 @@ main = do describe "Supporter badges" badgeTests describe "SimpleX chat markdown" markdownTests describe "JSON Tests" jsonTests + describe "SimpleX names protocol" namesProtocolTests describe "Member relations" memberRelationsTests describe "SimpleX chat view" viewTests describe "SimpleX chat protocol" protocolTests @@ -90,6 +92,7 @@ main = do xdescribe'' "SimpleX Broadcast bot" broadcastBotTests xdescribe'' "SimpleX Directory service bot" directoryServiceTests xdescribe'' "SimpleX Badge service bot" badgeServiceTests + xdescribe'' "SimpleX Names service" namesServiceTests describe "Remote session" remoteTests #if !defined(dbPostgres) xdescribe'' "Save query plans" saveQueryPlans