From dde4548e037a4cb6f2ee62e7c1eb2884d54587ac Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sat, 1 Mar 2025 21:27:32 +0000 Subject: [PATCH] captcha --- .../src/Directory/BlockedWords.hs | 1 - .../src/Directory/Events.hs | 14 +- .../src/Directory/Options.hs | 26 +-- .../src/Directory/Service.hs | 160 ++++++++++++++---- simplex-chat.cabal | 2 + src/Simplex/Chat/Bot.hs | 17 +- src/Simplex/Chat/Store/Profiles.hs | 34 ++-- 7 files changed, 180 insertions(+), 74 deletions(-) diff --git a/apps/simplex-directory-service/src/Directory/BlockedWords.hs b/apps/simplex-directory-service/src/Directory/BlockedWords.hs index ba44a8a878..e7bffd2b23 100644 --- a/apps/simplex-directory-service/src/Directory/BlockedWords.hs +++ b/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) diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index fbc3ca2558..8127b41a90 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/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 diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs index c33f43d0d9..a27db6cff1 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/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" diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 426925d929..0837f4dc5b 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/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 diff --git a/simplex-chat.cabal b/simplex-chat.cabal index e4f263be5b..e72b681d99 100644 --- a/simplex-chat.cabal +++ b/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 diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index 9432671518..54e7baa194 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/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 () diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index b022860786..38045500ce 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/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) =