Merge branch 'stable'

src/Simplex/Messaging/Agent/Protocol.hs

@@ -123,6 +123,7 @@ module Simplex.Messaging.Agent.Protocol
     ConnectionLink (..),
     AConnectionLink (..),
     SimplexNameInfo (..),
+    SimplexNameDomain (..),
     SimplexTLD (..),
     SimplexNameType (..),
     ConnShortLink (..),
@@ -1532,7 +1533,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
   }
@@ -1550,40 +1556,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)