core: render channel preview data in relays

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

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,

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,

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

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

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 "",

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,

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

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

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