From 7682999505642de7dc0f407d85b1eea62f3abdf0 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 27 May 2026 13:05:13 +0100 Subject: [PATCH 1/4] 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/4] 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 ee2ff402fed4d27d31521570c910fe82e0cf116a Mon Sep 17 00:00:00 2001 From: sh <37271604+shumvgolove@users.noreply.github.com> Date: Fri, 29 May 2026 08:11:08 +0000 Subject: [PATCH 3/4] agent: split SimplexNameDomain out of SimplexNameInfo (#1788) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * agent: split SimplexNameDomain out of SimplexNameInfo The type now separates the user-supplied type prefix (#/@) from the domain itself: data SimplexNameInfo = SimplexNameInfo { nameType :: SimplexNameType , nameDomain :: SimplexNameDomain } data SimplexNameDomain = SimplexNameDomain { nameTLD :: SimplexTLD , domain :: Text , subDomain :: [Text] } The domain is independent of the contact-vs-public-group distinction — the same dotted-labels structure applies to both. Future code that needs to talk about a domain without committing to a name type (e.g. server-side TLD-based registry lookup) can use SimplexNameDomain directly. fullDomainName now operates on SimplexNameDomain rather than the full info wrapper. Parser, StrEncoding instance, and aeson derivations updated accordingly. No external callers needed updating. * agent: split StrEncoding instance for SimplexNameDomain * agent: flatten TLD case + use unless guard * agent: address review - strict domain parser, permissive channel --- src/Simplex/Messaging/Agent/Protocol.hs | 65 ++++++++++++++++--------- 1 file changed, 41 insertions(+), 24 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 58e148f7e..a3f683770 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -123,6 +123,7 @@ module Simplex.Messaging.Agent.Protocol ConnectionLink (..), AConnectionLink (..), SimplexNameInfo (..), + SimplexNameDomain (..), SimplexTLD (..), SimplexNameType (..), ConnShortLink (..), @@ -1522,7 +1523,12 @@ data ContactConnType = CCTContact | CCTChannel | CCTGroup | CCTRelay deriving (E data SimplexNameInfo = SimplexNameInfo { nameType :: SimplexNameType, - nameTLD :: SimplexTLD, + nameDomain :: SimplexNameDomain + } + deriving (Eq, Show) + +data SimplexNameDomain = SimplexNameDomain + { nameTLD :: SimplexTLD, domain :: Text, subDomain :: [Text] -- parent to child: ["b", "a"] for a.b.domain.simplex } @@ -1540,40 +1546,49 @@ instance StrEncoding SimplexNameType where 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 = 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" - [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) [] +nameLabelP :: AT.Parser Text +nameLabelP = T.intercalate "-" <$> AT.takeWhile1 (\c -> isNameLetter c || isDigit c) `AT.sepBy1` AT.char '-' + where + isNameLetter c = isAlpha c && not (c >= '\x00c0' && c <= '\x024f') -fullDomainName :: SimplexNameInfo -> Text -fullDomainName SimplexNameInfo {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld') +instance StrEncoding SimplexNameInfo where + strEncode SimplexNameInfo {nameType, nameDomain} = + "simplex:/name" <> strEncode nameType <> strEncode nameDomain + strP = optional "simplex:/name" *> ((strP >>= infoP) <|> infoP NTPublicGroup) + where + infoP NTPublicGroup = SimplexNameInfo NTPublicGroup <$> (strP <|> bareName) + infoP NTContact = SimplexNameInfo NTContact <$> strP + bareName = parseBare . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace) + parseBare s = (\name -> SimplexNameDomain TLDSimplex name []) <$> AT.parseOnly (nameLabelP <* AT.endOfInput) s + +instance StrEncoding SimplexNameDomain where + strEncode = encodeUtf8 . fullDomainName + strP = parseDomain . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace) + where + parseDomain s = AT.parseOnly (nameLabelP `AT.sepBy1` AT.char '.' <* AT.endOfInput) s >>= mkDomain + mkDomain labels = case reverse labels of + [] -> Left "empty name" + [_] -> Left "domain requires TLD" + "simplex" : name : sub -> Right $ SimplexNameDomain TLDSimplex name sub + "testing" : name : sub -> Right $ SimplexNameDomain TLDTesting name sub + _ -> Right $ SimplexNameDomain TLDWeb (T.intercalate "." labels) [] + +fullDomainName :: SimplexNameDomain -> Text +fullDomainName SimplexNameDomain {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 + SimplexNameInfo {nameType = NTPublicGroup, nameDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain, subDomain = []}} -> "#" <> domain + info -> pfx <> fullDomainName (nameDomain info) where pfx = case nameType info of NTPublicGroup -> "#" - NTContact -> "@" + NTContact -> "@" data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m) @@ -2267,4 +2282,6 @@ $(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD) $(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType) +$(J.deriveJSON defaultJSON ''SimplexNameDomain) + $(J.deriveJSON defaultJSON ''SimplexNameInfo) From 39eb3c4a1381f93a9acb5507877016dc1e418b99 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 29 May 2026 09:31:37 +0100 Subject: [PATCH 4/4] 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