move hook

apps/simplex-directory-service/Main.hs

@@ -5,7 +5,9 @@ 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 ()
 main = do
@@ -14,5 +16,5 @@ main = do
   if runCLI
     then directoryServiceCLI st opts
     else do
-      cfg <- directoryChatConfig opts
+      let cfg = terminalChatConfig {chatHooks = defaultChatHooks {acceptMember = Just acceptMemberHook}}
       simplexChatCore cfg (mkChatOpts opts) $ directoryService st opts

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

@@ -11,16 +11,16 @@ import qualified Data.Text.Normalize as TN
 
 containsBlockedWords :: Map Char [Char] -> [String] -> Text -> Bool
 containsBlockedWords spelling blockedWords s =
-    let normalizedWords = concatMap words $ normalizeText spelling s
-        -- Fully normalize the entire string (no spaces or punctuation)
-        fullNorm = normalizeText spelling $ T.filter (not . isSpace) s
-        -- Check if any individual word is a swear word
-        wordCheck = any (`elem` blockedWords) normalizedWords
-        -- Check if the full string, when normalized, matches a swear word exactly
-        fullCheck = any (\bw -> T.length s <= length bw * 2 && any (bw ==) fullNorm) blockedWords
-        -- Check if the string is a single word (no spaces)
-        isSingleWord = not $ T.any isSpace s
-     in wordCheck || (fullCheck && not isSingleWord)
+  let normalizedWords = concatMap words $ normalizeText spelling s
+      -- Fully normalize the entire string (no spaces or punctuation)
+      fullNorm = normalizeText spelling $ T.filter (not . isSpace) s
+      -- Check if any individual word is a swear word
+      wordCheck = any (`elem` blockedWords) normalizedWords
+      -- Check if the full string, when normalized, matches a swear word exactly
+      fullCheck = any (\bw -> T.length s <= length bw * 2 && any (bw ==) fullNorm) blockedWords
+      -- Check if the string is a single word (no spaces)
+      isSingleWord = not $ T.any isSpace s
+   in wordCheck || (fullCheck && not isSingleWord)
 
 normalizeText :: Map Char [Char] -> Text -> [String]
 normalizeText spelling =

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

@@ -46,6 +46,7 @@ data DirectoryEvent
   | DEGroupInvitation {contact :: Contact, groupInfo :: GroupInfo, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole}
   | DEServiceJoinedGroup {contactId :: ContactId, groupInfo :: GroupInfo, hostMember :: GroupMember}
   | DEGroupUpdated {contactId :: ContactId, fromGroup :: GroupInfo, toGroup :: GroupInfo}
+  | DEMemberPendingApproval GroupInfo GroupMember
   | DEContactRoleChanged GroupInfo ContactId GroupMemberRole -- contactId here is the contact whose role changed
   | DEServiceRoleChanged GroupInfo GroupMemberRole
   | DEContactRemovedFromGroup ContactId GroupInfo
@@ -65,6 +66,9 @@ crDirectoryEvent = \case
   CRReceivedGroupInvitation {contact, groupInfo, fromMemberRole, memberRole} -> Just $ DEGroupInvitation {contact, groupInfo, fromMemberRole, memberRole}
   CRUserJoinedGroup {groupInfo, hostMember} -> (\contactId -> DEServiceJoinedGroup {contactId, groupInfo, hostMember}) <$> memberContactId hostMember
   CRGroupUpdated {fromGroup, toGroup, member_} -> (\contactId -> DEGroupUpdated {contactId, fromGroup, toGroup}) <$> (memberContactId =<< member_)
+  CRJoinedGroupMember {groupInfo, member}
+    | memberStatus member == GSMemPendingApproval -> Just $ DEMemberPendingApproval groupInfo member
+    | otherwise -> Nothing
   CRMemberRole {groupInfo, member, toRole}
     | groupMemberId' member == groupMemberId' (membership groupInfo) -> Just $ DEServiceRoleChanged groupInfo toRole
     | otherwise -> (\ctId -> DEContactRoleChanged groupInfo ctId toRole) <$> memberContactId member

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

@@ -29,6 +29,7 @@ data DirectoryOpts = DirectoryOpts
     nameSpellingFile :: Maybe FilePath,
     profileNameLimit :: Int,
     acceptAsObserver :: Maybe AcceptAsObserver,
+    captchaGenerator :: Maybe FilePath,
     directoryLog :: Maybe FilePath,
     serviceName :: T.Text,
     runCLI :: Bool,
@@ -99,6 +100,13 @@ directoryOpts appDir defaultDbName = do
             <> metavar "ACCEPT_AS_OBSERVER"
             <> help "Whether to accept all or some of the joining members without posting rights ('all', 'no-image', 'incognito')"
         )
+  captchaGenerator <-
+    optional $
+      strOption
+        ( long "captcha-generator"
+            <> metavar "CAPTCHA_GENERATOR"
+            <> help "Executable to generate captcha files, must accept text as parameter and save file to stdout as base64 up to 12500 bytes"
+        )
   directoryLog <-
     Just
       <$> strOption
@@ -129,6 +137,7 @@ directoryOpts appDir defaultDbName = do
         nameSpellingFile,
         profileNameLimit,
         acceptAsObserver,
+        captchaGenerator,
         directoryLog,
         serviceName = T.pack serviceName,
         runCLI,

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

@@ -11,7 +11,7 @@ module Directory.Service
   ( welcomeGetOpts,
     directoryService,
     directoryServiceCLI,
-    directoryChatConfig
+    acceptMemberHook
   )
 where
 
@@ -43,6 +43,7 @@ import Simplex.Chat.Core
 import Simplex.Chat.Messages
 import Simplex.Chat.Options
 import Simplex.Chat.Protocol (MsgContent (..))
+import Simplex.Chat.Store.Profiles (GroupLinkInfo (..))
 import Simplex.Chat.Store.Shared (StoreError (..))
 import Simplex.Chat.Terminal (terminalChatConfig)
 import Simplex.Chat.Terminal.Main (simplexChatCLI')
@@ -70,13 +71,15 @@ data GroupRolesStatus
   deriving (Eq)
 
 data ServiceState = ServiceState
-  { searchRequests :: TMap ContactId SearchRequest
+  { searchRequests :: TMap ContactId SearchRequest,
+    blockedWords :: TVar [String]
   }
 
 newServiceState :: IO ServiceState
 newServiceState = do
   searchRequests <- TM.emptyIO
-  pure ServiceState {searchRequests}
+  blockedWords <- newTVarIO []
+  pure ServiceState {searchRequests, blockedWords}
 
 welcomeGetOpts :: IO DirectoryOpts
 welcomeGetOpts = do
@@ -103,9 +106,9 @@ directoryServiceCLI st opts = do
   env <- newServiceState
   eventQ <- newTQueueIO
   let eventHook cc resp = atomically $ resp <$ writeTQueue eventQ (cc, resp)
-  cfg <- directoryChatConfig opts
+      chatHooks = defaultChatHooks {eventHook = Just eventHook, acceptMember = Just acceptMemberHook}
   race_
-    (simplexChatCLI' cfg {chatHooks = defaultChatHooks {eventHook}} (mkChatOpts opts) Nothing)
+    (simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing)
     (processEvents eventQ env)
   where
     processEvents eventQ env = forever $ do
@@ -121,23 +124,27 @@ directoryService st opts@DirectoryOpts {testing} user cc = do
     (_, _, resp) <- atomically . readTBQueue $ outputQ cc
     directoryServiceEvent st opts env user cc resp
 
-directoryChatConfig :: DirectoryOpts -> IO ChatConfig
-directoryChatConfig DirectoryOpts {blockedWordsFile, nameSpellingFile, blockedExtensionRules, profileNameLimit, acceptAsObserver} = do
-  blockedWords <- mapM (fmap lines . readFile) blockedWordsFile
-  spelling <- maybe (pure M.empty) (fmap (M.fromList . read) . readFile) nameSpellingFile
-  extensionRules <- maybe (pure []) (fmap read . readFile) blockedExtensionRules
-  let !bws = nubOrd . concatMap (wordVariants extensionRules) <$> blockedWords
-      !allowedProfileName = not .: containsBlockedWords spelling <$> bws
-  putStrLn $ "Blocked words: " <> show (maybe 0 length bws) <> ", spelling rules: " <> show (M.size spelling)
-  pure terminalChatConfig {allowedProfileName, profileNameLimit, acceptAsObserver}
+acceptMemberHook :: GroupInfo -> GroupLinkInfo -> Profile -> IO (Either GroupRejectionReason GroupMemberRole)
+acceptMemberHook _ GroupLinkInfo {memberRole} _ = pure $ Right memberRole
+
+-- directoryChatConfig :: DirectoryOpts -> IO ChatConfig
+-- directoryChatConfig DirectoryOpts {blockedWordsFile, nameSpellingFile, blockedExtensionRules, profileNameLimit, acceptAsObserver} = do
+  -- blockedWords <- mapM (fmap lines . readFile) blockedWordsFile
+  -- spelling <- maybe (pure M.empty) (fmap (M.fromList . read) . readFile) nameSpellingFile
+  -- extensionRules <- maybe (pure []) (fmap read . readFile) blockedExtensionRules
+  -- let !bws = nubOrd . concatMap (wordVariants extensionRules) <$> blockedWords
+  --     allowedProfileName name = not .: containsBlockedWords spelling <$> bws
+  -- putStrLn $ "Blocked words: " <> show (maybe 0 length bws) <> ", spelling rules: " <> show (M.size spelling)
+  -- pure terminalChatConfig {allowedProfileName, profileNameLimit, acceptAsObserver}
 
 directoryServiceEvent :: DirectoryStore -> DirectoryOpts -> ServiceState -> User -> ChatController -> ChatResponse -> IO ()
-directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults} ServiceState {searchRequests} user@User {userId} cc event =
+directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults} ServiceState {searchRequests, blockedWords} user@User {userId} cc event =
   forM_ (crDirectoryEvent event) $ \case
     DEContactConnected ct -> deContactConnected ct
     DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole
     DEServiceJoinedGroup ctId g owner -> deServiceJoinedGroup ctId g owner
     DEGroupUpdated {contactId, fromGroup, toGroup} -> deGroupUpdated contactId fromGroup toGroup
+    DEMemberPendingApproval g m -> deMemberPendingApproval g m
     DEContactRoleChanged g ctId role -> deContactRoleChanged g ctId role
     DEServiceRoleChanged g role -> deServiceRoleChanged g role
     DEContactRemovedFromGroup ctId g -> deContactRemovedFromGroup ctId g
@@ -163,7 +170,7 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own
     notifyOwner GroupReg {dbContactId} = sendMessage' cc dbContactId
     ctId `isOwner` GroupReg {dbContactId} = ctId == dbContactId
     withGroupReg GroupInfo {groupId, localDisplayName} err action = do
-      atomically (getGroupReg st groupId) >>= \case
+      getGroupReg st groupId >>= \case
         Just gr -> action gr
         Nothing -> logError $ "Error: " <> err <> ", group: " <> localDisplayName <> ", can't find group registration ID " <> tshow groupId
     groupInfoText GroupProfile {displayName = n, fullName = fn, description = d} =
@@ -373,6 +380,9 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own
             Just (Just msg) -> notifyOwner gr msg
             Just Nothing -> sendToApprove toGroup gr gaId
 
+    deMemberPendingApproval :: GroupInfo -> GroupMember -> IO ()
+    deMemberPendingApproval _g _m = pure ()
+
     sendToApprove :: GroupInfo -> GroupReg -> GroupApprovalId -> IO ()
     sendToApprove GroupInfo {groupProfile = p@GroupProfile {displayName, image = image'}} GroupReg {dbGroupId, dbContactId} gaId = do
       ct_ <- getContact cc dbContactId
@@ -518,8 +528,13 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own
                 _ -> processInvitation ct g
             _ -> sendReply $ "Error: the group ID " <> tshow ugrId <> " (" <> displayName <> ") is not pending confirmation."
       DCListUserGroups ->
-        atomically (getUserGroupRegs st $ contactId' ct) >>= \grs -> do
+        getUserGroupRegs st (contactId' ct) >>= \grs -> do
           sendReply $ tshow (length grs) <> " registered group(s)"
+          -- debug how it can be that user has 0 registered groups
+          when (length grs == 0) $ do
+            total <- length <$> readTVarIO (groupRegs st)
+            withSuperUsers $ \ctId -> sendMessage' cc ctId $
+              "0 registered groups for " <> localDisplayName' ct <> " (" <> tshow (contactId' ct) <> ") out of " <> tshow total <> " registrations"
           void . forkIO $ forM_ (reverse grs) $ \gr@GroupReg {userGroupRegId} ->
             sendGroupInfo ct gr userGroupRegId Nothing
       DCDeleteGroup ugrId gName ->
@@ -541,7 +556,7 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own
         knownCt = knownContact ct
         isAdmin = knownCt `elem` adminUsers || knownCt `elem` superUsers
         withUserGroupReg ugrId gName action =
-          atomically (getUserGroupReg st (contactId' ct) ugrId) >>= \case
+          getUserGroupReg st (contactId' ct) ugrId >>= \case
             Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found"
             Just gr@GroupReg {dbGroupId} -> do
               getGroup cc dbGroupId >>= \case
@@ -552,7 +567,7 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own
         sendReply = mkSendReply ct ciId
         withFoundListedGroups s_ action =
           getGroups_ s_ >>= \case
-            Just groups -> atomically (filterListedGroups st groups) >>= action
+            Just groups -> filterListedGroups st groups >>= action
             Nothing -> sendReply "Error: getGroups. Please notify the developers."
         sendSearchResults s = \case
           [] -> sendReply "No groups found"
@@ -765,7 +780,7 @@ directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, own
         Nothing -> sendReply $ "Group ID " <> tshow gId <> " not found (getGroup)"
         Just g@GroupInfo {groupProfile = GroupProfile {displayName}}
           | displayName == gName ->
-              atomically (getGroupReg st gId) >>= \case
+              getGroupReg st gId >>= \case
                 Nothing -> sendReply $ "Registration for group ID " <> tshow gId <> " not found (getGroupReg)"
                 Just gr -> action g gr
           | otherwise ->

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Directory.Store
   ( DirectoryStore (..),
@@ -10,6 +11,7 @@ module Directory.Store
     GroupRegStatus (..),
     UserGroupRegId,
     GroupApprovalId,
+    DirectoryGroupData,
     restoreDirectoryStore,
     addGroupReg,
     delGroupReg,
@@ -21,25 +23,31 @@ module Directory.Store
     filterListedGroups,
     groupRegStatusText,
     pendingApproval,
+    fromCustomData,
+    toCustomData,
   )
 where
 
 import Control.Concurrent.STM
 import Control.Monad
+import Data.Aeson ((.=), (.:), (.:?))
+import qualified Data.Aeson.KeyMap as JM
+import qualified Data.Aeson.TH as JQ
+import qualified Data.Aeson.Types as JT
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Composition ((.:))
 import Data.Int (Int64)
 import Data.List (find, foldl', sortOn)
 import Data.Map (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (isJust)
+import Data.Maybe (fromMaybe, isJust)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
 import Simplex.Chat.Types
 import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
 import Simplex.Messaging.Util (ifM)
 import System.Directory (doesFileExist, renameFile)
 import System.IO (BufferMode (..), Handle, IOMode (..), hSetBuffering, openFile)
@@ -67,6 +75,13 @@ data GroupRegData = GroupRegData
     groupRegStatus_ :: GroupRegStatus
   }
 
+data DirectoryGroupData = DirectoryGroupData
+  { nameProfanityFilter :: Bool,
+    memberAcceptance :: Maybe DirectoryMemberAcceptance
+  }
+
+data DirectoryMemberAcceptance = DMAMemberWithImage | DMACaptcha
+
 type UserGroupRegId = Int64
 
 type GroupApprovalId = Int64
@@ -106,16 +121,32 @@ grDirectoryStatus = \case
   GRSSuspendedBadRoles -> DSReserved
   _ -> DSRegistered
 
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "MA") ''DirectoryMemberAcceptance)
+
+$(JQ.deriveJSON defaultJSON ''DirectoryGroupData)
+
+fromCustomData :: Maybe CustomData -> DirectoryGroupData
+fromCustomData = \case
+  Just (CustomData o) ->
+    let nameProfanityFilter = fromMaybe False $ JT.parseMaybe (.: "nameProfanityFilter") o
+        memberAcceptance = fromMaybe Nothing $ JT.parseMaybe (.:? "memberAcceptance") o
+     in DirectoryGroupData {nameProfanityFilter, memberAcceptance}
+  Nothing -> DirectoryGroupData False Nothing
+
+toCustomData :: DirectoryGroupData -> CustomData
+toCustomData DirectoryGroupData {nameProfanityFilter = on, memberAcceptance = ma} =
+  CustomData $ JM.fromList ["nameProfanityFilter" .= on, "memberAcceptance" .= ma]
+
 addGroupReg :: DirectoryStore -> Contact -> GroupInfo -> GroupRegStatus -> IO UserGroupRegId
 addGroupReg st ct GroupInfo {groupId} grStatus = do
-  grData <- atomically addGroupReg_
+  grData <- addGroupReg_
   logGCreate st grData
   pure $ userGroupRegId_ grData
   where
     addGroupReg_ = do
       let grData = GroupRegData {dbGroupId_ = groupId, userGroupRegId_ = 1, dbContactId_ = ctId, dbOwnerMemberId_ = Nothing, groupRegStatus_ = grStatus}
       gr <- dataToGroupReg grData
-      stateTVar (groupRegs st) $ \grs ->
+      atomically $ stateTVar (groupRegs st) $ \grs ->
         let ugrId = 1 + foldl' maxUgrId 0 grs
             grData' = grData {userGroupRegId_ = ugrId}
             gr' = gr {userGroupRegId = ugrId}
@@ -149,18 +180,18 @@ setGroupRegOwner st gr owner = do
   logGUpdateOwner st (dbGroupId gr) memberId
   atomically $ writeTVar (dbOwnerMemberId gr) (Just memberId)
 
-getGroupReg :: DirectoryStore -> GroupId -> STM (Maybe GroupReg)
-getGroupReg st gId = find ((gId ==) . dbGroupId) <$> readTVar (groupRegs st)
+getGroupReg :: DirectoryStore -> GroupId -> IO (Maybe GroupReg)
+getGroupReg st gId = find ((gId ==) . dbGroupId) <$> readTVarIO (groupRegs st)
 
-getUserGroupReg :: DirectoryStore -> ContactId -> UserGroupRegId -> STM (Maybe GroupReg)
-getUserGroupReg st ctId ugrId = find (\r -> ctId == dbContactId r && ugrId == userGroupRegId r) <$> readTVar (groupRegs st)
+getUserGroupReg :: DirectoryStore -> ContactId -> UserGroupRegId -> IO (Maybe GroupReg)
+getUserGroupReg st ctId ugrId = find (\r -> ctId == dbContactId r && ugrId == userGroupRegId r) <$> readTVarIO (groupRegs st)
 
-getUserGroupRegs :: DirectoryStore -> ContactId -> STM [GroupReg]
-getUserGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVar (groupRegs st)
+getUserGroupRegs :: DirectoryStore -> ContactId -> IO [GroupReg]
+getUserGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVarIO (groupRegs st)
 
-filterListedGroups :: DirectoryStore -> [(GroupInfo, GroupSummary)] -> STM [(GroupInfo, GroupSummary)]
+filterListedGroups :: DirectoryStore -> [(GroupInfo, GroupSummary)] -> IO [(GroupInfo, GroupSummary)]
 filterListedGroups st gs = do
-  lgs <- readTVar $ listedGroups st
+  lgs <- readTVarIO $ listedGroups st
   pure $ filter (\(GroupInfo {groupId}, _) -> groupId `S.member` lgs) gs
 
 listGroup :: DirectoryStore -> GroupId -> STM ()
@@ -200,10 +231,10 @@ logGDelete :: DirectoryStore -> GroupId -> IO ()
 logGDelete st = logDLR st . GRDelete
 
 logGUpdateStatus :: DirectoryStore -> GroupId -> GroupRegStatus -> IO ()
-logGUpdateStatus st = logDLR st .: GRUpdateStatus
+logGUpdateStatus st gId = logDLR st . GRUpdateStatus gId
 
 logGUpdateOwner :: DirectoryStore -> GroupId -> GroupMemberId -> IO ()
-logGUpdateOwner st = logDLR st .: GRUpdateOwner
+logGUpdateOwner st gId = logDLR st . GRUpdateOwner gId
 
 instance StrEncoding DLRTag where
   strEncode = \case
@@ -271,10 +302,10 @@ instance StrEncoding GroupRegStatus where
       "removed" -> pure GRSRemoved
       _ -> fail "invalid GroupRegStatus"
 
-dataToGroupReg :: GroupRegData -> STM GroupReg
+dataToGroupReg :: GroupRegData -> IO GroupReg
 dataToGroupReg GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} = do
-  dbOwnerMemberId <- newTVar dbOwnerMemberId_
-  groupRegStatus <- newTVar groupRegStatus_
+  dbOwnerMemberId <- newTVarIO dbOwnerMemberId_
+  groupRegStatus <- newTVarIO groupRegStatus_
   pure
     GroupReg
       { dbGroupId = dbGroupId_,
@@ -286,10 +317,9 @@ dataToGroupReg GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerM
 
 restoreDirectoryStore :: Maybe FilePath -> IO DirectoryStore
 restoreDirectoryStore = \case
-  Just f -> ifM (doesFileExist f) (restore f) (newFile f >>= new . Just)
-  Nothing -> new Nothing
+  Just f -> ifM (doesFileExist f) (restore f) (newFile f >>= newDirectoryStore . Just)
+  Nothing -> newDirectoryStore Nothing
   where
-    new = atomically . newDirectoryStore
     newFile f = do
       h <- openFile f WriteMode
       hSetBuffering h LineBuffering
@@ -298,15 +328,15 @@ restoreDirectoryStore = \case
       grs <- readDirectoryData f
       renameFile f (f <> ".bak")
       h <- writeDirectoryData f grs -- compact
-      atomically $ mkDirectoryStore h grs
+      mkDirectoryStore h grs
 
 emptyStoreData :: ([GroupReg], Set GroupId, Set GroupId)
 emptyStoreData = ([], S.empty, S.empty)
 
-newDirectoryStore :: Maybe Handle -> STM DirectoryStore
+newDirectoryStore :: Maybe Handle -> IO DirectoryStore
 newDirectoryStore = (`mkDirectoryStore_` emptyStoreData)
 
-mkDirectoryStore :: Handle -> [GroupRegData] -> STM DirectoryStore
+mkDirectoryStore :: Handle -> [GroupRegData] -> IO DirectoryStore
 mkDirectoryStore h groups =
   foldM addGroupRegData emptyStoreData groups >>= mkDirectoryStore_ (Just h)
   where
@@ -318,11 +348,11 @@ mkDirectoryStore h groups =
         DSReserved -> (grs', listed, S.insert gId reserved)
         DSRegistered -> (grs', listed, reserved)
 
-mkDirectoryStore_ :: Maybe Handle -> ([GroupReg], Set GroupId, Set GroupId) -> STM DirectoryStore
+mkDirectoryStore_ :: Maybe Handle -> ([GroupReg], Set GroupId, Set GroupId) -> IO DirectoryStore
 mkDirectoryStore_ h (grs, listed, reserved) = do
-  groupRegs <- newTVar grs
-  listedGroups <- newTVar listed
-  reservedGroups <- newTVar reserved
+  groupRegs <- newTVarIO grs
+  listedGroups <- newTVarIO listed
+  reservedGroups <- newTVarIO reserved
   pure DirectoryStore {groupRegs, listedGroups, reservedGroups, directoryLogFile = h}
 
 readDirectoryData :: FilePath -> IO [GroupRegData]

simplex-chat.cabal

@@ -418,7 +418,8 @@ executable simplex-directory-service
       Paths_simplex_chat
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
   build-depends:
-      async ==2.2.*
+      aeson ==2.2.*
+    , async ==2.2.*
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , composition ==1.0.*

src/Simplex/Chat.hs

@@ -112,9 +112,6 @@ defaultChatConfig =
             ntf = _defaultNtfServers,
             netCfg = defaultNetworkConfig
           },
-      allowedProfileName = Nothing,
-      profileNameLimit = maxBound,
-      acceptAsObserver = Nothing,
       tbqSize = 1024,
       fileChunkSize = 15780, -- do not change
       xftpDescrPartSize = 14000,

src/Simplex/Chat/Controller.hs

@@ -60,7 +60,7 @@ import Simplex.Chat.Protocol
 import Simplex.Chat.Remote.AppVersion
 import Simplex.Chat.Remote.Types
 import Simplex.Chat.Stats (PresentedServersSummary)
-import Simplex.Chat.Store (AutoAccept, ChatLockEntity, StoreError (..), UserContactLink, UserMsgReceiptSettings)
+import Simplex.Chat.Store (AutoAccept, ChatLockEntity, StoreError (..), UserContactLink, GroupLinkInfo, UserMsgReceiptSettings)
 import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences
 import Simplex.Chat.Types.Shared
@@ -137,9 +137,6 @@ data ChatConfig = ChatConfig
     chatVRange :: VersionRangeChat,
     confirmMigrations :: MigrationConfirmation,
     presetServers :: PresetServers,
-    allowedProfileName :: Maybe (ContactName -> Bool),
-    profileNameLimit :: Int,
-    acceptAsObserver :: Maybe AcceptAsObserver,
     tbqSize :: Natural,
     fileChunkSize :: Integer,
     xftpDescrPartSize :: Int,
@@ -177,18 +174,16 @@ data ChatHooks = ChatHooks
   { -- preCmdHook can be used to process or modify the commands before they are processed.
     -- This hook should be used to process CustomChatCommand.
     -- if this hook returns ChatResponse, the command processing will be skipped.
-    preCmdHook :: ChatController -> ChatCommand -> IO (Either ChatResponse ChatCommand),
+    preCmdHook :: Maybe (ChatController -> ChatCommand -> IO (Either ChatResponse ChatCommand)),
     -- eventHook can be used to additionally process or modify events,
     -- it is called before the event is sent to the user (or to the UI).
-    eventHook :: ChatController -> ChatResponse -> IO ChatResponse
+    eventHook :: Maybe (ChatController -> ChatResponse -> IO ChatResponse),
+    -- acceptMember hook can be used to accept or reject member connecting via group link without API calls
+    acceptMember :: Maybe (GroupInfo -> GroupLinkInfo -> Profile -> IO (Either GroupRejectionReason GroupMemberRole))
   }
 
 defaultChatHooks :: ChatHooks
-defaultChatHooks =
-  ChatHooks
-    { preCmdHook = \_ -> pure . Right,
-      eventHook = \_ -> pure
-    }
+defaultChatHooks = ChatHooks Nothing Nothing Nothing
 
 data PresetServers = PresetServers
   { operators :: NonEmpty PresetOperator,
@@ -1510,7 +1505,9 @@ toView = lift . toView'
 toView' :: ChatResponse -> CM' ()
 toView' ev = do
   cc@ChatController {outputQ = localQ, remoteCtrlSession = session, config = ChatConfig {chatHooks}} <- ask
-  event <- liftIO $ eventHook chatHooks cc ev
+  event <- case eventHook chatHooks of
+    Just hook -> liftIO $ hook cc ev
+    Nothing -> pure ev
   atomically $
     readTVar session >>= \case
       Just (_, RCSessionConnected {remoteOutputQ})

src/Simplex/Chat/Library/Commands.hs

@@ -277,7 +277,9 @@ execChatCommand rh s = do
         | otherwise -> pure $ CRChatCmdError u $ ChatErrorRemoteHost (RHId rhId) $ RHELocalCommand
       _ -> do
         cc@ChatController {config = ChatConfig {chatHooks}} <- ask
-        liftIO (preCmdHook chatHooks cc cmd) >>= either pure (execChatCommand_ u)
+        case preCmdHook chatHooks of
+          Just hook -> liftIO (hook cc cmd) >>= either pure (execChatCommand_ u)
+          Nothing -> execChatCommand_ u cmd
 
 execChatCommand' :: ChatCommand -> CM' ChatResponse
 execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd)

src/Simplex/Chat/Library/Subscriber.hs

@@ -47,7 +47,7 @@ import Simplex.Chat.Library.Internal
 import Simplex.Chat.Messages
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Messages.CIContent.Events
-import Simplex.Chat.ProfileGenerator (generateRandomProfile, isRandomName)
+import Simplex.Chat.ProfileGenerator (generateRandomProfile)
 import Simplex.Chat.Protocol
 import Simplex.Chat.Store
 import Simplex.Chat.Store.Connections
@@ -1296,7 +1296,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
       _ -> pure ()
       where
         profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> PQSupport -> CM ()
-        profileContactRequest invId chatVRange p@Profile {displayName, image} xContactId_ reqPQSup = do
+        profileContactRequest invId chatVRange p@Profile {displayName} xContactId_ reqPQSup = do
           withStore (\db -> createOrUpdateContactRequest db vr user userContactLinkId invId chatVRange p xContactId_ reqPQSup) >>= \case
             CORContact contact -> toView $ CRContactRequestAlreadyAccepted user contact
             CORGroup gInfo -> toView $ CRBusinessRequestAlreadyAccepted user gInfo
@@ -1321,20 +1321,20 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
                         incognitoProfile <- if acceptIncognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
                         ct <- acceptContactRequestAsync user cReq incognitoProfile reqPQSup
                         toView $ CRAcceptingContactRequest user ct
-                      Just GroupLinkInfo {groupId, memberRole = gLinkMemRole, acceptance = _acceptance} -> do
+                      Just gli@GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
                         gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
-                        cfg <- asks config
-                        case rejectionReason cfg of
-                          Nothing
+                        acceptMember_ <- asks $ acceptMember . chatHooks . config
+                        maybe (pure $ Right gLinkMemRole) (\am -> liftIO $ am gInfo gli p) acceptMember_ >>= \case
+                          Right useRole
                             | v < groupFastLinkJoinVersion ->
                                 messageError "processUserContactRequest: chat version range incompatible for accepting group join request"
                             | otherwise -> do
                                 let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
-                                    useRole = userMemberRole gLinkMemRole $ acceptAsObserver cfg
+                                    -- useRole = userMemberRole gLinkMemRole $ acceptAsObserver cfg
                                 mem <- acceptGroupJoinRequestAsync user gInfo cReq useRole profileMode
                                 createInternalChatItem user (CDGroupRcv gInfo mem) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
                                 toView $ CRAcceptingGroupJoinRequestMember user gInfo mem
-                          Just rjctReason
+                          Left rjctReason
                             | v < groupJoinRejectVersion ->
                                 messageWarning $ "processUserContactRequest (group " <> groupName' gInfo <> "): joining of " <> displayName <> " is blocked"
                             | otherwise -> do
@@ -1342,17 +1342,17 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
                                 toViewTE $ TERejectingGroupJoinRequestMember user gInfo mem rjctReason
                 _ -> toView $ CRReceivedContactRequest user cReq
           where
-            rejectionReason ChatConfig {profileNameLimit, allowedProfileName}
-              | T.length displayName > profileNameLimit = Just GRRLongName
-              | maybe False (\f -> not $ f displayName) allowedProfileName = Just GRRBlockedName
-              | otherwise = Nothing
-            userMemberRole linkRole = \case
-              Just AOAll -> GRObserver
-              Just AONameOnly | noImage -> GRObserver
-              Just AOIncognito | noImage && isRandomName displayName -> GRObserver
-              _ -> linkRole
-              where
-                noImage = maybe True (\(ImageData i) -> i == "") image
+            -- rejectionReason ChatConfig {profileNameLimit, allowedProfileName}
+            --   | T.length displayName > profileNameLimit = Just GRRLongName
+            --   | maybe False (\f -> not $ f displayName) allowedProfileName = Just GRRBlockedName
+            --   | otherwise = Nothing
+            -- userMemberRole linkRole = \case
+            --   Just AOAll -> GRObserver
+            --   Just AONameOnly | noImage -> GRObserver
+            --   Just AOIncognito | noImage && isRandomName displayName -> GRObserver
+            --   _ -> linkRole
+            --   where
+            --     noImage = maybe True (\(ImageData i) -> i == "") image
 
     memberCanSend :: GroupMember -> CM () -> CM ()
     memberCanSend GroupMember {memberRole} a

src/Simplex/Chat/ProfileGenerator.hs

@@ -2,8 +2,6 @@
 
 module Simplex.Chat.ProfileGenerator where
 
-import qualified Data.Attoparsec.Text as A
-import Data.Either (isRight)
 import Data.Text (Text)
 import Simplex.Chat.Types (Profile (..))
 import System.Random (randomRIO)
@@ -25,15 +23,6 @@ generateRandomProfile = do
             then pickNoun adjective (n - 1)
             else pure noun
 
--- This function does not check for exact match with this disctionary,
--- it only checks for the WordWord style.
-isRandomName :: Text -> Bool
-isRandomName = isRight . A.parseOnly randomNameP
-  where
-    randomNameP = A.satisfy upper >> A.takeWhile1 lower >> A.satisfy upper >> A.takeWhile1 lower >> A.endOfInput
-    upper c = c >= 'A' && c <= 'Z'
-    lower c = c >= 'a' && c <= 'z'
-
 adjectives :: [Text]
 adjectives =
   [ "Abatic",

src/Simplex/Chat/Store.hs

@@ -6,6 +6,7 @@ module Simplex.Chat.Store
     ChatLockEntity (..),
     UserMsgReceiptSettings (..),
     UserContactLink (..),
+    GroupLinkInfo (..),
     AutoAccept (..),
     createChatStore,
     migrations, -- used in tests