diff --git a/apps/smp-server/static/link.html b/apps/smp-server/static/link.html
index b5be2d7ab..396f3dc12 100644
--- a/apps/smp-server/static/link.html
+++ b/apps/smp-server/static/link.html
@@ -512,6 +512,8 @@
element.innerHTML = 'This is a one-time link of the SimpleX network user'
} else if (url.includes('/c')) {
element.innerHTML = 'This is a public channel address on SimpleX network'
+ } else if (url.includes('/r')) {
+ element.innerHTML = 'This is a chat relay address on SimpleX network'
}
}
diff --git a/apps/smp-server/web/Static.hs b/apps/smp-server/web/Static.hs
index 50e4415eb..dc8f24ec9 100644
--- a/apps/smp-server/web/Static.hs
+++ b/apps/smp-server/web/Static.hs
@@ -103,6 +103,7 @@ generateSite si onionHost sitePath = do
createLinkPage "a"
createLinkPage "c"
createLinkPage "g"
+ createLinkPage "r"
createLinkPage "i"
logInfo $ "Generated static site contents at " <> tshow sitePath
where
diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs
index 44662754e..f1d5f2ec8 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -1129,7 +1129,7 @@ instance StrEncoding AConnectionRequestUri where
connReqUriP :: Maybe ServiceScheme -> Parser AConnectionRequestUri
connReqUriP overrideScheme = do
- crScheme <- (`fromMaybe` overrideScheme) <$> strP
+ crScheme <- (`fromMaybe` overrideScheme) <$> strP -- always parse, but use the passed one if any
crMode <- A.char '/' *> crModeP <* optional (A.char '/') <* "#/?"
query <- strP
aVRange <- queryParam "v" query
@@ -1445,7 +1445,7 @@ instance ConnectionModeI c => ToField (ConnShortLink c) where toField = toField
instance (Typeable c, ConnectionModeI c) => FromField (ConnShortLink c) where fromField = blobFieldDecoder strDecode
-data ContactConnType = CCTContact | CCTChannel | CCTGroup deriving (Eq, Show)
+data ContactConnType = CCTContact | CCTChannel | CCTGroup | CCTRelay deriving (Eq, Show)
data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m)
@@ -1593,6 +1593,7 @@ ctTypeP = \case
'A' -> pure CCTContact
'C' -> pure CCTChannel
'G' -> pure CCTGroup
+ 'R' -> pure CCTRelay
_ -> fail "unknown contact address type"
{-# INLINE ctTypeP #-}
@@ -1601,6 +1602,7 @@ ctTypeChar = \case
CCTContact -> 'A'
CCTChannel -> 'C'
CCTGroup -> 'G'
+ CCTRelay -> 'R'
{-# INLINE ctTypeChar #-}
-- the servers passed to this function should be all preset servers, not servers configured by the user.
diff --git a/src/Simplex/Messaging/Server/Information.hs b/src/Simplex/Messaging/Server/Information.hs
index 422dab224..a94148dbe 100644
--- a/src/Simplex/Messaging/Server/Information.hs
+++ b/src/Simplex/Messaging/Server/Information.hs
@@ -14,7 +14,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Int (Int64)
import Data.Maybe (isJust)
import Data.Text (Text)
-import Simplex.Messaging.Agent.Protocol (ConnectionMode (..), ConnectionRequestUri)
+import Simplex.Messaging.Agent.Protocol (ConnectionLink, ConnectionMode (..), ConnectionRequestUri)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
@@ -100,7 +100,7 @@ data Entity = Entity {name :: Text, country :: Maybe Text}
deriving (Show)
data ServerContactAddress = ServerContactAddress
- { simplex :: Maybe (ConnectionRequestUri 'CMContact),
+ { simplex :: Maybe (ConnectionLink 'CMContact),
email :: Maybe Text, -- it is recommended that it matches DNS email address, if either is present
pgp :: Maybe PGPKey
}
diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs
index 17c5de7e3..c5292b4e5 100644
--- a/src/Simplex/Messaging/Server/Main.hs
+++ b/src/Simplex/Messaging/Server/Main.hs
@@ -37,7 +37,7 @@ import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import qualified Data.Text.IO as T
import Options.Applicative
-import Simplex.Messaging.Agent.Protocol (connReqUriP')
+import Simplex.Messaging.Agent.Protocol (ConnectionLink (..), connReqUriP')
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SMPWebPortServers (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
@@ -638,7 +638,8 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
<$!> infoValue nameField
countryValue field = (either error id . validCountryValue (T.unpack field) . T.unpack) <$!> infoValue field
iniContacts simplexField emailField pgpKeyUriField pgpKeyFingerprintField =
- let simplex = either error id . parseAll (connReqUriP' Nothing) . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
+ let simplex = either error id . parseAll linkP . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
+ linkP = CLFull <$> connReqUriP' Nothing <|> CLShort <$> strP
email = infoValue emailField
pkURI_ = infoValue pgpKeyUriField
pkFingerprint_ = infoValue pgpKeyFingerprintField
diff --git a/src/Simplex/Messaging/Transport/Credentials.hs b/src/Simplex/Messaging/Transport/Credentials.hs
index 3d6155da0..f610ab943 100644
--- a/src/Simplex/Messaging/Transport/Credentials.hs
+++ b/src/Simplex/Messaging/Transport/Credentials.hs
@@ -25,14 +25,6 @@ import qualified Simplex.Messaging.Crypto as C
import qualified Time.System as Hourglass
import qualified Time.Types as HT
--- | Generate a certificate chain to be used with TLS fingerprint-pinning
---
--- @
--- genTlsCredentials = do
--- ca <- genCredentials Nothing (-25, 365 * 24) "Root" -- long-lived root cert
--- leaf <- genCredentials (Just ca) (0, 1) "Entity" -- session-signing cert
--- pure $ tlsCredentials (leaf :| [ca])
--- @
tlsCredentials :: NonEmpty Credentials -> (C.KeyHash, TLS.Credential)
tlsCredentials credentials = (C.KeyHash rootFP, (X509.CertificateChain certs, privateToTls $ snd leafKey))
where
diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs
index a4b4c9038..bde72fb23 100644
--- a/src/Simplex/RemoteControl/Client.hs
+++ b/src/Simplex/RemoteControl/Client.hs
@@ -85,7 +85,7 @@ encInvitationSize = 900
newRCHostPairing :: TVar ChaChaDRG -> IO RCHostPairing
newRCHostPairing drg = do
- ((_, caKey), caCert) <- genCredentials drg Nothing (-25, 24 * 999999) "ca"
+ ((_, caKey), caCert) <- genCredentials drg Nothing (25, 24 * 999999) "ca"
(_, idPrivKey) <- atomically $ C.generateKeyPair drg
pure RCHostPairing {caKey, caCert, idPrivKey, knownHost = Nothing}
@@ -193,7 +193,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
genTLSCredentials :: TVar ChaChaDRG -> C.APrivateSignKey -> X.SignedCertificate -> IO TLS.Credential
genTLSCredentials drg caKey caCert = do
let caCreds = (C.signatureKeyPair caKey, caCert)
- leaf <- genCredentials drg (Just caCreds) (0, 24 * 999999) "localhost" -- session-signing cert
+ leaf <- genCredentials drg (Just caCreds) (1, 24 * 999999) "localhost" -- session-signing cert
pure . snd $ tlsCredentials (leaf :| [caCreds])
certFingerprint :: X.SignedCertificate -> C.KeyHash
@@ -259,7 +259,7 @@ connectRCCtrl drg (RCVerifiedInvitation inv@RCInvitation {ca, idkey}) pairing_ h
where
newCtrlPairing :: IO RCCtrlPairing
newCtrlPairing = do
- ((_, caKey), caCert) <- genCredentials drg Nothing (0, 24 * 999999) "ca"
+ ((_, caKey), caCert) <- genCredentials drg Nothing (1, 24 * 999999) "ca"
(_, dhPrivKey) <- atomically $ C.generateKeyPair drg
pure RCCtrlPairing {caKey, caCert, ctrlFingerprint = ca, idPubKey = idkey, dhPrivKey, prevDhPrivKey = Nothing}
updateCtrlPairing :: RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing