From b3f28948b79db36a04ad753faaca1ea373884ede Mon Sep 17 00:00:00 2001 From: sh Date: Thu, 28 May 2026 09:06:01 +0000 Subject: [PATCH 1/4] agent: split SimplexNameDomain out of SimplexNameInfo MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- src/Simplex/Messaging/Agent/Protocol.hs | 35 ++++++++++++++++--------- 1 file changed, 22 insertions(+), 13 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 58e148f7e..a4c39b9fc 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 } @@ -1541,7 +1547,8 @@ instance StrEncoding SimplexNameType where strP = A.char '#' $> NTPublicGroup <|> A.char '@' $> NTContact instance StrEncoding SimplexNameInfo where - strEncode info = "simplex:/name" <> strEncode (nameType info) <> encodeUtf8 (fullDomainName info) + strEncode SimplexNameInfo {nameType, nameDomain} = + "simplex:/name" <> strEncode nameType <> encodeUtf8 (fullDomainName nameDomain) strP = optional "simplex:/name" *> (strP >>= nameP) <|> nameP NTPublicGroup where nameP nt = parseName nt . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace) @@ -1551,29 +1558,29 @@ instance StrEncoding SimplexNameInfo where mkNameInfo nt labels = case reverse labels of [] -> Left "empty name" [name] - | nt == NTPublicGroup -> Right $ SimplexNameInfo nt TLDSimplex name [] + | nt == NTPublicGroup -> Right $ SimplexNameInfo nt (SimplexNameDomain 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) [] + tld : name : sub -> Right $ SimplexNameInfo nt $ case tld of + "simplex" -> SimplexNameDomain TLDSimplex name sub + "testing" -> SimplexNameDomain TLDTesting name sub + _ -> SimplexNameDomain TLDWeb (T.intercalate "." labels) [] -fullDomainName :: SimplexNameInfo -> Text -fullDomainName SimplexNameInfo {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld') +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 +2274,6 @@ $(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD) $(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType) +$(J.deriveJSON defaultJSON ''SimplexNameDomain) + $(J.deriveJSON defaultJSON ''SimplexNameInfo) From c225be0a93795b42f0fd79d5d25784d80166e566 Mon Sep 17 00:00:00 2001 From: sh Date: Thu, 28 May 2026 14:59:12 +0000 Subject: [PATCH 2/4] agent: split StrEncoding instance for SimplexNameDomain --- src/Simplex/Messaging/Agent/Protocol.hs | 31 ++++++++++++++++--------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index a4c39b9fc..929c0fc9d 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -198,6 +198,7 @@ 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 Data.Attoparsec.Combinator (lookAhead) import qualified Data.Attoparsec.Text as AT import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Char8 (ByteString) @@ -1546,25 +1547,33 @@ instance StrEncoding SimplexNameType where NTContact -> "@" strP = A.char '#' $> NTPublicGroup <|> A.char '@' $> NTContact -instance StrEncoding SimplexNameInfo where - strEncode SimplexNameInfo {nameType, nameDomain} = - "simplex:/name" <> strEncode nameType <> encodeUtf8 (fullDomainName nameDomain) - strP = optional "simplex:/name" *> (strP >>= nameP) <|> nameP NTPublicGroup +instance StrEncoding SimplexNameDomain where + strEncode = encodeUtf8 . fullDomainName + strP = parseDomain . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace) 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 + parseDomain s = AT.parseOnly (nameLabelP `AT.sepBy1` AT.char '.' <* AT.endOfInput) s >>= mkDomain 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 + mkDomain labels = case reverse labels of [] -> Left "empty name" - [name] - | nt == NTPublicGroup -> Right $ SimplexNameInfo nt (SimplexNameDomain TLDSimplex name []) - | otherwise -> Left "contact name requires TLD" - tld : name : sub -> Right $ SimplexNameInfo nt $ case tld of + [name] -> Right $ SimplexNameDomain TLDSimplex name [] + tld : name : sub -> Right $ case tld of "simplex" -> SimplexNameDomain TLDSimplex name sub "testing" -> SimplexNameDomain TLDTesting name sub _ -> SimplexNameDomain TLDWeb (T.intercalate "." labels) [] +instance StrEncoding SimplexNameInfo where + strEncode SimplexNameInfo {nameType, nameDomain} = + "simplex:/name" <> strEncode nameType <> strEncode nameDomain + strP = optional "simplex:/name" *> ((strP >>= infoP) <|> infoP NTPublicGroup) + where + infoP NTContact = do + bs <- lookAhead $ A.takeWhile1 (not . A.isSpace) + if B.elem '.' bs + then SimplexNameInfo NTContact <$> strP + else fail "contact name requires TLD" + infoP nt = SimplexNameInfo nt <$> strP + fullDomainName :: SimplexNameDomain -> Text fullDomainName SimplexNameDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld') where From 4e2c9fc3934c07c6952bd84f2e61b5eb890c29d7 Mon Sep 17 00:00:00 2001 From: sh Date: Thu, 28 May 2026 15:09:45 +0000 Subject: [PATCH 3/4] agent: flatten TLD case + use unless guard --- src/Simplex/Messaging/Agent/Protocol.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 929c0fc9d..5c67f3031 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -191,6 +191,7 @@ where import Control.Applicative (optional, (<|>)) import Control.Exception (BlockedIndefinitelyOnMVar (..), BlockedIndefinitelyOnSTM (..), fromException) +import Control.Monad (unless) import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), (.:), (.:?)) import qualified Data.Aeson as J' import qualified Data.Aeson.Encoding as JE @@ -1557,10 +1558,9 @@ instance StrEncoding SimplexNameDomain where mkDomain labels = case reverse labels of [] -> Left "empty name" [name] -> Right $ SimplexNameDomain TLDSimplex name [] - tld : name : sub -> Right $ case tld of - "simplex" -> SimplexNameDomain TLDSimplex name sub - "testing" -> SimplexNameDomain TLDTesting name sub - _ -> SimplexNameDomain TLDWeb (T.intercalate "." labels) [] + "simplex" : name : sub -> Right $ SimplexNameDomain TLDSimplex name sub + "testing" : name : sub -> Right $ SimplexNameDomain TLDTesting name sub + _ -> Right $ SimplexNameDomain TLDWeb (T.intercalate "." labels) [] instance StrEncoding SimplexNameInfo where strEncode SimplexNameInfo {nameType, nameDomain} = @@ -1569,9 +1569,8 @@ instance StrEncoding SimplexNameInfo where where infoP NTContact = do bs <- lookAhead $ A.takeWhile1 (not . A.isSpace) - if B.elem '.' bs - then SimplexNameInfo NTContact <$> strP - else fail "contact name requires TLD" + unless (B.elem '.' bs) $ fail "contact name requires TLD" + SimplexNameInfo NTContact <$> strP infoP nt = SimplexNameInfo nt <$> strP fullDomainName :: SimplexNameDomain -> Text From b54a09f3d6b8567f8cde3f0b56aeaca962eca5c7 Mon Sep 17 00:00:00 2001 From: sh Date: Thu, 28 May 2026 15:39:40 +0000 Subject: [PATCH 4/4] agent: address review - strict domain parser, permissive channel --- src/Simplex/Messaging/Agent/Protocol.hs | 32 ++++++++++++------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 5c67f3031..a3f683770 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -191,7 +191,6 @@ where import Control.Applicative (optional, (<|>)) import Control.Exception (BlockedIndefinitelyOnMVar (..), BlockedIndefinitelyOnSTM (..), fromException) -import Control.Monad (unless) import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), (.:), (.:?)) import qualified Data.Aeson as J' import qualified Data.Aeson.Encoding as JE @@ -199,7 +198,6 @@ 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 Data.Attoparsec.Combinator (lookAhead) import qualified Data.Attoparsec.Text as AT import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Char8 (ByteString) @@ -1548,31 +1546,33 @@ instance StrEncoding SimplexNameType where NTContact -> "@" strP = A.char '#' $> NTPublicGroup <|> A.char '@' $> NTContact +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') + +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 - nameLabelP = T.intercalate "-" <$> AT.takeWhile1 (\c -> isNameLetter c || isDigit c) `AT.sepBy1` AT.char '-' - isNameLetter c = isAlpha c && not (c >= '\x00c0' && c <= '\x024f') mkDomain labels = case reverse labels of [] -> Left "empty name" - [name] -> Right $ SimplexNameDomain TLDSimplex 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) [] -instance StrEncoding SimplexNameInfo where - strEncode SimplexNameInfo {nameType, nameDomain} = - "simplex:/name" <> strEncode nameType <> strEncode nameDomain - strP = optional "simplex:/name" *> ((strP >>= infoP) <|> infoP NTPublicGroup) - where - infoP NTContact = do - bs <- lookAhead $ A.takeWhile1 (not . A.isSpace) - unless (B.elem '.' bs) $ fail "contact name requires TLD" - SimplexNameInfo NTContact <$> strP - infoP nt = SimplexNameInfo nt <$> strP - fullDomainName :: SimplexNameDomain -> Text fullDomainName SimplexNameDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld') where