diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 688381eeb..6249aaa8a 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/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) diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index fde483177..18e200bd7 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/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