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 +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) @@ -2267,4 +2282,6 @@ $(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD) $(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType) +$(J.deriveJSON defaultJSON ''SimplexNameDomain) + $(J.deriveJSON defaultJSON ''SimplexNameInfo)