diff --git a/apps/simplex-directory-service/Main.hs b/apps/simplex-directory-service/Main.hs index b01f088483..1fd3d26873 100644 --- a/apps/simplex-directory-service/Main.hs +++ b/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 diff --git a/apps/simplex-directory-service/src/Directory/BlockedWords.hs b/apps/simplex-directory-service/src/Directory/BlockedWords.hs index 7477226e53..03a4f45113 100644 --- a/apps/simplex-directory-service/src/Directory/BlockedWords.hs +++ b/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 = diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index adaccf612f..b8e6c2d3d7 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/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 diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs index 277d332cf6..cb429e821d 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/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, diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 543ba2c84e..d54f071c87 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/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 -> diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index cecb253e8d..b6707f9761 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/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] diff --git a/simplex-chat.cabal b/simplex-chat.cabal index ee688a1c2c..78add906bf 100644 --- a/simplex-chat.cabal +++ b/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.* diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 89bd16b273..bf07e4ae51 100644 --- a/src/Simplex/Chat.hs +++ b/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, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index a86dffaa7e..5e39e74da4 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/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}) diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 9905869210..0f33a9d7e3 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/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) diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index c831e7c0fa..279ad24164 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/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 diff --git a/src/Simplex/Chat/ProfileGenerator.hs b/src/Simplex/Chat/ProfileGenerator.hs index 8380bb58f1..95f5f16207 100644 --- a/src/Simplex/Chat/ProfileGenerator.hs +++ b/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", diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 03b4d7a640..a41641f88d 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -6,6 +6,7 @@ module Simplex.Chat.Store ChatLockEntity (..), UserMsgReceiptSettings (..), UserContactLink (..), + GroupLinkInfo (..), AutoAccept (..), createChatStore, migrations, -- used in tests