dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-07-28 07:49:50 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: render channel preview data in relays

Browse Source
This commit is contained in:
Evgeny @ SimpleX Chat
2026-05-30 22:02:41 +00:00
parent 9fa503c1c7
commit 5b733f0d71
10 changed files with 385 additions and 22 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+5 -3
View File
@@ -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,
src/Simplex/Chat/Controller.hs
+9 -1
View File
@@ -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,
src/Simplex/Chat/Library/Commands.hs
+18
View File
@@ -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
src/Simplex/Chat/Library/Internal.hs
+3 -2
View File
@@ -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
src/Simplex/Chat/Mobile.hs
+1 -1
View File
@@ -256,7 +256,7 @@ mobileChatOpts dbOptions =
tbqSize = 4096,
deviceName = Nothing,
chatRelay = False,
baseWebUrl = Nothing,
webPreviewConfig = Nothing,
highlyAvailable = False,
yesToUpMigrations = False,
migrationBackupPath = Just "",
src/Simplex/Chat/Options.hs
+28 -10
View File
@@ -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,
src/Simplex/Chat/Web.hs
+248
View File
@@ -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