core: render channel preview data

src/Simplex/Chat.hs

@@ -116,6 +116,7 @@ defaultChatConfig =
       highlyAvailable = False,
       deliveryWorkerDelay = 0,
       deliveryBucketSize = 10000,
+      baseWebUrl = Nothing,
       channelSubscriberRole = GRObserver,
       relayChecksInterval = 15 * 60, -- 15 minutes
       relayInactiveTTL = nominalDay,
@@ -140,11 +141,11 @@ newChatController
   ChatDatabase {chatStore, agentStore}
   user
   cfg@ChatConfig {agentConfig = aCfg, presetServers, inlineFiles, deviceNameForRemote, confirmMigrations}
-  ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, deviceName, highlyAvailable, yesToUpMigrations}, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize}
+  ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, deviceName, baseWebUrl, highlyAvailable, yesToUpMigrations}, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize}
   backgroundMode = do
     let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
         confirmMigrations' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations
-        config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'}
+        config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, baseWebUrl, highlyAvailable, confirmMigrations = confirmMigrations'}
     randomPresetServers <- chooseRandomServers presetServers'
     let rndSrvs = L.toList randomPresetServers
         operatorWithId (i, op) = (\o -> o {operatorId = DBEntityId i}) <$> pOperator op

src/Simplex/Chat/Controller.hs

@@ -158,6 +158,7 @@ data ChatConfig = ChatConfig
     ciExpirationInterval :: Int64, -- microseconds
     deliveryWorkerDelay :: Int64, -- microseconds
     deliveryBucketSize :: Int,
+    baseWebUrl :: Maybe Text,
     channelSubscriberRole :: GroupMemberRole, -- TODO [relays] starting role should be communicated in protocol from owner to relays
     relayChecksInterval :: NominalDiffTime,
     relayInactiveTTL :: NominalDiffTime,

src/Simplex/Chat/Library/Internal.hs

@@ -1045,8 +1045,8 @@ acceptRelayJoinRequestAsync
   cReqInvId
   cReqChatVRange
   relayLink = do
-    -- TODO [channel web] derive RelayCapabilities from relay config (RelayWebOptions)
-    let msg = XGrpRelayAcpt relayLink defaultRelayCapabilities
+    ChatConfig {baseWebUrl} <- asks config
+    let msg = XGrpRelayAcpt relayLink RelayCapabilities {baseWebUrl}
     subMode <- chatReadVar subscriptionMode
     vr <- chatVersionRange
     let chatV = vr `peerConnChatVersion` cReqChatVRange

src/Simplex/Chat/Mobile.hs

@@ -256,6 +256,7 @@ mobileChatOpts dbOptions =
             tbqSize = 4096,
             deviceName = Nothing,
             chatRelay = False,
+            baseWebUrl = Nothing,
             highlyAvailable = False,
             yesToUpMigrations = False,
             migrationBackupPath = Just "",

src/Simplex/Chat/Options.hs

@@ -66,6 +66,7 @@ data CoreChatOpts = CoreChatOpts
     tbqSize :: Natural,
     deviceName :: Maybe Text,
     chatRelay :: Bool,
+    baseWebUrl :: Maybe Text,
     highlyAvailable :: Bool,
     yesToUpMigrations :: Bool,
     migrationBackupPath :: Maybe FilePath,
@@ -240,6 +241,13 @@ coreChatOptsP appDir defaultDbName = do
       ( long "relay"
           <> help "Run as a chat relay client"
       )
+  baseWebUrl <-
+    optional $
+      strOption
+        ( long "web-url"
+            <> metavar "URL"
+            <> help "Base URL for channel web previews (relay only)"
+        )
   highlyAvailable <-
     switch
       ( long "ha"
@@ -283,6 +291,7 @@ coreChatOptsP appDir defaultDbName = do
         tbqSize,
         deviceName,
         chatRelay,
+        baseWebUrl,
         highlyAvailable,
         yesToUpMigrations,
         migrationBackupPath,

src/Simplex/Chat/View.hs

@@ -1206,8 +1206,8 @@ viewReceivedContactRequest c Profile {fullName, shortDescr} =
   ]
 
 showRelay :: GroupRelay -> StyledString
-showRelay GroupRelay {groupRelayId, relayStatus} =
-  "  - relay id " <> sShow groupRelayId <> ": " <> plain (relayStatusText relayStatus)
+showRelay GroupRelay {groupRelayId, relayStatus, relayCap = RelayCapabilities {baseWebUrl}} =
+  "  - relay id " <> sShow groupRelayId <> ": " <> plain (relayStatusText relayStatus) <> maybe "" (\url -> ", web: " <> plain url) baseWebUrl
 
 viewGroupRelays :: GroupInfo -> [GroupRelay] -> [StyledString]
 viewGroupRelays g relays =

tests/ChatClient.hs

@@ -24,6 +24,7 @@ import Control.Monad.Reader
 import Data.Functor (($>))
 import Data.List (dropWhileEnd, find)
 import Data.Maybe (isNothing)
+import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
 import Network.Socket
@@ -153,6 +154,7 @@ testCoreOpts =
       tbqSize = 16,
       deviceName = Nothing,
       chatRelay = False,
+      baseWebUrl = Nothing,
       highlyAvailable = False,
       yesToUpMigrations = False,
       migrationBackupPath = Nothing,
@@ -162,6 +164,9 @@ testCoreOpts =
 relayTestOpts :: ChatOpts
 relayTestOpts = testOpts {coreOptions = testCoreOpts {chatRelay = True}}
 
+relayWebTestOpts :: Text -> ChatOpts
+relayWebTestOpts webUrl = testOpts {coreOptions = testCoreOpts {chatRelay = True, baseWebUrl = Just webUrl}}
+
 #if !defined(dbPostgres)
 getTestOpts :: Bool -> ScrubbedBytes -> ChatOpts
 getTestOpts maintenance dbKey = testOpts {coreOptions = testCoreOpts {maintenance, dbOptions = (dbOptions testCoreOpts) {dbKey}}}

tests/ChatTests/ChatRelays.hs

@@ -28,6 +28,8 @@ chatRelayTests = do
     it "re-add soft-deleted relay by same name" testReAddRelaySameName
     it "test chat relay" testChatRelayTest
     it "relay profile updated in address" testRelayProfileUpdateInAddress
+  describe "relay capabilities" $ do
+    it "relay sends baseWebUrl in capabilities" testRelayWebCapabilities
   describe "share channel card" $ do
     it "share channel card in direct chat" testShareChannelDirect
     it "share channel card in group" testShareChannelGroup
@@ -325,6 +327,28 @@ testShareChannelChannel ps =
 getTermLine2 :: TestCC -> IO (String, String)
 getTermLine2 c = (,) <$> getTermLine c <*> getTermLine c
 
+testRelayWebCapabilities :: HasCallStack => TestParams -> IO ()
+testRelayWebCapabilities ps =
+  withNewTestChat ps "alice" aliceProfile $ \alice ->
+    withNewTestChatOpts ps (relayWebTestOpts "https://relay.example.com/preview") "bob" bobProfile $ \relay -> do
+      rName <- userName relay
+      relay ##> "/ad"
+      (relaySLink, _cLink) <- getContactLinks relay True
+      alice ##> ("/relays name=" <> rName <> " " <> relaySLink)
+      alice <## "ok"
+      alice ##> "/public group relays=1 #news"
+      alice <## "group #news is created"
+      alice <## "wait for selected relay(s) to join, then you can invite members via group link"
+      concurrentlyN_
+        [ do
+            alice <## "#news: group link relays updated, current relays:"
+            alice <## "  - relay id 1: active, web: https://relay.example.com/preview"
+            alice <## "group link:"
+            _ <- getTermLine alice
+            pure (),
+          relay <## "#news: you joined the group as relay"
+        ]
+
 -- Create a public group with relay=1, wait for relay to join
 createChannelWithRelay :: HasCallStack => String -> TestCC -> TestCC -> IO ()
 createChannelWithRelay gName owner relay = do