From 7682999505642de7dc0f407d85b1eea62f3abdf0 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 27 May 2026 13:05:13 +0100 Subject: [PATCH 1/3] agent: types for namespace support (#1786) * agent: types for namespace support * parser * refactor * more refactor * simplify * refactor again * refactor * refactor * import * use @ for contact addresses * remove AConnectTarget * update parser and types * revert TLDWeb --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com> --- src/Simplex/Messaging/Agent/Protocol.hs | 73 ++++++++++++++++++++++++- 1 file changed, 72 insertions(+), 1 deletion(-) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 30a2e53d9..841cc0088 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -122,6 +122,9 @@ module Simplex.Messaging.Agent.Protocol OwnerId, ConnectionLink (..), AConnectionLink (..), + SimplexNameInfo (..), + SimplexTLD (..), + SimplexNameType (..), ConnShortLink (..), AConnShortLink (..), CreatedConnLink (..), @@ -141,6 +144,8 @@ module Simplex.Messaging.Agent.Protocol connReqUriP', simplexConnReqUri, simplexShortLink, + fullDomainName, + shortNameInfoStr, AgentErrorType (..), CommandErrorType (..), ConnectionErrorType (..), @@ -184,6 +189,7 @@ module Simplex.Messaging.Agent.Protocol where import Control.Applicative (optional, (<|>)) +import Control.Monad import Control.Exception (BlockedIndefinitelyOnMVar (..), BlockedIndefinitelyOnSTM (..), fromException) import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), (.:), (.:?)) import qualified Data.Aeson as J' @@ -192,10 +198,11 @@ import qualified Data.Aeson.TH as J import qualified Data.Aeson.Types as JT import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.Attoparsec.Text as AT import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Char (toLower, toUpper) +import Data.Char (isAlpha, isDigit, toLower, toUpper) import Data.Foldable (find) import Data.Functor (($>)) import Data.Int (Int64) @@ -1514,6 +1521,64 @@ instance (Typeable c, ConnectionModeI c) => FromField (ConnShortLink c) where fr data ContactConnType = CCTContact | CCTChannel | CCTGroup | CCTRelay deriving (Eq, Show) +data SimplexNameInfo = SimplexNameInfo + { nameType :: SimplexNameType, + nameTLD :: SimplexTLD, + domain :: Text, + subDomain :: [Text] -- parent to child: ["b", "a"] for a.b.domain.simplex + } + deriving (Eq, Show) + +data SimplexTLD = TLDSimplex | TLDTesting | TLDWeb + deriving (Eq, Show) + +data SimplexNameType = NTPublicGroup | NTContact + deriving (Eq, Show) + +instance StrEncoding SimplexNameType where + strEncode = \case + NTPublicGroup -> "#" + NTContact -> "@" + strP = A.char '#' $> NTPublicGroup <|> A.char '@' $> NTContact + +instance StrEncoding SimplexNameInfo where + strEncode info = "simplex:/name" <> strEncode (nameType info) <> encodeUtf8 (fullDomainName info) + strP = optional "simplex:/name" *> (strP >>= nameP) <|> nameP NTPublicGroup + where + nameP nt = parseName nt . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace) + parseName nt s = AT.parseOnly (nameLabelP `AT.sepBy1` AT.char '.' <* AT.endOfInput) s >>= mkNameInfo nt + nameLabelP = do + ws <- AT.takeWhile1 (\c -> isNameLetter c || isDigit c) `AT.sepBy1` AT.char '-' + when (all (T.all isDigit) ws) $ fail "name must contain letters" + pure $ T.intercalate "-" ws + isNameLetter c = isAlpha c && not (c >= '\x00c0' && c <= '\x024f') + mkNameInfo nt labels = case reverse labels of + [] -> Left "empty name" + [name] + | nt == NTPublicGroup -> Right $ SimplexNameInfo nt TLDSimplex name [] + | otherwise -> Left "contact name requires TLD" + tld : name : sub -> Right $ case tld of + "simplex" -> SimplexNameInfo nt TLDSimplex name sub + "testing" -> SimplexNameInfo nt TLDTesting name sub + _ -> SimplexNameInfo nt TLDWeb (T.intercalate "." labels) [] + +fullDomainName :: SimplexNameInfo -> Text +fullDomainName SimplexNameInfo {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld') + where + tld' = case nameTLD of + TLDSimplex -> ["simplex"] + TLDTesting -> ["testing"] + TLDWeb -> [] + +shortNameInfoStr :: SimplexNameInfo -> Text +shortNameInfoStr = \case + SimplexNameInfo {nameType = NTPublicGroup, nameTLD = TLDSimplex, domain, subDomain = []} -> "#" <> domain + info -> pfx <> fullDomainName info + where + pfx = case nameType info of + NTPublicGroup -> "#" + NTContact -> "@" + data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m) instance Eq AConnShortLink where @@ -2201,3 +2266,9 @@ instance FromJSON ACreatedConnLink where instance ToJSON ACreatedConnLink where toEncoding (ACCL _ ccLink) = toEncoding ccLink toJSON (ACCL _ ccLink) = toJSON ccLink + +$(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD) + +$(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType) + +$(J.deriveJSON defaultJSON ''SimplexNameInfo) From e9265a7f7cb723d70b03e1b67af01f2666872a44 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Wed, 27 May 2026 18:06:44 +0100 Subject: [PATCH 2/3] agent: allow all-digit names --- src/Simplex/Messaging/Agent/Protocol.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 841cc0088..58e148f7e 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -189,7 +189,6 @@ module Simplex.Messaging.Agent.Protocol where import Control.Applicative (optional, (<|>)) -import Control.Monad import Control.Exception (BlockedIndefinitelyOnMVar (..), BlockedIndefinitelyOnSTM (..), fromException) import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), (.:), (.:?)) import qualified Data.Aeson as J' @@ -1547,10 +1546,7 @@ instance StrEncoding SimplexNameInfo where where nameP nt = parseName nt . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace) parseName nt s = AT.parseOnly (nameLabelP `AT.sepBy1` AT.char '.' <* AT.endOfInput) s >>= mkNameInfo nt - nameLabelP = do - ws <- AT.takeWhile1 (\c -> isNameLetter c || isDigit c) `AT.sepBy1` AT.char '-' - when (all (T.all isDigit) ws) $ fail "name must contain letters" - pure $ T.intercalate "-" ws + nameLabelP = T.intercalate "-" <$> AT.takeWhile1 (\c -> isNameLetter c || isDigit c) `AT.sepBy1` AT.char '-' isNameLetter c = isAlpha c && not (c >= '\x00c0' && c <= '\x024f') mkNameInfo nt labels = case reverse labels of [] -> Left "empty name" From 39eb3c4a1381f93a9acb5507877016dc1e418b99 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 29 May 2026 09:31:37 +0100 Subject: [PATCH 3/3] smp: fix handshake for rcv services between new client & old server (#1790) --- src/Simplex/Messaging/Transport.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index f1eb1a8bd..d98453ab8 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -824,10 +824,11 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer serviceKeys_ serverKey <- getServerVerifyKey c (,certKey) <$> (C.x509ToPublic' =<< C.verifyX509 serverKey exact) let v = maxVersion vr + serviceVersion ServiceCredentials {serviceRole} = if serviceRole == SRMessaging then rcvServiceSMPVersion else serviceCertsSMPVersion serviceKeys = case serviceKeys_ of - Just sks | v >= serviceCertsSMPVersion && certificateSent c -> Just sks + Just sks | v >= serviceVersion (fst sks) && certificateSent c -> Just sks _ -> Nothing - clientService = mkClientService v =<< serviceKeys + clientService = mkClientService <$> serviceKeys hs = SMPClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer, clientService} sendHandshake th hs service <- mapM getClientService serviceKeys @@ -835,12 +836,10 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer serviceKeys_ Nothing -> throwE TEVersion where th@THandle {params = THandleParams {sessionId}} = smpTHandle c - mkClientService :: VersionSMP -> (ServiceCredentials, C.KeyPairEd25519) -> Maybe SMPClientHandshakeService - mkClientService v (ServiceCredentials {serviceRole, serviceCreds, serviceSignKey}, (k, _)) - | serviceRole == SRMessaging && v < rcvServiceSMPVersion = Nothing - | otherwise = - let sk = C.signX509 serviceSignKey $ C.publicToX509 k - in Just SMPClientHandshakeService {serviceRole, serviceCertKey = CertChainPubKey (fst serviceCreds) sk} + mkClientService :: (ServiceCredentials, C.KeyPairEd25519) -> SMPClientHandshakeService + mkClientService (ServiceCredentials {serviceRole, serviceCreds, serviceSignKey}, (k, _)) = + let sk = C.signX509 serviceSignKey $ C.publicToX509 k + in SMPClientHandshakeService {serviceRole, serviceCertKey = CertChainPubKey (fst serviceCreds) sk} getClientService :: (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO THClientService getClientService (ServiceCredentials {serviceRole, serviceCertHash}, (_, pk)) = getHandshake th >>= \case