captcha

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

@@ -3,7 +3,6 @@
 
 module Directory.BlockedWords where
 
-import Control.Concurrent.STM
 import Data.Char (isMark, isPunctuation, isSpace)
 import Data.List (isPrefixOf)
 import Data.Maybe (fromMaybe)

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

@@ -46,7 +46,8 @@ 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
+  | DEPendingMember GroupInfo GroupMember
+  | DEPendingMemberMsg GroupInfo GroupMember Text
   | DEContactRoleChanged GroupInfo ContactId GroupMemberRole -- contactId here is the contact whose role changed
   | DEServiceRoleChanged GroupInfo GroupMemberRole
   | DEContactRemovedFromGroup ContactId GroupInfo
@@ -66,9 +67,12 @@ 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
+  CRJoinedGroupMember {groupInfo, member = m}
+    | pending m -> Just $ DEPendingMember groupInfo m
     | otherwise -> Nothing
+  CRNewChatItems {chatItems = AChatItem _ _ (GroupChat g) ci : _} -> case ci of
+    ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent (MCText t)} | pending m -> Just $ DEPendingMemberMsg g m t
+    _ -> Nothing
   CRMemberRole {groupInfo, member, toRole}
     | groupMemberId' member == groupMemberId' (membership groupInfo) -> Just $ DEServiceRoleChanged groupInfo toRole
     | otherwise -> (\ctId -> DEContactRoleChanged groupInfo ctId toRole) <$> memberContactId member
@@ -93,6 +97,8 @@ crDirectoryEvent = \case
     _ -> Just $ DELogChatResponse $ "chat error: " <> tshow chatError
   CRChatErrors {chatErrors} -> Just $ DELogChatResponse $ "chat errors: " <> T.intercalate ", " (map tshow chatErrors)
   _ -> Nothing
+  where
+    pending m = memberStatus m == GSMemPendingApproval
 
 data DirectoryRole = DRUser | DRAdmin | DRSuperUser
 
@@ -264,7 +270,7 @@ directoryCmdP =
       where
         gc f = f <$> (spacesP *> A.decimal) <*> (A.char ':' *> displayNameTextP)
         gc_ f = f <$> (spacesP *> A.decimal) <*> optional (A.char ':' *> displayNameTextP)
-        wordP = spacesP *> A.takeTill (== ' ')
+        -- wordP = spacesP *> A.takeTill (== ' ')
         spacesP = A.takeWhile1 (== ' ')
 
 viewName :: Text -> Text

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

@@ -13,7 +13,6 @@ module Directory.Options
 where
 
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
 import Options.Applicative
 import Simplex.Chat.Bot.KnownContacts
 import Simplex.Chat.Controller (updateStr, versionNumber, versionString)
@@ -29,7 +28,7 @@ data DirectoryOpts = DirectoryOpts
     blockedExtensionRules :: Maybe FilePath,
     nameSpellingFile :: Maybe FilePath,
     profileNameLimit :: Int,
-    captchaGenerator :: Maybe FilePath,
+    captchaGenerator :: FilePath,
     directoryLog :: Maybe FilePath,
     serviceName :: T.Text,
     runCLI :: Bool,
@@ -100,12 +99,11 @@ directoryOpts appDir defaultDbName = do
           <> value maxBound
       )
   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"
-        )
+    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
@@ -173,15 +171,3 @@ mkChatOpts DirectoryOpts {coreOptions} =
       markRead = False,
       maintenance = False
     }
-
-data AcceptAsObserver
-  = AOAll -- all members
-  | AONoImage -- members without image
-
-parseAcceptAsObserver :: ReadM AcceptAsObserver
-parseAcceptAsObserver = eitherReader $ decodeAAO . encodeUtf8 . T.pack
-  where
-    decodeAAO = \case
-      "all" -> Right AOAll
-      "no-image" -> Right AONoImage
-      _ -> Left "bad AcceptAsObserver"

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

@@ -5,6 +5,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -24,8 +25,6 @@ import qualified Control.Exception as E
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
-import Control.Monad.IO.Class
-import Data.Containers.ListUtils (nubOrd)
 import Data.List (find, intercalate)
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust, maybeToList)
@@ -34,7 +33,7 @@ import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
-import Data.Time.Clock (diffUTCTime, getCurrentTime)
+import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
 import Data.Time.LocalTime (getCurrentTimeZone)
 import Directory.BlockedWords
 import Directory.Events
@@ -49,7 +48,7 @@ import Simplex.Chat.Messages
 import Simplex.Chat.Options
 import Simplex.Chat.Protocol (MsgContent (..))
 import Simplex.Chat.Store.Direct (getContact)
-import Simplex.Chat.Store.Profiles (GroupLinkInfo (..))
+import Simplex.Chat.Store.Profiles (GroupLinkInfo (..), getGroupLinkInfo)
 import Simplex.Chat.Store.Shared (StoreError (..))
 import Simplex.Chat.Terminal (terminalChatConfig)
 import Simplex.Chat.Terminal.Main (simplexChatCLI')
@@ -63,6 +62,8 @@ import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (safeDecodeUtf8, tshow, ($>>=), (<$$>))
 import System.Directory (getAppUserDataDirectory)
+import System.Process (readProcess)
+import System.Random (randomRIO)
 
 data GroupProfileUpdate = GPNoServiceLink | GPServiceLinkAdded | GPServiceLinkRemoved | GPHasServiceLink | GPServiceLinkError
 
@@ -80,14 +81,31 @@ data GroupRolesStatus
 
 data ServiceState = ServiceState
   { searchRequests :: TMap ContactId SearchRequest,
-    blockedWordsCfg :: BlockedWordsConfig
+    blockedWordsCfg :: BlockedWordsConfig,
+    pendingCaptchas :: TMap GroupMemberId PendingCaptcha
   }
 
+data PendingCaptcha = PendingCaptcha
+  { captchaText :: Text,
+    sentAt :: UTCTime,
+    attempts :: Int
+  }
+
+captchaLength :: Int
+captchaLength = 7
+
+maxCaptchaAttempts :: Int
+maxCaptchaAttempts = 5
+
+captchaTTL :: NominalDiffTime
+captchaTTL = 600 -- 10 minutes
+
 newServiceState :: DirectoryOpts -> IO ServiceState
 newServiceState opts = do
   searchRequests <- TM.emptyIO
   blockedWordsCfg <- readBlockedWordsConfig opts
-  pure ServiceState {searchRequests, blockedWordsCfg}
+  pendingCaptchas <- TM.emptyIO
+  pure ServiceState {searchRequests, blockedWordsCfg, pendingCaptchas}
 
 welcomeGetOpts :: IO DirectoryOpts
 welcomeGetOpts = do
@@ -132,27 +150,35 @@ directoryService st opts@DirectoryOpts {testing} env user cc = do
     directoryServiceEvent st opts env user cc resp
 
 acceptMemberHook :: DirectoryOpts -> ServiceState -> GroupInfo -> GroupLinkInfo -> Profile -> IO (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
-acceptMemberHook DirectoryOpts {profileNameLimit} ServiceState {blockedWordsCfg} GroupInfo {customData} GroupLinkInfo {acceptance, memberRole} p = runExceptT $ do
-  let DirectoryGroupData {memberAcceptance = ma} = fromCustomData customData
-  case filterNames ma of
-    Just c | p `satisfies` c -> checkName p
-    _ -> pure ()
-  pure $ case useCaptcha ma of
-    Just c | p `satisfies` c -> (GAManual, GRMember)
-    _ -> case makeObserver ma of
-      Just c' | p `satisfies` c' -> (GAAuto, GRObserver)
-      _ -> (GAAuto, GRMember)
-  where
-    satisfies :: Profile -> ProfileCondition -> Bool
-    satisfies Profile {image} = \case
-      PCAll -> True
-      PCNoImage -> maybe True (\(ImageData i) -> i == "") image
-    checkName :: Profile -> ExceptT GroupRejectionReason IO ()
-    checkName Profile {displayName}
-      | T.length displayName > profileNameLimit = throwError GRRLongName
-      | otherwise = do
-          when (hasBlockedFragments blockedWordsCfg displayName) $ throwError GRRBlockedName
-          when (hasBlockedWords blockedWordsCfg displayName) $ throwError GRRBlockedName
+acceptMemberHook
+  DirectoryOpts {profileNameLimit}
+  ServiceState {blockedWordsCfg}
+  g
+  GroupLinkInfo {memberRole}
+  Profile {displayName, image = img} = runExceptT $ do
+    let a = groupMemberAcceptance g
+    when (useMemberFilter img $ filterNames a) checkName
+    pure $
+      if
+        | useMemberFilter img (useCaptcha a) -> (GAManual, GRMember)
+        | useMemberFilter img (makeObserver a) -> (GAAuto, GRObserver)
+        | otherwise -> (GAAuto, memberRole)
+    where
+      checkName :: ExceptT GroupRejectionReason IO ()
+      checkName
+        | T.length displayName > profileNameLimit = throwError GRRLongName
+        | otherwise = do
+            when (hasBlockedFragments blockedWordsCfg displayName) $ throwError GRRBlockedName
+            when (hasBlockedWords blockedWordsCfg displayName) $ throwError GRRBlockedName
+
+groupMemberAcceptance :: GroupInfo -> DirectoryMemberAcceptance
+groupMemberAcceptance GroupInfo {customData} = memberAcceptance $ fromCustomData customData
+
+useMemberFilter :: Maybe ImageData -> Maybe ProfileCondition -> Bool
+useMemberFilter img_ = \case
+  Just PCAll -> True
+  Just PCNoImage -> maybe True (\(ImageData i) -> i == "") img_
+  Nothing -> False
 
 readBlockedWordsConfig :: DirectoryOpts -> IO BlockedWordsConfig
 readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, nameSpellingFile, blockedExtensionRules} = do
@@ -165,13 +191,14 @@ readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, na
   pure BlockedWordsConfig {blockedFragments, blockedWords, extensionRules, spelling}
 
 directoryServiceEvent :: DirectoryStore -> DirectoryOpts -> ServiceState -> User -> ChatController -> ChatResponse -> IO ()
-directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults} ServiceState {searchRequests, blockedWordsCfg} user@User {userId} cc event =
+directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults} env@ServiceState {searchRequests} 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
+    DEPendingMember g m -> dePendingMember g m
+    DEPendingMemberMsg g m t -> dePendingMemberMsg g m t
     DEContactRoleChanged g ctId role -> deContactRoleChanged g ctId role
     DEServiceRoleChanged g role -> deServiceRoleChanged g role
     DEContactRemovedFromGroup ctId g -> deContactRemovedFromGroup ctId g
@@ -407,8 +434,76 @@ 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 ()
+    dePendingMember :: GroupInfo -> GroupMember -> IO ()
+    dePendingMember g m
+      | memberRequiresCaptcha a m = sendMemberCaptcha g m captchaNotice 0
+      | otherwise = approvePendingMember a g m
+      where
+        a = groupMemberAcceptance g
+        captchaNotice = "This image is generated in SimpleX Directory service, without any 3rd party APIs.\nEnter the text in the image to join group."
+
+    sendMemberCaptcha :: GroupInfo -> GroupMember -> Text -> Int -> IO ()
+    sendMemberCaptcha GroupInfo {groupId} m noticeText prevAttempts = do
+      s <- getCaptchaStr captchaLength ""
+      img <- getCaptcha s
+      sentAt <- getCurrentTime
+      let captcha = PendingCaptcha {captchaText = T.pack s, sentAt, attempts = prevAttempts + 1}
+      atomically $ TM.insert gmId captcha $ pendingCaptchas env
+      sendCaptcha $ ImageData img
+      where
+        getCaptchaStr 0 s = pure s
+        getCaptchaStr n s = do
+          i <- randomRIO (0, length chars - 1)
+          let c = chars !! i
+          getCaptchaStr (n - 1) (c : s)
+        chars = "23456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
+        getCaptcha t = T.pack <$> readProcess (captchaGenerator opts) [t] ""
+        sendCaptcha img = sendComposedMessages cc (SRGroup groupId $ Just gmId) [MCText noticeText, MCImage "" img]
+        gmId = groupMemberId' m
+
+    approvePendingMember :: DirectoryMemberAcceptance -> GroupInfo -> GroupMember -> IO ()
+    approvePendingMember a g@GroupInfo {groupId} m@GroupMember {memberProfile = LocalProfile {displayName, image}} = do
+      gli_ <- join <$> withDB' cc (\db -> getGroupLinkInfo db userId groupId)
+      let role = if useMemberFilter image (makeObserver a) then GRObserver else maybe GRMember (\GroupLinkInfo {memberRole} -> memberRole) gli_
+          gmId = groupMemberId' m
+      sendChatCmd cc (APIAcceptMember groupId gmId role) >>= \case
+        CRJoinedGroupMember {} -> do
+          atomically $ TM.delete gmId $ pendingCaptchas env
+          logInfo $ "Member " <> viewName displayName <> " accepted, group " <> tshow groupId <> ":" <> viewGroupName g
+        r -> logError $ "unexpected accept member response: " <> tshow r
+
+    dePendingMemberMsg :: GroupInfo -> GroupMember -> Text -> IO ()
+    dePendingMemberMsg g@GroupInfo {groupId} m@GroupMember {memberProfile = LocalProfile {displayName}} msgText
+      | memberRequiresCaptcha a m = do
+          ts <- getCurrentTime
+          atomically (TM.lookup (groupMemberId' m) $ pendingCaptchas env) >>= \case
+            Just PendingCaptcha {captchaText, sentAt, attempts}
+              | ts `diffUTCTime` sentAt > captchaTTL -> sendMemberCaptcha g m captchaExpired $ attempts - 1
+              | captchaText == msgText -> approvePendingMember a g m
+              | attempts >= maxCaptchaAttempts -> rejectPendingMember tooManyAttempts
+              | otherwise -> sendMemberCaptcha g m (wrongCaptcha attempts) attempts
+            Nothing -> sendMemberCaptcha g m noCaptcha 0
+      | otherwise = approvePendingMember a g m
+      where
+        a = groupMemberAcceptance g
+        rejectPendingMember rjctNotice = do
+          let gmId = groupMemberId' m
+          sendComposedMessages cc (SRGroup groupId $ Just gmId) [MCText rjctNotice]
+          sendChatCmd cc (APIRemoveMembers groupId [gmId]) >>= \case
+            CRUserDeletedMembers _ _ (_ : _) -> do
+              atomically $ TM.delete gmId $ pendingCaptchas env
+              logInfo $ "Member " <> viewName displayName <> " rejected, group " <> tshow groupId <> ":" <> viewGroupName g
+            r -> logError $ "unexpected remove member response: " <> tshow r
+        captchaExpired = "Captcha expired, please try again."
+        wrongCaptcha attempts
+          | attempts == maxCaptchaAttempts - 1 = "Incorrect text, please try again - this is your last attempt."
+          | otherwise = "Incorrect text, please try again."
+        noCaptcha = "Unexpected message, please try again."
+        tooManyAttempts = "Too many failed attempts, you can't join group."
+
+    memberRequiresCaptcha :: DirectoryMemberAcceptance -> GroupMember -> Bool
+    memberRequiresCaptcha a GroupMember {memberProfile = LocalProfile {image}} = do
+      useMemberFilter image $ useCaptcha a
 
     sendToApprove :: GroupInfo -> GroupReg -> GroupApprovalId -> IO ()
     sendToApprove GroupInfo {groupProfile = p@GroupProfile {displayName, image = image'}} GroupReg {dbGroupId, dbContactId} gaId = do
@@ -846,6 +941,9 @@ getGroup cc gId = resp <$> sendChatCmd cc (APIGroupInfo gId)
       CRGroupInfo {groupInfo} -> Just groupInfo
       _ -> Nothing
 
+withDB' :: ChatController -> (DB.Connection -> IO a) -> IO (Maybe a)
+withDB' cc a = withDB cc $ ExceptT . fmap Right . a
+
 withDB :: ChatController -> (DB.Connection -> ExceptT StoreError IO a) -> IO (Maybe a)
 withDB ChatController {chatStore} action = do
   r_ :: Either ChatError a <- withTransaction chatStore (runExceptT . withExceptT ChatErrorStore . action) `E.catches` handleDBErrors

simplex-chat.cabal

@@ -427,6 +427,8 @@ executable simplex-directory-service
     , directory ==1.3.*
     , mtl >=2.3.1 && <3.0
     , optparse-applicative >=0.15 && <0.17
+    , process >=1.6 && <1.6.18
+    , random >=1.1 && <1.3
     , simple-logger ==0.1.*
     , simplex-chat
     , simplexmq >=6.3

src/Simplex/Chat/Bot.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE TupleSections #-}
 
 module Simplex.Chat.Bot where
 
@@ -11,6 +12,8 @@ import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Monad
 import qualified Data.ByteString.Char8 as B
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as L
 import qualified Data.Map.Strict as M
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -68,10 +71,16 @@ sendComposedMessage :: ChatController -> Contact -> Maybe ChatItemId -> MsgConte
 sendComposedMessage cc = sendComposedMessage' cc . contactId'
 
 sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
-sendComposedMessage' cc ctId quotedItemId msgContent = do
-  let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent, mentions = M.empty}
-  sendChatCmd cc (APISendMessages (SRDirect ctId) False Nothing [cm]) >>= \case
-    CRNewChatItems {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId
+sendComposedMessage' cc ctId qiId mc = sendComposedMessages_ cc (SRDirect ctId) [(qiId, mc)]
+
+sendComposedMessages :: ChatController -> SendRef -> NonEmpty MsgContent -> IO ()
+sendComposedMessages cc sendRef = sendComposedMessages_ cc sendRef . L.map (Nothing,)
+
+sendComposedMessages_ :: ChatController -> SendRef -> NonEmpty (Maybe ChatItemId, MsgContent) -> IO ()
+sendComposedMessages_ cc sendRef qmcs = do
+  let cms = L.map (\(qiId, mc) -> ComposedMessage {fileSource = Nothing, quotedItemId = qiId, msgContent = mc, mentions = M.empty}) qmcs
+  sendChatCmd cc (APISendMessages sendRef False Nothing cms) >>= \case
+    CRNewChatItems {} -> printLog cc CLLInfo $ "sent " <> show (length cms) <> " messages to " <> show sendRef
     r -> putStrLn $ "unexpected send message response: " <> show r
 
 deleteMessage :: ChatController -> Contact -> ChatItemId -> IO ()

src/Simplex/Chat/Store/Profiles.hs

@@ -48,6 +48,7 @@ module Simplex.Chat.Store.Profiles
     deleteUserAddress,
     getUserAddress,
     getUserContactLinkById,
+    getGroupLinkInfo,
     getUserContactLinkByConnReq,
     getContactWithoutConnViaAddress,
     updateUserAddressAutoAccept,
@@ -492,20 +493,25 @@ getUserAddress db User {userId} =
 getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo)
 getUserContactLinkById db userId userContactLinkId =
   ExceptT . firstRow (\(ucl :. gli) -> (toUserContactLink ucl, toGroupLinkInfo gli)) SEUserContactLinkNotFound $
-    DB.query
-      db
-      [sql|
-        SELECT conn_req_contact, auto_accept, business_address, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_auto_accept, group_link_member_role
-        FROM user_contact_links
-        WHERE user_id = ?
-          AND user_contact_link_id = ?
-      |]
-      (userId, userContactLinkId)
-  where
-    toGroupLinkInfo :: (Maybe GroupId, Maybe GroupAcceptance, Maybe GroupMemberRole) -> Maybe GroupLinkInfo
-    toGroupLinkInfo (groupId_, acceptance_, mRole_) =
-      (\groupId -> GroupLinkInfo {groupId, acceptance = fromMaybe GAAuto acceptance_, memberRole = fromMaybe GRMember mRole_})
-        <$> groupId_
+    DB.query db (groupLinkInfoQuery <> " AND user_contact_link_id = ?") (userId, userContactLinkId)
+
+groupLinkInfoQuery :: Query
+groupLinkInfoQuery =
+  [sql|
+    SELECT conn_req_contact, auto_accept, business_address, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_auto_accept, group_link_member_role
+    FROM user_contact_links
+    WHERE user_id = ?
+  |]
+
+toGroupLinkInfo :: (Maybe GroupId, Maybe GroupAcceptance, Maybe GroupMemberRole) -> Maybe GroupLinkInfo
+toGroupLinkInfo (groupId_, acceptance_, mRole_) =
+  (\groupId -> GroupLinkInfo {groupId, acceptance = fromMaybe GAAuto acceptance_, memberRole = fromMaybe GRMember mRole_})
+    <$> groupId_
+
+getGroupLinkInfo :: DB.Connection -> UserId -> GroupId -> IO (Maybe GroupLinkInfo)
+getGroupLinkInfo db userId groupId =
+  fmap join $ maybeFirstRow toGroupLinkInfo $ 
+    DB.query db (groupLinkInfoQuery <> " AND group_id = ?") (userId, groupId)
 
 getUserContactLinkByConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe UserContactLink)
 getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) =