dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-08-29 09:58:41 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge origin/stable

Browse Source
This commit is contained in:
sh
2026-05-29 16:08:27 +00:00
parent daac3e2e02 92fb0ea1dd
commit 1e2cf239a2
2 changed files with 42 additions and 24 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Messaging/Agent/Protocol.hs
+2 -1
View File
@@ -123,6 +123,7 @@ module Simplex.Messaging.Agent.Protocol
ConnectionLink (..),
AConnectionLink (..),
SimplexNameInfo (..),
SimplexNameDomain (..),
SimplexTLD (..),
SimplexNameType (..),
ConnShortLink (..),
@@ -236,7 +237,7 @@ import Simplex.Messaging.Crypto.Ratchet
)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.SimplexName (SimplexNameInfo (..), SimplexNameType (..), SimplexTLD (..), fullDomainName, shortNameInfoStr)
import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexNameInfo (..), SimplexNameType (..), SimplexTLD (..), fullDomainName, shortNameInfoStr)
import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol
( AProtocolType,
src/Simplex/Messaging/SimplexName.hs
+40 -23
View File
@@ -9,6 +9,7 @@
-- from the user) and the server (which validates them on the RSLV path).
module Simplex.Messaging.SimplexName
( SimplexNameInfo (..),
SimplexNameDomain (..),
SimplexTLD (..),
SimplexNameType (..),
fullDomainName,
@@ -17,9 +18,9 @@ module Simplex.Messaging.SimplexName
where
import Control.Applicative (optional, (<|>))
import qualified Data.Aeson.TH as J
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.Attoparsec.Text as AT
import qualified Data.Aeson.TH as J
import Data.Char (isAlpha, isDigit)
import Data.Functor (($>))
import Data.Text (Text)
@@ -31,7 +32,12 @@ import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>))
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
}
@@ -49,26 +55,35 @@ 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"]
@@ -77,8 +92,8 @@ fullDomainName SimplexNameInfo {nameTLD, domain, subDomain} = T.intercalate "."
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 -> "#"
@@ -88,4 +103,6 @@ $(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD)
$(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType)
$(J.deriveJSON defaultJSON ''SimplexNameDomain)
$(J.deriveJSON defaultJSON ''SimplexNameInfo)