From c9209bc3cc7770579a4760cdcede0a846154ac78 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Wed, 3 Jun 2026 20:00:19 +0000 Subject: [PATCH] fixes --- simplex-chat.cabal | 4 +- src/Simplex/Chat/Controller.hs | 3 +- src/Simplex/Chat/Library/Subscriber.hs | 6 +- src/Simplex/Chat/Options.hs | 11 +- src/Simplex/Chat/Store/Postgres/Migrations.hs | 4 +- ....hs => M20260601_relay_sent_web_domain.hs} | 10 +- src/Simplex/Chat/Store/SQLite/Migrations.hs | 4 +- ....hs => M20260601_relay_sent_web_domain.hs} | 10 +- src/Simplex/Chat/Web.hs | 142 +++++++++++------- tests/ChatClient.hs | 2 +- website/channel_sample.html | 10 +- website/src/js/channel-preview.jsc | 2 +- website/src/js/simplex-lib.jsc | 2 +- 13 files changed, 124 insertions(+), 86 deletions(-) rename src/Simplex/Chat/Store/Postgres/Migrations/{M20260531_relay_sent_web_domain.hs => M20260601_relay_sent_web_domain.hs} (54%) rename src/Simplex/Chat/Store/SQLite/Migrations/{M20260531_relay_sent_web_domain.hs => M20260601_relay_sent_web_domain.hs} (53%) diff --git a/simplex-chat.cabal b/simplex-chat.cabal index ff0c4e3fbf..7f1d50413f 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -138,7 +138,7 @@ library Simplex.Chat.Store.Postgres.Migrations.M20260529_delivery_job_senders Simplex.Chat.Store.Postgres.Migrations.M20260530_client_services Simplex.Chat.Store.Postgres.Migrations.M20260531_member_removed_at - Simplex.Chat.Store.Postgres.Migrations.M20260531_relay_sent_web_domain + Simplex.Chat.Store.Postgres.Migrations.M20260601_relay_sent_web_domain else exposed-modules: Simplex.Chat.Archive @@ -298,7 +298,7 @@ library Simplex.Chat.Store.SQLite.Migrations.M20260529_delivery_job_senders Simplex.Chat.Store.SQLite.Migrations.M20260530_client_services Simplex.Chat.Store.SQLite.Migrations.M20260531_member_removed_at - Simplex.Chat.Store.SQLite.Migrations.M20260531_relay_sent_web_domain + Simplex.Chat.Store.SQLite.Migrations.M20260601_relay_sent_web_domain other-modules: Paths_simplex_chat hs-source-dirs: diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 8e845fab26..dc4ae9b28b 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -175,7 +175,8 @@ data WebPreviewConfig = WebPreviewConfig { webDomain :: Text, webJsonDir :: FilePath, webCorsFile :: Maybe FilePath, - webUpdateInterval :: Int -- seconds + webUpdateInterval :: Int, -- seconds + webPreviewItemCount :: Int } data WebPreviewState = WebPreviewState diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 14a36c6e90..29d3d04c9c 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -47,7 +47,7 @@ import Simplex.Chat.Call import Simplex.Chat.Controller import Simplex.Chat.Delivery import Simplex.Chat.Library.Internal -import Simplex.Chat.Web (channelChanged, channelRemoved) +import Simplex.Chat.Web (channelContentChanged, channelProfileUpdated, channelRemoved) import Simplex.Chat.Messages import Simplex.Chat.Messages.Batch (batchDeliveryTasks1, batchProfiles, batchProfilesWithBody, encodeBinaryBatch, encodeFwdElement, maxBatchElementSize) import Simplex.Chat.Messages.CIContent @@ -1077,13 +1077,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> Nothing <$ messageError ("unsupported message: " <> tshow event) forM deliveryTaskContext_ $ \taskContext -> do let contentChanged :: CM () - contentChanged = atomically $ channelChanged cc groupId False + contentChanged = atomically $ channelContentChanged cc groupId case event of XMsgNew {} -> contentChanged XMsgUpdate {} -> contentChanged XMsgDel {} -> contentChanged XMsgReact {} -> contentChanged - XGrpInfo {} -> atomically $ channelChanged cc groupId True + XGrpInfo p' -> atomically $ channelProfileUpdated cc groupId p' XGrpDel {} -> atomically $ channelRemoved cc groupId _ -> pure () pure $ NewMessageDeliveryTask {messageId = msgId, taskContext} diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index fb2ef5747b..a936f58848 100644 --- a/src/Simplex/Chat/Options.hs +++ b/src/Simplex/Chat/Options.hs @@ -270,10 +270,17 @@ coreChatOptsP appDir defaultDbName = do <> help "Interval between web preview regeneration in seconds (relay only)" <> value 300 ) + webPreviewItemCount <- + option auto + ( long "relay-web-item-count" + <> metavar "COUNT" + <> help "Number of recent messages in channel web preview (relay only)" + <> value 50 + ) pure $ case (webDomain_, webJsonDir_) of - (Just webDomain, Just webJsonDir) -> Just WebPreviewConfig {webDomain, webJsonDir, webCorsFile, webUpdateInterval} + (Just webDomain, Just webJsonDir) -> Just WebPreviewConfig {webDomain, webJsonDir, webCorsFile, webUpdateInterval, webPreviewItemCount} (Nothing, Nothing) -> Nothing - _ -> error "--relay-web-domain and --relay-web-dir must both be provided" + _ -> errorWithoutStackTrace "--relay-web-domain and --relay-web-dir must both be provided" highlyAvailable <- switch ( long "ha" diff --git a/src/Simplex/Chat/Store/Postgres/Migrations.hs b/src/Simplex/Chat/Store/Postgres/Migrations.hs index 6495801026..4ba1ba85fa 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations.hs @@ -35,7 +35,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260515_public_group_access import Simplex.Chat.Store.Postgres.Migrations.M20260529_delivery_job_senders import Simplex.Chat.Store.Postgres.Migrations.M20260530_client_services import Simplex.Chat.Store.Postgres.Migrations.M20260531_member_removed_at -import Simplex.Chat.Store.Postgres.Migrations.M20260531_relay_sent_web_domain +import Simplex.Chat.Store.Postgres.Migrations.M20260601_relay_sent_web_domain import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Text, Maybe Text)] @@ -71,7 +71,7 @@ schemaMigrations = ("20260529_delivery_job_senders", m20260529_delivery_job_senders, Just down_m20260529_delivery_job_senders), ("20260530_client_services", m20260530_client_services, Just down_m20260530_client_services), ("20260531_member_removed_at", m20260531_member_removed_at, Just down_m20260531_member_removed_at), - ("20260531_relay_sent_web_domain", m20260531_relay_sent_web_domain, Just down_m20260531_relay_sent_web_domain) + ("20260601_relay_sent_web_domain", m20260601_relay_sent_web_domain, Just down_m20260601_relay_sent_web_domain) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260531_relay_sent_web_domain.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260601_relay_sent_web_domain.hs similarity index 54% rename from src/Simplex/Chat/Store/Postgres/Migrations/M20260531_relay_sent_web_domain.hs rename to src/Simplex/Chat/Store/Postgres/Migrations/M20260601_relay_sent_web_domain.hs index c7cbf1a556..1b8efbcead 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20260531_relay_sent_web_domain.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260601_relay_sent_web_domain.hs @@ -1,19 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -module Simplex.Chat.Store.Postgres.Migrations.M20260531_relay_sent_web_domain where +module Simplex.Chat.Store.Postgres.Migrations.M20260601_relay_sent_web_domain where import Data.Text (Text) import Text.RawString.QQ (r) -m20260531_relay_sent_web_domain :: Text -m20260531_relay_sent_web_domain = +m20260601_relay_sent_web_domain :: Text +m20260601_relay_sent_web_domain = [r| ALTER TABLE groups ADD COLUMN relay_sent_web_domain TEXT; |] -down_m20260531_relay_sent_web_domain :: Text -down_m20260531_relay_sent_web_domain = +down_m20260601_relay_sent_web_domain :: Text +down_m20260601_relay_sent_web_domain = [r| ALTER TABLE groups DROP COLUMN relay_sent_web_domain; |] diff --git a/src/Simplex/Chat/Store/SQLite/Migrations.hs b/src/Simplex/Chat/Store/SQLite/Migrations.hs index 984f74b546..37084d732a 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations.hs @@ -158,7 +158,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260515_public_group_access import Simplex.Chat.Store.SQLite.Migrations.M20260529_delivery_job_senders import Simplex.Chat.Store.SQLite.Migrations.M20260530_client_services import Simplex.Chat.Store.SQLite.Migrations.M20260531_member_removed_at -import Simplex.Chat.Store.SQLite.Migrations.M20260531_relay_sent_web_domain +import Simplex.Chat.Store.SQLite.Migrations.M20260601_relay_sent_web_domain import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -317,7 +317,7 @@ schemaMigrations = ("20260529_delivery_job_senders", m20260529_delivery_job_senders, Just down_m20260529_delivery_job_senders), ("20260530_client_services", m20260530_client_services, Just down_m20260530_client_services), ("20260531_member_removed_at", m20260531_member_removed_at, Just down_m20260531_member_removed_at), - ("20260531_relay_sent_web_domain", m20260531_relay_sent_web_domain, Just down_m20260531_relay_sent_web_domain) + ("20260601_relay_sent_web_domain", m20260601_relay_sent_web_domain, Just down_m20260601_relay_sent_web_domain) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260531_relay_sent_web_domain.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260601_relay_sent_web_domain.hs similarity index 53% rename from src/Simplex/Chat/Store/SQLite/Migrations/M20260531_relay_sent_web_domain.hs rename to src/Simplex/Chat/Store/SQLite/Migrations/M20260601_relay_sent_web_domain.hs index 793d60d6ba..922a563356 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20260531_relay_sent_web_domain.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260601_relay_sent_web_domain.hs @@ -1,18 +1,18 @@ {-# LANGUAGE QuasiQuotes #-} -module Simplex.Chat.Store.SQLite.Migrations.M20260531_relay_sent_web_domain where +module Simplex.Chat.Store.SQLite.Migrations.M20260601_relay_sent_web_domain where import Database.SQLite.Simple (Query) import Database.SQLite.Simple.QQ (sql) -m20260531_relay_sent_web_domain :: Query -m20260531_relay_sent_web_domain = +m20260601_relay_sent_web_domain :: Query +m20260601_relay_sent_web_domain = [sql| ALTER TABLE groups ADD COLUMN relay_sent_web_domain TEXT; |] -down_m20260531_relay_sent_web_domain :: Query -down_m20260531_relay_sent_web_domain = +down_m20260601_relay_sent_web_domain :: Query +down_m20260601_relay_sent_web_domain = [sql| ALTER TABLE groups DROP COLUMN relay_sent_web_domain; |] diff --git a/src/Simplex/Chat/Web.hs b/src/Simplex/Chat/Web.hs index 94d4cc0afc..cf1bc9941f 100644 --- a/src/Simplex/Chat/Web.hs +++ b/src/Simplex/Chat/Web.hs @@ -15,7 +15,10 @@ module Simplex.Chat.Web WebFileInfo (..), CorsOrigin (..), webPreviewWorker, - channelChanged, + renderWebPreviews, + writeCorsConfig, + channelContentChanged, + channelProfileUpdated, channelRemoved, ) where @@ -31,11 +34,10 @@ 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 qualified Data.Map.Strict as M import qualified Data.Set as S -import Data.Maybe (isJust, mapMaybe) +import Data.Maybe (isJust, mapMaybe, maybeToList) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as TIO @@ -125,7 +127,7 @@ $(JQ.deriveJSON defaultJSON ''WebMessage) $(JQ.deriveJSON defaultJSON ''WebChannelPreview) webPreviewWorker :: WebPreviewConfig -> ChatController -> [User] -> IO () -webPreviewWorker WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterval} cc users = +webPreviewWorker cfg@WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterval} cc users = forM_ (webPreviewState cc) $ \wps -> do createDirectoryIfMissing True webJsonDir initPublishableGroups wps @@ -138,8 +140,12 @@ webPreviewWorker WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterval} c drainRemovals drainPriority handleCors - processOneRoutine - sleepOrWake + drainRoutine + groups <- loadRelayGroups + regenerateCors groups + cleanStaleFiles groups + seedRoutinePending wps + interruptibleSleep workerLoop wps where drainRemovals = atomically (tryReadTQueue filesToRemove) >>= \case @@ -156,26 +162,18 @@ webPreviewWorker WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterval} c handleCors = do needed <- atomically $ swapTVar corsNeeded False - when needed regenerateCors + when needed $ loadRelayGroups >>= regenerateCors - processOneRoutine = do + drainRoutine = do mGId <- atomically $ do pending <- readTVar routinePending case S.minView pending of Nothing -> pure Nothing Just (gId, rest) -> writeTVar routinePending rest >> pure (Just gId) - forM_ mGId $ renderOneGroup wps - - sleepOrWake = do - pending <- readTVarIO routinePending - if S.null pending - then do - cleanStaleFiles - seedRoutinePending wps - interruptibleSleep - else do - hasPriority <- atomically $ not <$> isEmptyTQueue priorityRender - unless hasPriority interruptibleSleep + forM_ mGId $ \gId -> do + renderOneGroup wps gId + drainPriority + drainRoutine interruptibleSleep = do delay <- registerDelay (webUpdateInterval * 1000000) @@ -184,8 +182,7 @@ webPreviewWorker WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterval} c `orElse` takeTMVar wakeSignal initPublishableGroups WebPreviewState {publishableGroupIds} = do - groups <- withTransaction (chatStore cc) $ \db -> - concat <$> mapM (getRelayServedGroups db vr') users + groups <- loadRelayGroups let gIds = M.fromList [(groupId, f) | g@GroupInfo {groupId} <- groups, Just f <- [publicGroupFileName g]] atomically $ writeTVar publishableGroupIds gIds @@ -194,20 +191,23 @@ webPreviewWorker WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterval} c renderOneGroup WebPreviewState {publishableGroupIds} gId = do publishable <- atomically $ M.member gId <$> readTVar publishableGroupIds - when publishable $ do - r <- withTransaction (chatStore cc) $ \db -> - findUser $ \u -> fmap (\g -> (u, g)) <$> runExceptT (getGroupInfo db vr' u gId) - case r of - Just (u, gInfo) | hasPublicGroup gInfo -> - void $ renderGroupPreview webJsonDir cc u gInfo - _ -> do - fName <- atomically $ do - ids <- readTVar publishableGroupIds - modifyTVar' publishableGroupIds (M.delete gId) - pure $ M.lookup gId ids - forM_ fName $ \f -> - removeFile (webJsonDir > f) `catch` \(_ :: SomeException) -> pure () - logInfo $ "web preview: group " <> T.pack (show gId) <> " no longer publishable" + when publishable $ + do + r <- withTransaction (chatStore cc) $ \db -> + findUser $ \u -> fmap (\g -> (u, g)) <$> runExceptT (getGroupInfo db vr' u gId) + case r of + Just (u, gInfo) | hasPublicGroup gInfo -> + void $ renderGroupPreview cfg cc u gInfo + _ -> do + fName <- atomically $ do + ids <- readTVar publishableGroupIds + modifyTVar' publishableGroupIds (M.delete gId) + pure $ M.lookup gId ids + forM_ fName $ \f -> + removeFile (webJsonDir > f) `catch` \(_ :: SomeException) -> pure () + logInfo $ "web preview: group " <> T.pack (show gId) <> " no longer publishable" + `catch` \(e :: SomeException) -> + logError $ "web preview: error rendering group " <> T.pack (show gId) <> ": " <> T.pack (show e) findUser f = go users where @@ -216,35 +216,43 @@ webPreviewWorker WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterval} c Right a -> pure (Just a) Left _ -> go us - regenerateCors = do - groups <- withTransaction (chatStore cc) $ \db -> + loadRelayGroups = + withTransaction (chatStore cc) $ \db -> concat <$> mapM (getRelayServedGroups db vr') users + + regenerateCors groups = do let entries = mapMaybe groupCorsEntry groups forM_ webCorsFile $ writeCorsConfig entries + cleanStaleFiles groups = do + let activeFiles = S.fromList $ mapMaybe publicGroupFileName [g | g <- groups, hasPublicGroup g] + removeStaleFiles webJsonDir activeFiles + groupCorsEntry GroupInfo {groupProfile = GroupProfile {publicGroup}} = publicGroup >>= \PublicGroupProfile {publicGroupId, publicGroupAccess} -> corsEntry publicGroupId <$> publicGroupAccess - cleanStaleFiles = do - groups <- withTransaction (chatStore cc) $ \db -> - concat <$> mapM (getRelayServedGroups db vr') users - let activeFiles = S.fromList $ mapMaybe publicGroupFileName [g | g <- groups, hasPublicGroup g] - removeStaleFiles webJsonDir activeFiles +renderWebPreviews :: WebPreviewConfig -> ChatController -> User -> IO () +renderWebPreviews cfg@WebPreviewConfig {webJsonDir} cc user = do + let vr' = chatVRange (config cc) + createDirectoryIfMissing True webJsonDir + groups <- withTransaction (chatStore cc) $ \db -> getRelayServedGroups db vr' user + forM_ [gInfo | gInfo <- groups, hasPublicGroup gInfo] $ \gInfo -> + void $ renderGroupPreview cfg cc user gInfo -renderGroupPreview :: FilePath -> ChatController -> User -> GroupInfo -> IO (Maybe (Text, CorsOrigin)) -renderGroupPreview webJsonDir cc user gInfo@GroupInfo {groupProfile = gp@GroupProfile {shortDescr = sd, description = wd, publicGroup}} = +renderGroupPreview :: WebPreviewConfig -> ChatController -> User -> GroupInfo -> IO (Maybe (Text, CorsOrigin)) +renderGroupPreview WebPreviewConfig {webJsonDir, webPreviewItemCount} cc user gInfo@GroupInfo {groupProfile = gp@GroupProfile {shortDescr = sd, description = wd, publicGroup}} = case publicGroup of Just PublicGroupProfile {publicGroupId, publicGroupAccess} -> do let fName = publicGroupIdFileName publicGroupId <> ".json" (items, owners) <- withTransaction (chatStore cc) $ \db -> do - is <- getGroupWebPreviewItems db user gInfo 50 + is <- getGroupWebPreviewItems db user gInfo webPreviewItemCount os <- getGroupOwners db vr' user gInfo pure (is, os) ts <- getCurrentTime let rendered = mapMaybe toRenderedItem $ rights items msgs = map fst rendered - senders = uniqueSenders $ map memberToProfile owners <> mapMaybe snd rendered + senders = collectSenders $ map memberToProfile owners <> mapMaybe snd rendered preview = WebChannelPreview { channel = gp, shortDescription = toFormattedText =<< sd, @@ -259,16 +267,34 @@ renderGroupPreview webJsonDir cc user gInfo@GroupInfo {groupProfile = gp@GroupPr where vr' = chatVRange (config cc) -channelChanged :: ChatController -> Int64 -> Bool -> STM () -channelChanged cc gId updateCors = - forM_ (webPreviewState cc) $ \WebPreviewState {publishableGroupIds, priorityRender, corsNeeded, routinePending, wakeSignal} -> do +channelContentChanged :: ChatController -> Int64 -> STM () +channelContentChanged cc gId = + forM_ (webPreviewState cc) $ \WebPreviewState {publishableGroupIds, priorityRender, routinePending, wakeSignal} -> do ids <- readTVar publishableGroupIds when (M.member gId ids) $ do writeTQueue priorityRender gId modifyTVar' routinePending (S.delete gId) - when updateCors $ writeTVar corsNeeded True void $ tryPutTMVar wakeSignal () +channelProfileUpdated :: ChatController -> Int64 -> GroupProfile -> STM () +channelProfileUpdated cc gId GroupProfile {publicGroup} = + forM_ (webPreviewState cc) $ \WebPreviewState {publishableGroupIds, priorityRender, filesToRemove, corsNeeded, routinePending, wakeSignal} -> + case publicGroup of + Just PublicGroupProfile {publicGroupId} -> do + let fName = publicGroupIdFileName publicGroupId <> ".json" + modifyTVar' publishableGroupIds (M.insert gId fName) + writeTQueue priorityRender gId + modifyTVar' routinePending (S.delete gId) + writeTVar corsNeeded True + void $ tryPutTMVar wakeSignal () + Nothing -> do + ids <- readTVar publishableGroupIds + forM_ (M.lookup gId ids) $ writeTQueue filesToRemove + modifyTVar' publishableGroupIds (M.delete gId) + modifyTVar' routinePending (S.delete gId) + writeTVar corsNeeded True + void $ tryPutTMVar wakeSignal () + channelRemoved :: ChatController -> Int64 -> STM () channelRemoved cc gId = forM_ (webPreviewState cc) $ \WebPreviewState {publishableGroupIds, filesToRemove, corsNeeded, routinePending, wakeSignal} -> do @@ -324,10 +350,8 @@ ciQuoteToQuotedMsg CIQuote {chatDir = qDir, sharedMsgId, sentAt, content = qCont webFileInfo :: CIFile d -> WebFileInfo webFileInfo CIFile {fileName, fileSize} = WebFileInfo {fileName, fileSize} -uniqueSenders :: [WebMemberProfile] -> [WebMemberProfile] -uniqueSenders = nubBy sameId - where - sameId (WebMemberProfile {memberId = a}) (WebMemberProfile {memberId = b}) = a == b +collectSenders :: [WebMemberProfile] -> [WebMemberProfile] +collectSenders = M.elems . M.fromList . map (\p@WebMemberProfile {memberId} -> (memberId, p)) memberToProfile :: GroupMember -> WebMemberProfile memberToProfile GroupMember {memberId, memberProfile = LocalProfile {displayName, image}} = @@ -341,10 +365,14 @@ corsEntry publicGroupId PublicGroupAccess {groupWebPage, allowEmbedding} = let fName = T.pack $ publicGroupIdFileName publicGroupId <> ".json" origin | allowEmbedding = CorsAny - | isJust groupWebPage = CorsOrigins $ mapMaybe id [groupWebPage] - | otherwise = CorsOrigins [] + | otherwise = CorsOrigins $ filter isSafeOrigin $ maybeToList groupWebPage in (fName, origin) +isSafeOrigin :: Text -> Bool +isSafeOrigin t = + (T.isPrefixOf "https://" t || T.isPrefixOf "http://" t) + && T.all (\c -> c /= '"' && c /= '\n' && c /= '\r' && c /= ' ') t + channelPath :: Text channelPath = "/channel/" diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index f2cdd212a9..18e91e7544 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -165,7 +165,7 @@ relayTestOpts :: ChatOpts relayTestOpts = testOpts {coreOptions = testCoreOpts {chatRelay = True}} relayWebTestOpts :: Text -> FilePath -> ChatOpts -relayWebTestOpts webDomain webDir = testOpts {coreOptions = testCoreOpts {chatRelay = True, webPreviewConfig = Just WebPreviewConfig {webDomain, webJsonDir = webDir, webCorsFile = Nothing, webUpdateInterval = 300}}} +relayWebTestOpts webDomain webDir = testOpts {coreOptions = testCoreOpts {chatRelay = True, webPreviewConfig = Just WebPreviewConfig {webDomain, webJsonDir = webDir, webCorsFile = Nothing, webUpdateInterval = 300, webPreviewItemCount = 50}}} #if !defined(dbPostgres) getTestOpts :: Bool -> ScrubbedBytes -> ChatOpts diff --git a/website/channel_sample.html b/website/channel_sample.html index 7760d27c31..169db55599 100644 --- a/website/channel_sample.html +++ b/website/channel_sample.html @@ -11,15 +11,17 @@
+