diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 166c31aa25..44985806aa 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -90,6 +90,7 @@ library Simplex.Chat.Types.Shared Simplex.Chat.Types.UITheme Simplex.Chat.Util + Simplex.Chat.Web if !flag(client_library) exposed-modules: Simplex.Chat.Bot diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 5e4694dbe8..bc22ab2c3b 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -116,7 +116,7 @@ defaultChatConfig = highlyAvailable = False, deliveryWorkerDelay = 0, deliveryBucketSize = 10000, - baseWebUrl = Nothing, + webPreviewConfig = Nothing, channelSubscriberRole = GRObserver, relayChecksInterval = 15 * 60, -- 15 minutes relayInactiveTTL = nominalDay, @@ -141,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, baseWebUrl, highlyAvailable, yesToUpMigrations}, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize} + ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, deviceName, webPreviewConfig, 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, baseWebUrl, highlyAvailable, confirmMigrations = confirmMigrations'} + config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, webPreviewConfig, highlyAvailable, confirmMigrations = confirmMigrations'} randomPresetServers <- chooseRandomServers presetServers' let rndSrvs = L.toList randomPresetServers operatorWithId (i, op) = (\o -> o {operatorId = DBEntityId i}) <$> pOperator op @@ -183,6 +183,7 @@ newChatController deliveryJobWorkers <- TM.emptyIO relayRequestWorkers <- TM.emptyIO relayGroupLinkChecksAsync <- newTVarIO Nothing + webPreviewAsync <- newTVarIO Nothing chatRelayTests <- TM.emptyIO expireCIThreads <- TM.emptyIO expireCIFlags <- TM.emptyIO @@ -227,6 +228,7 @@ newChatController deliveryJobWorkers, relayRequestWorkers, relayGroupLinkChecksAsync, + webPreviewAsync, chatRelayTests, expireCIThreads, expireCIFlags, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 91472eca2a..5bb9a8c85e 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -158,7 +158,7 @@ data ChatConfig = ChatConfig ciExpirationInterval :: Int64, -- microseconds deliveryWorkerDelay :: Int64, -- microseconds deliveryBucketSize :: Int, - baseWebUrl :: Maybe Text, + webPreviewConfig :: Maybe WebPreviewConfig, channelSubscriberRole :: GroupMemberRole, -- TODO [relays] starting role should be communicated in protocol from owner to relays relayChecksInterval :: NominalDiffTime, relayInactiveTTL :: NominalDiffTime, @@ -170,6 +170,13 @@ data ChatConfig = ChatConfig chatHooks :: ChatHooks } +data WebPreviewConfig = WebPreviewConfig + { baseWebUrl :: Text, + webJsonDir :: FilePath, + webCorsFile :: Maybe FilePath, + webUpdateInterval :: Int -- seconds + } + data RandomAgentServers = RandomAgentServers { smpServers :: NonEmpty (ServerCfg 'PSMP), xftpServers :: NonEmpty (ServerCfg 'PXFTP) @@ -257,6 +264,7 @@ data ChatController = ChatController deliveryJobWorkers :: TMap DeliveryWorkerKey Worker, relayRequestWorkers :: TMap Int Worker, -- single global worker with key 1 is used to fit into existing worker management framework relayGroupLinkChecksAsync :: TVar (Maybe (Async ())), + webPreviewAsync :: TVar (Maybe (Async ())), chatRelayTests :: TMap ConnId RelayTest, expireCIThreads :: TMap UserId (Maybe (Async ())), expireCIFlags :: TMap UserId Bool, diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index de2efd45cc..378f714103 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -55,6 +55,7 @@ import Data.Type.Equality import qualified Data.UUID as UUID import qualified Data.UUID.V4 as V4 import Simplex.Chat.Library.Subscriber +import Simplex.Chat.Web (renderWebPreviews) import Simplex.Chat.Call import Simplex.Chat.Controller import Simplex.Chat.Delivery (DeliveryJobScope (..), DeliveryJobSpec (..), DeliveryWorkerScope (..)) @@ -200,6 +201,7 @@ startChatController mainApp enableSndFiles = do startCleanupManager void $ forkIO $ mapM_ startExpireCIs users startRelayChecks users + startWebPreview users else when enableSndFiles $ startXFTP xftpStartSndWorkers pure a1 startXFTP startWorkers = do @@ -231,6 +233,22 @@ startChatController mainApp enableSndFiles = do a <- Just <$> async (void $ runExceptT $ runRelayGroupLinkChecks relayUser) atomically $ writeTVar relayAsync a _ -> pure () + startWebPreview users = do + let relayUsers = filter (\User {userChatRelay} -> isTrue userChatRelay) users + ChatConfig {webPreviewConfig = cfg_} <- asks config + case (relayUsers, cfg_) of + (_ : _, Just cfg) -> do + wpAsync <- asks webPreviewAsync + readTVarIO wpAsync >>= \case + Nothing -> do + cc <- ask + a <- Just <$> async (liftIO $ forever $ do + forM_ relayUsers $ \relayUser -> + renderWebPreviews cfg cc relayUser + threadDelay (webUpdateInterval cfg * 1000000)) + atomically $ writeTVar wpAsync a + _ -> pure () + _ -> pure () startExpireCIs user = whenM shouldExpireChats $ do startExpireCIThread user setExpireCIFlag user True diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 0a7b6edd6b..71029cf1df 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -1045,8 +1045,9 @@ acceptRelayJoinRequestAsync cReqInvId cReqChatVRange relayLink = do - ChatConfig {baseWebUrl} <- asks config - let msg = XGrpRelayAcpt relayLink RelayCapabilities {baseWebUrl} + ChatConfig {webPreviewConfig} <- asks config + let webUrl = (\WebPreviewConfig {baseWebUrl} -> baseWebUrl) <$> webPreviewConfig + msg = XGrpRelayAcpt relayLink RelayCapabilities {baseWebUrl = webUrl} subMode <- chatReadVar subscriptionMode vr <- chatVersionRange let chatV = vr `peerConnChatVersion` cReqChatVRange diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index b5732d9d5f..201216d640 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -256,7 +256,7 @@ mobileChatOpts dbOptions = tbqSize = 4096, deviceName = Nothing, chatRelay = False, - baseWebUrl = Nothing, + webPreviewConfig = Nothing, highlyAvailable = False, yesToUpMigrations = False, migrationBackupPath = Just "", diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index bd64c5a036..e2b8189240 100644 --- a/src/Simplex/Chat/Options.hs +++ b/src/Simplex/Chat/Options.hs @@ -22,13 +22,14 @@ where import Control.Logger.Simple (LogLevel (..)) import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B +import Data.Functor ((<&>)) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Numeric.Natural (Natural) import Options.Applicative -import Simplex.Chat.Controller (ChatLogLevel (..), SimpleNetCfg (..), updateStr, versionNumber, versionString) +import Simplex.Chat.Controller (ChatLogLevel (..), SimpleNetCfg (..), WebPreviewConfig (..), updateStr, versionNumber, versionString) import Simplex.FileTransfer.Description (mb) import Simplex.Messaging.Client (HostMode (..), SMPWebPortServers (..), SocksMode (..), textToHostMode) import Simplex.Messaging.Encoding.String @@ -66,7 +67,7 @@ data CoreChatOpts = CoreChatOpts tbqSize :: Natural, deviceName :: Maybe Text, chatRelay :: Bool, - baseWebUrl :: Maybe Text, + webPreviewConfig :: Maybe WebPreviewConfig, highlyAvailable :: Bool, yesToUpMigrations :: Bool, migrationBackupPath :: Maybe FilePath, @@ -241,13 +242,30 @@ 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)" - ) + webPreviewConfig <- do + baseWebUrl_ <- + optional $ + strOption + ( long "web-url" + <> metavar "URL" + <> help "Base URL for channel web previews (relay only)" + ) + webJsonDir_ <- + optional $ + strOption + ( long "web-dir" + <> metavar "DIR" + <> help "Directory for channel web preview JSON files (relay only)" + ) + webCorsFile <- + optional $ + strOption + ( long "web-cors" + <> metavar "FILE" + <> help "Path to generated Caddy CORS config file (relay only)" + ) + pure $ baseWebUrl_ <&> \baseWebUrl -> + WebPreviewConfig {baseWebUrl, webJsonDir = fromMaybe "web_preview" webJsonDir_, webCorsFile, webUpdateInterval = 300} highlyAvailable <- switch ( long "ha" @@ -291,7 +309,7 @@ coreChatOptsP appDir defaultDbName = do tbqSize, deviceName, chatRelay, - baseWebUrl, + webPreviewConfig, highlyAvailable, yesToUpMigrations, migrationBackupPath, diff --git a/src/Simplex/Chat/Web.hs b/src/Simplex/Chat/Web.hs new file mode 100644 index 0000000000..896374b1f8 --- /dev/null +++ b/src/Simplex/Chat/Web.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} + +module Simplex.Chat.Web + ( WebChannelPreview (..), + WebMessage (..), + WebMemberProfile (..), + WebFileInfo (..), + CorsOrigin (..), + renderWebPreviews, + writeCorsConfig, + ) +where + +import Control.Logger.Simple +import Control.Monad (forM_) +import Control.Monad.Except (runExceptT) +import qualified Data.Aeson as J +import qualified Data.Aeson.TH as JQ +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as LB +import Data.List (nubBy) +import Data.Map.Strict (Map) +import Data.Maybe (isJust, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Time.Clock (UTCTime, getCurrentTime) +import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatPagination (..), WebPreviewConfig (..)) +import Simplex.Chat.Markdown (MarkdownList) +import Simplex.Chat.Messages + ( CChatItem (..), + CIDirection (..), + CIFile (..), + CIMention, + CIMeta (..), + CIQDirection (..), + CIQuote (..), + CIReactionCount, + Chat (..), + ChatItem (..), + ChatType (..), + ) +import Simplex.Chat.Messages.CIContent (ciMsgContent) +import Simplex.Chat.Protocol (MsgContent, MsgRef (..), QuotedMsg (..), isReport) +import Simplex.Chat.Store (StoreError) +import Simplex.Chat.Store.Groups (getRelayServedGroups) +import Simplex.Chat.Store.Messages (getGroupChat) +import Simplex.Chat.Types + ( B64UrlByteString, + GroupId, + GroupInfo (..), + GroupMember (..), + GroupProfile (..), + ImageData, + LocalProfile (..), + MemberId, + MemberName, + PublicGroupAccess (..), + PublicGroupProfile (..), + User, + ) +import Simplex.Messaging.Agent.Store.Common (withTransaction) +import Simplex.Messaging.Encoding.String (strEncode) +import Simplex.Messaging.Parsers (defaultJSON) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) + +data WebFileInfo = WebFileInfo + { fileName :: String, + fileSize :: Integer + } + deriving (Show) + +data WebMemberProfile = WebMemberProfile + { memberId :: MemberId, + displayName :: Text, + image :: Maybe ImageData + } + deriving (Show) + +data WebMessage = WebMessage + { sender :: Maybe MemberId, + ts :: UTCTime, + content :: MsgContent, + formattedText :: Maybe MarkdownList, + file :: Maybe WebFileInfo, + quote :: Maybe QuotedMsg, + mentions :: Map MemberName CIMention, + reactions :: [CIReactionCount], + forward :: Maybe Bool, + edited :: Bool + } + deriving (Show) + +data WebChannelPreview = WebChannelPreview + { channel :: GroupProfile, + members :: [WebMemberProfile], + messages :: [WebMessage], + updatedAt :: UTCTime + } + deriving (Show) + +$(JQ.deriveJSON defaultJSON ''WebFileInfo) + +$(JQ.deriveJSON defaultJSON ''WebMemberProfile) + +$(JQ.deriveJSON defaultJSON ''WebMessage) + +$(JQ.deriveJSON defaultJSON ''WebChannelPreview) + +renderWebPreviews :: WebPreviewConfig -> ChatController -> User -> IO () +renderWebPreviews WebPreviewConfig {webJsonDir, webCorsFile} cc user = do + groups <- withTransaction (chatStore cc) $ \db -> getRelayServedGroups db vr' user + let publishable = filter hasPublicGroup groups + corsEntries <- mapMaybe id <$> mapM (renderGroupPreview webJsonDir cc user) publishable + forM_ webCorsFile $ writeCorsConfig corsEntries + where + vr' = chatVRange (config cc) + hasPublicGroup GroupInfo {groupProfile = GroupProfile {publicGroup}} = case publicGroup of + Just _ -> True + _ -> False + +renderGroupPreview :: FilePath -> ChatController -> User -> GroupInfo -> IO (Maybe (Text, CorsOrigin)) +renderGroupPreview webJsonDir cc user GroupInfo {groupId = gId, groupProfile = gp@GroupProfile {publicGroup}} = + case publicGroup of + Just PublicGroupProfile {publicGroupId, publicGroupAccess} -> do + let fName = publicGroupIdFileName publicGroupId <> ".json" + result <- loadMessages cc user gId + case result of + Left e -> do + logError $ "renderGroupPreview error for group " <> T.pack (show gId) <> ": " <> T.pack (show e) + pure Nothing + Right items -> do + ts <- getCurrentTime + let msgs = mapMaybe toWebMessage items + senders = uniqueSenders items + preview = WebChannelPreview + { channel = gp, + members = senders, + messages = msgs, + updatedAt = ts + } + createDirectoryIfMissing True webJsonDir + LB.writeFile (webJsonDir fName) (J.encode preview) + pure $ corsEntry publicGroupId <$> publicGroupAccess + Nothing -> pure Nothing + +loadMessages :: ChatController -> User -> GroupId -> IO (Either StoreError [CChatItem 'CTGroup]) +loadMessages cc user gId = + withTransaction (chatStore cc) $ \db -> do + let vr' = chatVRange (config cc) + fmap (chatItems . fst) <$> runExceptT (getGroupChat db vr' user gId Nothing Nothing (CPLast 50) Nothing) + +toWebMessage :: CChatItem 'CTGroup -> Maybe WebMessage +toWebMessage (CChatItem _ ChatItem {chatDir, meta = CIMeta {itemTs, itemDeleted, itemTimed, itemForwarded, itemEdited}, content, mentions, formattedText, quotedItem, reactions, file}) + | isJust itemDeleted = Nothing + | isJust itemTimed = Nothing + | otherwise = case ciMsgContent content of + Just mc | not (isReport mc) -> + let sender = case chatDir of + CIGroupRcv GroupMember {memberId} -> Just memberId + _ -> Nothing + in Just WebMessage + { sender, + ts = itemTs, + content = mc, + formattedText, + file = webFileInfo <$> file, + quote = quotedItem >>= ciQuoteToQuotedMsg, + mentions, + reactions, + forward = if isJust itemForwarded then Just True else Nothing, + edited = itemEdited + } + _ -> Nothing + +ciQuoteToQuotedMsg :: CIQuote c -> Maybe QuotedMsg +ciQuoteToQuotedMsg CIQuote {chatDir = qDir, sharedMsgId, sentAt, content = qContent} = + Just QuotedMsg + { msgRef = MsgRef + { msgId = sharedMsgId, + sentAt, + sent = case qDir of + CIQDirectSnd -> True + CIQGroupSnd -> True + _ -> False, + memberId = case qDir of + CIQGroupRcv (Just GroupMember {memberId}) -> Just memberId + _ -> Nothing + }, + content = qContent + } + +webFileInfo :: CIFile d -> WebFileInfo +webFileInfo CIFile {fileName, fileSize} = WebFileInfo {fileName, fileSize} + +uniqueSenders :: [CChatItem 'CTGroup] -> [WebMemberProfile] +uniqueSenders = nubBy sameId . mapMaybe senderProfile + where + sameId (WebMemberProfile {memberId = a}) (WebMemberProfile {memberId = b}) = a == b + senderProfile :: CChatItem 'CTGroup -> Maybe WebMemberProfile + senderProfile (CChatItem _ ChatItem {chatDir}) = case chatDir of + CIGroupRcv m -> Just $ memberToProfile m + _ -> Nothing + +memberToProfile :: GroupMember -> WebMemberProfile +memberToProfile GroupMember {memberId, memberProfile = LocalProfile {displayName, image}} = + WebMemberProfile {memberId, displayName, image} + +data CorsOrigin = CorsAny | CorsOrigins [Text] + deriving (Show) + +corsEntry :: B64UrlByteString -> PublicGroupAccess -> (Text, CorsOrigin) +corsEntry publicGroupId PublicGroupAccess {groupWebPage, allowEmbedding} = + let fName = T.pack $ publicGroupIdFileName publicGroupId <> ".json" + origin + | allowEmbedding = CorsAny + | isJust groupWebPage = CorsOrigins $ mapMaybe id [groupWebPage] + | otherwise = CorsOrigins [] + in (fName, origin) + +writeCorsConfig :: [(Text, CorsOrigin)] -> FilePath -> IO () +writeCorsConfig entries path = + TIO.writeFile path $ T.unlines $ + ["map {path} {cors_origin} {"] + <> map corsLine entries + <> [ " default \"\"", + "}", + "header /preview/*.json Access-Control-Allow-Origin {cors_origin}", + "header /preview/*.json Access-Control-Allow-Methods \"GET, OPTIONS\"" + ] + where + corsLine (fName, origin) = case origin of + CorsAny -> " /preview/" <> fName <> " \"*\"" + CorsOrigins origins -> case origins of + [] -> " # " <> fName <> " (no origin configured)" + (o : _) -> " /preview/" <> fName <> " \"" <> o <> "\"" + +publicGroupIdFileName :: B64UrlByteString -> String +publicGroupIdFileName = B.unpack . strEncode diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 009459366c..673ddc8835 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -29,7 +29,7 @@ import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) import Network.Socket import Simplex.Chat -import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), defaultSimpleNetCfg) +import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), WebPreviewConfig (..), defaultSimpleNetCfg) import Simplex.Chat.Core import Simplex.Chat.Library.Commands import Simplex.Chat.Options @@ -154,7 +154,7 @@ testCoreOpts = tbqSize = 16, deviceName = Nothing, chatRelay = False, - baseWebUrl = Nothing, + webPreviewConfig = Nothing, highlyAvailable = False, yesToUpMigrations = False, migrationBackupPath = Nothing, @@ -164,8 +164,8 @@ testCoreOpts = relayTestOpts :: ChatOpts relayTestOpts = testOpts {coreOptions = testCoreOpts {chatRelay = True}} -relayWebTestOpts :: Text -> ChatOpts -relayWebTestOpts webUrl = testOpts {coreOptions = testCoreOpts {chatRelay = True, baseWebUrl = Just webUrl}} +relayWebTestOpts :: Text -> FilePath -> ChatOpts +relayWebTestOpts webUrl webDir = testOpts {coreOptions = testCoreOpts {chatRelay = True, webPreviewConfig = Just WebPreviewConfig {baseWebUrl = webUrl, webJsonDir = webDir, webCorsFile = Nothing, webUpdateInterval = 300}}} #if !defined(dbPostgres) getTestOpts :: Bool -> ScrubbedBytes -> ChatOpts diff --git a/tests/ChatTests/ChatRelays.hs b/tests/ChatTests/ChatRelays.hs index 06d13694bf..bac7a84bae 100644 --- a/tests/ChatTests/ChatRelays.hs +++ b/tests/ChatTests/ChatRelays.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module ChatTests.ChatRelays where @@ -14,11 +15,16 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Maybe (fromMaybe) import qualified Data.Text as T import ProtocolTests (testGroupProfile) +import Simplex.Chat.Controller (ChatConfig (..), ChatController (..)) import Simplex.Chat.Protocol (LinkOwnerSig, MsgChatLink (..), MsgContent (..)) import Simplex.Chat.Types (GroupProfile (..)) +import Simplex.Chat.Web (CorsOrigin (..), WebChannelPreview (..), WebMessage (..), renderWebPreviews, writeCorsConfig) import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Util (decodeJSON) +import System.Directory (listDirectory) +import System.FilePath (()) import Test.Hspec hiding (it) +import UnliftIO.STM (readTVarIO) chatRelayTests :: SpecWith TestParams chatRelayTests = do @@ -30,6 +36,9 @@ chatRelayTests = do it "relay profile updated in address" testRelayProfileUpdateInAddress describe "relay capabilities" $ do it "relay sends baseWebUrl in capabilities" testRelayWebCapabilities + describe "web preview" $ do + it "render web preview JSON for channel" testWebPreviewRender + it "generate CORS config" testWebPreviewCors describe "share channel card" $ do it "share channel card in direct chat" testShareChannelDirect it "share channel card in group" testShareChannelGroup @@ -330,7 +339,7 @@ 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 + withNewTestChatOpts ps (relayWebTestOpts "https://relay.example.com/preview" (tmpPath ps "web_cap")) "bob" bobProfile $ \relay -> do rName <- userName relay relay ##> "/ad" (relaySLink, _cLink) <- getContactLinks relay True @@ -349,6 +358,64 @@ testRelayWebCapabilities ps = relay <## "#news: you joined the group as relay" ] +testWebPreviewRender :: HasCallStack => TestParams -> IO () +testWebPreviewRender ps = do + let webDir = tmpPath ps "web_preview" + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps (relayWebTestOpts "https://relay.example.com/preview" webDir) "bob" bobProfile $ \relay -> do + _ <- setupRelay alice relay + 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" + ] + alice #> "#news hello from the channel" + relay <# "#news> hello from the channel" + alice #> "#news second message" + relay <# "#news> second message" + threadDelay 500000 + let cc = chatController relay + ChatConfig {webPreviewConfig = cfg_} = config cc + Just user <- readTVarIO (currentUser cc) + case cfg_ of + Nothing -> error "no web preview config" + Just cfg -> do + renderWebPreviews cfg cc user + files <- listDirectory webDir + length files `shouldBe` 1 + let jsonFile = webDir head files + jsonBytes <- LB.readFile jsonFile + case J.eitherDecode jsonBytes of + Left err -> error $ "JSON decode error: " <> err + Right (wPreview :: WebChannelPreview) -> do + length (messages wPreview) `shouldBe` 2 + let WebMessage {content = mc1} = messages wPreview !! 0 + WebMessage {content = mc2} = messages wPreview !! 1 + mc1 `shouldBe` MCText "hello from the channel" + mc2 `shouldBe` MCText "second message" + +testWebPreviewCors :: HasCallStack => TestParams -> IO () +testWebPreviewCors ps = do + let corsFile = tmpPath ps "simplex-cors.conf" + entries = + [ ("abc123.json", CorsAny), + ("def456.json", CorsOrigins ["https://owner-site.com"]), + ("ghi789.json", CorsOrigins []) + ] + writeCorsConfig entries corsFile + corsContent <- readFile corsFile + corsContent `shouldContain` "/preview/abc123.json \"*\"" + corsContent `shouldContain` "/preview/def456.json \"https://owner-site.com\"" + corsContent `shouldContain` "# ghi789.json (no origin configured)" + corsContent `shouldContain` "Access-Control-Allow-Origin" + -- Create a public group with relay=1, wait for relay to join createChannelWithRelay :: HasCallStack => String -> TestCC -> TestCC -> IO () createChannelWithRelay gName owner relay = do