Merge branch 'master' into ep/spec-2

src/Simplex/Messaging/Agent/Protocol.hs

@@ -122,6 +122,10 @@ module Simplex.Messaging.Agent.Protocol
     OwnerId,
     ConnectionLink (..),
     AConnectionLink (..),
+    SimplexNameInfo (..),
+    SimplexNameDomain (..),
+    SimplexTLD (..),
+    SimplexNameType (..),
     ConnShortLink (..),
     AConnShortLink (..),
     CreatedConnLink (..),
@@ -138,6 +142,8 @@ module Simplex.Messaging.Agent.Protocol
     connReqUriP',
     simplexConnReqUri,
     simplexShortLink,
+    fullDomainName,
+    shortNameInfoStr,
     AgentErrorType (..),
     CommandErrorType (..),
     ConnectionErrorType (..),
@@ -189,10 +195,11 @@ 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 qualified Data.Attoparsec.Text as AT
 import qualified Data.ByteString.Base64.URL as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Char (toLower, toUpper)
+import Data.Char (isAlpha, isDigit, toLower, toUpper)
 import Data.Foldable (find)
 import Data.Functor (($>))
 import Data.Int (Int64)
@@ -1525,6 +1532,75 @@ instance (Typeable c, ConnectionModeI c) => FromField (ConnShortLink c) where fr
 
 data ContactConnType = CCTContact | CCTChannel | CCTGroup | CCTRelay deriving (Eq, Show)
 
+data SimplexNameInfo = SimplexNameInfo
+  { nameType :: SimplexNameType,
+    nameDomain :: SimplexNameDomain
+  }
+  deriving (Eq, Show)
+
+data SimplexNameDomain = SimplexNameDomain
+  { nameTLD :: SimplexTLD,
+    domain :: Text,
+    subDomain :: [Text] -- parent to child: ["b", "a"] for a.b.domain.simplex
+  }
+  deriving (Eq, Show)
+
+data SimplexTLD = TLDSimplex | TLDTesting | TLDWeb
+  deriving (Eq, Show)
+
+data SimplexNameType = NTPublicGroup | NTContact
+  deriving (Eq, Show)
+
+instance StrEncoding SimplexNameType where
+  strEncode = \case
+    NTPublicGroup -> "#"
+    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
+      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, nameDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain, subDomain = []}} -> "#" <> domain
+  info -> pfx <> fullDomainName (nameDomain info)
+    where
+      pfx = case nameType info of
+        NTPublicGroup -> "#"
+        NTContact -> "@"
+
 data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m)
 
 instance Eq AConnShortLink where
@@ -2202,3 +2278,11 @@ instance FromJSON ACreatedConnLink where
 instance ToJSON ACreatedConnLink where
   toEncoding (ACCL _ ccLink) = toEncoding ccLink
   toJSON (ACCL _ ccLink) = toJSON ccLink
+
+$(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD)
+
+$(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType)
+
+$(J.deriveJSON defaultJSON ''SimplexNameDomain)
+
+$(J.deriveJSON defaultJSON ''SimplexNameInfo)

src/Simplex/Messaging/Transport.hs

@@ -828,10 +828,11 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer serviceKeys_
           serverKey <- getServerVerifyKey c
           (,certKey) <$> (C.x509ToPublic' =<< C.verifyX509 serverKey exact)
       let v = maxVersion vr
+          serviceVersion ServiceCredentials {serviceRole} = if serviceRole == SRMessaging then rcvServiceSMPVersion else serviceCertsSMPVersion
           serviceKeys = case serviceKeys_ of
-            Just sks | v >= serviceCertsSMPVersion && certificateSent c -> Just sks
+            Just sks | v >= serviceVersion (fst sks) && certificateSent c -> Just sks
             _ -> Nothing
-          clientService = mkClientService v =<< serviceKeys
+          clientService = mkClientService <$> serviceKeys
           hs = SMPClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer, clientService}
       sendHandshake th hs
       service <- mapM getClientService serviceKeys
@@ -839,12 +840,10 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer serviceKeys_
     Nothing -> throwE TEVersion
   where
     th@THandle {params = THandleParams {sessionId}} = smpTHandle c
-    mkClientService :: VersionSMP -> (ServiceCredentials, C.KeyPairEd25519) -> Maybe SMPClientHandshakeService
-    mkClientService v (ServiceCredentials {serviceRole, serviceCreds, serviceSignKey}, (k, _))
-      | serviceRole == SRMessaging && v < rcvServiceSMPVersion = Nothing
-      | otherwise =
-          let sk = C.signX509 serviceSignKey $ C.publicToX509 k
-           in Just SMPClientHandshakeService {serviceRole, serviceCertKey = CertChainPubKey (fst serviceCreds) sk}
+    mkClientService :: (ServiceCredentials, C.KeyPairEd25519) -> SMPClientHandshakeService
+    mkClientService (ServiceCredentials {serviceRole, serviceCreds, serviceSignKey}, (k, _)) =
+      let sk = C.signX509 serviceSignKey $ C.publicToX509 k
+       in SMPClientHandshakeService {serviceRole, serviceCertKey = CertChainPubKey (fst serviceCreds) sk}
     getClientService :: (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO THClientService
     getClientService (ServiceCredentials {serviceRole, serviceCertHash}, (_, pk)) =
       getHandshake th >>= \case