website: directory page (#6283)

* website: directory page

* core: use markdown in directory entries

* render markdown on directory page

* update markdown

* toggle secrets on click

* update listings asynchronously

* add group links to the listing

* cleanup

* better directory layout with pagination

* script to run website

* update page navigation

* search

* readable markdown colors, better "read less"

* core: atomic update of directory listings, to avoid files unavailable

* fix symlink, sort entries on page with new first

* update listings every 15 min, add activeAt time

* fix sorting in the page and listing url

* replace simplex:/ links on desktop

apps/simplex-directory-service/Main.hs

@@ -5,8 +5,6 @@ module Main where
 import Directory.Options
 import Directory.Service
 import Directory.Store
-import Simplex.Chat.Controller (ChatConfig (..), ChatHooks (..), defaultChatHooks)
-import Simplex.Chat.Core
 import Simplex.Chat.Terminal (terminalChatConfig)
 
 main :: IO ()
@@ -15,11 +13,4 @@ main = do
   st <- restoreDirectoryStore directoryLog
   if runCLI
     then directoryServiceCLI st opts
-    else do
-      env <- newServiceState opts
-      let chatHooks =
-            defaultChatHooks
-              { postStartHook = Just $ directoryStartHook st opts,
-                acceptMember = Just $ acceptMemberHook opts env
-              }
-      simplexChatCore (terminalChatConfig {chatHooks}) (mkChatOpts opts) $ directoryService st opts env
+    else directoryService st opts terminalChatConfig

apps/simplex-directory-service/src/Directory/Listing.hs

@@ -1,9 +1,11 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module Directory.Listing where
@@ -11,23 +13,36 @@ module Directory.Listing where
 import Control.Applicative ((<|>))
 import Control.Concurrent.STM
 import Control.Monad
+import Crypto.Hash (Digest, MD5)
+import qualified Crypto.Hash as CH
 import qualified Data.Aeson as J
 import qualified Data.Aeson.TH as JQ
+import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
-import Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Base64.URL as B64URL
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as LB
-import Data.Maybe (fromMaybe)
+import Data.List (isPrefixOf)
+import Data.Maybe (catMaybes, fromMaybe)
 import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Format.ISO8601 (iso8601Show)
 import Directory.Store
+import Simplex.Chat.Markdown
 import Simplex.Chat.Types
+import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
 import System.Directory
 import System.FilePath
 
+directoryDataPath :: String
+directoryDataPath = "data"
+
 listingFileName :: String
 listingFileName = "listing.json"
 
@@ -47,9 +62,12 @@ $(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "DET") ''DirectoryEntryType)
 data DirectoryEntry = DirectoryEntry
   { entryType :: DirectoryEntryType,
     displayName :: Text,
-    shortDescr :: Maybe Text,
-    welcomeMessage :: Maybe Text,
-    imageFile :: Maybe String
+    groupLink :: CreatedLinkContact,
+    shortDescr :: Maybe MarkdownList,
+    welcomeMessage :: Maybe MarkdownList,
+    imageFile :: Maybe String,
+    activeAt :: UTCTime,
+    createdAt :: UTCTime
   }
 
 $(JQ.deriveJSON defaultJSON ''DirectoryEntry)
@@ -60,38 +78,67 @@ $(JQ.deriveJSON defaultJSON ''DirectoryListing)
 
 type ImageFileData = ByteString
 
-groupDirectoryEntry :: GroupInfoSummary -> (DirectoryEntry, Maybe (FilePath, ImageFileData))
-groupDirectoryEntry (GIS GroupInfo {groupId, groupProfile} summary) =
+groupDirectoryEntry :: GroupInfoSummary -> Maybe (DirectoryEntry, Maybe (FilePath, ImageFileData))
+groupDirectoryEntry (GIS GroupInfo {groupProfile, chatTs, createdAt} summary gLink_) =
   let GroupProfile {displayName, shortDescr, description, image, memberAdmission} = groupProfile
       entryType = DETGroup memberAdmission summary
-      imgData = imgFileData =<< image
-   in (DirectoryEntry {entryType, displayName, shortDescr, welcomeMessage = description, imageFile = fst <$> imgData}, imgData)
+      entry groupLink =
+        let de =
+              DirectoryEntry
+                { entryType,
+                  displayName,
+                  groupLink,
+                  shortDescr = toFormattedText <$> shortDescr,
+                  welcomeMessage = toFormattedText <$> description,
+                  imageFile = fst <$> imgData,
+                  activeAt = fromMaybe createdAt chatTs,
+                  createdAt
+                }
+            imgData = imgFileData groupLink =<< image
+         in (de, imgData)
+   in (entry . connLinkContact) <$> gLink_
   where
-    imgFileData (ImageData img) =
+    imgFileData :: CreatedConnLink 'CMContact -> ImageData -> Maybe (FilePath, ByteString)
+    imgFileData groupLink (ImageData img) =
       let (img', imgExt) =
             fromMaybe (img, ".jpg") $
               (,".jpg") <$> T.stripPrefix "data:image/jpg;base64," img
                 <|> (,".png") <$> T.stripPrefix "data:image/png;base64," img
-          imgFile = listingImageFolder </> show groupId <> imgExt
+          imgName = B.unpack $ B64URL.encodeUnpadded $ BA.convert $ (CH.hash :: ByteString -> Digest MD5) $ strEncode (connFullLink groupLink)
+          imgFile = listingImageFolder </> imgName <> imgExt
        in case B64.decode $ encodeUtf8 img' of
             Right img'' -> Just (imgFile, img'')
             Left _ -> Nothing
 
 generateListing :: DirectoryStore -> FilePath -> [GroupInfoSummary] -> IO ()
 generateListing st dir gs = do
+  createDirectoryIfMissing True dir
+  oldDirs <- filter ((directoryDataPath <> ".") `isPrefixOf`) <$> listDirectory dir
+  ts <- getCurrentTime
+  let newDirPath = directoryDataPath <> "." <> iso8601Show ts <> "/"
+      newDir = dir </> newDirPath
   gs' <- filterListedGroups st gs
-  removePathForcibly (dir </> listingImageFolder)
-  createDirectoryIfMissing True (dir </> listingImageFolder)
-  gs'' <- forM gs' $ \g@(GIS GroupInfo {groupId} _) -> do
-    let (g', img) = groupDirectoryEntry g
-    forM_ img $ \(imgFile, imgData) -> B.writeFile (dir </> imgFile) imgData
-    pure (groupId, g')
-  saveListing listingFileName gs''
-  saveListing promotedFileName =<< filterPromotedGroups st gs''
+  createDirectoryIfMissing True (newDir </> listingImageFolder)
+  gs'' <-
+    fmap catMaybes $ forM gs' $ \g@(GIS GroupInfo {groupId} _ _) ->
+      forM (groupDirectoryEntry g) $ \(g', img) -> do
+        forM_ img $ \(imgFile, imgData) -> B.writeFile (newDir </> imgFile) imgData
+        pure (groupId, g')
+  saveListing newDir listingFileName gs''
+  saveListing newDir promotedFileName =<< filterPromotedGroups st gs''
+  -- atomically update the link
+  let newSymLink = newDir <> ".link"
+      symLink = dir </> directoryDataPath
+  createDirectoryLink newDirPath newSymLink
+  renamePath newSymLink symLink
+  mapM_ (removePathForcibly . (dir </>)) oldDirs
   where
-    saveListing f = LB.writeFile (dir </> f) . J.encode . DirectoryListing . map snd
+    saveListing newDir f = LB.writeFile (newDir </> f) . J.encode . DirectoryListing . map snd
 
 filterPromotedGroups :: DirectoryStore -> [(GroupId, DirectoryEntry)] -> IO [(GroupId, DirectoryEntry)]
 filterPromotedGroups st gs = do
   pgs <- readTVarIO $ promotedGroups st
   pure $ filter (\g -> fst g `S.member` pgs) gs
+
+toFormattedText :: Text -> MarkdownList
+toFormattedText t = fromMaybe [FormattedText Nothing t] $ parseMaybeMarkdownList t

apps/simplex-directory-service/src/Directory/Search.hs

@@ -20,13 +20,13 @@ data SearchRequest = SearchRequest
 data SearchType = STAll | STRecent | STSearch Text
 
 takeTop :: Int -> [GroupInfoSummary] -> [GroupInfoSummary]
-takeTop n = take n . sortOn (\(GIS _ GroupSummary {currentMembers}) -> Down currentMembers)
+takeTop n = take n . sortOn (\(GIS _ GroupSummary {currentMembers} _) -> Down currentMembers)
 
 takeRecent :: Int -> [GroupInfoSummary] -> [GroupInfoSummary]
-takeRecent n = take n . sortOn (\(GIS GroupInfo {createdAt} _) -> Down createdAt)
+takeRecent n = take n . sortOn (\(GIS GroupInfo {createdAt} _ _) -> Down createdAt)
 
 groupIds :: [GroupInfoSummary] -> Set GroupId
-groupIds = S.fromList . map (\(GIS GroupInfo {groupId} _) -> groupId)
+groupIds = S.fromList . map (\(GIS GroupInfo {groupId} _ _) -> groupId)
 
 filterNotSent :: Set GroupId -> [GroupInfoSummary] -> [GroupInfoSummary]
-filterNotSent sentGroups = filter (\(GIS GroupInfo {groupId} _) -> groupId `S.notMember` sentGroups)
+filterNotSent sentGroups = filter (\(GIS GroupInfo {groupId} _ _) -> groupId `S.notMember` sentGroups)

apps/simplex-directory-service/src/Directory/Service.hs

@@ -21,7 +21,6 @@ module Directory.Service
 where
 
 import Control.Concurrent (forkIO)
-import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Logger.Simple
 import Control.Monad
@@ -54,7 +53,6 @@ import Simplex.Chat.Markdown (Format (..), FormattedText (..), parseMaybeMarkdow
 import Simplex.Chat.Messages
 import Simplex.Chat.Options
 import Simplex.Chat.Protocol (MsgContent (..))
-import Simplex.Chat.Store (GroupLink (..))
 import Simplex.Chat.Store.Direct (getContact)
 import Simplex.Chat.Store.Groups (getGroupInfo, getGroupLink, getGroupSummary, getUserGroupsWithSummary, setGroupCustomData)
 import Simplex.Chat.Store.Profiles (GroupLinkInfo (..), getGroupLinkInfo)
@@ -69,7 +67,7 @@ import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConnectionLink (.
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Util (safeDecodeUtf8, tshow, unlessM, whenM, ($>>=), (<$$>))
+import Simplex.Messaging.Util (raceAny_, safeDecodeUtf8, tshow, unlessM, whenM, ($>>=), (<$$>))
 import System.Directory (getAppUserDataDirectory)
 import System.Exit (exitFailure)
 import System.Process (readProcess)
@@ -96,7 +94,8 @@ data GroupRolesStatus
 data ServiceState = ServiceState
   { searchRequests :: TMap ContactId SearchRequest,
     blockedWordsCfg :: BlockedWordsConfig,
-    pendingCaptchas :: TMap GroupMemberId PendingCaptcha
+    pendingCaptchas :: TMap GroupMemberId PendingCaptcha,
+    updateListingsJob :: TMVar ChatController
   }
 
 data PendingCaptcha = PendingCaptcha
@@ -119,7 +118,8 @@ newServiceState opts = do
   searchRequests <- TM.emptyIO
   blockedWordsCfg <- readBlockedWordsConfig opts
   pendingCaptchas <- TM.emptyIO
-  pure ServiceState {searchRequests, blockedWordsCfg, pendingCaptchas}
+  updateListingsJob <- newEmptyTMVarIO
+  pure ServiceState {searchRequests, blockedWordsCfg, pendingCaptchas, updateListingsJob}
 
 welcomeGetOpts :: IO DirectoryOpts
 welcomeGetOpts = do
@@ -146,22 +146,41 @@ directoryServiceCLI st opts = do
   env <- newServiceState opts
   eventQ <- newTQueueIO
   let eventHook cc resp = atomically $ resp <$ writeTQueue eventQ (cc, resp)
-      chatHooks = defaultChatHooks {postStartHook = Just $ directoryStartHook st opts, eventHook = Just eventHook, acceptMember = Just $ acceptMemberHook opts env}
-  race_
-    (simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing)
-    (processEvents eventQ env)
+      chatHooks = defaultChatHooks {postStartHook = Just $ directoryStartHook opts env, eventHook = Just eventHook, acceptMember = Just $ acceptMemberHook opts env}
+  raceAny_ $
+    [ simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing,
+      processEvents eventQ env
+    ]
+      <> updateListingsThread_ st opts env
   where
     processEvents eventQ env = forever $ do
       (cc, resp) <- atomically $ readTQueue eventQ
       u_ <- readTVarIO (currentUser cc)
       forM_ u_ $ \user -> directoryServiceEvent st opts env user cc resp
 
-directoryStartHook :: DirectoryStore -> DirectoryOpts -> ChatController -> IO ()
-directoryStartHook st opts cc =
+updateListingDelay :: Int
+updateListingDelay = 15 * 60 * 1000000 -- update every 15 minutes
+
+updateListingsThread_ :: DirectoryStore -> DirectoryOpts -> ServiceState -> [IO ()]
+updateListingsThread_ st opts env = maybe [] (\f -> [updateListingsThread f]) $ webFolder opts
+  where
+    updateListingsThread f = do
+      cc <- atomically $ takeTMVar $ updateListingsJob env
+      forever $ do
+        u <- readTVarIO $ currentUser cc
+        forM_ u $ \user -> updateGroupListingFiles cc st user f
+        delay <- registerDelay updateListingDelay
+        atomically $ void (takeTMVar $ updateListingsJob env) `orElse` unlessM (readTVar delay) retry
+
+listingsUpdated :: ServiceState -> ChatController -> IO ()
+listingsUpdated env = void . atomically . tryPutTMVar (updateListingsJob env)
+
+directoryStartHook :: DirectoryOpts -> ServiceState -> ChatController -> IO ()
+directoryStartHook opts env cc =
   readTVarIO (currentUser cc) >>= \case
     Nothing -> putStrLn "No current user" >> exitFailure
-    Just user@User {userId, profile = p@LocalProfile {preferences}} -> do
-      forM_ (webFolder opts) $ updateGroupListingFiles cc st user
+    Just User {userId, profile = p@LocalProfile {preferences}} -> do
+      listingsUpdated env cc
       let cmds = fromMaybe [] $ preferences >>= commands_
       unless (cmds == directoryCommands) $ do
         let prefs = (fromMaybe emptyChatPrefs preferences) {files = Just FilesPreference {allow = FANo}, commands = Just directoryCommands} :: Preferences
@@ -188,12 +207,23 @@ directoryCommands =
   where
     idParam = Just "<ID>"
 
-directoryService :: DirectoryStore -> DirectoryOpts -> ServiceState -> User -> ChatController -> IO ()
-directoryService st opts@DirectoryOpts {testing} env user cc = do
-  initializeBotAddress' (not testing) cc
-  race_ (forever $ void getLine) . forever $ do
-    (_, resp) <- atomically . readTBQueue $ outputQ cc
-    directoryServiceEvent st opts env user cc resp
+directoryService :: DirectoryStore -> DirectoryOpts -> ChatConfig -> IO ()
+directoryService st opts@DirectoryOpts {testing} cfg = do
+  env <- newServiceState opts
+  let chatHooks =
+        defaultChatHooks
+          { postStartHook = Just $ directoryStartHook opts env,
+            acceptMember = Just $ acceptMemberHook opts env
+          }
+  simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \user cc -> do
+    initializeBotAddress' (not testing) cc
+    raceAny_ $
+      [ forever $ void getLine,
+        forever $ do
+          (_, resp) <- atomically . readTBQueue $ outputQ cc
+          directoryServiceEvent st opts env user cc resp
+      ]
+        <> updateListingsThread_ st opts env
 
 acceptMemberHook :: DirectoryOpts -> ServiceState -> GroupInfo -> GroupLinkInfo -> Profile -> IO (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
 acceptMemberHook
@@ -301,7 +331,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
     getDuplicateGroup GroupInfo {groupId, groupProfile = GroupProfile {displayName, fullName}} =
       getGroups fullName >>= mapM duplicateGroup
       where
-        sameGroupNotRemoved (GIS g@GroupInfo {groupId = gId, groupProfile = GroupProfile {displayName = n, fullName = fn}} _) =
+        sameGroupNotRemoved (GIS g@GroupInfo {groupId = gId, groupProfile = GroupProfile {displayName = n, fullName = fn}} _ _) =
           gId /= groupId && n == displayName && fn == fullName && not (memberRemoved $ membership g)
         duplicateGroup [] = pure DGUnique
         duplicateGroup groups = do
@@ -310,13 +340,13 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
             then pure DGUnique
             else do
               (lgs, rgs) <- atomically $ (,) <$> readTVar (listedGroups st) <*> readTVar (reservedGroups st)
-              let reserved = any (\(GIS GroupInfo {groupId = gId} _) -> gId `S.member` lgs || gId `S.member` rgs) gs
+              let reserved = any (\(GIS GroupInfo {groupId = gId} _ _) -> gId `S.member` lgs || gId `S.member` rgs) gs
               if reserved
                 then pure DGReserved
                 else do
                   removed <- foldM (\r -> fmap (r &&) . isGroupRemoved) True gs
                   pure $ if removed then DGUnique else DGRegistered
-        isGroupRemoved (GIS GroupInfo {groupId = gId} _) =
+        isGroupRemoved (GIS GroupInfo {groupId = gId} _ _) =
           getGroupReg st gId >>= \case
             Just GroupReg {groupRegStatus} -> groupRemoved <$> readTVarIO groupRegStatus
             Nothing -> pure True
@@ -395,7 +425,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
           notifyOwner gr $ "Joined the group " <> displayName <> ", creating the link…"
           sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case
             Right CRGroupLinkCreated {groupLink = GroupLink {connLinkContact = gLink}} -> do
-              setGroupStatus st opts cc user gr GRSPendingUpdate
+              setGroupStatus st env cc gr GRSPendingUpdate
               notifyOwner
                 gr
                 "Created the public link to join the group via this directory service that is always online.\n\n\
@@ -456,7 +486,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
             Just DGReserved -> notifyOwner gr $ groupAlreadyListed toGroup
             _ -> do
               let gaId = 1
-              setGroupStatus st opts cc user gr $ GRSPendingApproval gaId
+              setGroupStatus st env cc gr $ GRSPendingApproval gaId
               notifyOwner gr $
                 ("Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message" <> byMember)
                   <> ".\nYou will be notified once the group is added to the directory - it may take up to 48 hours."
@@ -466,18 +496,18 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
               groupRef = groupReference toGroup
           groupProfileUpdate >>= \case
             GPNoServiceLink -> do
-              setGroupStatus st opts cc user gr GRSPendingUpdate
+              setGroupStatus st env cc gr GRSPendingUpdate
               notifyOwner gr $
                 ("The group profile is updated for " <> userGroupRef <> byMember <> ", but no link is added to the welcome message.\n\n")
                   <> "The group will remain hidden from the directory until the group link is added and the group is re-approved."
             GPServiceLinkRemoved -> do
-              setGroupStatus st opts cc user gr GRSPendingUpdate
+              setGroupStatus st env cc gr GRSPendingUpdate
               notifyOwner gr $
                 ("The group link for " <> userGroupRef <> " is removed from the welcome message" <> byMember)
                   <> ".\n\nThe group is hidden from the directory until the group link is added and the group is re-approved."
               notifyAdminUsers $ "The group link is removed from " <> groupRef <> ", de-listed."
             GPServiceLinkAdded _ -> do
-              setGroupStatus st opts cc user gr $ GRSPendingApproval n'
+              setGroupStatus st env cc gr $ GRSPendingApproval n'
               notifyOwner gr $
                 ("The group link is added to " <> userGroupRef <> byMember)
                   <> "!\nIt is hidden from the directory until approved."
@@ -490,7 +520,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
                       <> "!\nThe group is listed in directory."
                   notifyAdminUsers $ "The group " <> groupRef <> " is updated" <> byMember <> " - only link or whitespace changes.\nThe group remained listed in directory."
               | otherwise -> do
-                  setGroupStatus st opts cc user gr $ GRSPendingApproval n'
+                  setGroupStatus st env cc gr $ GRSPendingApproval n'
                   notifyOwner gr $
                     ("The group " <> userGroupRef <> " is updated" <> byMember)
                       <> "!\nIt is hidden from the directory until approved."
@@ -628,14 +658,14 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
         when (ctId `isOwner` gr) $ do
           readTVarIO (groupRegStatus gr) >>= \case
             GRSSuspendedBadRoles -> when (rStatus == GRSOk) $ do
-              setGroupStatus st opts cc user gr GRSActive
+              setGroupStatus st env cc gr GRSActive
               notifyOwner gr $ uCtRole <> ".\n\nThe group is listed in the directory again."
               notifyAdminUsers $ "The group " <> groupRef <> " is listed " <> suCtRole
             GRSPendingApproval gaId -> when (rStatus == GRSOk) $ do
               sendToApprove g gr gaId
               notifyOwner gr $ uCtRole <> ".\n\nThe group is submitted for approval."
             GRSActive -> when (rStatus /= GRSOk) $ do
-              setGroupStatus st opts cc user gr GRSSuspendedBadRoles
+              setGroupStatus st env cc gr GRSSuspendedBadRoles
               notifyOwner gr $ uCtRole <> ".\n\nThe group is no longer listed in the directory."
               notifyAdminUsers $ "The group " <> groupRef <> " is de-listed " <> suCtRole
             _ -> pure ()
@@ -654,7 +684,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
         readTVarIO (groupRegStatus gr) >>= \case
           GRSSuspendedBadRoles -> when (serviceRole == GRAdmin) $
             whenContactIsOwner gr $ do
-              setGroupStatus st opts cc user gr GRSActive
+              setGroupStatus st env cc gr GRSActive
               notifyOwner gr $ uSrvRole <> ".\n\nThe group is listed in the directory again."
               notifyAdminUsers $ "The group " <> groupRef <> " is listed " <> suSrvRole
           GRSPendingApproval gaId -> when (serviceRole == GRAdmin) $
@@ -662,7 +692,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
               sendToApprove g gr gaId
               notifyOwner gr $ uSrvRole <> ".\n\nThe group is submitted for approval."
           GRSActive -> when (serviceRole /= GRAdmin) $ do
-            setGroupStatus st opts cc user gr GRSSuspendedBadRoles
+            setGroupStatus st env cc gr GRSSuspendedBadRoles
             notifyOwner gr $ uSrvRole <> ".\n\nThe group is no longer listed in the directory."
             notifyAdminUsers $ "The group " <> groupRef <> " is de-listed " <> suSrvRole
           _ -> pure ()
@@ -679,7 +709,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
       logInfo $ "contact ID " <> tshow ctId <> " removed from group " <> viewGroupName g
       withGroupReg g "contact removed" $ \gr -> do
         when (ctId `isOwner` gr) $ do
-          setGroupStatus st opts cc user gr GRSRemoved
+          setGroupStatus st env cc gr GRSRemoved
           notifyOwner gr $ "You are removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory."
           notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (group owner is removed)."
 
@@ -688,7 +718,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
       logInfo $ "contact ID " <> tshow ctId <> " left group " <> viewGroupName g
       withGroupReg g "contact left" $ \gr -> do
         when (ctId `isOwner` gr) $ do
-          setGroupStatus st opts cc user gr GRSRemoved
+          setGroupStatus st env cc gr GRSRemoved
           notifyOwner gr $ "You left the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory."
           notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (group owner left)."
 
@@ -696,7 +726,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
     deServiceRemovedFromGroup g = do
       logInfo $ "service removed from group " <> viewGroupName g
       withGroupReg g "service removed" $ \gr -> do
-        setGroupStatus st opts cc user gr GRSRemoved
+        setGroupStatus st env cc gr GRSRemoved
         notifyOwner gr $ serviceName <> " is removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory."
         notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (directory service is removed)."
 
@@ -704,7 +734,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
     deGroupDeleted g = do
       logInfo $ "group removed " <> viewGroupName g
       withGroupReg g "group removed" $ \gr -> do
-        setGroupStatus st opts cc user gr GRSRemoved
+        setGroupStatus st env cc gr GRSRemoved
         notifyOwner gr $ "The group " <> userGroupReference gr g <> " is deleted.\n\nThe group is no longer listed in the directory."
         notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (group is deleted)."
 
@@ -925,7 +955,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
           where
             msgs = replyMsg :| map foundGroup gs <> [moreMsg | moreGroups > 0]
             replyMsg = (Just ciId, MCText reply)
-            foundGroup (GIS GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_}} GroupSummary {currentMembers}) =
+            foundGroup (GIS GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_}} GroupSummary {currentMembers} _) =
               let membersStr = "_" <> tshow currentMembers <> " members_"
                   showId = if isAdmin then tshow groupId <> ". " else ""
                   text = showId <> groupInfoText p <> "\n" <> membersStr
@@ -946,16 +976,16 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
                         _ -> do
                           getGroupRolesStatus g gr >>= \case
                             Just GRSOk -> do
-                              setGroupStatus st opts cc user gr GRSActive
+                              setGroupStatus st env cc gr GRSActive
                               forM_ promote $ \promo ->
                                 if promo -- admins can unpromote, only super-user can promote when approving
                                   then
                                     unlessM (readTVarIO promoted) $
                                       if knownCt `elem` superUsers
-                                        then setGroupPromoted st opts cc user gr True
+                                        then setGroupPromoted st env cc gr True
                                         else sendReply "You cannot promote groups"
                                   else do
-                                    whenM (readTVarIO promoted) $ setGroupPromoted st opts cc user gr False
+                                    whenM (readTVarIO promoted) $ setGroupPromoted st env cc gr False
                                     notifyOtherSuperUsers $ "Group promotion is disabled for " <> groupRef
                               let approved = "The group " <> userGroupReference' gr n <> " is approved"
                               notifyOwner gr $
@@ -991,7 +1021,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
             withGroupAndReg sendReply groupId gName $ \_ gr ->
               readTVarIO (groupRegStatus gr) >>= \case
                 GRSActive -> do
-                  setGroupStatus st opts cc user gr GRSSuspended
+                  setGroupStatus st env cc gr GRSSuspended
                   let suspended = "The group " <> userGroupReference' gr gName <> " is suspended"
                   notifyOwner gr $ suspended <> " and hidden from directory. Please contact the administrators."
                   sendReply "Group suspended!"
@@ -1002,7 +1032,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
             withGroupAndReg sendReply groupId gName $ \_ gr ->
               readTVarIO (groupRegStatus gr) >>= \case
                 GRSSuspended -> do
-                  setGroupStatus st opts cc user gr GRSActive
+                  setGroupStatus st env cc gr GRSActive
                   let groupStr = "The group " <> userGroupReference' gr gName
                   notifyOwner gr $ groupStr <> " is listed in the directory again!"
                   sendReply "Group listing resumed!"
@@ -1078,7 +1108,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
             withGroupAndReg sendReply groupId gName $ \_ gr@GroupReg {groupRegStatus, promoted} -> do
               status <- readTVarIO groupRegStatus
               promote <- readTVarIO promoted
-              when (promote' /= promote) $ setGroupPromoted st opts cc user gr promote'
+              when (promote' /= promote) $ setGroupPromoted st env cc gr promote'
               let msg =
                     "Group promotion "
                       <> (if promote' then "enabled" <> (if status == GRSActive then "." else ", but the group is not listed.") else "disabled.")
@@ -1132,18 +1162,16 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
           let text = T.unlines $ [tshow useGroupId <> ". Error: getGroup. Please notify the developers."] <> maybeToList ownerStr_ <> [statusStr]
           sendComposedMessage cc ct Nothing $ MCText text
 
-setGroupStatus :: DirectoryStore -> DirectoryOpts -> ChatController -> User -> GroupReg -> GroupRegStatus -> IO ()
-setGroupStatus st opts cc u gr grStatus' = do
+setGroupStatus :: DirectoryStore -> ServiceState -> ChatController -> GroupReg -> GroupRegStatus -> IO ()
+setGroupStatus st env cc gr grStatus' = do
   let status' = grDirectoryStatus grStatus'
   status <- setGroupStatusStore st gr grStatus'
-  forM_ (webFolder opts) $ \dir ->
-    when ((status == DSListed || status' == DSListed) && status /= status') $ updateGroupListingFiles cc st u dir
+  when ((status == DSListed || status' == DSListed) && status /= status') $ listingsUpdated env cc
 
-setGroupPromoted :: DirectoryStore -> DirectoryOpts -> ChatController -> User -> GroupReg -> Bool -> IO ()
-setGroupPromoted st opts cc u gr grPromoted' = do
+setGroupPromoted :: DirectoryStore -> ServiceState -> ChatController -> GroupReg -> Bool -> IO ()
+setGroupPromoted st env cc gr grPromoted' = do
   (status, grPromoted) <- setGroupPromotedStore st gr grPromoted'
-  forM_ (webFolder opts) $ \dir ->
-    when (status == DSListed && grPromoted' /= grPromoted) $ updateGroupListingFiles cc st u dir
+  when (status == DSListed && grPromoted' /= grPromoted) $ listingsUpdated env cc
 
 updateGroupListingFiles :: ChatController -> DirectoryStore -> User -> FilePath -> IO ()
 updateGroupListingFiles cc st u dir =

apps/simplex-directory-service/src/Directory/Store.hs

@@ -273,7 +273,7 @@ getUserGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVarIO (grou
 filterListedGroups :: DirectoryStore -> [GroupInfoSummary] -> IO [GroupInfoSummary]
 filterListedGroups st gs = do
   lgs <- readTVarIO $ listedGroups st
-  pure $ filter (\(GIS GroupInfo {groupId} _) -> groupId `S.member` lgs) gs
+  pure $ filter (\(GIS GroupInfo {groupId} _ _) -> groupId `S.member` lgs) gs
 
 listGroup :: DirectoryStore -> GroupReg -> STM ()
 listGroup st gr = do