Skip to content

agent: split SimplexNameDomain out of SimplexNameInfo #1788

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
epoberezkin merged 4 commits into from
May 29, 2026
+39 −22
Merged

agent: split SimplexNameDomain out of SimplexNameInfo #1788

Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
b3f2894
agent: split SimplexNameDomain out of SimplexNameInfo
shumvgolove May 28, 2026
c225be0
agent: split StrEncoding instance for SimplexNameDomain
shumvgolove May 28, 2026
4e2c9fc
agent: flatten TLD case + use unless guard
shumvgolove May 28, 2026
b54a09f
agent: address review - strict domain parser, permissive channel
shumvgolove May 28, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
61 changes: 39 additions & 22 deletions src/Simplex/Messaging/Agent/Protocol.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -123,6 +123,7 @@ module Simplex.Messaging.Agent.Protocol
ConnectionLink (..),
AConnectionLink (..),
SimplexNameInfo (..),
SimplexNameDomain (..),
SimplexTLD (..),
SimplexNameType (..),
ConnShortLink (..),
Expand Down Expand Up @@ -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
}
Expand All @@ -1540,40 +1546,49 @@ 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 info = "simplex:/name" <> strEncode (nameType info) <> encodeUtf8 (fullDomainName info)
strP = optional "simplex:/name" *> (strP >>= nameP) <|> nameP NTPublicGroup
strEncode SimplexNameInfo {nameType, nameDomain} =
"simplex:/name" <> strEncode nameType <> strEncode nameDomain
strP = optional "simplex:/name" *> ((strP >>= infoP) <|> infoP 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
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"
[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')
[_] -> 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)

Expand Down Expand Up @@ -2267,4 +2282,6 @@ $(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD)

$(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType)

$(J.deriveJSON defaultJSON ''SimplexNameDomain)

$(J.deriveJSON defaultJSON ''SimplexNameInfo)
Loading