diff --git a/apps/simplex-bot-advanced/Main.hs b/apps/simplex-bot-advanced/Main.hs index 6b31a62dce..f5acebe96a 100644 --- a/apps/simplex-bot-advanced/Main.hs +++ b/apps/simplex-bot-advanced/Main.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -40,7 +39,7 @@ mySquaringBot _user cc = do race_ (forever $ void getLine) . forever $ do (_, resp) <- atomically . readTBQueue $ outputQ cc case resp of - CRContactConnected contact -> do + CRContactConnected contact _ -> do contactConnected contact void . sendMsg contact $ "Hello! I am a simple squaring bot - if you send me a number, I will calculate its square" CRNewChatItem (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content}) -> do diff --git a/docs/rfcs/2022-08-10-incognito-connections.md b/docs/rfcs/2022-08-10-incognito-connections.md new file mode 100644 index 0000000000..e25093cda4 --- /dev/null +++ b/docs/rfcs/2022-08-10-incognito-connections.md @@ -0,0 +1,51 @@ +# Incognito connections + +## Problems + +Allow users to connect with incognito profile using the same user account without exposing main profile - either with randomly generated per connection profile / no profile, or custom profile created by user per connection. The latter option involves designing complex UI for creating profile on connection and seems to detract from UX, so we consider first two options. + +## Proposal + +Add incognito mode determining whether newly created connections are incognito, and a switch on connection pages affecting current connection. + +Add API to turn incognito mode on/off - it is saved as part of ChatController state to allow terminal users to set it. We can save preference on mobile and set it on chat start. We can also persist it to database to carry across terminal sessions, but it seems unnecessary. + +Parameterize `AddContact`, `Connect` and `ConnectSimplex` API - create connection as incognito based on incognito mode and parameter, parameter is given preference. + +### Option 1 - random profile + +Add nullable field `custom_user_profile_id` to `connections` table - `incognitoProfile: Maybe Profile` in `Connection` type; when connection is created as incognito on API call, random profile is created and saved to `profiles` table. + +Incognito profile is created only with a display name, it can be: + +- Some prefix followed by sequence of random character/digits +- Passphrase-like (2-4 random words) +- A name from a dictionary(ies)? +- One of above chosen randomly. + +We could generate other parts of profile (picture?) but it's not necessary for MVP. + +When user initiates connection as incognito, incognito profile is sent as part of XInfo upon receiving CONF from joining user. + +### Option 2 - no profile + +Add `incognito` flag to `connections` table - `incognito: Bool` in `Connection` type. + +Instead of XInfo both in `Connect` API and on receiving CONF when initiating, send a message that doesn't contain profile, e.g. XOk. + +When saving connection profile (`saveConnInfo`) or processing contact request on receiving XOk / other message, contact generates a random profile for the user to distinguish from other connections. He is also able to mark this connection as incognito. + +### Considerations + +- Don't broadcast user profile updates to contacts with whom the user has established incognito connections. +- Add indication on chat info page that connection was established as incognito, show profile name so the user knows how the contact sees him. +- While profile names generated in option 1 may be distinguishable as incognito depending on generator, technically the fact that connection was established as incognito is not explicitly leaked, which is clear with option 2. +- We could offer same random profile generator on creating profiles, which would blend users with such profile as permanent and users who chose to connect with incognito profile to an observer (i.e. the fact that user chooses to be incognito for this specific connection is no longer leaked, just that he chose to be incognito generally). +- There's a use case for custom incognito profile created by user for a given connection in case user wants to hide the fact of incognito connection (leaked by distinguishable pattern in profile name or lack of profile), but it may better be solved by multi-profile. +- Send incognito profile when accepting contact requests in incognito mode? Parameterize API and give option in dialog? + +### Groups + +- If host used user's incognito connection when inviting, save same field marking group as incognito in `groups` table? +- Use incognito profile in XGrpMemInfo +- Allow host to create group in incognito profile - all connections with members are created as incognito? diff --git a/package.yaml b/package.yaml index e0e8dad315..7e5aa0834d 100644 --- a/package.yaml +++ b/package.yaml @@ -31,6 +31,7 @@ dependencies: - network >= 3.1.2.7 && < 3.2 - optparse-applicative >= 0.15 && < 0.17 - process == 1.6.* + - random >= 1.1 && < 1.3 - simple-logger == 0.1.* - simplexmq >= 3.0 - socks == 0.6.* diff --git a/simplex-chat.cabal b/simplex-chat.cabal index d78d21f178..33be0c784c 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -43,8 +43,10 @@ library Simplex.Chat.Migrations.M20220702_calls Simplex.Chat.Migrations.M20220715_groups_chat_item_id Simplex.Chat.Migrations.M20220811_chat_items_indices + Simplex.Chat.Migrations.M20220812_incognito_profiles Simplex.Chat.Mobile Simplex.Chat.Options + Simplex.Chat.ProfileGenerator Simplex.Chat.Protocol Simplex.Chat.Store Simplex.Chat.Styled @@ -80,6 +82,7 @@ library , network >=3.1.2.7 && <3.2 , optparse-applicative >=0.15 && <0.17 , process ==1.6.* + , random >=1.1 && <1.3 , simple-logger ==0.1.* , simplexmq >=3.0 , socks ==0.6.* @@ -120,6 +123,7 @@ executable simplex-bot , network >=3.1.2.7 && <3.2 , optparse-applicative >=0.15 && <0.17 , process ==1.6.* + , random >=1.1 && <1.3 , simple-logger ==0.1.* , simplex-chat , simplexmq >=3.0 @@ -161,6 +165,7 @@ executable simplex-bot-advanced , network >=3.1.2.7 && <3.2 , optparse-applicative >=0.15 && <0.17 , process ==1.6.* + , random >=1.1 && <1.3 , simple-logger ==0.1.* , simplex-chat , simplexmq >=3.0 @@ -203,6 +208,7 @@ executable simplex-chat , network ==3.1.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* + , random >=1.1 && <1.3 , simple-logger ==0.1.* , simplex-chat , simplexmq >=3.0 @@ -254,6 +260,7 @@ test-suite simplex-chat-test , network ==3.1.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* + , random >=1.1 && <1.3 , simple-logger ==0.1.* , simplex-chat , simplexmq >=3.0 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 79e7d33325..eba26284ec 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -31,13 +31,12 @@ import Data.Either (fromRight) import Data.Fixed (div') import Data.Functor (($>)) import Data.Int (Int64) -import Data.List (find, isSuffixOf, sortBy, sortOn) +import Data.List (find, isSuffixOf, sortOn) import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) -import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds) @@ -51,6 +50,7 @@ import Simplex.Chat.Controller import Simplex.Chat.Markdown import Simplex.Chat.Messages import Simplex.Chat.Options +import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.Protocol import Simplex.Chat.Store import Simplex.Chat.Types @@ -143,8 +143,9 @@ newChatController chatStore user cfg@ChatConfig {agentConfig = aCfg, tbqSize, de rcvFiles <- newTVarIO M.empty currentCalls <- atomically TM.empty filesFolder <- newTVarIO Nothing + incognitoMode <- newTVarIO False chatStoreChanged <- newTVarIO False - pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, filesFolder} + pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, incognitoMode, filesFolder} where resolveServers :: InitialAgentServers -> IO InitialAgentServers resolveServers ss@InitialAgentServers {smp = defaultSMPServers} = case nonEmpty smpServers of @@ -233,6 +234,10 @@ processChatCommand = \case ff <- asks filesFolder atomically . writeTVar ff $ Just filesFolder' pure CRCmdOk + SetIncognito onOff -> do + incognito <- asks incognitoMode + atomically . writeTVar incognito $ onOff + pure CRCmdOk APIExportArchive cfg -> checkChatStopped $ exportArchive cfg $> CRCmdOk APIImportArchive cfg -> checkChatStopped $ importArchive cfg >> setStoreChanged $> CRCmdOk APIDeleteStorage -> checkChatStopped $ deleteStorage >> setStoreChanged $> CRCmdOk @@ -254,16 +259,14 @@ processChatCommand = \case pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci where setupSndFileTransfer :: Contact -> m (Maybe (FileInvitation, CIFile 'MDSnd)) - setupSndFileTransfer ct = case file_ of - Nothing -> pure Nothing - Just file -> do - (fileSize, chSize) <- checkSndFile file - (agentConnId, fileConnReq) <- withAgent (`createConnection` SCMInvitation) - let fileName = takeFileName file - fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Just fileConnReq} - fileId <- withStore' $ \db -> createSndFileTransfer db userId ct file fileInvitation agentConnId chSize - let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored} - pure $ Just (fileInvitation, ciFile) + setupSndFileTransfer ct = forM file_ $ \file -> do + (fileSize, chSize) <- checkSndFile file + (agentConnId, fileConnReq) <- withAgent (`createConnection` SCMInvitation) + let fileName = takeFileName file + fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Just fileConnReq} + fileId <- withStore' $ \db -> createSndFileTransfer db userId ct file fileInvitation agentConnId chSize + let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored} + pure (fileInvitation, ciFile) prepareMsg :: Maybe FileInvitation -> m (MsgContainer, Maybe (CIQuote 'CTDirect)) prepareMsg fileInvitation_ = case quotedItemId_ of Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_), Nothing) @@ -291,15 +294,13 @@ processChatCommand = \case pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci where setupSndFileTransfer :: GroupInfo -> m (Maybe (FileInvitation, CIFile 'MDSnd)) - setupSndFileTransfer gInfo = case file_ of - Nothing -> pure Nothing - Just file -> do - (fileSize, chSize) <- checkSndFile file - let fileName = takeFileName file - fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Nothing} - fileId <- withStore' $ \db -> createSndGroupFileTransfer db userId gInfo file fileInvitation chSize - let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored} - pure $ Just (fileInvitation, ciFile) + setupSndFileTransfer gInfo = forM file_ $ \file -> do + (fileSize, chSize) <- checkSndFile file + let fileName = takeFileName file + fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Nothing} + fileId <- withStore' $ \db -> createSndGroupFileTransfer db userId gInfo file fileInvitation chSize + let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored} + pure (fileInvitation, ciFile) prepareMsg :: Maybe FileInvitation -> GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup)) prepareMsg fileInvitation_ membership = case quotedItemId_ of Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_), Nothing) @@ -597,11 +598,17 @@ processChatCommand = \case APISetNetworkConfig cfg -> withUser' $ \_ -> withAgent (`setNetworkConfig` cfg) $> CRCmdOk APIGetNetworkConfig -> CRNetworkConfig <$> withUser' (\_ -> withAgent getNetworkConfig) APIContactInfo contactId -> withUser $ \User {userId} -> do - ct <- withStore $ \db -> getContact db userId contactId - CRContactInfo ct <$> withAgent (`getConnectionServers` contactConnId ct) - APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do - (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId - CRGroupMemberInfo g m <$> mapM (withAgent . flip getConnectionServers) (memberConnId m) + -- [incognito] print user's incognito profile for this contact + ct@Contact {activeConn = Connection {customUserProfileId}} <- withStore $ \db -> getContact db userId contactId + incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) + connectionStats <- withAgent (`getConnectionServers` contactConnId ct) + pure $ CRContactInfo ct connectionStats incognitoProfile + APIGroupMemberInfo gId gMemberId -> withUser $ \user@User {userId} -> do + -- [incognito] print group member main profile + (g, m@GroupMember {memberContactProfileId}) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId + mainProfile <- if memberIncognito m then Just <$> withStore (\db -> getProfileById db userId memberContactProfileId) else pure Nothing + connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m) + pure $ CRGroupMemberInfo g m connectionStats mainProfile ContactInfo cName -> withUser $ \User {userId} -> do contactId <- withStore $ \db -> getContactIdByName db userId cName processChatCommand $ APIContactInfo contactId @@ -611,20 +618,29 @@ processChatCommand = \case ChatHelp section -> pure $ CRChatHelp section Welcome -> withUser $ pure . CRWelcome AddContact -> withUser $ \User {userId} -> withChatLock . procCmd $ do + -- [incognito] generate profile for connection + incognito <- readTVarIO =<< asks incognitoMode + incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing (connId, cReq) <- withAgent (`createConnection` SCMInvitation) - conn <- withStore' $ \db -> createDirectConnection db userId connId ConnNew + conn <- withStore' $ \db -> createDirectConnection db userId connId ConnNew incognitoProfile toView $ CRNewContactConnection conn pure $ CRInvitation cReq Connect (Just (ACR SCMInvitation cReq)) -> withUser $ \User {userId, profile} -> withChatLock . procCmd $ do - connId <- withAgent $ \a -> joinConnection a cReq . directMessage $ XInfo profile - conn <- withStore' $ \db -> createDirectConnection db userId connId ConnJoined + -- [incognito] generate profile to send + incognito <- readTVarIO =<< asks incognitoMode + incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing + let profileToSend = fromMaybe (fromLocalProfile profile) incognitoProfile + connId <- withAgent $ \a -> joinConnection a cReq . directMessage $ XInfo profileToSend + conn <- withStore' $ \db -> createDirectConnection db userId connId ConnJoined incognitoProfile toView $ CRNewContactConnection conn pure CRSentConfirmation Connect (Just (ACR SCMContact cReq)) -> withUser $ \User {userId, profile} -> - connectViaContact userId cReq profile + -- [incognito] generate profile to send + connectViaContact userId cReq $ fromLocalProfile profile Connect Nothing -> throwChatError CEInvalidConnReq ConnectSimplex -> withUser $ \User {userId, profile} -> - connectViaContact userId adminContactReq profile + -- [incognito] generate profile to send + connectViaContact userId adminContactReq $ fromLocalProfile profile DeleteContact cName -> withUser $ \User {userId} -> do contactId <- withStore $ \db -> getContactIdByName db userId cName processChatCommand $ APIDeleteChat (ChatRef CTDirect contactId) @@ -686,29 +702,37 @@ processChatCommand = \case processChatCommand $ APIUpdateChatItem chatRef editedItemId mc NewGroup gProfile -> withUser $ \user -> do gVar <- asks idsDrg - CRGroupCreated <$> withStore (\db -> createNewGroup db gVar user gProfile) + -- [incognito] create membership with incognito profile + incognito <- readTVarIO =<< asks incognitoMode + incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing + groupInfo <- withStore (\db -> createNewGroup db gVar user gProfile incognitoProfile) + pure $ CRGroupCreated groupInfo incognitoProfile APIAddMember groupId contactId memRole -> withUser $ \user@User {userId} -> withChatLock $ do -- TODO for large groups: no need to load all members to determine if contact is a member (group, contact) <- withStore $ \db -> (,) <$> getGroup db user groupId <*> getContact db userId contactId + -- [incognito] forbid to invite contact to whom user is connected as incognito if user's membership is not incognito let Group gInfo@GroupInfo {localDisplayName, groupProfile, membership} members = group GroupMember {memberRole = userRole, memberId = userMemberId} = membership Contact {localDisplayName = cName} = contact + when (contactConnIncognito contact && not (memberIncognito membership)) $ throwChatError CEGroupNotIncognitoCantInvite when (userRole < GRAdmin || userRole < memRole) $ throwChatError CEGroupUserRole when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined gInfo) unless (memberActive membership) $ throwChatError CEGroupMemberNotActive let sendInvitation member@GroupMember {groupMemberId, memberId} cReq = do - let groupInv = GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile + -- [incognito] if membership is incognito, send its incognito profile in GroupInvitation + let incognitoProfile = if memberIncognito membership then Just (fromLocalProfile $ memberProfile membership) else Nothing + groupInv = GroupInvitation (MemberIdRole userMemberId userRole) incognitoProfile (MemberIdRole memberId memRole) cReq groupProfile msg <- sendDirectContactMessage contact $ XGrpInv groupInv - let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole + let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending, invitedIncognito = Just $ memberIncognito membership}) memRole ci <- saveSndChatItem user (CDDirectSnd contact) msg content Nothing Nothing toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci setActive $ ActiveG localDisplayName - pure $ CRSentGroupInvitation gInfo contact member + pure $ CRSentGroupInvitation gInfo contact member incognitoProfile case contactMember contact members of Nothing -> do gVar <- asks idsDrg (agentConnId, cReq) <- withAgent (`createConnection` SCMInvitation) - member <- withStore $ \db -> createContactMember db gVar user groupId contact memRole agentConnId cReq + member <- withStore $ \db -> createNewContactMember db gVar user groupId contact memRole agentConnId cReq sendInvitation member cReq Just member@GroupMember {groupMemberId, memberStatus} | memberStatus == GSMemInvited -> @@ -719,13 +743,30 @@ processChatCommand = \case APIJoinGroup groupId -> withUser $ \user@User {userId} -> do ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} <- withStore $ \db -> getGroupInvitation db user groupId withChatLock . procCmd $ do - agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage . XGrpAcpt $ memberId (membership :: GroupMember) + -- [incognito] if (incognito mode is enabled OR direct connection with host is incognito) [AND membership is not incognito] update membership to use incognito profile + incognito <- readTVarIO =<< asks incognitoMode + hostConnIncognito <- case (incognito, memberContactId fromMember) of + (True, _) -> pure True -- we don't need to check whether connection with host is incognito if incognito mode is on + (_, Just hostContactId) -> do + hostContact <- withStore $ \db -> getContact db userId hostContactId + pure $ contactConnIncognito hostContact + _ -> pure False + g'@GroupInfo {membership = membership'} <- + if (incognito || hostConnIncognito) && not (memberIncognito membership) + then do + incognitoProfile <- liftIO generateRandomProfile + membership' <- withStore $ \db -> createMemberIncognitoProfile db userId membership (Just incognitoProfile) + pure g {membership = membership'} + else pure g + -- [incognito] if membership is incognito, send its incognito profile in XGrpAcpt + let incognitoProfile = if memberIncognito membership' then Just (fromLocalProfile $ memberProfile membership') else Nothing + agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage $ XGrpAcpt (memberId (membership' :: GroupMember)) incognitoProfile withStore' $ \db -> do createMemberConnection db userId fromMember agentConnId updateGroupMemberStatus db userId fromMember GSMemAccepted - updateGroupMemberStatus db userId membership GSMemAccepted + updateGroupMemberStatus db userId membership' GSMemAccepted updateCIGroupInvitationStatus user - pure $ CRUserAcceptedGroupSent g {membership = membership {memberStatus = GSMemAccepted}} + pure $ CRUserAcceptedGroupSent g' {membership = membership' {memberStatus = GSMemAccepted}} where updateCIGroupInvitationStatus user@User {userId} = do AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withStore $ \db -> getChatItemByGroupId db user groupId @@ -750,7 +791,7 @@ processChatCommand = \case withStore' $ \db -> deleteGroupMember db user m _ -> do msg <- sendGroupMessage gInfo members $ XGrpMemDel mId - ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent $ SGEMemberDeleted memberId memberProfile) Nothing Nothing + ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent $ SGEMemberDeleted memberId (fromLocalProfile memberProfile)) Nothing Nothing toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci deleteMemberConnection m withStore' $ \db -> updateGroupMemberStatus db userId m GSMemRemoved @@ -861,12 +902,12 @@ processChatCommand = \case pure $ CRRcvFileCancelled ftr FileStatus fileId -> CRFileTransferStatus <$> withUser (\user -> withStore $ \db -> getFileTransferProgress db user fileId) - ShowProfile -> withUser $ \User {profile} -> pure $ CRUserProfile profile + ShowProfile -> withUser $ \User {profile} -> pure $ CRUserProfile (fromLocalProfile profile) UpdateProfile displayName fullName -> withUser $ \user@User {profile} -> do - let p = (profile :: Profile) {displayName = displayName, fullName = fullName} + let p = (fromLocalProfile profile :: Profile) {displayName = displayName, fullName = fullName} updateProfile user p UpdateProfileImage image -> withUser $ \user@User {profile} -> do - let p = (profile :: Profile) {image} + let p = (fromLocalProfile profile :: Profile) {image} updateProfile user p QuitChat -> liftIO exitSuccess ShowVersion -> pure $ CRVersionInfo versionNumber @@ -910,10 +951,18 @@ processChatCommand = \case (_, xContactId_) -> procCmd $ do let randomXContactId = XContactId <$> (asks idsDrg >>= liftIO . (`randomBytes` 16)) xContactId <- maybe randomXContactId pure xContactId_ - connId <- withAgent $ \a -> joinConnection a cReq $ directMessage (XContact profile $ Just xContactId) - conn <- withStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId + -- [incognito] generate profile to send + -- if user makes a contact request using main profile, then turns on incognito mode and repeats the request, + -- an incognito profile will be sent even though the address holder will have user's main profile received as well; + -- we ignore this edge case as we already allow profile updates on repeat contact requests; + -- alternatively we can re-send the main profile even if incognito mode is enabled + incognito <- readTVarIO =<< asks incognitoMode + incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing + let profileToSend = fromMaybe profile incognitoProfile + connId <- withAgent $ \a -> joinConnection a cReq $ directMessage (XContact profileToSend $ Just xContactId) + conn <- withStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId incognitoProfile toView $ CRNewContactConnection conn - pure CRSentInvitation + pure $ CRSentInvitation incognitoProfile contactMember :: Contact -> [GroupMember] -> Maybe GroupMember contactMember Contact {contactId} = find $ \GroupMember {memberContactId = cId, memberStatus = s} -> @@ -924,17 +973,20 @@ processChatCommand = \case unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f (,) <$> getFileSize fsFilePath <*> asks (fileChunkSize . config) updateProfile :: User -> Profile -> m ChatResponse - updateProfile user@User {profile = p} p'@Profile {displayName} - | p' == p = pure CRUserProfileNoChange + updateProfile user@User {profile = p@LocalProfile {profileId}} p'@Profile {displayName} + | p' == fromLocalProfile p = pure CRUserProfileNoChange | otherwise = do withStore $ \db -> updateUserProfile db user p' - let user' = (user :: User) {localDisplayName = displayName, profile = p'} + let user' = (user :: User) {localDisplayName = displayName, profile = toLocalProfile profileId p'} asks currentUser >>= atomically . (`writeTVar` Just user') - contacts <- filter isReady <$> withStore' (`getUserContacts` user) + -- [incognito] filter out contacts with whom user has incognito connections + contacts <- + filter (\ct -> isReady ct && not (contactConnIncognito ct)) + <$> withStore' (`getUserContacts` user) withChatLock . procCmd $ do forM_ contacts $ \ct -> void (sendDirectContactMessage ct $ XInfo p') `catchError` (toView . CRChatError) - pure $ CRUserProfileUpdated p p' + pure $ CRUserProfileUpdated (fromLocalProfile p) p' isReady :: Contact -> Bool isReady ct = let s = connStatus $ activeConn (ct :: Contact) @@ -1117,8 +1169,12 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = F acceptContactRequest :: ChatMonad m => User -> UserContactRequest -> m Contact acceptContactRequest User {userId, profile} UserContactRequest {agentInvitationId = AgentInvId invId, localDisplayName = cName, profileId, profile = p, userContactLinkId, xContactId} = do - connId <- withAgent $ \a -> acceptContact a invId . directMessage $ XInfo profile - withStore' $ \db -> createAcceptedContact db userId connId cName profileId p userContactLinkId xContactId + -- [incognito] generate profile to send, create connection with incognito profile + incognito <- readTVarIO =<< asks incognitoMode + incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing + let profileToSend = fromMaybe (fromLocalProfile profile) incognitoProfile + connId <- withAgent $ \a -> acceptContact a invId . directMessage $ XInfo profileToSend + withStore' $ \db -> createAcceptedContact db userId connId cName profileId p userContactLinkId xContactId incognitoProfile agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m () agentSubscriber = do @@ -1192,7 +1248,7 @@ subscribeUserConnections agentBatchSubscribe user = do groupSubsToView :: Map ConnId (Either AgentErrorType ()) -> [Group] -> Map ConnId GroupMember -> Bool -> m () groupSubsToView rs gs ms ce = do mapM_ groupSub $ - sortBy (comparing $ \(Group GroupInfo {localDisplayName = g} _) -> g) gs + sortOn (\(Group GroupInfo {localDisplayName = g} _) -> g) gs toView . CRMemberSubSummary $ map (uncurry MemberSubStatus) mRs where mRs = resultsFor rs ms @@ -1293,11 +1349,14 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage _ -> Nothing processDirectMessage :: ACommand 'Agent -> Connection -> Maybe Contact -> m () - processDirectMessage agentMsg conn@Connection {connId, viaUserContactLink} = \case + processDirectMessage agentMsg conn@Connection {connId, viaUserContactLink, customUserProfileId} = \case Nothing -> case agentMsg of CONF confId _ connInfo -> do + -- [incognito] send saved profile + incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) + let profileToSend = fromMaybe (fromLocalProfile profile) incognitoProfile saveConnInfo conn connInfo - allowAgentConnection conn confId $ XInfo profile + allowAgentConnection conn confId $ XInfo profileToSend INFO connInfo -> saveConnInfo conn connInfo MSG meta _msgFlags msgBody -> do @@ -1358,7 +1417,9 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage CON -> withStore' (\db -> getViaGroupMember db user ct) >>= \case Nothing -> do - toView $ CRContactConnected ct + -- [incognito] print incognito profile used for this contact + incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) + toView $ CRContactConnected ct incognitoProfile setActive $ ActiveC c showToast (c <> "> ") "connected" forM_ viaUserContactLink $ \userContactLinkId -> do @@ -1386,25 +1447,26 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage -- TODO print errors MERR msgId err -> do chatItemId_ <- withStore' $ \db -> getChatItemIdByAgentMsgId db connId msgId - case chatItemId_ of - Nothing -> pure () - Just chatItemId -> do - chatItem <- withStore $ \db -> updateDirectChatItemStatus db userId contactId chatItemId (agentErrToItemStatus err) - toView $ CRChatItemStatusUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem) + forM_ chatItemId_ $ \chatItemId -> do + chatItem <- withStore $ \db -> updateDirectChatItemStatus db userId contactId chatItemId (agentErrToItemStatus err) + toView $ CRChatItemStatusUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem) ERR err -> toView . CRChatError $ ChatErrorAgent err -- TODO add debugging output _ -> pure () processGroupMessage :: ACommand 'Agent -> Connection -> GroupInfo -> GroupMember -> m () - processGroupMessage agentMsg conn gInfo@GroupInfo {groupId, localDisplayName = gName, membership} m = case agentMsg of + processGroupMessage agentMsg conn gInfo@GroupInfo {groupId, localDisplayName = gName, membership} m@GroupMember {memberContactProfileId} = case agentMsg of CONF confId _ connInfo -> do ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo case memberCategory m of GCInviteeMember -> case chatMsgEvent of - XGrpAcpt memId + XGrpAcpt memId incognitoProfile | sameMemberId memId m -> do - withStore' $ \db -> updateGroupMemberStatus db userId m GSMemAccepted + -- [incognito] update member profile to incognito profile + withStore $ \db -> do + liftIO $ updateGroupMemberStatus db userId m GSMemAccepted + void $ createMemberIncognitoProfile db userId m incognitoProfile allowAgentConnection conn confId XOk | otherwise -> messageError "x.grp.acpt: memberId is different from expected" _ -> messageError "CONF from invited member must have x.grp.acpt" @@ -1413,7 +1475,8 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage XGrpMemInfo memId _memProfile | sameMemberId memId m -> do -- TODO update member profile - allowAgentConnection conn confId $ XGrpMemInfo (memberId (membership :: GroupMember)) profile + -- [incognito] send membership incognito profile + allowAgentConnection conn confId $ XGrpMemInfo (memberId (membership :: GroupMember)) (fromLocalProfile $ memberProfile membership) | otherwise -> messageError "x.grp.mem.info: memberId is different from expected" _ -> messageError "CONF from member must have x.grp.mem.info" INFO connInfo -> do @@ -1436,13 +1499,17 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage sendPendingGroupMessages m conn case memberCategory m of GCHostMember -> do - memberConnectedChatItem gInfo m - toView $ CRUserJoinedGroup gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected} + -- [incognito] chat item & event with indication that host connected incognito + mainProfile <- if memberIncognito m then Just <$> withStore (\db -> getProfileById db userId memberContactProfileId) else pure Nothing + memberConnectedChatItem gInfo m mainProfile + toView $ CRUserJoinedGroup gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected} (memberIncognito membership) setActive $ ActiveG gName showToast ("#" <> gName) "you are connected to group" GCInviteeMember -> do - memberConnectedChatItem gInfo m - toView $ CRJoinedGroupMember gInfo m {memberStatus = GSMemConnected} + -- [incognito] chat item & event with indication that invitee connected incognito + mainProfile <- if memberIncognito m then Just <$> withStore (\db -> getProfileById db userId memberContactProfileId) else pure Nothing + memberConnectedChatItem gInfo m mainProfile + toView $ CRJoinedGroupMember gInfo m {memberStatus = GSMemConnected} mainProfile setActive $ ActiveG gName showToast ("#" <> gName) $ "member " <> localDisplayName (m :: GroupMember) <> " is connected" intros <- withStore' $ \db -> createIntroductions db members m @@ -1629,10 +1696,12 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage cancelRcvFileTransfer user ft throwChatError $ CEFileRcvChunk err - memberConnectedChatItem :: GroupInfo -> GroupMember -> m () - memberConnectedChatItem gInfo m = do + memberConnectedChatItem :: GroupInfo -> GroupMember -> Maybe Profile -> m () + memberConnectedChatItem gInfo m mainProfile_ = do createdAt <- liftIO getCurrentTime - let content = CIRcvGroupEvent RGEMemberConnected + let content = CIRcvGroupEvent $ case mainProfile_ of + Just mainProfile -> RGEMemberConnected $ Just mainProfile + _ -> RGEMemberConnected Nothing cd = CDGroupRcv gInfo m -- first ts should be broker ts but we don't have it for CON ciId <- withStore' $ \db -> createNewChatItemNoMsg db user cd content createdAt createdAt @@ -1641,7 +1710,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage notifyMemberConnected :: GroupInfo -> GroupMember -> m () notifyMemberConnected gInfo m@GroupMember {localDisplayName = c} = do - memberConnectedChatItem gInfo m + memberConnectedChatItem gInfo m Nothing toView $ CRConnectedToGroupMember gInfo m let g = groupName' gInfo setActive $ ActiveG g @@ -1679,13 +1748,12 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage setActive $ ActiveC c processFileInvitation :: Maybe FileInvitation -> (FileInvitation -> Integer -> m RcvFileTransfer) -> m (Maybe (CIFile 'MDRcv)) - processFileInvitation fileInvitation_ createRcvFileTransferF = case fileInvitation_ of - Nothing -> pure Nothing - Just fileInvitation@FileInvitation {fileName, fileSize} -> do + processFileInvitation fileInvitation_ createRcvFileTransferF = + forM fileInvitation_ $ \fileInvitation@FileInvitation {fileName, fileSize} -> do chSize <- asks $ fileChunkSize . config RcvFileTransfer {fileId} <- createRcvFileTransferF fileInvitation chSize let ciFile = CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation} - pure $ Just ciFile + pure ciFile messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> m () messageUpdate ct@Contact {contactId, localDisplayName = c} sharedMsgId mc msg@RcvMessage {msgId} msgMeta = do @@ -1830,16 +1898,19 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> m () - processGroupInvitation ct@Contact {localDisplayName = c} inv@(GroupInvitation (MemberIdRole fromMemId fromRole) (MemberIdRole memId memRole) _ _) msg msgMeta = do + processGroupInvitation ct@Contact {localDisplayName = c} inv@GroupInvitation {fromMember = (MemberIdRole fromMemId fromRole), fromMemberProfile, invitedMember = (MemberIdRole memId memRole)} msg msgMeta = do checkIntegrityCreateItem (CDDirectRcv ct) msgMeta when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c) when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId - gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = GroupMember {groupMemberId}} <- withStore $ \db -> createGroupInvitation db user ct inv - let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole + -- [incognito] if received group invitation has host's incognito profile, create membership with new incognito profile; incognito mode is checked when joining group + let invitedIncognito = isJust fromMemberProfile + incognitoProfile <- if invitedIncognito then Just <$> liftIO generateRandomProfile else pure Nothing + gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = GroupMember {groupMemberId}} <- withStore $ \db -> createGroupInvitation db user ct inv incognitoProfile + let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending, invitedIncognito = Just invitedIncognito}) memRole ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta content Nothing withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci) toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci - toView $ CRReceivedGroupInvitation gInfo ct memRole + toView $ CRReceivedGroupInvitation gInfo ct memRole fromMemberProfile showToast ("#" <> localDisplayName <> " " <> c <> "> ") "invited you to join the group" checkIntegrityCreateItem :: forall c. ChatTypeI c => ChatDirection c 'MDRcv -> MsgMeta -> m () @@ -1857,23 +1928,27 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage toView $ CRNewChatItem $ AChatItem (chatTypeI @c) SMDRcv (toChatInfo cd) ci xInfo :: Contact -> Profile -> m () - xInfo c@Contact {profile = p} p' = unless (p == p') $ do + xInfo c@Contact {profile = p} p' = unless (fromLocalProfile p == p') $ do c' <- withStore $ \db -> updateContactProfile db userId c p' toView $ CRContactUpdated c c' xInfoProbe :: Contact -> Probe -> m () - xInfoProbe c2 probe = do - r <- withStore' $ \db -> matchReceivedProbe db userId c2 probe - forM_ r $ \c1 -> probeMatch c1 c2 probe + xInfoProbe c2 probe = + -- [incognito] unless connected incognito + unless (contactConnIncognito c2) $ do + r <- withStore' $ \db -> matchReceivedProbe db userId c2 probe + forM_ r $ \c1 -> probeMatch c1 c2 probe xInfoProbeCheck :: Contact -> ProbeHash -> m () - xInfoProbeCheck c1 probeHash = do - r <- withStore' $ \db -> matchReceivedProbeHash db userId c1 probeHash - forM_ r . uncurry $ probeMatch c1 + xInfoProbeCheck c1 probeHash = + -- [incognito] unless connected incognito + unless (contactConnIncognito c1) $ do + r <- withStore' $ \db -> matchReceivedProbeHash db userId c1 probeHash + forM_ r . uncurry $ probeMatch c1 probeMatch :: Contact -> Contact -> Probe -> m () probeMatch c1@Contact {profile = p1} c2@Contact {profile = p2} probe = - when (p1 == p2) $ do + when (fromLocalProfile p1 == fromLocalProfile p2) $ do void . sendDirectContactMessage c1 $ XInfoProbeOk probe mergeContacts c1 c2 @@ -2009,7 +2084,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage toView $ CRJoinedGroupMemberConnecting gInfo m newMember xGrpMemIntro :: Connection -> GroupInfo -> GroupMember -> MemberInfo -> m () - xGrpMemIntro conn gInfo@GroupInfo {groupId} m memInfo@(MemberInfo memId _ _) = do + xGrpMemIntro conn gInfo@GroupInfo {groupId, membership} m memInfo@(MemberInfo memId _ _) = do case memberCategory m of GCHostMember -> do members <- withStore' $ \db -> getGroupMembers db user gInfo @@ -2018,7 +2093,9 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage else do (groupConnId, groupConnReq) <- withAgent (`createConnection` SCMInvitation) (directConnId, directConnReq) <- withAgent (`createConnection` SCMInvitation) - newMember <- withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnId directConnId + -- [incognito] direct connection with member has to be established using same incognito profile + customUserProfileId <- if memberIncognito membership then Just <$> withStore (\db -> getGroupMemberProfileId db userId membership) else pure Nothing + newMember <- withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnId directConnId customUserProfileId let msg = XGrpMemInv memId IntroInvitation {groupConnReq, directConnReq} void $ sendDirectMessage conn msg (GroupId groupId) withStore' $ \db -> updateGroupMemberStatus db userId newMember GSMemIntroInvited @@ -2047,10 +2124,12 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage Nothing -> withStore $ \db -> createNewGroupMember db user gInfo memInfo GCPostMember GSMemAnnounced Just m' -> pure m' withStore' $ \db -> saveMemberInvitation db toMember introInv - let msg = XGrpMemInfo (memberId (membership :: GroupMember)) profile + -- [incognito] send membership incognito profile, create direct connection as incognito + let msg = XGrpMemInfo (memberId (membership :: GroupMember)) (fromLocalProfile $ memberProfile membership) groupConnId <- withAgent $ \a -> joinConnection a groupConnReq $ directMessage msg directConnId <- withAgent $ \a -> joinConnection a directConnReq $ directMessage msg - withStore' $ \db -> createIntroToMemberContact db userId m toMember groupConnId directConnId + customUserProfileId <- if memberIncognito membership then Just <$> withStore (\db -> getGroupMemberProfileId db userId membership) else pure Nothing + withStore' $ \db -> createIntroToMemberContact db userId m toMember groupConnId directConnId customUserProfileId xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> MsgMeta -> m () xGrpMemDel gInfo@GroupInfo {membership} m memId msg msgMeta = do @@ -2071,7 +2150,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage else do deleteMemberConnection member withStore' $ \db -> updateGroupMemberStatus db userId member GSMemRemoved - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent $ RGEMemberDeleted groupMemberId memberProfile) Nothing + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile)) Nothing groupMsgToView gInfo m ci msgMeta toView $ CRDeletedMember gInfo m member {memberStatus = GSMemRemoved} @@ -2388,7 +2467,7 @@ getCreateActiveUser st = do withTransaction st (`setActiveUser` userId user) pure user userStr :: User -> String - userStr User {localDisplayName, profile = Profile {fullName}} = + userStr User {localDisplayName, profile = LocalProfile {fullName}} = T.unpack $ localDisplayName <> if T.null fullName || localDisplayName == fullName then "" else " (" <> fullName <> ")" getContactName :: IO ContactName getContactName = do @@ -2556,6 +2635,7 @@ chatCommandP = "/profile_image" $> UpdateProfileImage Nothing, ("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> userNames), ("/profile" <|> "/p") $> ShowProfile, + "/incognito " *> (SetIncognito <$> onOffP), ("/quit" <|> "/q" <|> "/exit") $> QuitChat, ("/version" <|> "/v") $> ShowVersion ] diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index ef055143a6..0fb2812f5d 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/src/Simplex/Chat/Bot.hs @@ -24,7 +24,7 @@ chatBotRepl welcome answer _user cc = do race_ (forever $ void getLine) . forever $ do (_, resp) <- atomically . readTBQueue $ outputQ cc case resp of - CRContactConnected contact -> do + CRContactConnected contact _ -> do contactConnected contact void $ sendMsg contact welcome CRNewChatItem (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content}) -> do @@ -40,7 +40,7 @@ initializeBotAddress cc = do sendChatCmd cc "/show_address" >>= \case CRUserContactLink uri _ _ -> showBotAddress uri CRChatCmdError (ChatErrorStore SEUserContactLinkNotFound) -> do - putStrLn $ "No bot address, creating..." + putStrLn "No bot address, creating..." sendChatCmd cc "/address" >>= \case CRUserContactLinkCreated uri -> showBotAddress uri _ -> putStrLn "can't create bot address" >> exitFailure diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index a606cf2f11..173bd90382 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -88,7 +88,8 @@ data ChatController = ChatController rcvFiles :: TVar (Map Int64 Handle), currentCalls :: TMap ContactId Call, config :: ChatConfig, - filesFolder :: TVar (Maybe FilePath) -- path to files folder for mobile apps + filesFolder :: TVar (Maybe FilePath), -- path to files folder for mobile apps, + incognitoMode :: TVar Bool } data HelpSection = HSMain | HSFiles | HSGroups | HSMyAddress | HSMarkdown | HSMessages | HSSettings @@ -107,6 +108,7 @@ data ChatCommand | APISuspendChat {suspendTimeout :: Int} | ResubscribeAllConnections | SetFilesFolder FilePath + | SetIncognito Bool | APIExportArchive ArchiveConfig | APIImportArchive ArchiveConfig | APIDeleteStorage @@ -210,8 +212,8 @@ data ChatResponse | CRApiParsedMarkdown {formattedText :: Maybe MarkdownList} | CRUserSMPServers {smpServers :: [SMPServer]} | CRNetworkConfig {networkConfig :: NetworkConfig} - | CRContactInfo {contact :: Contact, connectionStats :: ConnectionStats} - | CRGroupMemberInfo {groupInfo :: GroupInfo, member :: GroupMember, connectionStats_ :: Maybe ConnectionStats} + | CRContactInfo {contact :: Contact, connectionStats :: ConnectionStats, customUserProfile :: Maybe Profile} + | CRGroupMemberInfo {groupInfo :: GroupInfo, member :: GroupMember, connectionStats_ :: Maybe ConnectionStats, mainProfile :: Maybe Profile} | CRNewChatItem {chatItem :: AChatItem} | CRChatItemStatusUpdated {chatItem :: AChatItem} | CRChatItemUpdated {chatItem :: AChatItem} @@ -223,7 +225,7 @@ data ChatResponse | CRCmdOk | CRChatHelp {helpSection :: HelpSection} | CRWelcome {user :: User} - | CRGroupCreated {groupInfo :: GroupInfo} + | CRGroupCreated {groupInfo :: GroupInfo, customUserProfile :: Maybe Profile} | CRGroupMembers {group :: Group} | CRContactsList {contacts :: [Contact]} | CRUserContactLink {connReqContact :: ConnReqContact, autoAccept :: Bool, autoReply :: Maybe MsgContent} @@ -232,14 +234,14 @@ data ChatResponse | CRUserAcceptedGroupSent {groupInfo :: GroupInfo} | CRUserDeletedMember {groupInfo :: GroupInfo, member :: GroupMember} | CRGroupsList {groups :: [GroupInfo]} - | CRSentGroupInvitation {groupInfo :: GroupInfo, contact :: Contact, member :: GroupMember} + | CRSentGroupInvitation {groupInfo :: GroupInfo, contact :: Contact, member :: GroupMember, sentCustomProfile :: Maybe Profile} | CRFileTransferStatus (FileTransfer, [Integer]) -- TODO refactor this type to FileTransferStatus | CRUserProfile {profile :: Profile} | CRUserProfileNoChange | CRVersionInfo {version :: String} | CRInvitation {connReqInvitation :: ConnReqInvitation} | CRSentConfirmation - | CRSentInvitation + | CRSentInvitation {customUserProfile :: Maybe Profile} | CRContactUpdated {fromContact :: Contact, toContact :: Contact} | CRContactsMerged {intoContact :: Contact, mergedContact :: Contact} | CRContactDeleted {contact :: Contact} @@ -265,7 +267,7 @@ data ChatResponse | CRSndGroupFileCancelled {chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta, sndFileTransfers :: [SndFileTransfer]} | CRUserProfileUpdated {fromProfile :: Profile, toProfile :: Profile} | CRContactConnecting {contact :: Contact} - | CRContactConnected {contact :: Contact} + | CRContactConnected {contact :: Contact, userCustomProfile :: Maybe Profile} | CRContactAnotherClient {contact :: Contact} | CRContactsDisconnected {server :: SMPServer, contactRefs :: [ContactRef]} | CRContactsSubscribed {server :: SMPServer, contactRefs :: [ContactRef]} @@ -274,9 +276,9 @@ data ChatResponse | CRHostConnected {protocol :: AProtocolType, transportHost :: TransportHost} | CRHostDisconnected {protocol :: AProtocolType, transportHost :: TransportHost} | CRGroupInvitation {groupInfo :: GroupInfo} - | CRReceivedGroupInvitation {groupInfo :: GroupInfo, contact :: Contact, memberRole :: GroupMemberRole} - | CRUserJoinedGroup {groupInfo :: GroupInfo, hostMember :: GroupMember} - | CRJoinedGroupMember {groupInfo :: GroupInfo, member :: GroupMember} + | CRReceivedGroupInvitation {groupInfo :: GroupInfo, contact :: Contact, memberRole :: GroupMemberRole, receivedCustomProfile :: Maybe Profile} + | CRUserJoinedGroup {groupInfo :: GroupInfo, hostMember :: GroupMember, usedCustomProfile :: Bool} + | CRJoinedGroupMember {groupInfo :: GroupInfo, member :: GroupMember, mainProfile :: Maybe Profile} | CRJoinedGroupMemberConnecting {groupInfo :: GroupInfo, hostMember :: GroupMember, member :: GroupMember} | CRConnectedToGroupMember {groupInfo :: GroupInfo, member :: GroupMember} | CRDeletedMember {groupInfo :: GroupInfo, byMember :: GroupMember, deletedMember :: GroupMember} @@ -383,6 +385,7 @@ data ChatErrorType | CEContactNotReady {contact :: Contact} | CEContactGroups {contact :: Contact, groupNames :: [GroupName]} | CEGroupUserRole + | CEGroupNotIncognitoCantInvite | CEGroupContactRole {contactName :: ContactName} | CEGroupDuplicateMember {contactName :: ContactName} | CEGroupDuplicateMemberId diff --git a/src/Simplex/Chat/Help.hs b/src/Simplex/Chat/Help.hs index f35cd39ec7..7872284ae9 100644 --- a/src/Simplex/Chat/Help.hs +++ b/src/Simplex/Chat/Help.hs @@ -18,7 +18,7 @@ import Data.Text (Text) import qualified Data.Text as T import Simplex.Chat.Markdown import Simplex.Chat.Styled -import Simplex.Chat.Types (Profile (..), User (..)) +import Simplex.Chat.Types (User (..), LocalProfile (..)) import System.Console.ANSI.Types highlight :: Text -> Markdown @@ -55,7 +55,7 @@ chatWelcome user = "Type " <> highlight "/help" <> " for usage info, " <> highlight "/welcome" <> " to show this message" ] where - User {profile = Profile {displayName, fullName}} = user + User {profile = LocalProfile {displayName, fullName}} = user userName = if T.null fullName then displayName else fullName chatHelpInfo :: [StyledString] diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 5be8deb6c5..02fa60d937 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -501,22 +501,24 @@ ciGroupInvitationToText CIGroupInvitation {groupProfile = GroupProfile {displayN rcvGroupEventToText :: RcvGroupEvent -> Text rcvGroupEventToText = \case - RGEMemberAdded _ p -> "added " <> memberProfileToText p - RGEMemberConnected -> "connected" + RGEMemberAdded _ p -> "added " <> profileToText p + RGEMemberConnected contactMainProfile -> case contactMainProfile of + Just p -> profileToText p <> " connected incognito" + Nothing -> "connected" RGEMemberLeft -> "left" - RGEMemberDeleted _ p -> "removed " <> memberProfileToText p + RGEMemberDeleted _ p -> "removed " <> profileToText p RGEUserDeleted -> "removed you" RGEGroupDeleted -> "deleted group" RGEGroupUpdated _ -> "group profile updated" sndGroupEventToText :: SndGroupEvent -> Text sndGroupEventToText = \case - SGEMemberDeleted _ p -> "removed " <> memberProfileToText p + SGEMemberDeleted _ p -> "removed " <> profileToText p SGEUserLeft -> "left" SGEGroupUpdated _ -> "group profile updated" -memberProfileToText :: Profile -> Text -memberProfileToText Profile {displayName, fullName} = displayName <> optionalFullName displayName fullName +profileToText :: Profile -> Text +profileToText Profile {displayName, fullName} = displayName <> optionalFullName displayName fullName -- This type is used both in API and in DB, so we use different JSON encodings for the database and for the API data CIContent (d :: MsgDirection) where @@ -536,7 +538,7 @@ deriving instance Show (CIContent d) data RcvGroupEvent = RGEMemberAdded {groupMemberId :: GroupMemberId, profile :: Profile} -- CRJoinedGroupMemberConnecting - | RGEMemberConnected -- CRUserJoinedGroup, CRJoinedGroupMember, CRConnectedToGroupMember + | RGEMemberConnected {contactMainProfile :: Maybe Profile} -- CRUserJoinedGroup, CRJoinedGroupMember, CRConnectedToGroupMember | RGEMemberLeft -- CRLeftMember | RGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRDeletedMember | RGEUserDeleted -- CRDeletedMemberUser @@ -569,13 +571,14 @@ data CIGroupInvitation = CIGroupInvitation groupMemberId :: GroupMemberId, localDisplayName :: GroupName, groupProfile :: GroupProfile, - status :: CIGroupInvitationStatus + status :: CIGroupInvitationStatus, + invitedIncognito :: Maybe Bool } deriving (Eq, Show, Generic, FromJSON) instance ToJSON CIGroupInvitation where - toJSON = J.genericToJSON J.defaultOptions - toEncoding = J.genericToEncoding J.defaultOptions + toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} + toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} data CIGroupInvitationStatus = CIGISPending diff --git a/src/Simplex/Chat/Migrations/M20220812_incognito_profiles.hs b/src/Simplex/Chat/Migrations/M20220812_incognito_profiles.hs new file mode 100644 index 0000000000..2ece1be90d --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20220812_incognito_profiles.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20220812_incognito_profiles where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20220812_incognito_profiles :: Query +m20220812_incognito_profiles = + [sql| +ALTER TABLE connections ADD COLUMN custom_user_profile_id INTEGER REFERENCES contact_profiles ON DELETE SET NULL; -- only set for direct connections + +ALTER TABLE group_members ADD COLUMN member_profile_id INTEGER REFERENCES contact_profiles ON DELETE SET NULL; -- member profile id if incognito profile was saved for member (used for hosts and invitees in incognito groups) + +ALTER TABLE contact_profiles ADD COLUMN incognito INTEGER; -- 1 for incognito +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 8ef4889572..ce4c6553fd 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -13,7 +13,8 @@ CREATE TABLE contact_profiles( created_at TEXT CHECK(created_at NOT NULL), updated_at TEXT CHECK(updated_at NOT NULL), image TEXT, - user_id INTEGER DEFAULT NULL REFERENCES users ON DELETE CASCADE + user_id INTEGER DEFAULT NULL REFERENCES users ON DELETE CASCADE, + incognito INTEGER ); CREATE INDEX contact_profiles_index ON contact_profiles( display_name, @@ -145,6 +146,7 @@ CREATE TABLE group_members( contact_id INTEGER REFERENCES contacts ON DELETE CASCADE, created_at TEXT CHECK(created_at NOT NULL), updated_at TEXT CHECK(updated_at NOT NULL), + member_profile_id INTEGER REFERENCES contact_profiles ON DELETE SET NULL, FOREIGN KEY(user_id, local_display_name) REFERENCES display_names(user_id, local_display_name) ON DELETE CASCADE @@ -236,6 +238,7 @@ CREATE TABLE connections( xcontact_id BLOB, via_user_contact_link INTEGER DEFAULT NULL REFERENCES user_contact_links(user_contact_link_id) ON DELETE SET NULL, + custom_user_profile_id INTEGER REFERENCES contact_profiles ON DELETE SET NULL, FOREIGN KEY(snd_file_id, connection_id) REFERENCES snd_files(file_id, connection_id) ON DELETE CASCADE diff --git a/src/Simplex/Chat/ProfileGenerator.hs b/src/Simplex/Chat/ProfileGenerator.hs new file mode 100644 index 0000000000..c42cd6ab66 --- /dev/null +++ b/src/Simplex/Chat/ProfileGenerator.hs @@ -0,0 +1,3140 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.Chat.ProfileGenerator where + +import Data.Text (Text) +import Simplex.Chat.Types (Profile (..)) +import System.Random (randomRIO) + +generateRandomProfile :: IO Profile +generateRandomProfile = do + adjective <- pick adjectives + noun <- pickNoun adjective 2 + pure $ Profile {displayName = adjective <> noun, fullName = "", image = Nothing} + where + pick :: [a] -> IO a + pick xs = (xs !!) <$> randomRIO (0, length xs - 1) + pickNoun :: Text -> Int -> IO Text + pickNoun adjective n + | n == 0 = pick nouns + | otherwise = do + noun <- pick nouns + if noun == adjective + then pickNoun adjective (n - 1) + else pure noun + +adjectives :: [Text] +adjectives = + [ "Abatic", + "Abducent", + "Abecedarian", + "Aberrant", + "Abeyant", + "Abject", + "Ablative", + "Ablaze", + "Able", + "Abloom", + "Ablutionary", + "Abolishable", + "Abolitionary", + "Aboriginal", + "Aboulic", + "Abounding", + "About", + "Aboveboard", + "Aboveground", + "Abranchial", + "Abranchiate", + "Abranchious", + "Abrasive", + "Abrupt", + "Abscessed", + "Absent", + "Absolute", + "Absolved", + "Absorbable", + "Absorbed", + "Absorbing", + "Absorptive", + "Abstinent", + "Abstracted", + "Abstractionist", + "Abundant", + "Abysmal", + "Abyssal", + "Academic", + "Acceptable", + "Accessible", + "Acclaimed", + "Accommodating", + "Accomplished", + "Accordant", + "Accurate", + "Acknowledged", + "Acrobatic", + "Active", + "Actual", + "Adamant", + "Adaptable", + "Adept", + "Adequate", + "Adhesive", + "Adhoc", + "Adjusted", + "Admirable", + "Admired", + "Admissible", + "Adorable", + "Adored", + "Adroit", + "Advantaged", + "Adventuresome", + "Adventurous", + "Aesthetic", + "Aesthetical", + "Affable", + "Affecting", + "Affectionate", + "Affiliated", + "Affluent", + "Aged", + "Ageless", + "Agile", + "Agitated", + "Agonizing", + "Agreeable", + "Ahead", + "Aholic", + "Alarmed", + "Alarming", + "Alert", + "Alienated", + "Alike", + "Alive", + "Alleged", + "Allied", + "Alright", + "Amative", + "Amatory", + "Ambiguous", + "Ambitious", + "Amelioratory", + "Amenable", + "Amicable", + "Ample", + "Amused", + "Amusing", + "Anchored", + "Ancient", + "Angelic", + "Animated", + "Annual", + "Antsy", + "Appealing", + "Appetent", + "Apposite", + "Apprehensible", + "Apprehensive", + "Approachable", + "Apropos", + "Apt", + "Aquatic", + "Arctic", + "Arid", + "Aromatic", + "Arousing", + "Arrogant", + "Articulate", + "Artistic", + "Aspirant", + "Assertive", + "Assiduous", + "Assistant", + "Associate", + "Associative", + "Assured", + "Assuring", + "Astonishing", + "Astounding", + "Astute", + "Athletic", + "Attached", + "Attainable", + "Attendant", + "Attentive", + "Attractive", + "August", + "Auspicious", + "Authentic", + "Automatic", + "Autonomous", + "Available", + "Awaited", + "Awake", + "Aware", + "Awash", + "Awesome", + "Babyish", + "Back", + "Baggy", + "Balanced", + "Bare", + "Barren", + "Basic", + "Beaming", + "Beatific", + "Beauteous", + "Beautified", + "Beautiful", + "Becoming", + "Beefy", + "Belated", + "Believable", + "Beloved", + "Benedictory", + "Benefic", + "Beneficent", + "Beneficial", + "Beneficiary", + "Benevolent", + "Benign", + "Benignant", + "Best", + "Better", + "Bewitched", + "Big", + "Biggest", + "Bijou", + "Bitter", + "Blameless", + "Bland", + "Blank", + "Blaring", + "Blazing", + "Blessed", + "Blissful", + "Blithe", + "Blond", + "Blooming", + "Blue", + "Blushing", + "Bodacious", + "Bogus", + "Boiling", + "Boisterous", + "Bold", + "Bonafide", + "Bonny", + "Bony", + "Bonzer", + "Boring", + "Boss", + "Bossy", + "Both", + "Bouncy", + "Bound", + "Bounteous", + "Bountiful", + "Bowed", + "Brainy", + "Brave", + "Brawny", + "Breakable", + "Breezy", + "Brief", + "Bright", + "Brill", + "Brilliant", + "Brimming", + "Brisk", + "Broadminded", + "Broken", + "Bronze", + "Bruised", + "Bubbly", + "Budding", + "Buff", + "Bulky", + "Bullish", + "Bumpy", + "Buoyant", + "Burdensome", + "Burly", + "Bustling", + "Busy", + "Buttery", + "Buzzing", + "Calm", + "Calmative", + "Calming", + "Candescent", + "Canny", + "Canty", + "Capable", + "Capital", + "Captivating", + "Carefree", + "Careful", + "Caring", + "Casual", + "Causative", + "Celebrated", + "Celestial", + "Centered", + "Central", + "Cerebral", + "Certain", + "Champion", + "Changeable", + "Changeless", + "Charismatic", + "Charitable", + "Charming", + "Cheerful", + "Cherished", + "Cherry", + "Chic", + "Childlike", + "Chipper", + "Chirpy", + "Chosen", + "Chummy", + "Civic", + "Civil", + "Civilized", + "Clairvoyant", + "Classic", + "Classical", + "Classy", + "Clean", + "Clear", + "Clearheaded", + "Clement", + "Clever", + "Close", + "Clubby", + "Coadjutant", + "Coequal", + "Cogent", + "Cognizant", + "Coherent", + "Collected", + "Comfortable", + "Comforting", + "Comic", + "Comical", + "Commanding", + "Commendable", + "Commendatory", + "Commending", + "Commiserative", + "Committed", + "Commodious", + "Commonsensical", + "Communicative", + "Commutual", + "Companionable", + "Compassionate", + "Compatible", + "Compelling", + "Competent", + "Complete", + "Completed", + "Complimentary", + "Composed", + "Comprehensive", + "Concentrated", + "Concise", + "Conclusive", + "Concordant", + "Concrete", + "Condolatory", + "Confederate", + "Conferrable", + "Confident", + "Congenial", + "Consentient", + "Consequential", + "Considerable", + "Considerate", + "Consistent", + "Consonant", + "Conspicuous", + "Constant", + "Constitutional", + "Constructive", + "Contemplative", + "Contemporary", + "Content", + "Contributive", + "Convenient", + "Conversant", + "Convictive", + "Convincing", + "Convivial", + "Cool", + "Cooperative", + "Coordinated", + "Copacetic", + "Copious", + "Cordial", + "Correct", + "Coruscant", + "Cosmic", + "Courageous", + "Courteous", + "Courtly", + "Cozy", + "Crackerjack", + "Creative", + "Credible", + "Creditable", + "Crisp", + "Crucial", + "Crystal", + "Cuddly", + "Cultivated", + "Cultured", + "Cunning", + "Curious", + "Current", + "Cushy", + "Cute", + "Dainty", + "Dandy", + "Dapper", + "Daring", + "Dark", + "Darling", + "Dashing", + "Dauntless", + "Dazzling", + "Dear", + "Dearest", + "Debonair", + "Decent", + "Deciding", + "Decimal", + "Decisive", + "Decorous", + "Dedicated", + "Deep", + "Defensive", + "Definite", + "Definitive", + "Delectable", + "Deliberate", + "Delicate", + "Delicious", + "Delighted", + "Delightful", + "Deluxe", + "Demanding", + "Demonstrative", + "Dental", + "Dependable", + "Dependent", + "Descriptive", + "Deserving", + "Designer", + "Desirable", + "Desired", + "Desirous", + "Destined", + "Detailed", + "Determined", + "Developed", + "Developing", + "Devoted", + "Devotional", + "Devout", + "Dexterous", + "Didactic", + "Different", + "Digital", + "Dignified", + "Diligent", + "Dim", + "Dimpled", + "Diplomatic", + "Direct", + "Disarming", + "Discerning", + "Disciplined", + "Discreet", + "Discrete", + "Disguised", + "Distinct", + "Distinctive", + "Distinguished", + "Distinguishing", + "Diverse", + "Diverting", + "Divine", + "Dominant", + "Doting", + "Doubtless", + "Doughty", + "Downright", + "Drafty", + "Dramatic", + "Dreamy", + "Driven", + "Driving", + "Dry", + "Dual", + "Durable", + "Dutiful", + "Dynamic", + "Dynamite", + "Eager", + "Early", + "Earnest", + "Earthly", + "Earthy", + "Easy", + "Easygoing", + "Ebullient", + "Eclectic", + "Economic", + "Economical", + "Ecstatic", + "Ecumenical", + "Edible", + "Edified", + "Educated", + "Educational", + "Effective", + "Effectual", + "Effervescent", + "Efficient", + "Effortless", + "Elaborate", + "Elastic", + "Elated", + "Elating", + "Elder", + "Elderly", + "Electric", + "Electrifying", + "Eleemosynary", + "Elegant", + "Elemental", + "Elementary", + "Eligible", + "Elliptical", + "Eloquent", + "Embellished", + "Emerging", + "Eminent", + "Emotional", + "Empathetic", + "Empowered", + "Enamored", + "Enchanted", + "Enchanting", + "Encouraged", + "Encouraging", + "Endearing", + "Enduring", + "Energetic", + "Energizing", + "Engaging", + "Enhanced", + "Enjoyable", + "Enlightened", + "Enlightening", + "Enlivened", + "Enlivening", + "Enormous", + "Enough", + "Enriching", + "Enterprising", + "Entertaining", + "Enthralling", + "Enthusiastic", + "Enticing", + "Entire", + "Entrancing", + "Entrepreneurial", + "Epicurean", + "Epideictic", + "Equable", + "Equal", + "Equatorial", + "Equiponderant", + "Equipped", + "Equitable", + "Equivalent", + "Erudite", + "Especial", + "Essential", + "Established", + "Esteemed", + "Esthetic", + "Esthetical", + "Eternal", + "Ethical", + "Euphoric", + "Even", + "Eventful", + "Evergreen", + "Everlasting", + "Evident", + "Evocative", + "Exact", + "Exalted", + "Exceeding", + "Excellent", + "Exceptional", + "Excitable", + "Excited", + "Exciting", + "Executive", + "Exemplary", + "Exhilarating", + "Exotic", + "Expansive", + "Expectant", + "Expeditious", + "Expeditive", + "Expensive", + "Experienced", + "Expert", + "Explorative", + "Expressive", + "Exquisite", + "Extraneous", + "Extraordinary", + "Extroverted", + "Exuberant", + "Exultant", + "Fab", + "Fabulous", + "Facile", + "Factual", + "Facultative", + "Fain", + "Faint", + "Fair", + "Faithful", + "Famed", + "Familial", + "Familiar", + "Family", + "Famous", + "Fancy", + "Fantastic", + "Far", + "Faraway", + "Fascinating", + "Fashionable", + "Fast", + "Fatal", + "Fatherly", + "Faultless", + "Favorable", + "Favored", + "Favorite", + "Fearful", + "Fearless", + "Feasible", + "Fecund", + "Feisty", + "Felicitous", + "Feline", + "Fervent", + "Festal", + "Festive", + "Fetching", + "Fickle", + "Fiery", + "Fine", + "Finer", + "Finest", + "Finished", + "Firm", + "First", + "Firsthand", + "Fit", + "Fitting", + "Fixed", + "Flamboyant", + "Flash", + "Flashy", + "Flat", + "Flavorful", + "Flawed", + "Flawless", + "Fleet", + "Flexible", + "Flickering", + "Flimsy", + "Flippant", + "Flourishing", + "Flowery", + "Fluent", + "Fluffy", + "Fluid", + "Flustered", + "Flying", + "Focused", + "Fond", + "Foremost", + "Foresighted", + "Forgiving", + "Forked", + "Formal", + "Formidable", + "Forthcoming", + "Forthright", + "Fortified", + "Fortuitous", + "Fortunate", + "Forward", + "Foundational", + "Foxy", + "Fragrant", + "Frail", + "Frank", + "Fraternal", + "Frayed", + "Freely", + "Frequent", + "Fresh", + "Friendly", + "Frilly", + "Frisky", + "Front", + "Frosty", + "Frozen", + "Fruitful", + "Fulfilled", + "Fulfilling", + "Full", + "Fumbling", + "Fun", + "Functional", + "Funny", + "Fussy", + "Futuristic", + "Fuzzy", + "Gabby", + "Gainful", + "Gallant", + "Galore", + "Game", + "Gamesome", + "Gamy", + "Gaping", + "Gaseous", + "Gaudy", + "General", + "Generous", + "Genial", + "Genteel", + "Gentle", + "Genuine", + "Germane", + "Gettable", + "Giant", + "Giddy", + "Gifted", + "Gigantic", + "Giving", + "Glad", + "Glamorous", + "Glaring", + "Glass", + "Gleaming", + "Gleeful", + "Glib", + "Glistening", + "Glittering", + "Glorious", + "Glossy", + "Glowing", + "Glum", + "Gnarly", + "Godly", + "Golden", + "Good", + "Goodhearted", + "Goodly", + "Goofy", + "Gorgeous", + "Graced", + "Graceful", + "Gracile", + "Gracious", + "Gradely", + "Graithly", + "Grand", + "Grandiose", + "Granular", + "Grateful", + "Gratified", + "Gratifying", + "Gray", + "Greasy", + "Great", + "Greatest", + "Greathearted", + "Green", + "Gregarious", + "Grey", + "Gripping", + "Groovy", + "Grounded", + "Growing", + "Grown", + "Grubby", + "Grumpy", + "Guaranteed", + "Guarded", + "Gubernatorial", + "Guided", + "Guiding", + "Guileless", + "Guiltless", + "Guilty", + "Gullible", + "Gummy", + "Gumptious", + "Gustatory", + "Gusty", + "Gutsy", + "Gymnastic", + "Hairy", + "Halcyon", + "Hale", + "Half", + "Hallowed", + "Handmade", + "Handsome", + "Handy", + "Happening", + "Happy", + "Hardy", + "Harmless", + "Harmonious", + "Harsh", + "Hasty", + "Head", + "Healing", + "Healthful", + "Healthy", + "Heartfelt", + "Hearty", + "Heavenly", + "Heavy", + "Heedful", + "Hefty", + "Hegemonic", + "Helpful", + "Hep", + "Heralded", + "Heroic", + "Heteroclite", + "Heuristic", + "High", + "Highest", + "Hilarious", + "Hip", + "Holy", + "Homely", + "Honest", + "Honeyed", + "Honorable", + "Honorary", + "Honored", + "Hopeful", + "Hortative", + "Hospitable", + "Hot", + "Hotshot", + "Huge", + "Humane", + "Humanitarian", + "Humble", + "Humming", + "Humongous", + "Humorous", + "Hungry", + "Husky", + "Hygienic", + "Icy", + "Ideal", + "Idealistic", + "Identical", + "Idiosyncratic", + "Idolized", + "Ignorant", + "Illimitable", + "Illuminated", + "Illuminating", + "Illustrious", + "Imaginary", + "Imaginative", + "Imitable", + "Immaculate", + "Immaterial", + "Immeasurable", + "Immediate", + "Immense", + "Immortal", + "Immune", + "Impartial", + "Impassioned", + "Impeccable", + "Impeccant", + "Imperturbable", + "Important", + "Impossible", + "Impractical", + "Impressionable", + "Impressive", + "Improbable", + "Improved", + "Improving", + "Improvisational", + "Inborn", + "Incisive", + "Included", + "Inclusive", + "Incomparable", + "Inconsequential", + "Incontestable", + "Incontrovertible", + "Incredible", + "Inculpable", + "Indefatigable", + "Indelible", + "Independent", + "Indestructible", + "Indispensable", + "Indisputable", + "Individual", + "Individualistic", + "Indivisible", + "Indomitable", + "Indubitable", + "Industrious", + "Inerrant", + "Inexhaustible", + "Infallible", + "Infamous", + "Infant", + "Infantile", + "Infatuated", + "Inferior", + "Infinite", + "Influential", + "Informal", + "Informative", + "Informed", + "Ingenious", + "Inimitable", + "Initiate", + "Initiative", + "Innocent", + "Innovative", + "Innoxious", + "Inquisitive", + "Insightful", + "Insignificant", + "Insistent", + "Inspired", + "Inspiring", + "Inspiriting", + "Instantaneous", + "Instinctive", + "Instructive", + "Instrumental", + "Integral", + "Integrated", + "Intellectual", + "Intelligent", + "Intense", + "Intent", + "Intentional", + "Interactive", + "Interconnected", + "Interested", + "Interesting", + "Internal", + "International", + "Intertwined", + "Intimate", + "Intoxicating", + "Intrepid", + "Intriguing", + "Introducer", + "Inventive", + "Invigorated", + "Invigorating", + "Invincible", + "Inviolable", + "Inviting", + "Irrefragable", + "Irrefutable", + "Irreplaceable", + "Irrepressible", + "Irreproachable", + "Irresistible", + "Jaculable", + "Jaded", + "Jaunty", + "Jazzed", + "Jazzy", + "Jessant", + "Jestful", + "Jesting", + "Jeweled", + "Jiggish", + "Jigjog", + "Jimp", + "Jittery", + "Jobbing", + "Jocose", + "Jocoserious", + "Jocular", + "Joculatory", + "Jocund", + "Joint", + "Jointed", + "Jolly", + "Jovial", + "Joyful", + "Joyous", + "Joysome", + "Jubilant", + "Judicious", + "Juicy", + "Julie", + "Jumbled", + "Jumbo", + "Jump", + "Jumpy", + "Junior", + "Just", + "Justified", + "Juvenile", + "Kaleidoscopic", + "Keen", + "Kempt", + "Key", + "Kind", + "Kindhearted", + "Kindly", + "Kindred", + "Kinetic", + "Kingly", + "Knightly", + "Knobby", + "Knotty", + "Knowable", + "Knowing", + "Knowledgeable", + "Known", + "Kooky", + "Kosher", + "Ladylike", + "Large", + "Last", + "Lasting", + "Latitudinarian", + "Laudable", + "Laureate", + "Lavish", + "Lawful", + "Leading", + "Leafy", + "Learned", + "Legal", + "Legendary", + "Legible", + "Legit", + "Legitimate", + "Leisured", + "Leisurely", + "Lenien", + "Leonine", + "Lepid", + "Lettered", + "Liberal", + "Liberated", + "Liberating", + "Light", + "Lighthearted", + "Lightly", + "Likable", + "Like", + "Liked", + "Likely", + "Limber", + "Limited", + "Linear", + "Lined", + "Lionhearted", + "Liquid", + "Literary", + "Literate", + "Lithe", + "Lithesome", + "Little", + "Live", + "Lively", + "Livid", + "Logical", + "Long", + "Lordly", + "Loud", + "Lovable", + "Loved", + "Lovely", + "Loving", + "Low", + "Loyal", + "Lucent", + "Lucid", + "Lucky", + "Lucrative", + "Lumbering", + "Luminous", + "Luscious", + "Lush", + "Lustrous", + "Luxuriant", + "Luxurious", + "Made", + "Magical", + "Magnanimous", + "Magnetic", + "Magnificent", + "Main", + "Majestic", + "Major", + "Malleable", + "Manageable", + "Managerial", + "Manifest", + "Mannerly", + "Marked", + "Marvelous", + "Massive", + "Master", + "Masterful", + "Masterly", + "Matchless", + "Maternal", + "Mature", + "Maturing", + "Maximal", + "Meager", + "Mealy", + "Meaningful", + "Measly", + "Mediate", + "Medical", + "Meditative", + "Medium", + "Mellow", + "Melodic", + "Melodious", + "Memorable", + "Merciful", + "Meritable", + "Meritorious", + "Merry", + "Mesmerizing", + "Metallic", + "Metaphysical", + "Meteoric", + "Methodical", + "Meticulous", + "Mettlesome", + "Mighty", + "Mild", + "Milky", + "Mindful", + "Mindless", + "Miniature", + "Minikin", + "Ministerial", + "Mint", + "Minty", + "Miraculous", + "Mirthful", + "Misty", + "Mitigative", + "Mitigatory", + "Mixed", + "Model", + "Modern", + "Modernistic", + "Modest", + "Moist", + "Momentous", + "Moneyed", + "Monthly", + "Monumental", + "Moral", + "Mortified", + "Motherly", + "Motionless", + "Motivated", + "Motivating", + "Motivational", + "Motor", + "Mountainous", + "Moving", + "Multicolored", + "Multidimensional", + "Multidisciplined", + "Multifaceted", + "Mundane", + "Munificent", + "Muscular", + "Musical", + "Mutual", + "Mysterious", + "Narrow", + "National", + "Nationwide", + "Native", + "Natty", + "Natural", + "Nautical", + "Near", + "Nearby", + "Neat", + "Necessary", + "Needed", + "Negligible", + "Neighboring", + "Neighborly", + "Neoteric", + "Nestling", + "New", + "Newborn", + "Next", + "Nice", + "Nifty", + "Nimble", + "Nippy", + "Noble", + "Nocturnal", + "Noetic", + "Nonchalant", + "Nonpareil", + "Nonstop", + "Normal", + "Notable", + "Noted", + "Noteworthy", + "Noticeable", + "Nourished", + "Nourishing", + "Novel", + "Nubile", + "Nutrimental", + "Nutritious", + "Obedient", + "Objective", + "Obliging", + "Oblong", + "Observant", + "Obtainable", + "Obvious", + "Occasional", + "Oecumenical", + "Official", + "Okay", + "Olympian", + "Onward", + "Open", + "Operative", + "Opportune", + "Optimal", + "Optimistic", + "Optimum", + "Opulent", + "Orange", + "Orderly", + "Ordinary", + "Organic", + "Organized", + "Oriented", + "Original", + "Ornamental", + "Ornate", + "Ornery", + "Outgoing", + "Outlandish", + "Outlying", + "Outrageous", + "Outstanding", + "Oval", + "Overflowing", + "Overjoyed", + "Overriding", + "Overt", + "Palatable", + "Pally", + "Palpable", + "Paradisiac", + "Paradisiacal", + "Parallel", + "Paramount", + "Parched", + "Parental", + "Parnassian", + "Partial", + "Participant", + "Participative", + "Particular", + "Partisan", + "Passionate", + "Pastel", + "Paternal", + "Patient", + "Peaceable", + "Peaceful", + "Peachy", + "Peerless", + "Penetrating", + "Peppery", + "Peppy", + "Perceptive", + "Perfect", + "Perfumed", + "Periodic", + "Perky", + "Permanent", + "Permissive", + "Perseverant", + "Persevering", + "Persistent", + "Personable", + "Personal", + "Perspective", + "Perspicacious", + "Perspicuous", + "Persuasive", + "Pert", + "Pertinent", + "Petite", + "Phenomenal", + "Philanthropic", + "Philoprogenitive", + "Philosophical", + "Physical", + "Picked", + "Picturesque", + "Piercing", + "Pierian", + "Pilot", + "Pink", + "Pioneering", + "Pious", + "Piquant", + "Pithy", + "Pivotal", + "Placid", + "Plain", + "Plaintive", + "Plastic", + "Plausible", + "Playful", + "Pleasant", + "Pleased", + "Pleasing", + "Pleasurable", + "Plenary", + "Plenteous", + "Plentiful", + "Pliable", + "Plucky", + "Plummy", + "Plump", + "Plush", + "Poetic", + "Poignant", + "Pointed", + "Poised", + "Polished", + "Polite", + "Political", + "Popular", + "Portly", + "Posh", + "Positive", + "Possible", + "Potable", + "Potent", + "Potential", + "Powerful", + "Practicable", + "Practical", + "Practised", + "Pragmatic", + "Praiseworthy", + "Prayerful", + "Precious", + "Precise", + "Predominant", + "Preeminent", + "Preferable", + "Preferred", + "Premier", + "Premium", + "Prepared", + "Preponderant", + "Prepotent", + "Present", + "Prestigious", + "Pretty", + "Prevailing", + "Prevalent", + "Prevenient", + "Previous", + "Primal", + "Primary", + "Prime", + "Primed", + "Primo", + "Princely", + "Principled", + "Pristine", + "Private", + "Privileged", + "Prize", + "Prized", + "Prizewinning", + "Pro", + "Proactive", + "Probable", + "Probative", + "Procurable", + "Prodigious", + "Productive", + "Professional", + "Proficient", + "Profitable", + "Profound", + "Profuse", + "Progressive", + "Prolific", + "Prominent", + "Promising", + "Prompt", + "Proper", + "Propertied", + "Prophetic", + "Propitious", + "Prospective", + "Prosperous", + "Protean", + "Protective", + "Proud", + "Provocative", + "Prudent", + "Puissant", + "Pulchritudinous", + "Punchy", + "Punctilious", + "Punctual", + "Pungent", + "Pure", + "Purple", + "Purposeful", + "Quaint", + "Qualified", + "Qualitative", + "Quality", + "Quantifiable", + "Quarterly", + "Queenly", + "Questionable", + "Quick", + "Quiet", + "Quietsome", + "Quintessential", + "Quirky", + "Quiver", + "Quixotic", + "Quizzical", + "Quotable", + "Racy", + "Rad", + "Radiant", + "Rapid", + "Rapturous", + "Rare", + "Rational", + "Raw", + "Reachable", + "Ready", + "Real", + "Realistic", + "Realizable", + "Reasonable", + "Reassuring", + "Recent", + "Receptive", + "Recherche", + "Recipient", + "Reciprocal", + "Recognizable", + "Recognized", + "Recommendable", + "Rectangular", + "Recuperative", + "Red", + "Refined", + "Reflecting", + "Reflective", + "Refreshing", + "Refulgent", + "Regal", + "Regnant", + "Regular", + "Rejuvenescent", + "Relaxed", + "Relevant", + "Reliable", + "Relieved", + "Remarkable", + "Remissive", + "Remote", + "Renowned", + "Repentant", + "Reputable", + "Required", + "Resilient", + "Resolute", + "Resolved", + "Resounding", + "Resourceful", + "Respectable", + "Respectful", + "Resplendent", + "Responsible", + "Responsive", + "Restful", + "Restorative", + "Retentive", + "Revealing", + "Revered", + "Reverent", + "Revitalizing", + "Revolutionary", + "Revolving", + "Rewardable", + "Rewarding", + "Rhapsodic", + "Rich", + "Right", + "Righteous", + "Rightful", + "Ringed", + "Ripe", + "Risible", + "Robust", + "Rollicking", + "Romantic", + "Rooted", + "Rosy", + "Rotating", + "Round", + "Rounded", + "Rousing", + "Royal", + "Rugged", + "Ruling", + "Runny", + "Rural", + "Saccharine", + "Sacred", + "Sacrosanct", + "Safe", + "Sagacious", + "Sage", + "Saintly", + "Salient", + "Salubrious", + "Salutary", + "Salutiferous", + "Sanctified", + "Sanctimonious", + "Sanctioned", + "Sandy", + "Sane", + "Sanguine", + "Sapid", + "Sapient", + "Sapoforic", + "Sassy", + "Satisfactory", + "Satisfied", + "Satisfying", + "Saucy", + "Saving", + "Savory", + "Savvy", + "Scenic", + "Scented", + "Scholarly", + "Scientific", + "Scintillating", + "Scrumptious", + "Scrupulous", + "Seamless", + "Seasonal", + "Seasoned", + "Second", + "Secondary", + "Secret", + "Secure", + "Sedulous", + "Seemly", + "Select", + "Selfless", + "Sensational", + "Sensible", + "Sensitive", + "Sensuous", + "Sentimental", + "Separate", + "Sequacious", + "Serendipitous", + "Serene", + "Serious", + "Service", + "Settled", + "Several", + "Severe", + "Shabby", + "Shadowy", + "Shapely", + "Sharp", + "Shatterproof", + "Sheen", + "Shimmering", + "Shining", + "Shiny", + "Shipshape", + "Shocked", + "Short", + "Showy", + "Shrewd", + "Sightly", + "Significant", + "Silent", + "Silken", + "Silky", + "Silver", + "Silvery", + "Similar", + "Simple", + "Simplistic", + "Sincere", + "Sinewy", + "Single", + "Singular", + "Sisterly", + "Sizable", + "Sizzling", + "Skeletal", + "Skilled", + "Skillful", + "Sleek", + "Slick", + "Slight", + "Slim", + "Slinky", + "Slippery", + "Slow", + "Smacking", + "Small", + "Smart", + "Smashing", + "Smiley", + "Smooth", + "Snap", + "Snappy", + "Snazzy", + "Snod", + "Snoopy", + "Snug", + "Soaring", + "Sociable", + "Social", + "Societal", + "Soft", + "Soigne", + "Solicitous", + "Solid", + "Sonsy", + "Sooth", + "Soothing", + "Sophisticated", + "Soulful", + "Sound", + "Soupy", + "Sour", + "Sovereign", + "Spacious", + "Spangly", + "Spanking", + "Sparkling", + "Sparkly", + "Special", + "Specific", + "Spectacular", + "Specular", + "Speedy", + "Spellbinding", + "Spherical", + "Spicy", + "Spiffy", + "Spirited", + "Spiritual", + "Splendid", + "Splendiferous", + "Spontaneous", + "Sport", + "Sporting", + "Sportive", + "Sporty", + "Spotless", + "Sprightly", + "Spruce", + "Spry", + "Spunky", + "Square", + "Stable", + "Stacked", + "Stainless", + "Stalwart", + "Staminal", + "Standard", + "Standing", + "Star", + "Starchy", + "Stark", + "Starry", + "State", + "Stately", + "Statuesque", + "Staunch", + "Steadfast", + "Steady", + "Steamy", + "Steel", + "Stellar", + "Sterling", + "Sthenic", + "Stimulant", + "Stimulating", + "Stimulative", + "Stipendiary", + "Stirred", + "Stirring", + "Stocky", + "Stoical", + "Storied", + "Stout", + "Stouthearted", + "Straightforward", + "Strange", + "Strapping", + "Strategic", + "Streetwise", + "Strenuous", + "Strict", + "Strident", + "Striking", + "Striped", + "Strong", + "Studious", + "Stunning", + "Stupendous", + "Sturdy", + "Stylish", + "Suasive", + "Suave", + "Sublime", + "Substant", + "Substantial", + "Substantive", + "Subtle", + "Suburban", + "Successful", + "Succinct", + "Succulent", + "Sufficient", + "Sugary", + "Suitable", + "Sultry", + "Summary", + "Summery", + "Sumptuous", + "Sunny", + "Super", + "Superabundant", + "Superb", + "Supereminent", + "Superethical", + "Superexcellent", + "Superficial", + "Superfluous", + "Superior", + "Superlative", + "Supernal", + "Supersonic", + "Supple", + "Supportive", + "Supreme", + "Sure", + "Surpassing", + "Surprised", + "Sustained", + "Svelte", + "Swank", + "Swashbuckling", + "Sweet", + "Swell", + "Swift", + "Swish", + "Sybaritic", + "Sylvan", + "Symmetrical", + "Sympathetic", + "Symphonious", + "Synergistic", + "Systematic", + "Tactful", + "Talented", + "Tall", + "Tame", + "Tan", + "Tangible", + "Tart", + "Tasteful", + "Tasty", + "Teachable", + "Teeming", + "Tempean", + "Temperate", + "Tenable", + "Tenacious", + "Tender", + "Terrific", + "Testimonial", + "Thankful", + "Thankworthy", + "Therapeutic", + "Thorough", + "Those", + "Thoughtful", + "Thrifty", + "Thrilled", + "Thrilling", + "Thriving", + "Tidy", + "Tight", + "Timeless", + "Timely", + "Tinted", + "Tiny", + "Tiptop", + "Tireless", + "Titanic", + "Titillating", + "Today", + "Together", + "Tolerant", + "Top", + "Tops", + "Total", + "Touching", + "Tough", + "Trailblazing", + "Trained", + "Tranquil", + "Transcendent", + "Transcendental", + "Transient", + "Transparent", + "Transpicuous", + "Traveled", + "Treasured", + "Tremendous", + "Triangular", + "Trim", + "Triumphant", + "True", + "Trustful", + "Trusting", + "Trustworthy", + "Trusty", + "Truthful", + "Tubular", + "Tuneful", + "Turgent", + "Twin", + "Tympanic", + "Uber", + "Ultimate", + "Ultra", + "Ultraprecise", + "Unabashed", + "Unadulterated", + "Unaffected", + "Unafraid", + "Unalloyed", + "Unambiguous", + "Unanimous", + "Unarguable", + "Unassuming", + "Unattached", + "Unbeaten", + "Unbelievable", + "Unbiased", + "Unbigoted", + "Unblemished", + "Unbroken", + "Uncommon", + "Uncomplicated", + "Unconditional", + "Unconscious", + "Uncontestable", + "Unconventional", + "Uncorrupted", + "Uncritical", + "Undamaged", + "Undauntable", + "Undaunted", + "Undefeated", + "Undefiled", + "Undeniable", + "Understandable", + "Understanding", + "Understated", + "Understood", + "Undesigning", + "Undiminished", + "Undisputed", + "Undivided", + "Undoubted", + "Unencumbered", + "Unequaled", + "Unequalled", + "Unequivocal", + "Unerring", + "Unfailing", + "Unfaltering", + "Unfaultable", + "Unfeigned", + "Unfettered", + "Unflagging", + "Unflappable", + "Ungrudging", + "Unhampered", + "Unharmed", + "Unhesitating", + "Unhurt", + "Unified", + "Uniform", + "Unimpaired", + "Unimpeachable", + "Unimpeded", + "Unique", + "United", + "Universal", + "Unlimited", + "Unmistakable", + "Unmitigated", + "Unobjectionable", + "Unobstructed", + "Unobtrusive", + "Unopposed", + "Unpretentious", + "Unquestionable", + "Unrefuted", + "Unreserved", + "Unrivalled", + "Unruffled", + "Unselfish", + "Unshakable", + "Unshaken", + "Unspoiled", + "Unspoilt", + "Unstoppable", + "Unsullied", + "Unsurpassed", + "Untarnished", + "Untiring", + "Untouched", + "Untroubled", + "Ununprejudiced", + "Unusual", + "Unwavering", + "Upbeat", + "Upcoming", + "Uplifted", + "Uplifting", + "Uppermost", + "Upright", + "Upset", + "Upstanding", + "Upward", + "Upwardly", + "Urban", + "Urbane", + "Usable", + "Useful", + "Useless", + "Utmost", + "Vacant", + "Vain", + "Valiant", + "Valid", + "Validatory", + "Valorous", + "Valuable", + "Valued", + "Vapid", + "Variable", + "Vast", + "Vaulting", + "Vehement", + "Velvety", + "Venerable", + "Venerated", + "Venturesome", + "Venue", + "Veracious", + "Verdurous", + "Veridical", + "Verifiable", + "Verified", + "Versatile", + "Versed", + "Vestal", + "Veteran", + "Viable", + "Vibrant", + "Vibratile", + "Victor", + "Victorious", + "Vigilant", + "Vigorous", + "Violet", + "Virile", + "Virtual", + "Virtuous", + "Visible", + "Visionary", + "Vital", + "Vivacious", + "Vivid", + "Vocal", + "Volant", + "Volitional", + "Voluminous", + "Voluptuous", + "Vulnerary", + "Wanted", + "Warm", + "Warmhearted", + "Warranted", + "Wasteful", + "Watchful", + "Waterlogged", + "Watery", + "Wavy", + "Wealthy", + "Weekly", + "Weighty", + "Welcome", + "Welcomed", + "Welcoming", + "Weleful", + "Welfaring", + "Well", + "Welsome", + "Wet", + "Whimsical", + "Whole", + "Wholehearted", + "Wholesome", + "Whopping", + "Wide", + "Wild", + "Willed", + "Willing", + "Winding", + "Windy", + "Winged", + "Winning", + "Winsome", + "Wired", + "Wise", + "Witty", + "Wizard", + "Wizardly", + "Wobbly", + "Wonderful", + "Wondrous", + "Wooden", + "Wordy", + "Workable", + "Worldly", + "Worshipful", + "Worth", + "Worthwhile", + "Worthy", + "Xenial", + "Xenodochial", + "Yearly", + "Yern", + "Young", + "Youthful", + "Yummy", + "Zaftig", + "Zany", + "Zappy", + "Zazzy", + "Zealand", + "Zealful", + "Zealous", + "Zestful", + "Zesty", + "Zigzag", + "Zingy", + "Zippy", + "Zootrophic", + "Zooty" + ] + +nouns :: [Text] +nouns = + [ "Academician", + "Acceptor", + "Access", + "Acclaim", + "Accolade", + "Account", + "Accuracy", + "Ace", + "Achiever", + "Acumen", + "Addition", + "Adherent", + "Adjutant", + "Administrator", + "Admirer", + "Adorer", + "Advantage", + "Aesthete", + "Aficionada", + "Aficionado", + "Agent", + "Aide", + "Almsgiver", + "Altruist", + "Ambassador", + "Amity", + "Angel", + "Apostle", + "Appreciator", + "Arbiter", + "Archetype", + "Architect", + "Artisan", + "Artist", + "Artiste", + "Asset", + "Assignee", + "Assigner", + "Athlete", + "Author", + "Authority", + "Avowal", + "Awardee", + "Aye", + "Azure", + "Baby", + "Backer", + "Backup", + "Beatitude", + "Beauty", + "Begetter", + "Being", + "Believer", + "Benchmark", + "Benefaction", + "Benefactor", + "Benefactress", + "Beneficiary", + "Benefit", + "Bestower", + "Betterment", + "Bigwig", + "Blessing", + "Bliss", + "Bloom", + "Blossom", + "Blossoming", + "Bodyguard", + "Bonanza", + "Bonus", + "Boost", + "Booster", + "Boss", + "Bound", + "Bounty", + "Brain", + "Brass", + "Brief", + "Brother", + "Buddy", + "Builder", + "Calm", + "Campaigner", + "Capital", + "Captain", + "Care", + "Caretaker", + "Catalyst", + "Cause", + "Celebrant", + "Celebrator", + "Celestial", + "Chair", + "Chairperson", + "Chamberlain", + "Champ", + "Champion", + "Charity", + "Charmer", + "Cheer", + "Cheers", + "Chief", + "Chieftain", + "Chirpy", + "Choice", + "Chortle", + "Chosen", + "Chuckle", + "Chum", + "Cinch", + "Civility", + "Clairvoyant", + "Classic", + "Clear", + "Climb", + "Climber", + "Climbing", + "Close", + "Closing", + "Coadjutant", + "Coadjutor", + "Coequal", + "Coiner", + "Collaborator", + "Colleague", + "Collector", + "Comfort", + "Comforter", + "Comic", + "Commander", + "Commendatory", + "Compassion", + "Composer", + "Comrade", + "Concierge", + "Condolence", + "Conductor", + "Confederate", + "Confidant", + "Confidence", + "Connoisseur", + "Consciousness", + "Conservator", + "Consoler", + "Constant", + "Constitutional", + "Consul", + "Consultant", + "Contemporary", + "Content", + "Contributor", + "Controller", + "Conversant", + "Cooperator", + "Cope", + "Cornerstone", + "Councillor", + "Counselor", + "Courage", + "Crack", + "Crackerjack", + "Craftsperson", + "Creator", + "Credential", + "Credit", + "Curator", + "Custodian", + "Dainty", + "Dancer", + "Daring", + "Darling", + "Dean", + "Dear", + "Decency", + "Deep", + "Defender", + "Definite", + "Delight", + "Demulcent", + "Deserving", + "Designer", + "Devisee", + "Devisor", + "Devotee", + "Devotional", + "Devout", + "Didactic", + "Director", + "Disciple", + "Discoverer", + "Distributor", + "Doer", + "Doll", + "Donee", + "Donor", + "Doting", + "Doyen", + "Doyenne", + "Dreamboat", + "Dynamic", + "Dynamite", + "Dynamo", + "Earnest", + "Ease", + "Effect", + "Efficiency", + "Efficient", + "Einstein", + "Elder", + "Eligible", + "Employer", + "Enchanter", + "Enchantress", + "Encourager", + "Endorser", + "Enlivening", + "Enough", + "Entertainer", + "Enthusiast", + "Entrepreneur", + "Epicure", + "Epicurean", + "Epitome", + "Equal", + "Equity", + "Equivalent", + "Essence", + "Essential", + "Esteem", + "Eternal", + "Ethic", + "Example", + "Exclusive", + "Executive", + "Exemplar", + "Exemplary", + "Experimenter", + "Expert", + "Exponent", + "Eyes", + "Fair", + "Faith", + "Faithful", + "Fame", + "Familiar", + "Fancier", + "Fancy", + "Fantastic", + "Fare", + "Fascinator", + "Fashioner", + "Favor", + "Favorite", + "Favour", + "Felicity", + "Fine", + "Fireball", + "Firm", + "First", + "Fleet", + "Folks", + "Foodie", + "Forbear", + "Force", + "Forefather", + "Foreman", + "Forerunner", + "Foresight", + "Forever", + "Forgiveness", + "Fortunate", + "Fortune", + "Forward", + "Foundation", + "Founder", + "Fountain", + "Fountainhead", + "Freedom", + "Freethinking", + "Fresh", + "Friend", + "Friendly", + "Fulfilling", + "Full", + "Fun", + "Funny", + "Gag", + "Gaiety", + "Gain", + "Gala", + "Galahad", + "Gale", + "Gallant", + "Gallantry", + "Game", + "Garb", + "Garden", + "Garland", + "Garnish", + "Gastronome", + "Gastronomy", + "Gather", + "Gathering", + "Geek", + "Gem", + "Generativity", + "Generator", + "Generosity", + "Genius", + "Gentle", + "Gentlefolk", + "Gentleman", + "Gentlewoman", + "Gift", + "Gild", + "Gilt", + "Girlfriend", + "Gist", + "Giver", + "Giving", + "Glamour", + "Glance", + "Glare", + "Glaze", + "Gleam", + "Gleaming", + "Glimmer", + "Glimmering", + "Glint", + "Glisten", + "Glister", + "Glitterati", + "Glitz", + "Glory", + "Gloss", + "Glossy", + "Goal", + "God", + "Goddess", + "Godparent", + "Godsend", + "Golconda", + "Gold", + "Good", + "Goodness", + "Goodwill", + "Goody", + "Gorgeousness", + "Gourmet", + "Governor", + "Grace", + "Gracility", + "Graciousness", + "Grade", + "Graduate", + "Grammy", + "Grandee", + "Grandeur", + "Grandmaster", + "Grant", + "Grantee", + "Grantor", + "Grass", + "Gratefulness", + "Gratification", + "Gratitude", + "Great", + "Greatness", + "Greeting", + "Grin", + "Grit", + "Groove", + "Growing", + "Growth", + "Grubstake", + "Guarantor", + "Guard", + "Guardian", + "Guest", + "Guffaw", + "Guidance", + "Guide", + "Gumption", + "Guru", + "Gush", + "Gusto", + "Gut", + "Gymnastic", + "Hale", + "Handler", + "Happening", + "Harmony", + "Head", + "Headman", + "Heart", + "Heartthrob", + "Heaven", + "Height", + "Heir", + "Heiress", + "Hello", + "Help", + "Helper", + "Helpmate", + "Heritor", + "Heritress", + "Heritrix", + "Hero", + "Heroine", + "Heuristic", + "Highflier", + "Hilarity", + "Holy", + "Honesty", + "Honor", + "Hooray", + "Hope", + "Hopeful", + "Hotshot", + "Humanitarian", + "Humor", + "Husband", + "Icon", + "Idea", + "Ideal", + "Idol", + "Idolizer", + "Improvement", + "Inamorata", + "Inamorato", + "Increase", + "Independent", + "Indivisible", + "Industrialist", + "Infant", + "Infinite", + "Ingenuity", + "Inheritor", + "Initiative", + "Initiator", + "Innocent", + "Innovator", + "Inspiration", + "Institutor", + "Integral", + "Intellect", + "Intent", + "Interest", + "Intimate", + "Inventor", + "Invitation", + "Invite", + "Invitee", + "Jest", + "Jester", + "Jingle", + "Joker", + "Josh", + "Jubilation", + "Juggler", + "Justice", + "Keeper", + "Key", + "Kindred", + "Kingpin", + "Kiss", + "Knight", + "Lady", + "Lark", + "Lasting", + "Latitudinarian", + "Laugh", + "Laureate", + "Lead", + "Leader", + "Learning", + "Legatee", + "Legator", + "Legend", + "Legislator", + "Leisure", + "Liberation", + "Libertarian", + "Lieutenant", + "Life", + "Light", + "Like", + "Liking", + "Lionheart", + "Literate", + "Lord", + "Love", + "Lover", + "Luck", + "Lust", + "Luster", + "Lustre", + "Luxury", + "Maestro", + "Magician", + "Magistrate", + "Magnitude", + "Majesty", + "Major", + "Majority", + "Make", + "Maker", + "Mana", + "Manager", + "Manner", + "Marvel", + "Massage", + "Mastermind", + "Mate", + "Matriarch", + "Matter", + "Mentor", + "Mercy", + "Merit", + "Method", + "Might", + "Minder", + "Minikin", + "Mint", + "Miracle", + "Mirth", + "Model", + "Modern", + "Mom", + "Moppet", + "Morale", + "Most", + "Motivator", + "Motor", + "Mover", + "Moving", + "Much", + "Multitude", + "Music", + "Nabit", + "Narration", + "Narrator", + "Nascency", + "Natation", + "National", + "Native", + "Natural", + "Negoce", + "Neighbor", + "Neonate", + "Neoteric", + "Nestling", + "Newborn", + "Nicety", + "Nimblewit", + "Nipper", + "Nirvana", + "Noble", + "Nobleman", + "Nod", + "Nonpareil", + "Noon", + "Notable", + "Note", + "Notice", + "Novel", + "Nudge", + "Nurse", + "Nursling", + "Nurture", + "Objective", + "Offer", + "Officer", + "Official", + "Offspring", + "Olympian", + "One", + "Oodles", + "Oomph", + "Ooze", + "Operator", + "Opportunity", + "Optimist", + "Optimum", + "Orchestrator", + "Organizer", + "Original", + "Originator", + "Ornamental", + "Overflowing", + "Overseer", + "Owner", + "Pacifist", + "Pal", + "Paradigm", + "Paradise", + "Paragon", + "Paramount", + "Pard", + "Pardon", + "Parent", + "Participant", + "Particular", + "Partisan", + "Partner", + "Passion", + "Pathfinder", + "Patience", + "Patient", + "Patriarch", + "Patron", + "Peace", + "Peacekeeper", + "Peach", + "Peak", + "Pearl", + "Peer", + "Pep", + "Perfection", + "Perfectionist", + "Performer", + "Personality", + "Perspective", + "Pet", + "Phenomenon", + "Philanthropist", + "Philanthropy", + "Philosopher", + "Pick", + "Pilot", + "Pioneer", + "Pivot", + "Plan", + "Planner", + "Play", + "Player", + "Playmate", + "Pleasing", + "Pleasure", + "Plenitude", + "Plenty", + "Poet", + "Poise", + "Positive", + "Possessor", + "Possible", + "Postulant", + "Potential", + "Pragmatic", + "Praise", + "Prayer", + "Precious", + "Preemption", + "Premier", + "Premium", + "Presence", + "Present", + "Presenter", + "President", + "Pretty", + "Primary", + "Prime", + "Primogenitor", + "Prince", + "Princess", + "Principal", + "Prize", + "Pro", + "Proconsul", + "Procreator", + "Prodigy", + "Produce", + "Producer", + "Professional", + "Professor", + "Progenitor", + "Progeny", + "Progress", + "Progressive", + "Prolepsis", + "Promoter", + "Promotion", + "Promulgator", + "Prophet", + "Proponent", + "Proposer", + "Proprietor", + "Prospective", + "Protagonist", + "Protector", + "Protege", + "Provider", + "Provocative", + "Publisher", + "Purveyor", + "Quaff", + "Quaintise", + "Quaintisiness", + "Quality", + "Quantity", + "Quarter", + "Queen", + "Queenhood", + "Querist", + "Quest", + "Quester", + "Question", + "Quick", + "Quickness", + "Quickstep", + "Quiet", + "Quillet", + "Quintessence", + "Quip", + "Quirk", + "Quotation", + "Radiant", + "Rapture", + "Rational", + "Ready", + "Real", + "Reason", + "Receiver", + "Reception", + "Reciprocal", + "Recuperation", + "Regulator", + "Rejoicing", + "Rejuvenation", + "Release", + "Relief", + "Reliever", + "Renovation", + "Reputation", + "Resource", + "Respect", + "Restoration", + "Result", + "Reverence", + "Reward", + "Rhapsody", + "Rich", + "Right", + "Rise", + "Roll", + "Romantic", + "Romeo", + "Rooter", + "Rose", + "Round", + "Rouse", + "Ruler", + "Ruling", + "Run", + "Runner", + "Sage", + "Saint", + "Salient", + "Salubrity", + "Salute", + "Sanctity", + "Sanctuary", + "Satisfaction", + "Savant", + "Saver", + "Savior", + "Savory", + "Savvy", + "Scholar", + "Scholarship", + "Science", + "Scion", + "Script", + "Scripter", + "Sculptor", + "Seeker", + "Select", + "Sensation", + "Sense", + "Sensibility", + "Sentiment", + "Sentinel", + "Serendipity", + "Serene", + "Serenity", + "Server", + "Set", + "Settling", + "Shape", + "Share", + "Sharp", + "Sharpy", + "Shaver", + "Shelter", + "Shine", + "Show", + "Sight", + "Significance", + "Significant", + "Simplicity", + "Sinew", + "Sir", + "Sire", + "Sister", + "Size", + "Skill", + "Skin", + "Skipper", + "Sleek", + "Slick", + "Smash", + "Smile", + "Smooth", + "Smoothie", + "Snap", + "Snuggle", + "Soar", + "Sociable", + "Social", + "Socializer", + "Sol", + "Solid", + "Sophisticate", + "Soul", + "Sovereign", + "Spark", + "Sparkling", + "Special", + "Specialist", + "Spectacle", + "Spectacular", + "Speed", + "Spell", + "Spice", + "Spirit", + "Spiritual", + "Splendor", + "Sponsor", + "Sport", + "Sportsmanship", + "Spot", + "Sprite", + "Sprout", + "Squire", + "Stalwart", + "Standard", + "Star", + "State", + "Steady", + "Steward", + "Stipend", + "Stipendiary", + "Stir", + "Stirring", + "Strategist", + "Strategy", + "Stripling", + "Strive", + "Student", + "Style", + "Stylist", + "Sublime", + "Substance", + "Success", + "Successor", + "Sufficiency", + "Sugar", + "Suitor", + "Summary", + "Summer", + "Super", + "Superintendent", + "Superior", + "Superlative", + "Superman", + "Supervisor", + "Superwoman", + "Supplier", + "Supply", + "Support", + "Surety", + "Surprise", + "Survivor", + "Swain", + "Sweetheart", + "Sweetness", + "Swell", + "Sympathy", + "Synergy", + "System", + "Tact", + "Talent", + "Taste", + "Teacher", + "Teaching", + "Team", + "Teammate", + "Tender", + "Testament", + "Testator", + "Testimonial", + "Testimony", + "Thank", + "Thanksgiving", + "Therapy", + "Thinker", + "Thrill", + "Timesaver", + "Tiptop", + "Titleholder", + "Today", + "Tootsie", + "Top", + "Tot", + "Total", + "Touch", + "Tout", + "Trailblazer", + "Training", + "Tranquillity", + "Transcendent", + "Transient", + "Travel", + "Treasure", + "Trim", + "Triumph", + "Trust", + "Trustee", + "Trusty", + "Truth", + "Try", + "Tuition", + "Tune", + "Tutor", + "Tycoon", + "Uberty", + "Ubiquitary", + "Ultimate", + "Ultimation", + "Understanding", + "Underwriter", + "Unique", + "Universal", + "Upholder", + "Uplift", + "Valedictorian", + "Valiant", + "Validator", + "Valuable", + "Value", + "Vast", + "Vaulter", + "Veracity", + "Vestal", + "Veteran", + "Virtue", + "Virtuosity", + "Visionary", + "Visitor", + "Vitality", + "Vogue", + "Votary", + "Warden", + "Warmth", + "Warrantee", + "Warrantor", + "Welcome", + "Well", + "Wellspring", + "Whip", + "Whiz", + "Whole", + "Wife", + "Will", + "Willpower", + "Win", + "Winner", + "Winning", + "Wisdom", + "Wise", + "Wizard", + "Wonder", + "Wonderment", + "Wooer", + "Wordsmith", + "Workhorse", + "Workmate", + "Worshipper", + "Worth", + "Worthy", + "Writer", + "Wunderkind", + "X", + "Xenagogue", + "Xenium", + "Xenophile", + "Xenophilia", + "Xesturgy", + "Xfactor", + "Yard", + "Yeve", + "Yield", + "Yift", + "Yoke", + "Young", + "Youngster", + "Youth", + "Zaniness", + "Zarf", + "Zeal", + "Zegedine", + "Zest", + "Zibeline", + "Zing" + ] diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 8b6a402288..3a957fbe2b 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -124,7 +124,7 @@ data ChatMsgEvent | XInfo Profile | XContact Profile (Maybe XContactId) | XGrpInv GroupInvitation - | XGrpAcpt MemberId + | XGrpAcpt MemberId (Maybe Profile) | XGrpMemNew MemberInfo | XGrpMemIntro MemberInfo | XGrpMemInv MemberId IntroInvitation @@ -413,7 +413,7 @@ toCMEventTag = \case XInfo _ -> XInfo_ XContact _ _ -> XContact_ XGrpInv _ -> XGrpInv_ - XGrpAcpt _ -> XGrpAcpt_ + XGrpAcpt _ _ -> XGrpAcpt_ XGrpMemNew _ -> XGrpMemNew_ XGrpMemIntro _ -> XGrpMemIntro_ XGrpMemInv _ _ -> XGrpMemInv_ @@ -479,7 +479,7 @@ appToChatMessage AppMessage {msgId, event, params} = do XInfo_ -> XInfo <$> p "profile" XContact_ -> XContact <$> p "profile" <*> opt "contactReqId" XGrpInv_ -> XGrpInv <$> p "groupInvitation" - XGrpAcpt_ -> XGrpAcpt <$> p "memberId" + XGrpAcpt_ -> XGrpAcpt <$> p "memberId" <*> opt "memberProfile" XGrpMemNew_ -> XGrpMemNew <$> p "memberInfo" XGrpMemIntro_ -> XGrpMemIntro <$> p "memberInfo" XGrpMemInv_ -> XGrpMemInv <$> p "memberId" <*> p "memberIntro" @@ -521,7 +521,7 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, p XInfo profile -> o ["profile" .= profile] XContact profile xContactId -> o $ ("contactReqId" .=? xContactId) ["profile" .= profile] XGrpInv groupInv -> o ["groupInvitation" .= groupInv] - XGrpAcpt memId -> o ["memberId" .= memId] + XGrpAcpt memId profile -> o $ ("memberProfile" .=? profile) ["memberId" .= memId] XGrpMemNew memInfo -> o ["memberInfo" .= memInfo] XGrpMemIntro memInfo -> o ["memberInfo" .= memInfo] XGrpMemInv memId memIntro -> o ["memberId" .= memId, "memberIntro" .= memIntro] diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index de0abc8d21..456bb21634 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -27,6 +27,7 @@ module Simplex.Chat.Store setActiveUser, createDirectConnection, createConnReqConnection, + getProfileById, getConnReqContactXContactId, createDirectContact, getContactGroupNames, @@ -76,16 +77,18 @@ module Simplex.Chat.Store getUserGroups, getUserGroupDetails, getGroupInvitation, - createContactMember, + createNewContactMember, getMemberInvitation, createMemberConnection, updateGroupMemberStatus, + createMemberIncognitoProfile, createNewGroupMember, deleteGroupMember, deleteGroupMemberConnection, createIntroductions, updateIntroStatus, saveIntroInvitation, + getGroupMemberProfileId, createIntroReMember, createIntroToMemberContact, saveMemberInvitation, @@ -223,6 +226,7 @@ import Simplex.Chat.Migrations.M20220626_auto_reply import Simplex.Chat.Migrations.M20220702_calls import Simplex.Chat.Migrations.M20220715_groups_chat_item_id import Simplex.Chat.Migrations.M20220811_chat_items_indices +import Simplex.Chat.Migrations.M20220812_incognito_profiles import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, InvitationId, MsgMeta (..)) @@ -252,7 +256,8 @@ schemaMigrations = ("20220626_auto_reply", m20220626_auto_reply), ("20220702_calls", m20220702_calls), ("20220715_groups_chat_item_id", m20220715_groups_chat_item_id), - ("20220811_chat_items_indices", m20220811_chat_items_indices) + ("20220811_chat_items_indices", m20220811_chat_items_indices), + ("20220812_incognito_profiles", m20220812_incognito_profiles) ] -- | The list of migrations in ascending order by date @@ -302,7 +307,7 @@ createUser db Profile {displayName, fullName, image} activeUser = (profileId, displayName, userId, True, currentTs, currentTs) contactId <- insertedRowId db DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId) - pure $ toUser (userId, contactId, activeUser, displayName, fullName, image) + pure $ toUser (userId, contactId, profileId, activeUser, displayName, fullName, image) getUsers :: DB.Connection -> IO [User] getUsers db = @@ -310,15 +315,15 @@ getUsers db = <$> DB.query_ db [sql| - SELECT u.user_id, u.contact_id, u.active_user, u.local_display_name, p.full_name, p.image + SELECT u.user_id, u.contact_id, p.contact_profile_id, u.active_user, u.local_display_name, p.full_name, p.image FROM users u JOIN contacts c ON u.contact_id = c.contact_id JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id |] -toUser :: (UserId, Int64, Bool, ContactName, Text, Maybe ImageData) -> User -toUser (userId, userContactId, activeUser, displayName, fullName, image) = - let profile = Profile {displayName, fullName, image} +toUser :: (UserId, ContactId, ProfileId, Bool, ContactName, Text, Maybe ImageData) -> User +toUser (userId, userContactId, profileId, activeUser, displayName, fullName, image) = + let profile = LocalProfile {profileId, displayName, fullName, image} in User {userId, userContactId, localDisplayName = displayName, profile, activeUser} setActiveUser :: DB.Connection -> UserId -> IO () @@ -326,21 +331,22 @@ setActiveUser db userId = do DB.execute_ db "UPDATE users SET active_user = 0" DB.execute db "UPDATE users SET active_user = 1 WHERE user_id = ?" (Only userId) -createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> IO PendingContactConnection -createConnReqConnection db userId acId cReqHash xContactId = do +createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> IO PendingContactConnection +createConnReqConnection db userId acId cReqHash xContactId incognitoProfile = do createdAt <- getCurrentTime + customUserProfileId <- createIncognitoProfile_ db userId createdAt incognitoProfile let pccConnStatus = ConnJoined DB.execute db [sql| INSERT INTO connections ( user_id, agent_conn_id, conn_status, conn_type, - created_at, updated_at, via_contact_uri_hash, xcontact_id - ) VALUES (?,?,?,?,?,?,?,?) + via_contact_uri_hash, xcontact_id, custom_user_profile_id, created_at, updated_at + ) VALUES (?,?,?,?,?,?,?,?,?) |] - (userId, acId, pccConnStatus, ConnContact, createdAt, createdAt, cReqHash, xContactId) + (userId, acId, pccConnStatus, ConnContact, cReqHash, xContactId, customUserProfileId, createdAt, createdAt) pccConnId <- insertedRowId db - pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, viaUserContactLink = Nothing, createdAt, updatedAt = createdAt} + pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, viaUserContactLink = Nothing, customUserProfileId, createdAt, updatedAt = createdAt} getConnReqContactXContactId :: DB.Connection -> UserId -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId) getConnReqContactXContactId db userId cReqHash = do @@ -356,9 +362,9 @@ getConnReqContactXContactId db userId cReqHash = do [sql| SELECT -- Contact - ct.contact_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, ct.created_at, ct.updated_at, + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, ct.created_at, ct.updated_at, -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.conn_status, c.conn_type, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM contacts ct JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id @@ -376,47 +382,72 @@ getConnReqContactXContactId db userId cReqHash = do "SELECT xcontact_id FROM connections WHERE user_id = ? AND via_contact_uri_hash = ? LIMIT 1" (userId, cReqHash) -createDirectConnection :: DB.Connection -> UserId -> ConnId -> ConnStatus -> IO PendingContactConnection -createDirectConnection db userId acId pccConnStatus = do +createDirectConnection :: DB.Connection -> UserId -> ConnId -> ConnStatus -> Maybe Profile -> IO PendingContactConnection +createDirectConnection db userId acId pccConnStatus incognitoProfile = do createdAt <- getCurrentTime + customUserProfileId <- createIncognitoProfile_ db userId createdAt incognitoProfile DB.execute db [sql| INSERT INTO connections - (user_id, agent_conn_id, conn_status, conn_type, created_at, updated_at) VALUES (?,?,?,?,?,?) + (user_id, agent_conn_id, conn_status, conn_type, custom_user_profile_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?) |] - (userId, acId, pccConnStatus, ConnContact, createdAt, createdAt) + (userId, acId, pccConnStatus, ConnContact, customUserProfileId, createdAt, createdAt) pccConnId <- insertedRowId db - pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = False, viaUserContactLink = Nothing, createdAt, updatedAt = createdAt} + pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = False, viaUserContactLink = Nothing, customUserProfileId, createdAt, updatedAt = createdAt} -createMemberContactConnection_ :: DB.Connection -> UserId -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection -createMemberContactConnection_ db userId agentConnId viaContact = createConnection_ db userId ConnContact Nothing agentConnId viaContact Nothing +createIncognitoProfile_ :: DB.Connection -> UserId -> UTCTime -> Maybe Profile -> IO (Maybe Int64) +createIncognitoProfile_ db userId createdAt incognitoProfile = + forM incognitoProfile $ \Profile {displayName, fullName, image} -> do + DB.execute + db + [sql| + INSERT INTO contact_profiles (display_name, full_name, image, user_id, incognito, created_at, updated_at) + VALUES (?,?,?,?,?,?,?) + |] + (displayName, fullName, image, userId, Just True, createdAt, createdAt) + insertedRowId db -createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> Maybe Int64 -> Maybe Int64 -> Int -> UTCTime -> IO Connection -createConnection_ db userId connType entityId acId viaContact viaUserContactLink connLevel currentTs = do +getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO Profile +getProfileById db userId profileId = + ExceptT . firstRow toProfile (SEProfileNotFound profileId) $ + DB.query + db + [sql| + SELECT display_name, full_name, image + FROM contact_profiles + WHERE user_id = ? AND contact_profile_id = ? + |] + (userId, profileId) + where + toProfile :: (ContactName, Text, Maybe ImageData) -> Profile + toProfile (displayName, fullName, image) = Profile {displayName, fullName, image} + +createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> IO Connection +createConnection_ db userId connType entityId acId viaContact viaUserContactLink customUserProfileId connLevel currentTs = do DB.execute db [sql| INSERT INTO connections ( - user_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, conn_status, conn_type, + user_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, custom_user_profile_id, conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, updated_at - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?) + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] - ( (userId, acId, connLevel, viaContact, viaUserContactLink, ConnNew, connType) + ( (userId, acId, connLevel, viaContact, viaUserContactLink, customUserProfileId, ConnNew, connType) :. (ent ConnContact, ent ConnMember, ent ConnSndFile, ent ConnRcvFile, ent ConnUserContact, currentTs, currentTs) ) connId <- insertedRowId db - pure Connection {connId, agentConnId = AgentConnId acId, connType, entityId, viaContact, viaUserContactLink, connLevel, connStatus = ConnNew, createdAt = currentTs} + pure Connection {connId, agentConnId = AgentConnId acId, connType, entityId, viaContact, viaUserContactLink, customUserProfileId, connLevel, connStatus = ConnNew, createdAt = currentTs} where ent ct = if connType == ct then entityId else Nothing createDirectContact :: DB.Connection -> UserId -> Connection -> Profile -> ExceptT StoreError IO Contact createDirectContact db userId activeConn@Connection {connId} profile = do createdAt <- liftIO getCurrentTime - (localDisplayName, contactId, _) <- createContact_ db userId connId profile Nothing createdAt - pure $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup = Nothing, createdAt, updatedAt = createdAt} + (localDisplayName, contactId, profileId) <- createContact_ db userId connId profile Nothing createdAt + pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile, activeConn, viaGroup = Nothing, createdAt, updatedAt = createdAt} -createContact_ :: DB.Connection -> UserId -> Int64 -> Profile -> Maybe Int64 -> UTCTime -> ExceptT StoreError IO (Text, Int64, Int64) +createContact_ :: DB.Connection -> UserId -> Int64 -> Profile -> Maybe Int64 -> UTCTime -> ExceptT StoreError IO (Text, ContactId, ProfileId) createContact_ db userId connId Profile {displayName, fullName, image} viaGroup currentTs = ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do DB.execute @@ -430,7 +461,7 @@ createContact_ db userId connId Profile {displayName, fullName, image} viaGroup (profileId, ldn, userId, viaGroup, currentTs, currentTs) contactId <- insertedRowId db DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId) - pure (ldn, contactId, profileId) + pure . Right $ (ldn, contactId, profileId) getContactGroupNames :: DB.Connection -> UserId -> Contact -> IO [GroupName] getContactGroupNames db userId Contact {contactId} = @@ -482,9 +513,9 @@ deleteContactProfile_ db userId contactId = (userId, contactId) updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO () -updateUserProfile db User {userId, userContactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName} +updateUserProfile db User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName}} p'@Profile {displayName = newName} | displayName == newName = - liftIO $ updateContactProfile_ db userId userContactId p' + liftIO $ updateContactProfile_ db userId profileId p' | otherwise = checkConstraint SEDuplicateName . liftIO $ do currentTs <- getCurrentTime @@ -493,49 +524,35 @@ updateUserProfile db User {userId, userContactId, localDisplayName, profile = Pr db "INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" (newName, newName, userId, currentTs, currentTs) - updateContactProfile_' db userId userContactId p' currentTs + updateContactProfile_' db userId profileId p' currentTs updateContact_ db userId userContactId localDisplayName newName currentTs updateContactProfile :: DB.Connection -> UserId -> Contact -> Profile -> ExceptT StoreError IO Contact -updateContactProfile db userId c@Contact {contactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName} +updateContactProfile db userId c@Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName}} p'@Profile {displayName = newName} | displayName == newName = - liftIO $ updateContactProfile_ db userId contactId p' $> (c :: Contact) {profile = p'} + liftIO $ updateContactProfile_ db userId profileId p' $> (c :: Contact) {profile = toLocalProfile profileId p'} | otherwise = ExceptT . withLocalDisplayName db userId newName $ \ldn -> do currentTs <- getCurrentTime - updateContactProfile_' db userId contactId p' currentTs + updateContactProfile_' db userId profileId p' currentTs updateContact_ db userId contactId localDisplayName ldn currentTs - pure $ (c :: Contact) {localDisplayName = ldn, profile = p'} + pure . Right $ (c :: Contact) {localDisplayName = ldn, profile = toLocalProfile profileId p'} -updateContactProfile_ :: DB.Connection -> UserId -> Int64 -> Profile -> IO () -updateContactProfile_ db userId contactId profile = do +updateContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> IO () +updateContactProfile_ db userId profileId profile = do currentTs <- getCurrentTime - updateContactProfile_' db userId contactId profile currentTs + updateContactProfile_' db userId profileId profile currentTs -updateContactProfile_' :: DB.Connection -> UserId -> Int64 -> Profile -> UTCTime -> IO () -updateContactProfile_' db userId contactId Profile {displayName, fullName, image} updatedAt = do - DB.executeNamed +updateContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO () +updateContactProfile_' db userId profileId Profile {displayName, fullName, image} updatedAt = do + DB.execute db [sql| UPDATE contact_profiles - SET display_name = :display_name, - full_name = :full_name, - image = :image, - updated_at = :updated_at - WHERE contact_profile_id IN ( - SELECT contact_profile_id - FROM contacts - WHERE user_id = :user_id - AND contact_id = :contact_id - ) + SET display_name = ?, full_name = ?, image = ?, updated_at = ? + WHERE user_id = ? AND contact_profile_id = ? |] - [ ":display_name" := displayName, - ":full_name" := fullName, - ":image" := image, - ":updated_at" := updatedAt, - ":user_id" := userId, - ":contact_id" := contactId - ] + (displayName, fullName, image, updatedAt, userId, profileId) updateContact_ :: DB.Connection -> UserId -> Int64 -> ContactName -> ContactName -> UTCTime -> IO () updateContact_ db userId contactId displayName newName updatedAt = do @@ -549,17 +566,17 @@ updateContact_ db userId contactId displayName newName updatedAt = do (newName, updatedAt, userId, contactId) DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (displayName, userId) -type ContactRow = (Int64, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, UTCTime, UTCTime) +type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, UTCTime, UTCTime) toContact :: ContactRow :. ConnectionRow -> Contact -toContact ((contactId, localDisplayName, viaGroup, displayName, fullName, image, createdAt, updatedAt) :. connRow) = - let profile = Profile {displayName, fullName, image} +toContact ((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, createdAt, updatedAt) :. connRow) = + let profile = LocalProfile {profileId, displayName, fullName, image} activeConn = toConnection connRow in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, createdAt, updatedAt} toContactOrError :: ContactRow :. MaybeConnectionRow -> Either StoreError Contact -toContactOrError ((contactId, localDisplayName, viaGroup, displayName, fullName, image, createdAt, updatedAt) :. connRow) = - let profile = Profile {displayName, fullName, image} +toContactOrError ((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, createdAt, updatedAt) :. connRow) = + let profile = LocalProfile {profileId, displayName, fullName, image} in case toMaybeConnection connRow of Just activeConn -> Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, createdAt, updatedAt} @@ -586,7 +603,7 @@ createUserContactLink db userId agentConnId cReq = "INSERT INTO user_contact_links (user_id, conn_req_contact, created_at, updated_at) VALUES (?,?,?,?)" (userId, cReq, currentTs, currentTs) userContactLinkId <- insertedRowId db - void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing 0 currentTs + void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs getUserContactLinkConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection] getUserContactLinkConnections db user = do @@ -599,7 +616,7 @@ getUserContactLinks db User {userId} = <$> DB.queryNamed db [sql| - SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, uc.user_contact_link_id, uc.conn_req_contact FROM connections c @@ -717,7 +734,7 @@ createOrUpdateContactRequest db userId userContactLinkId invId Profile {displayN createContactRequest :: IO (Either StoreError Int64) createContactRequest = do currentTs <- getCurrentTime - withLocalDisplayName db userId displayName (createContactRequest_ currentTs) + withLocalDisplayName db userId displayName (fmap Right . createContactRequest_ currentTs) where createContactRequest_ currentTs ldn = do DB.execute @@ -742,9 +759,9 @@ createOrUpdateContactRequest db userId userContactLinkId invId Profile {displayN [sql| SELECT -- Contact - ct.contact_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, ct.created_at, ct.updated_at, + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, ct.created_at, ct.updated_at, -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.conn_status, c.conn_type, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM contacts ct JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id @@ -777,9 +794,10 @@ createOrUpdateContactRequest db userId userContactLinkId invId Profile {displayN updateProfile currentTs if displayName == oldDisplayName then Right <$> DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, currentTs, userId, cReqId) - else withLocalDisplayName db userId displayName $ \ldn -> do - DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, ldn, currentTs, userId, cReqId) - DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (oldLdn, userId) + else withLocalDisplayName db userId displayName $ \ldn -> + Right <$> do + DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, ldn, currentTs, userId, cReqId) + DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (oldLdn, userId) where updateProfile currentTs = DB.execute @@ -853,17 +871,18 @@ deleteContactRequest db userId contactRequestId = do (userId, userId, contactRequestId) DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?" (userId, contactRequestId) -createAcceptedContact :: DB.Connection -> UserId -> ConnId -> ContactName -> Int64 -> Profile -> Int64 -> Maybe XContactId -> IO Contact -createAcceptedContact db userId agentConnId localDisplayName profileId profile userContactLinkId xContactId = do +createAcceptedContact :: DB.Connection -> UserId -> ConnId -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe Profile -> IO Contact +createAcceptedContact db userId agentConnId localDisplayName profileId profile userContactLinkId xContactId incognitoProfile = do DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) - currentTs <- getCurrentTime + createdAt <- getCurrentTime + customUserProfileId <- createIncognitoProfile_ db userId createdAt incognitoProfile DB.execute db "INSERT INTO contacts (user_id, local_display_name, contact_profile_id, created_at, updated_at, xcontact_id) VALUES (?,?,?,?,?,?)" - (userId, localDisplayName, profileId, currentTs, currentTs, xContactId) + (userId, localDisplayName, profileId, createdAt, createdAt, xContactId) contactId <- insertedRowId db - activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId Nothing (Just userContactLinkId) 0 currentTs - pure $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup = Nothing, createdAt = currentTs, updatedAt = currentTs} + activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId Nothing (Just userContactLinkId) customUserProfileId 0 createdAt + pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile, activeConn, viaGroup = Nothing, createdAt = createdAt, updatedAt = createdAt} getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer] getLiveSndFileTransfers db User {userId} = do @@ -917,7 +936,7 @@ getPendingContactConnections db User {userId} = do <$> DB.queryNamed db [sql| - SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, created_at, updated_at + SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, custom_user_profile_id, created_at, updated_at FROM connections WHERE user_id = :user_id AND conn_type = :conn_type @@ -933,7 +952,7 @@ getContactConnections db userId Contact {contactId} = DB.query db [sql| - SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM connections c JOIN contacts ct ON ct.contact_id = c.contact_id @@ -945,14 +964,14 @@ getContactConnections db userId Contact {contactId} = type EntityIdsRow = (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64) -type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, ConnStatus, ConnType) :. EntityIdsRow :. Only UTCTime +type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, Maybe Int64, ConnStatus, ConnType) :. EntityIdsRow :. Only UTCTime -type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe ConnStatus, Maybe ConnType) :. EntityIdsRow :. Only (Maybe UTCTime) +type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe Int64, Maybe ConnStatus, Maybe ConnType) :. EntityIdsRow :. Only (Maybe UTCTime) toConnection :: ConnectionRow -> Connection -toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, connStatus, connType) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. Only createdAt) = +toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, customUserProfileId, connStatus, connType) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. Only createdAt) = let entityId = entityId_ connType - in Connection {connId, agentConnId = AgentConnId acId, connLevel, viaContact, viaUserContactLink, connStatus, connType, entityId, createdAt} + in Connection {connId, agentConnId = AgentConnId acId, connLevel, viaContact, viaUserContactLink, customUserProfileId, connStatus, connType, entityId, createdAt} where entityId_ :: ConnType -> Maybe Int64 entityId_ ConnContact = contactId @@ -962,30 +981,25 @@ toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, connStat entityId_ ConnUserContact = userContactLinkId toMaybeConnection :: MaybeConnectionRow -> Maybe Connection -toMaybeConnection ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just connStatus, Just connType) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. Only (Just createdAt)) = - Just $ toConnection ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, connStatus, connType) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. Only createdAt) +toMaybeConnection ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, customUserProfileId, Just connStatus, Just connType) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. Only (Just createdAt)) = + Just $ toConnection ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, customUserProfileId, connStatus, connType) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. Only createdAt) toMaybeConnection _ = Nothing getMatchingContacts :: DB.Connection -> UserId -> Contact -> IO [Contact] -getMatchingContacts db userId Contact {contactId, profile = Profile {displayName, fullName, image}} = do +getMatchingContacts db userId Contact {contactId, profile = LocalProfile {displayName, fullName, image}} = do contactIds <- map fromOnly - <$> DB.queryNamed + <$> DB.query db [sql| SELECT ct.contact_id FROM contacts ct JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id - WHERE ct.user_id = :user_id AND ct.contact_id != :contact_id - AND p.display_name = :display_name AND p.full_name = :full_name - AND ((p.image IS NULL AND :image IS NULL) OR p.image = :image) + WHERE ct.user_id = ? AND ct.contact_id != ? + AND p.display_name = ? AND p.full_name = ? + AND ((p.image IS NULL AND ? IS NULL) OR p.image = ?) |] - [ ":user_id" := userId, - ":contact_id" := contactId, - ":display_name" := displayName, - ":full_name" := fullName, - ":image" := image - ] + (userId, contactId, displayName, fullName, image, image) rights <$> mapM (runExceptT . getContact db userId) contactIds createSentProbe :: DB.Connection -> TVar ChaChaDRG -> UserId -> Contact -> ExceptT StoreError IO (Probe, Int64) @@ -1127,7 +1141,7 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do DB.query db [sql| - SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, + SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, custom_user_profile_id, conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at FROM connections WHERE user_id = ? AND agent_conn_id = ? @@ -1139,15 +1153,15 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do <$> DB.query db [sql| - SELECT c.local_display_name, p.display_name, p.full_name, p.image, c.via_group, c.created_at, c.updated_at + SELECT c.contact_profile_id, c.local_display_name, p.display_name, p.full_name, p.image, c.via_group, c.created_at, c.updated_at FROM contacts c JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id WHERE c.user_id = ? AND c.contact_id = ? |] (userId, contactId) - toContact' :: Int64 -> Connection -> [(ContactName, Text, Text, Maybe ImageData, Maybe Int64, UTCTime, UTCTime)] -> Either StoreError Contact - toContact' contactId activeConn [(localDisplayName, displayName, fullName, image, viaGroup, createdAt, updatedAt)] = - let profile = Profile {displayName, fullName, image} + toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe Int64, UTCTime, UTCTime)] -> Either StoreError Contact + toContact' contactId activeConn [(profileId, localDisplayName, displayName, fullName, image, viaGroup, createdAt, updatedAt)] = + let profile = LocalProfile {profileId, displayName, fullName, image} in Right $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup, createdAt, updatedAt} toContact' _ _ _ = Left $ SEInternalError "referenced contact not found" getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember) @@ -1161,18 +1175,18 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at, g.updated_at, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, -- GroupInfo {membership = GroupMember {memberProfile}} pu.display_name, pu.full_name, pu.image, -- from GroupMember m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, p.image + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image FROM group_members m - JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) JOIN groups g ON g.group_id = m.group_id JOIN group_profiles gp USING (group_profile_id) JOIN group_members mu ON g.group_id = mu.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ? |] (groupMemberId, userId, userContactId) @@ -1249,20 +1263,20 @@ getGroupAndMember db User {userId, userContactId} groupMemberId = g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at, g.updated_at, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, -- GroupInfo {membership = GroupMember {memberProfile}} pu.display_name, pu.full_name, pu.image, -- from GroupMember m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, p.image, - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM group_members m - JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) JOIN groups g ON g.group_id = m.group_id JOIN group_profiles gp USING (group_profile_id) JOIN group_members mu ON g.group_id = mu.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) LEFT JOIN connections c ON c.connection_id = ( SELECT max(cc.connection_id) FROM connections cc @@ -1284,30 +1298,32 @@ updateConnectionStatus db Connection {connId} connStatus = do DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId) -- | creates completely new group with a single member - the current user -createNewGroup :: DB.Connection -> TVar ChaChaDRG -> User -> GroupProfile -> ExceptT StoreError IO GroupInfo -createNewGroup db gVar user@User {userId} groupProfile = ExceptT $ do +createNewGroup :: DB.Connection -> TVar ChaChaDRG -> User -> GroupProfile -> Maybe Profile -> ExceptT StoreError IO GroupInfo +createNewGroup db gVar user@User {userId} groupProfile incognitoProfile = ExceptT $ do let GroupProfile {displayName, fullName, image} = groupProfile currentTs <- getCurrentTime - withLocalDisplayName db userId displayName $ \ldn -> do - DB.execute - db - "INSERT INTO group_profiles (display_name, full_name, image, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (displayName, fullName, image, userId, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - "INSERT INTO groups (local_display_name, user_id, group_profile_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (ldn, userId, profileId, currentTs, currentTs) - groupId <- insertedRowId db - memberId <- encodedRandomBytes gVar 12 - membership <- createContactMember_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser currentTs + withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do + groupId <- liftIO $ do + DB.execute + db + "INSERT INTO group_profiles (display_name, full_name, image, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (displayName, fullName, image, userId, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + "INSERT INTO groups (local_display_name, user_id, group_profile_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (ldn, userId, profileId, currentTs, currentTs) + insertedRowId db + memberId <- liftIO $ encodedRandomBytes gVar 12 + -- TODO ldn from incognito profile + membership <- createContactMemberInv_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser incognitoProfile currentTs pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, membership, createdAt = currentTs, updatedAt = currentTs} -- | creates a new group record for the group the current user was invited to, or returns an existing one -createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> ExceptT StoreError IO GroupInfo -createGroupInvitation db user@User {userId} contact@Contact {contactId} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} = +createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> Maybe Profile -> ExceptT StoreError IO GroupInfo +createGroupInvitation db user@User {userId} contact@Contact {contactId} GroupInvitation {fromMember, fromMemberProfile, invitedMember, connRequest, groupProfile} incognitoProfile = do liftIO getInvitationGroupId_ >>= \case - Nothing -> ExceptT createGroupInvitation_ + Nothing -> createGroupInvitation_ -- TODO treat the case that the invitation details could've changed Just gId -> getGroupInfo db user gId where @@ -1315,24 +1331,81 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId} GroupInv getInvitationGroupId_ = maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMIT 1" (connRequest, userId) - createGroupInvitation_ :: IO (Either StoreError GroupInfo) + createGroupInvitation_ :: ExceptT StoreError IO GroupInfo createGroupInvitation_ = do let GroupProfile {displayName, fullName, image} = groupProfile - withLocalDisplayName db userId displayName $ \localDisplayName -> do - currentTs <- getCurrentTime + ExceptT $ + withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do + currentTs <- liftIO getCurrentTime + groupId <- liftIO $ do + DB.execute + db + "INSERT INTO group_profiles (display_name, full_name, image, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (displayName, fullName, image, userId, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + "INSERT INTO groups (group_profile_id, local_display_name, inv_queue_info, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (profileId, localDisplayName, connRequest, userId, currentTs, currentTs) + insertedRowId db + _ <- createContactMemberInv_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown fromMemberProfile currentTs + membership <- createContactMemberInv_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfile currentTs + pure GroupInfo {groupId, localDisplayName, groupProfile, membership, createdAt = currentTs, updatedAt = currentTs} + +createContactMemberInv_ :: IsContact a => DB.Connection -> User -> GroupId -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> Maybe Profile -> UTCTime -> ExceptT StoreError IO GroupMember +createContactMemberInv_ db User {userId, userContactId} groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy incognitoProfile createdAt = do + customUserProfileId <- liftIO $ createIncognitoProfile_ db userId createdAt incognitoProfile + (localDisplayName, memberProfile) <- case (incognitoProfile, customUserProfileId) of + (Just profile@Profile {displayName}, Just profileId) -> + (,toLocalProfile profileId profile) <$> insertMemberIncognitoProfile_ displayName profileId + _ -> (,profile' userOrContact) <$> liftIO insertMember_ + groupMemberId <- liftIO $ insertedRowId db + pure + GroupMember + { groupMemberId, + groupId, + memberId, + memberRole, + memberCategory, + memberStatus, + invitedBy, + localDisplayName, + memberProfile, + memberContactId = Just $ contactId' userOrContact, + memberContactProfileId = localProfileId (profile' userOrContact), + activeConn = Nothing + } + where + insertMember_ :: IO ContactName + insertMember_ = do + let localDisplayName = localDisplayName' userOrContact + DB.execute + db + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, + user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy) + :. (userId, localDisplayName' userOrContact, contactId' userOrContact, localProfileId $ profile' userOrContact, createdAt, createdAt) + ) + pure localDisplayName + insertMemberIncognitoProfile_ :: ContactName -> ProfileId -> ExceptT StoreError IO ContactName + insertMemberIncognitoProfile_ incognitoDisplayName customUserProfileId = ExceptT $ + withLocalDisplayName db userId incognitoDisplayName $ \incognitoLdn -> do DB.execute db - "INSERT INTO group_profiles (display_name, full_name, image, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (displayName, fullName, image, userId, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - "INSERT INTO groups (group_profile_id, local_display_name, inv_queue_info, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (profileId, localDisplayName, connRequest, userId, currentTs, currentTs) - groupId <- insertedRowId db - _ <- createContactMember_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown currentTs - membership <- createContactMember_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact contactId) currentTs - pure $ GroupInfo {groupId, localDisplayName, groupProfile, membership, createdAt = currentTs, updatedAt = currentTs} + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, + user_id, local_display_name, contact_id, contact_profile_id, member_profile_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy) + :. (userId, incognitoLdn, contactId' userOrContact, localProfileId $ profile' userOrContact, customUserProfileId, createdAt, createdAt) + ) + pure $ Right incognitoLdn setGroupInvitationChatItemId :: DB.Connection -> User -> GroupId -> ChatItemId -> IO () setGroupInvitationChatItemId db User {userId} groupId chatItemId = do @@ -1390,11 +1463,11 @@ getUserGroupDetails db User {userId, userContactId} = [sql| SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at, g.updated_at, m.group_member_id, g.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, mp.display_name, mp.full_name, mp.image + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, mp.contact_profile_id, mp.display_name, mp.full_name, mp.image FROM groups g JOIN group_profiles gp USING (group_profile_id) JOIN group_members m USING (group_id) - JOIN contact_profiles mp USING (contact_profile_id) + JOIN contact_profiles mp ON mp.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) WHERE g.user_id = ? AND m.contact_id = ? |] (userId, userContactId) @@ -1419,11 +1492,11 @@ getGroupMember db user@User {userId} groupId groupMemberId = [sql| SELECT m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, p.image, - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM group_members m - JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) LEFT JOIN connections c ON c.connection_id = ( SELECT max(cc.connection_id) FROM connections cc @@ -1441,11 +1514,11 @@ getGroupMembers db user@User {userId, userContactId} GroupInfo {groupId} = do [sql| SELECT m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, p.image, - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM group_members m - JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) LEFT JOIN connections c ON c.connection_id = ( SELECT max(cc.connection_id) FROM connections cc @@ -1479,29 +1552,61 @@ getGroupInvitation db user groupId = do findFromContact (IBContact contactId) = find ((== Just contactId) . memberContactId) findFromContact _ = const Nothing -type GroupMemberRow = (Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Maybe Int64, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData) +type GroupMemberRow = ((Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus) :. (Maybe Int64, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData)) -type MaybeGroupMemberRow = (Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Int64, Maybe ContactName, Maybe Int64, Maybe ContactName, Maybe Text, Maybe ImageData) +type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus) :. (Maybe Int64, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData)) toGroupMember :: Int64 -> GroupMemberRow -> GroupMember -toGroupMember userContactId (groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, localDisplayName, memberContactId, displayName, fullName, image) = - let memberProfile = Profile {displayName, fullName, image} +toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image)) = + let memberProfile = LocalProfile {profileId, displayName, fullName, image} invitedBy = toInvitedBy userContactId invitedById activeConn = Nothing in GroupMember {..} toMaybeGroupMember :: Int64 -> MaybeGroupMemberRow -> Maybe GroupMember -toMaybeGroupMember userContactId (Just groupMemberId, Just groupId, Just memberId, Just memberRole, Just memberCategory, Just memberStatus, invitedById, Just localDisplayName, memberContactId, Just displayName, Just fullName, image) = - Just $ toGroupMember userContactId (groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, localDisplayName, memberContactId, displayName, fullName, image) +toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just memberId, Just memberRole, Just memberCategory, Just memberStatus) :. (invitedById, Just localDisplayName, memberContactId, Just memberContactProfileId, Just profileId, Just displayName, Just fullName, image)) = + Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image)) toMaybeGroupMember _ _ = Nothing -createContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> Int64 -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> ExceptT StoreError IO GroupMember -createContactMember db gVar user groupId contact memberRole agentConnId connRequest = +createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> ExceptT StoreError IO GroupMember +createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole agentConnId connRequest = createWithRandomId gVar $ \memId -> do - currentTs <- getCurrentTime - member@GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId contact (MemberIdRole (MemberId memId) memberRole) GCInviteeMember GSMemInvited IBUser (Just connRequest) currentTs - void $ createMemberConnection_ db (userId user) groupMemberId agentConnId Nothing 0 currentTs + createdAt <- liftIO getCurrentTime + member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt + void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt pure member + where + createMember_ memberId createdAt = do + insertMember_ + groupMemberId <- liftIO $ insertedRowId db + pure + GroupMember + { groupMemberId, + groupId, + memberId, + memberRole, + memberCategory = GCInviteeMember, + memberStatus = GSMemInvited, + invitedBy = IBUser, + localDisplayName, + memberProfile = profile, + memberContactId = Just contactId, + memberContactProfileId = localProfileId profile, + activeConn = Nothing + } + where + insertMember_ = + DB.execute + db + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, + user_id, local_display_name, contact_id, contact_profile_id, sent_inv_queue_info, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, GCInviteeMember, GSMemInvited, fromInvitedBy userContactId IBUser) + :. (userId, localDisplayName, contactId, localProfileId profile, connRequest, createdAt, createdAt) + ) getMemberInvitation :: DB.Connection -> User -> Int64 -> IO (Maybe ConnReqInvitation) getMemberInvitation db User {userId} groupMemberId = @@ -1516,18 +1621,33 @@ createMemberConnection db userId GroupMember {groupMemberId} agentConnId = do updateGroupMemberStatus :: DB.Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO () updateGroupMemberStatus db userId GroupMember {groupMemberId} memStatus = do currentTs <- getCurrentTime - DB.executeNamed + DB.execute db [sql| UPDATE group_members - SET member_status = :member_status, updated_at = :updated_at - WHERE user_id = :user_id AND group_member_id = :group_member_id + SET member_status = ?, updated_at = ? + WHERE user_id = ? AND group_member_id = ? |] - [ ":user_id" := userId, - ":group_member_id" := groupMemberId, - ":member_status" := memStatus, - ":updated_at" := currentTs - ] + (memStatus, currentTs, userId, groupMemberId) + +createMemberIncognitoProfile :: DB.Connection -> UserId -> GroupMember -> Maybe Profile -> ExceptT StoreError IO GroupMember +createMemberIncognitoProfile db userId m@GroupMember {groupMemberId} incognitoProfile = do + currentTs <- liftIO getCurrentTime + customUserProfileId <- liftIO $ createIncognitoProfile_ db userId currentTs incognitoProfile + case (incognitoProfile, customUserProfileId) of + (Just profile@Profile {displayName}, Just profileId) -> + ExceptT $ + withLocalDisplayName db userId displayName $ \incognitoLdn -> do + DB.execute + db + [sql| + UPDATE group_members + SET local_display_name = ?, member_profile_id = ?, updated_at = ? + WHERE user_id = ? AND group_member_id = ? + |] + (incognitoLdn, profileId, currentTs, userId, groupMemberId) + pure . Right $ m {localDisplayName = incognitoLdn, memberProfile = toLocalProfile profileId profile} + _ -> pure m -- | add new member with profile createNewGroupMember :: DB.Connection -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember @@ -1549,7 +1669,7 @@ createNewGroupMember db user@User {userId} gInfo memInfo@(MemberInfo _ _ Profile memContactId = Nothing, memProfileId } - createNewMember_ db user gInfo newMember currentTs + Right <$> createNewMember_ db user gInfo newMember currentTs createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> UTCTime -> IO GroupMember createNewMember_ @@ -1563,7 +1683,7 @@ createNewMember_ memInvitedBy = invitedBy, localDisplayName, memContactId = memberContactId, - memProfileId + memProfileId = memberContactProfileId } createdAt = do let invitedById = fromInvitedBy userContactId invitedBy @@ -1573,12 +1693,12 @@ createNewMember_ [sql| INSERT INTO group_members (group_id, member_id, member_role, member_category, member_status, - invited_by, user_id, local_display_name, contact_profile_id, contact_id, created_at, updated_at) + invited_by, user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?) |] - (groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memProfileId, memberContactId, createdAt, createdAt) + (groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memberContactId, memberContactProfileId, createdAt, createdAt) groupMemberId <- insertedRowId db - pure GroupMember {..} + pure GroupMember {groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedBy, localDisplayName, memberProfile = toLocalProfile memberContactProfileId memberProfile, memberContactId, memberContactProfileId, activeConn} deleteGroupMember :: DB.Connection -> User -> GroupMember -> IO () deleteGroupMember db user@User {userId} m@GroupMember {groupMemberId} = do @@ -1684,11 +1804,23 @@ getIntroduction_ db reMember toMember = ExceptT $ do in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation} toIntro _ = Left SEIntroNotFound -createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> ConnId -> ConnId -> ExceptT StoreError IO GroupMember -createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) groupAgentConnId directAgentConnId = do +getGroupMemberProfileId :: DB.Connection -> UserId -> GroupMember -> ExceptT StoreError IO Int64 +getGroupMemberProfileId db userId GroupMember {groupMemberId, groupId} = + ExceptT . firstRow fromOnly (SEGroupMemberNotFound {groupId, groupMemberId}) $ + DB.query + db + [sql| + SELECT contact_profile_id + FROM group_members + WHERE user_id = ? AND group_member_id = ? + |] + (userId, groupMemberId) + +createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> ConnId -> ConnId -> Maybe ProfileId -> ExceptT StoreError IO GroupMember +createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) groupAgentConnId directAgentConnId customUserProfileId = do let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn currentTs <- liftIO getCurrentTime - Connection {connId = directConnId} <- liftIO $ createMemberContactConnection_ db userId directAgentConnId memberContactId cLevel currentTs + Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId memberContactId Nothing customUserProfileId cLevel currentTs (localDisplayName, contactId, memProfileId) <- createContact_ db userId directConnId memberProfile (Just groupId) currentTs liftIO $ do let newMember = @@ -1705,12 +1837,12 @@ createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupM conn <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId memberContactId cLevel currentTs pure (member :: GroupMember) {activeConn = Just conn} -createIntroToMemberContact :: DB.Connection -> UserId -> GroupMember -> GroupMember -> ConnId -> ConnId -> IO () -createIntroToMemberContact db userId GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} groupAgentConnId directAgentConnId = do +createIntroToMemberContact :: DB.Connection -> UserId -> GroupMember -> GroupMember -> ConnId -> ConnId -> Maybe ProfileId -> IO () +createIntroToMemberContact db userId GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} groupAgentConnId directAgentConnId customUserProfileId = do let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn currentTs <- getCurrentTime void $ createMemberConnection_ db userId groupMemberId groupAgentConnId viaContactId cLevel currentTs - Connection {connId = directConnId} <- createMemberContactConnection_ db userId directAgentConnId viaContactId cLevel currentTs + Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId viaContactId Nothing customUserProfileId cLevel currentTs contactId <- createMemberContact_ directConnId currentTs updateMember_ contactId currentTs where @@ -1740,48 +1872,7 @@ createIntroToMemberContact db userId GroupMember {memberContactId = viaContactId [":contact_id" := contactId, ":updated_at" := ts, ":group_member_id" := groupMemberId] createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection -createMemberConnection_ db userId groupMemberId agentConnId viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId viaContact Nothing - -createContactMember_ :: IsContact a => DB.Connection -> User -> Int64 -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> UTCTime -> IO GroupMember -createContactMember_ db user groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy = - createContactMemberInv_ db user groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy Nothing - -createContactMemberInv_ :: IsContact a => DB.Connection -> User -> Int64 -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> Maybe ConnReqInvitation -> UTCTime -> IO GroupMember -createContactMemberInv_ db User {userId, userContactId} groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy connRequest createdAt = do - insertMember_ - groupMemberId <- insertedRowId db - let memberProfile = profile' userOrContact - memberContactId = Just $ contactId' userOrContact - localDisplayName = localDisplayName' userOrContact - activeConn = Nothing - pure GroupMember {..} - where - insertMember_ = - DB.executeNamed - db - [sql| - INSERT INTO group_members - ( group_id, member_id, member_role, member_category, member_status, invited_by, - user_id, local_display_name, contact_profile_id, contact_id, sent_inv_queue_info, created_at, updated_at) - VALUES - (:group_id,:member_id,:member_role,:member_category,:member_status,:invited_by, - :user_id,:local_display_name, - (SELECT contact_profile_id FROM contacts WHERE contact_id = :contact_id), - :contact_id, :sent_inv_queue_info, :created_at, :updated_at) - |] - [ ":group_id" := groupId, - ":member_id" := memberId, - ":member_role" := memberRole, - ":member_category" := memberCategory, - ":member_status" := memberStatus, - ":invited_by" := fromInvitedBy userContactId invitedBy, - ":user_id" := userId, - ":local_display_name" := localDisplayName' userOrContact, - ":contact_id" := contactId' userOrContact, - ":sent_inv_queue_info" := connRequest, - ":created_at" := createdAt, - ":updated_at" := createdAt - ] +createMemberConnection_ db userId groupMemberId agentConnId viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId viaContact Nothing Nothing getViaGroupMember :: DB.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember)) getViaGroupMember db User {userId, userContactId} Contact {contactId} = @@ -1794,21 +1885,21 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} = g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at, g.updated_at, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, -- GroupInfo {membership = GroupMember {memberProfile}} pu.display_name, pu.full_name, pu.image, -- via GroupMember m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, p.image, - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM group_members m JOIN contacts ct ON ct.contact_id = m.contact_id - JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group JOIN group_profiles gp USING (group_profile_id) JOIN group_members mu ON g.group_id = mu.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) LEFT JOIN connections c ON c.connection_id = ( SELECT max(cc.connection_id) FROM connections cc @@ -1831,8 +1922,8 @@ getViaGroupContact db User {userId} GroupMember {groupMemberId} = db [sql| SELECT - ct.contact_id, ct.local_display_name, p.display_name, p.full_name, p.image, ct.via_group, ct.created_at, ct.updated_at, - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, + ct.contact_id, ct.contact_profile_id, ct.local_display_name, p.display_name, p.full_name, p.image, ct.via_group, ct.created_at, ct.updated_at, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM contacts ct JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id @@ -1847,9 +1938,9 @@ getViaGroupContact db User {userId} GroupMember {groupMemberId} = |] (userId, groupMemberId) where - toContact' :: (Int64, ContactName, Text, Text, Maybe ImageData, Maybe Int64, UTCTime, UTCTime) :. ConnectionRow -> Contact - toContact' ((contactId, localDisplayName, displayName, fullName, image, viaGroup, createdAt, updatedAt) :. connRow) = - let profile = Profile {displayName, fullName, image} + toContact' :: (ContactId, ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe Int64, UTCTime, UTCTime) :. ConnectionRow -> Contact + toContact' ((contactId, profileId, localDisplayName, displayName, fullName, image, viaGroup, createdAt, updatedAt) :. connRow) = + let profile = LocalProfile {profileId, displayName, fullName, image} activeConn = toConnection connRow in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, createdAt, updatedAt} @@ -1957,7 +2048,7 @@ getChatRefByFileId db User {userId} fileId = createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection createSndFileConnection_ db userId fileId agentConnId = do currentTs <- getCurrentTime - createConnection_ db userId ConnSndFile (Just fileId) agentConnId Nothing Nothing 0 currentTs + createConnection_ db userId ConnSndFile (Just fileId) agentConnId Nothing Nothing Nothing 0 currentTs updateSndFileStatus :: DB.Connection -> SndFileTransfer -> FileStatus -> IO () updateSndFileStatus db SndFileTransfer {fileId, connId} status = do @@ -1975,14 +2066,12 @@ createSndFileChunk db SndFileTransfer {fileId, connId, fileSize, chunkSize} = do pure $ case map fromOnly ns of [] -> Just 1 n : _ -> if n * chunkSize >= fileSize then Nothing else Just (n + 1) - insertChunk = \case - Just chunkNo -> do - currentTs <- getCurrentTime - DB.execute - db - "INSERT OR REPLACE INTO snd_file_chunks (file_id, connection_id, chunk_number, created_at, updated_at) VALUES (?,?,?,?,?)" - (fileId, connId, chunkNo, currentTs, currentTs) - Nothing -> pure () + insertChunk chunkNo_ = forM_ chunkNo_ $ \chunkNo -> do + currentTs <- getCurrentTime + DB.execute + db + "INSERT OR REPLACE INTO snd_file_chunks (file_id, connection_id, chunk_number, created_at, updated_at) VALUES (?,?,?,?,?)" + (fileId, connId, chunkNo, currentTs, currentTs) updateSndFileChunkMsg :: DB.Connection -> SndFileTransfer -> Integer -> AgentMsgId -> IO () updateSndFileChunkMsg db SndFileTransfer {fileId, connId} chunkNo msgId = do @@ -2491,9 +2580,7 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q |] ((userId, msgId_) :. idsRow :. itemRow :. quoteRow) ciId <- insertedRowId db - case msgId_ of - Just msgId -> insertChatItemMessage_ db ciId msgId createdAt - Nothing -> pure () + forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt pure ciId where itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId, UTCTime, UTCTime) @@ -2555,10 +2642,10 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe SELECT i.chat_item_id, -- GroupMember m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, - m.member_status, m.invited_by, m.local_display_name, m.contact_id, + m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image FROM group_members m - JOIN contact_profiles p ON m.contact_profile_id = p.contact_profile_id + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) LEFT JOIN contacts c ON m.contact_id = c.contact_id LEFT JOIN chat_items i ON i.group_id = m.group_id AND m.group_member_id = i.group_member_id @@ -2593,9 +2680,9 @@ getDirectChatPreviews_ db User {userId} = do [sql| SELECT -- Contact - ct.contact_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, ct.created_at, ct.updated_at, + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, ct.created_at, ct.updated_at, -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.conn_status, c.conn_type, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, -- ChatStats COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), @@ -2661,7 +2748,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at, g.updated_at, -- GroupMember - membership mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, -- ChatStats COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), @@ -2671,18 +2758,18 @@ getGroupChatPreviews_ db User {userId, userContactId} = do f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, -- Maybe GroupMember - sender m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, - m.member_status, m.invited_by, m.local_display_name, m.contact_id, + m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, -- quoted ChatItem ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, -- quoted GroupMember rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, - rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, + rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, rp.display_name, rp.full_name, rp.image FROM groups g JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id JOIN group_members mu ON mu.group_id = g.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) LEFT JOIN ( SELECT group_id, MAX(chat_item_id) AS MaxId FROM chat_items @@ -2699,10 +2786,10 @@ getGroupChatPreviews_ db User {userId, userContactId} = do GROUP BY group_id ) ChatStats ON ChatStats.group_id = g.group_id LEFT JOIN group_members m ON m.group_member_id = i.group_member_id - LEFT JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id + LEFT JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id - LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id + LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id) WHERE g.user_id = ? AND mu.contact_id = ? ORDER BY i.item_ts DESC |] @@ -2744,13 +2831,13 @@ getContactConnectionChatPreviews_ db User {userId} _ = <$> DB.query db [sql| - SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, created_at, updated_at + SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, custom_user_profile_id, created_at, updated_at FROM connections WHERE user_id = ? AND conn_type = ? AND contact_id IS NULL AND conn_level = 0 AND via_contact IS NULL |] (userId, ConnContact) where - toContactConnectionChatPreview :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, UTCTime, UTCTime) -> AChat + toContactConnectionChatPreview :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, Maybe Int64, UTCTime, UTCTime) -> AChat toContactConnectionChatPreview connRow = let conn = toPendingContactConnection connRow stats = ChatStats {unreadCount = 0, minUnreadItemId = 0} @@ -2762,7 +2849,7 @@ getPendingContactConnection db userId connId = do DB.query db [sql| - SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, created_at, updated_at + SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, custom_user_profile_id, created_at, updated_at FROM connections WHERE user_id = ? AND connection_id = ? @@ -2788,9 +2875,9 @@ deletePendingContactConnection db userId connId = |] (userId, connId, ConnContact) -toPendingContactConnection :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, UTCTime, UTCTime) -> PendingContactConnection -toPendingContactConnection (pccConnId, acId, pccConnStatus, connReqHash, viaUserContactLink, createdAt, updatedAt) = - PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = isJust connReqHash, viaUserContactLink, createdAt, updatedAt} +toPendingContactConnection :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, Maybe Int64, UTCTime, UTCTime) -> PendingContactConnection +toPendingContactConnection (pccConnId, acId, pccConnStatus, connReqHash, viaUserContactLink, customUserProfileId, createdAt, updatedAt) = + PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = isJust connReqHash, viaUserContactLink, customUserProfileId, createdAt, updatedAt} getDirectChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTDirect) getDirectChat db user contactId pagination search_ = do @@ -2925,9 +3012,9 @@ getContact db userId contactId = [sql| SELECT -- Contact - ct.contact_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, ct.created_at, ct.updated_at, + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, ct.created_at, ct.updated_at, -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.conn_status, c.conn_type, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM contacts ct JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id @@ -3053,12 +3140,12 @@ getGroupInfo db User {userId, userContactId} groupId = g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at, g.updated_at, -- GroupMember - membership mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image FROM groups g JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id JOIN group_members mu ON mu.group_id = g.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) WHERE g.group_id = ? AND g.user_id = ? AND mu.contact_id = ? |] (groupId, userId, userContactId) @@ -3073,7 +3160,7 @@ updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, grou currentTs <- getCurrentTime updateGroupProfile_ currentTs updateGroup_ ldn currentTs - pure $ (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p'} + pure . Right $ (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p'} where updateGroupProfile_ currentTs = DB.execute @@ -3422,21 +3509,21 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, -- GroupMember m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, - m.member_status, m.invited_by, m.local_display_name, m.contact_id, + m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, -- quoted ChatItem ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, -- quoted GroupMember rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, - rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, + rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, rp.display_name, rp.full_name, rp.image FROM chat_items i LEFT JOIN files f ON f.chat_item_id = i.chat_item_id LEFT JOIN group_members m ON m.group_member_id = i.group_member_id - LEFT JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id + LEFT JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id - LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id + LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id) WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id = ? |] (userId, groupId, itemId) @@ -3748,7 +3835,7 @@ getCalls db User {userId} = do -- | Saves unique local display name based on passed displayName, suffixed with _N if required. -- This function should be called inside transaction. -withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO a) -> IO (Either StoreError a) +withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO (Either StoreError a)) -> IO (Either StoreError a) withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreateName` 20) where getLdnSuffix :: IO Int @@ -3769,7 +3856,7 @@ withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreate currentTs <- getCurrentTime let ldn = displayName <> (if ldnSuffix == 0 then "" else T.pack $ '_' : show ldnSuffix) E.try (insertName ldn currentTs) >>= \case - Right () -> Right <$> action ldn + Right () -> action ldn Left e | DB.sqlError e == DB.ErrorConstraint -> tryCreateName (ldnSuffix + 1) (attempts - 1) | otherwise -> E.throwIO e @@ -3843,6 +3930,7 @@ data StoreError | SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId} | SEChatItemNotFoundByFileId {fileId :: FileTransferId} | SEChatItemNotFoundByGroupId {groupId :: GroupId} + | SEProfileNotFound {profileId :: Int64} deriving (Show, Exception, Generic) instance ToJSON StoreError where diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 80d99490f0..95d01d2a20 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -22,6 +22,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Int (Int64) +import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime) @@ -39,7 +40,7 @@ import Simplex.Messaging.Util ((<$?>)) class IsContact a where contactId' :: a -> ContactId - profile' :: a -> Profile + profile' :: a -> LocalProfile localDisplayName' :: a -> ContactName instance IsContact User where @@ -56,7 +57,7 @@ data User = User { userId :: UserId, userContactId :: ContactId, localDisplayName :: ContactName, - profile :: Profile, + profile :: LocalProfile, activeUser :: Bool } deriving (Show, Generic, FromJSON) @@ -67,10 +68,12 @@ type UserId = ContactId type ContactId = Int64 +type ProfileId = Int64 + data Contact = Contact { contactId :: ContactId, localDisplayName :: ContactName, - profile :: Profile, + profile :: LocalProfile, activeConn :: Connection, viaGroup :: Maybe Int64, createdAt :: UTCTime, @@ -88,6 +91,9 @@ contactConn = activeConn contactConnId :: Contact -> ConnId contactConnId Contact {activeConn} = aConnId activeConn +contactConnIncognito :: Contact -> Bool +contactConnIncognito Contact {activeConn = Connection {customUserProfileId}} = isJust customUserProfileId + data ContactRef = ContactRef { contactId :: ContactId, localDisplayName :: ContactName @@ -198,6 +204,7 @@ data Profile = Profile { displayName :: ContactName, fullName :: Text, image :: Maybe ImageData + -- incognito field should not be read as is into this data type to prevent sending it as part of profile to contacts } deriving (Eq, Show, Generic, FromJSON) @@ -205,6 +212,29 @@ instance ToJSON Profile where toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} +data LocalProfile = LocalProfile + { profileId :: ProfileId, + displayName :: ContactName, + fullName :: Text, + image :: Maybe ImageData + } + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON LocalProfile where + toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} + toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + +localProfileId :: LocalProfile -> ProfileId +localProfileId = profileId + +toLocalProfile :: ProfileId -> Profile -> LocalProfile +toLocalProfile profileId Profile {displayName, fullName, image} = + LocalProfile {profileId, displayName, fullName, image} + +fromLocalProfile :: LocalProfile -> Profile +fromLocalProfile LocalProfile {displayName, fullName, image} = + Profile {displayName, fullName, image} + data GroupProfile = GroupProfile { displayName :: GroupName, fullName :: Text, @@ -232,13 +262,16 @@ instance FromField ImageData where fromField = fmap ImageData . fromField data GroupInvitation = GroupInvitation { fromMember :: MemberIdRole, + fromMemberProfile :: Maybe Profile, invitedMember :: MemberIdRole, connRequest :: ConnReqInvitation, groupProfile :: GroupProfile } deriving (Eq, Show, Generic, FromJSON) -instance ToJSON GroupInvitation where toEncoding = J.genericToEncoding J.defaultOptions +instance ToJSON GroupInvitation where + toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} + toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} data MemberIdRole = MemberIdRole { memberId :: MemberId, @@ -267,7 +300,7 @@ instance ToJSON MemberInfo where toEncoding = J.genericToEncoding J.defaultOptio memberInfo :: GroupMember -> MemberInfo memberInfo GroupMember {memberId, memberRole, memberProfile} = - MemberInfo memberId memberRole memberProfile + MemberInfo memberId memberRole (fromLocalProfile memberProfile) data ReceivedGroupInvitation = ReceivedGroupInvitation { fromMember :: GroupMember, @@ -278,6 +311,8 @@ data ReceivedGroupInvitation = ReceivedGroupInvitation type GroupMemberId = Int64 +-- memberProfile's profileId is COALESCE(member_profile_id, contact_profile_id), member_profile_id is non null +-- if incognito profile was saved for member (used for hosts and invitees in incognito groups) data GroupMember = GroupMember { groupMemberId :: GroupMemberId, groupId :: GroupId, @@ -287,8 +322,9 @@ data GroupMember = GroupMember memberStatus :: GroupMemberStatus, invitedBy :: InvitedBy, localDisplayName :: ContactName, - memberProfile :: Profile, - memberContactId :: Maybe Int64, + memberProfile :: LocalProfile, + memberContactId :: Maybe ContactId, + memberContactProfileId :: ProfileId, activeConn :: Maybe Connection } deriving (Eq, Show, Generic) @@ -306,6 +342,9 @@ memberConnId GroupMember {activeConn} = aConnId <$> activeConn groupMemberId' :: GroupMember -> GroupMemberId groupMemberId' GroupMember {groupMemberId} = groupMemberId +memberIncognito :: GroupMember -> Bool +memberIncognito GroupMember {memberProfile, memberContactProfileId} = localProfileId memberProfile /= memberContactProfileId + data NewGroupMember = NewGroupMember { memInfo :: MemberInfo, memCategory :: GroupMemberCategory, @@ -695,6 +734,7 @@ data Connection = Connection connLevel :: Int, viaContact :: Maybe Int64, -- group member contact ID, if not direct connection viaUserContactLink :: Maybe Int64, -- user contact link ID, if connected via "user address" + customUserProfileId :: Maybe Int64, connType :: ConnType, connStatus :: ConnStatus, entityId :: Maybe Int64, -- contact, group member, file ID or user contact ID @@ -705,6 +745,9 @@ data Connection = Connection aConnId :: Connection -> ConnId aConnId Connection {agentConnId = AgentConnId cId} = cId +connCustomUserProfileId :: Connection -> Maybe Int64 +connCustomUserProfileId Connection {customUserProfileId} = customUserProfileId + instance ToJSON Connection where toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} @@ -715,6 +758,7 @@ data PendingContactConnection = PendingContactConnection pccConnStatus :: ConnStatus, viaContactUri :: Bool, viaUserContactLink :: Maybe Int64, + customUserProfileId :: Maybe Int64, createdAt :: UTCTime, updatedAt :: UTCTime } diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 426f22b66e..443ce285fe 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -54,7 +54,7 @@ serializeChatResponse = unlines . map unStyle . responseToView False responseToView :: Bool -> ChatResponse -> [StyledString] responseToView testView = \case - CRActiveUser User {profile} -> viewUserProfile profile + CRActiveUser User {profile} -> viewUserProfile $ fromLocalProfile profile CRChatStarted -> ["chat started"] CRChatRunning -> ["chat is running"] CRChatStopped -> ["chat stopped"] @@ -64,8 +64,8 @@ responseToView testView = \case CRApiParsedMarkdown ft -> [plain . bshow $ J.encode ft] CRUserSMPServers smpServers -> viewSMPServers smpServers testView CRNetworkConfig cfg -> viewNetworkConfig cfg - CRContactInfo ct cStats -> viewContactInfo ct cStats - CRGroupMemberInfo g m cStats -> viewGroupMemberInfo g m cStats + CRContactInfo ct cStats customUserProfile -> viewContactInfo ct cStats customUserProfile + CRGroupMemberInfo g m cStats mainProfile -> viewGroupMemberInfo g m cStats mainProfile CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item False CRLastMessages chatItems -> concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True) chatItems CRChatItemStatusUpdated _ -> [] @@ -89,10 +89,10 @@ responseToView testView = \case CRUserContactLink cReqUri autoAccept autoReply -> connReqContact_ "Your chat address:" cReqUri <> autoAcceptStatus_ autoAccept autoReply CRUserContactLinkUpdated _ autoAccept autoReply -> autoAcceptStatus_ autoAccept autoReply CRContactRequestRejected UserContactRequest {localDisplayName = c} -> [ttyContact c <> ": contact request rejected"] - CRGroupCreated g -> viewGroupCreated g + CRGroupCreated g customUserProfile -> viewGroupCreated g customUserProfile testView CRGroupMembers g -> viewGroupMembers g CRGroupsList gs -> viewGroupsList gs - CRSentGroupInvitation g c _ -> ["invitation to join the group " <> ttyGroup' g <> " sent to " <> ttyContact' c] + CRSentGroupInvitation g c _ sentCustomProfile -> viewSentGroupInvitation g c sentCustomProfile CRFileTransferStatus ftStatus -> viewFileTransferStatus ftStatus CRUserProfile p -> viewUserProfile p CRUserProfileNoChange -> ["user profile did not change"] @@ -100,7 +100,7 @@ responseToView testView = \case CRChatCmdError e -> viewChatError e CRInvitation cReq -> viewConnReqInvitation cReq CRSentConfirmation -> ["confirmation sent!"] - CRSentInvitation -> ["connection request sent!"] + CRSentInvitation customUserProfile -> viewSentInvitation customUserProfile testView CRContactDeleted c -> [ttyContact' c <> ": contact is deleted"] CRChatCleared chatInfo -> viewChatCleared chatInfo CRAcceptingContactRequest c -> [ttyFullContact c <> ": accepting contact request..."] @@ -129,7 +129,7 @@ responseToView testView = \case CRSndFileRcvCancelled _ ft@SndFileTransfer {recipientDisplayName = c} -> [ttyContact c <> " cancelled receiving " <> sndFile ft] CRContactConnecting _ -> [] - CRContactConnected ct -> [ttyFullContact ct <> ": contact is connected"] + CRContactConnected ct userCustomProfile -> viewContactConnected ct userCustomProfile testView CRContactAnotherClient c -> [ttyContact' c <> ": contact is connected to another client"] CRContactsDisconnected srv cs -> [plain $ "server disconnected " <> showSMPServer srv <> " (" <> contactList cs <> ")"] CRContactsSubscribed srv cs -> [plain $ "server connected " <> showSMPServer srv <> " (" <> contactList cs <> ")"] @@ -138,13 +138,13 @@ responseToView testView = \case [sShow (length subscribed) <> " contacts connected (use " <> highlight' "/cs" <> " for the list)" | not (null subscribed)] <> viewErrorsSummary errors " contact errors" where (errors, subscribed) = partition (isJust . contactError) summary + CRGroupInvitation GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership} -> + [groupInvitation' ldn fullName $ memberIncognito membership] + CRReceivedGroupInvitation g c role receivedCustomProfile -> viewReceivedGroupInvitation g c role receivedCustomProfile + CRUserJoinedGroup g _ usedCustomProfile -> viewUserJoinedGroup g usedCustomProfile testView + CRJoinedGroupMember g m mainProfile -> viewJoinedGroupMember g m mainProfile CRHostConnected p h -> [plain $ "connected to " <> viewHostEvent p h] CRHostDisconnected p h -> [plain $ "disconnected from " <> viewHostEvent p h] - CRGroupInvitation GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}} -> - [groupInvitation' ldn fullName] - CRReceivedGroupInvitation g c role -> viewReceivedGroupInvitation g c role - CRUserJoinedGroup g _ -> [ttyGroup' g <> ": you joined the group"] - CRJoinedGroupMember g m -> [ttyGroup' g <> ": " <> ttyMember m <> " joined the group "] CRJoinedGroupMemberConnecting g host m -> [ttyGroup' g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"] CRConnectedToGroupMember g m -> [ttyGroup' g <> ": " <> connectedMember m <> " is connected"] CRDeletedMemberUser g by -> [ttyGroup' g <> ": " <> ttyMember by <> " removed you from the group"] <> groupPreserved g @@ -156,7 +156,7 @@ responseToView testView = \case CRGroupUpdated g g' m -> viewGroupUpdated g g' m CRMemberSubError g m e -> [ttyGroup' g <> " member " <> ttyMember m <> " error: " <> sShow e] CRMemberSubSummary summary -> viewErrorsSummary (filter (isJust . memberError) summary) " group member errors" - CRGroupSubscribed g -> [ttyFullGroup g <> ": connected to server(s)"] + CRGroupSubscribed g -> viewGroupSubscribed g CRPendingSubSummary _ -> [] CRSndFileSubError SndFileTransfer {fileId, fileName} e -> ["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e] @@ -208,6 +208,12 @@ responseToView testView = \case contactList :: [ContactRef] -> String contactList cs = T.unpack . T.intercalate ", " $ map (\ContactRef {localDisplayName = n} -> "@" <> n) cs +viewGroupSubscribed :: GroupInfo -> [StyledString] +viewGroupSubscribed g@GroupInfo {membership} = + [incognito <> ttyFullGroup g <> ": connected to server(s)"] + where + incognito = if memberIncognito membership then incognitoPrefix else "" + showSMPServer :: SMPServer -> String showSMPServer = B.unpack . strEncode . host @@ -363,6 +369,12 @@ viewConnReqInvitation cReq = "and ask them to connect: " <> highlight' "/c " ] +viewSentGroupInvitation :: GroupInfo -> Contact -> Maybe Profile -> [StyledString] +viewSentGroupInvitation g c sentCustomProfile = + if isJust sentCustomProfile + then ["invitation to join the group " <> ttyGroup' g <> " incognito sent to " <> ttyContact' c] + else ["invitation to join the group " <> ttyGroup' g <> " sent to " <> ttyContact' c] + viewChatCleared :: AChatInfo -> [StyledString] viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of DirectChat ct -> [ttyContact' ct <> ": all messages are removed locally ONLY"] @@ -372,7 +384,8 @@ viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of viewContactsList :: [Contact] -> [StyledString] viewContactsList = let ldn = T.toLower . (localDisplayName :: Contact -> ContactName) - in map ttyFullContact . sortOn ldn + incognito ct = if contactConnIncognito ct then incognitoPrefix else "" + in map (\ct -> incognito ct <> ttyFullContact ct) . sortOn ldn viewUserContactLinkDeleted :: [StyledString] viewUserContactLinkDeleted = @@ -396,6 +409,17 @@ autoAcceptStatus_ autoAccept autoReply = ("auto_accept " <> if autoAccept then "on" else "off") : maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply +viewSentInvitation :: Maybe Profile -> Bool -> [StyledString] +viewSentInvitation incognitoProfile testView = + case incognitoProfile of + Just profile -> + if testView + then incognitoProfile' profile : message + else message + where + message = ["connection request sent incognito!"] + Nothing -> ["connection request sent!"] + viewReceivedContactRequest :: ContactName -> Profile -> [StyledString] viewReceivedContactRequest c Profile {fullName} = [ ttyFullName c fullName <> " wants to connect to you!", @@ -403,11 +427,22 @@ viewReceivedContactRequest c Profile {fullName} = "to reject: " <> highlight ("/rc " <> c) <> " (the sender will NOT be notified)" ] -viewGroupCreated :: GroupInfo -> [StyledString] -viewGroupCreated g@GroupInfo {localDisplayName} = - [ "group " <> ttyFullGroup g <> " is created", - "use " <> highlight ("/a " <> localDisplayName <> " ") <> " to add members" - ] +viewGroupCreated :: GroupInfo -> Maybe Profile -> Bool -> [StyledString] +viewGroupCreated g@GroupInfo {localDisplayName} incognitoProfile testView = + case incognitoProfile of + Just profile -> + if testView + then incognitoProfile' profile : message + else message + where + message = + [ "group " <> ttyFullGroup g <> " is created incognito, your profile for this group: " <> incognitoProfile' profile, + "use " <> highlight ("/a " <> localDisplayName <> " ") <> " to add members" + ] + Nothing -> + [ "group " <> ttyFullGroup g <> " is created", + "use " <> highlight ("/a " <> localDisplayName <> " ") <> " to add members" + ] viewCannotResendInvitation :: GroupInfo -> ContactName -> [StyledString] viewCannotResendInvitation GroupInfo {localDisplayName = gn} c = @@ -415,11 +450,33 @@ viewCannotResendInvitation GroupInfo {localDisplayName = gn} c = "to re-send invitation: " <> highlight ("/rm " <> gn <> " " <> c) <> ", " <> highlight ("/a " <> gn <> " " <> c) ] -viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString] -viewReceivedGroupInvitation g c role = - [ ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role), - "use " <> highlight ("/j " <> groupName' g) <> " to accept" - ] +viewUserJoinedGroup :: GroupInfo -> Bool -> Bool -> [StyledString] +viewUserJoinedGroup g@GroupInfo {membership = GroupMember {memberProfile}} incognito testView = + if incognito + then + if testView + then incognitoProfile' (fromLocalProfile memberProfile) : incognitoMessage + else incognitoMessage + else [ttyGroup' g <> ": you joined the group"] + where + incognitoMessage = [ttyGroup' g <> ": you joined the group incognito as " <> incognitoProfile' (fromLocalProfile memberProfile)] + +viewJoinedGroupMember :: GroupInfo -> GroupMember -> Maybe Profile -> [StyledString] +viewJoinedGroupMember g m@GroupMember {localDisplayName} = \case + Just Profile {displayName = mainProfileName} -> [ttyGroup' g <> ": " <> ttyContact mainProfileName <> " joined the group incognito as " <> styleIncognito localDisplayName] + Nothing -> [ttyGroup' g <> ": " <> ttyMember m <> " joined the group "] + +viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> Maybe Profile -> [StyledString] +viewReceivedGroupInvitation g c role hostIncognitoProfile = + case hostIncognitoProfile of + Just profile -> + [ ttyFullGroup g <> ": " <> ttyContact' c <> " (known to the group as " <> incognitoProfile' profile <> ") invites you to join the group incognito as " <> plain (strEncode role), + "use " <> highlight ("/j " <> groupName' g) <> " to join this group incognito" + ] + Nothing -> + [ ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role), + "use " <> highlight ("/j " <> groupName' g) <> " to accept" + ] groupPreserved :: GroupInfo -> [StyledString] groupPreserved g = ["use " <> highlight ("/d #" <> groupName' g) <> " to delete the group"] @@ -434,7 +491,8 @@ viewGroupMembers :: Group -> [StyledString] viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filter (not . removedOrLeft) $ membership : members where removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft - groupMember m = ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m + groupMember m = incognito m <> ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m + incognito m = if memberIncognito m then incognitoPrefix else "" role m = plain . strEncode $ memberRole (m :: GroupMember) category m = case memberCategory m of GCUserMember -> "you, " @@ -450,6 +508,21 @@ viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filt GSMemCreator -> "created group" _ -> "" +viewContactConnected :: Contact -> Maybe Profile -> Bool -> [StyledString] +viewContactConnected ct@Contact {localDisplayName} userIncognitoProfile testView = + case userIncognitoProfile of + Just profile -> + if testView + then incognitoProfile' profile : message + else message + where + message = + [ ttyFullContact ct <> ": contact is connected, your incognito profile for this contact is " <> incognitoProfile' profile, + "use " <> highlight ("/info " <> localDisplayName) <> " to print out this incognito profile again" + ] + Nothing -> + [ttyFullContact ct <> ": contact is connected"] + viewGroupsList :: [GroupInfo] -> [StyledString] viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g "] viewGroupsList gs = map groupSS $ sortOn ldn_ gs @@ -457,9 +530,10 @@ viewGroupsList gs = map groupSS $ sortOn ldn_ gs ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName) groupSS GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership} = case memberStatus membership of - GSMemInvited -> groupInvitation' ldn fullName - s -> ttyGroup ldn <> optFullName ldn fullName <> viewMemberStatus s + GSMemInvited -> groupInvitation' ldn fullName $ memberIncognito membership + s -> incognito <> ttyGroup ldn <> optFullName ldn fullName <> viewMemberStatus s where + incognito = if memberIncognito membership then incognitoPrefix else "" viewMemberStatus = \case GSMemRemoved -> delete "you are removed" GSMemLeft -> delete "you left" @@ -467,15 +541,20 @@ viewGroupsList gs = map groupSS $ sortOn ldn_ gs _ -> "" delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> ldn) <> ")" -groupInvitation' :: GroupName -> Text -> StyledString -groupInvitation' displayName fullName = +groupInvitation' :: GroupName -> Text -> Bool -> StyledString +groupInvitation' displayName fullName membershipIncognito = highlight ("#" <> displayName) <> optFullName displayName fullName - <> " - you are invited (" + <> invitationText <> highlight ("/j " <> displayName) <> " to join, " <> highlight ("/d #" <> displayName) <> " to delete invitation)" + where + invitationText = + if membershipIncognito + then " - you are invited incognito (" + else " - you are invited (" viewContactsMerged :: Contact -> Contact -> [StyledString] viewContactsMerged _into@Contact {localDisplayName = c1} _merged@Contact {localDisplayName = c2} = @@ -514,16 +593,24 @@ viewNetworkConfig NetworkConfig {socksProxy, tcpTimeout} = "use `/network socks=[ timeout=]` to change settings" ] -viewContactInfo :: Contact -> ConnectionStats -> [StyledString] -viewContactInfo Contact {contactId} stats = +viewContactInfo :: Contact -> ConnectionStats -> Maybe Profile -> [StyledString] +viewContactInfo Contact {contactId} stats incognitoProfile = ["contact ID: " <> sShow contactId] <> viewConnectionStats stats + <> maybe + ["you've shared main profile with this contact"] + (\p -> ["you've shared incognito profile with this contact: " <> incognitoProfile' p]) + incognitoProfile -viewGroupMemberInfo :: GroupInfo -> GroupMember -> Maybe ConnectionStats -> [StyledString] -viewGroupMemberInfo GroupInfo {groupId} GroupMember {groupMemberId} stats = +viewGroupMemberInfo :: GroupInfo -> GroupMember -> Maybe ConnectionStats -> Maybe Profile -> [StyledString] +viewGroupMemberInfo GroupInfo {groupId} GroupMember {groupMemberId} stats mainProfile = [ "group ID: " <> sShow groupId, "member ID: " <> sShow groupMemberId ] <> maybe ["member not connected"] viewConnectionStats stats + <> maybe + ["unknown whether group member uses his main profile or incognito one for the group"] + (\Profile {displayName, fullName} -> ["member is using " <> styleIncognito' "incognito" <> " profile for the group, main profile known: " <> ttyFullName displayName fullName]) + mainProfile viewConnectionStats :: ConnectionStats -> [StyledString] viewConnectionStats ConnectionStats {rcvServers, sndServers} = @@ -559,8 +646,8 @@ viewGroupUpdated viewContactUpdated :: Contact -> Contact -> [StyledString] viewContactUpdated - Contact {localDisplayName = n, profile = Profile {fullName}} - Contact {localDisplayName = n', profile = Profile {fullName = fullName'}} + Contact {localDisplayName = n, profile = LocalProfile {fullName}} + Contact {localDisplayName = n', profile = LocalProfile {fullName = fullName'}} | n == n' && fullName == fullName' = [] | n == n' = ["contact " <> ttyContact n <> fullNameUpdate] | otherwise = @@ -817,6 +904,7 @@ viewChatError = \case CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"] CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"] CEGroupUserRole -> ["you have insufficient permissions for this group command"] + CEGroupNotIncognitoCantInvite -> ["you're using main profile for this group - prohibited to invite contact to whom you are connected incognito"] CEGroupContactRole c -> ["contact " <> ttyContact c <> " has insufficient permissions for this group action"] CEGroupNotJoined g -> ["you did not join this group, use " <> highlight ("/join #" <> groupName' g)] CEGroupMemberNotActive -> ["you cannot invite other members yet, try later"] @@ -883,14 +971,14 @@ ttyContact' :: Contact -> StyledString ttyContact' Contact {localDisplayName = c} = ttyContact c ttyFullContact :: Contact -> StyledString -ttyFullContact Contact {localDisplayName, profile = Profile {fullName}} = +ttyFullContact Contact {localDisplayName, profile = LocalProfile {fullName}} = ttyFullName localDisplayName fullName ttyMember :: GroupMember -> StyledString ttyMember GroupMember {localDisplayName} = ttyContact localDisplayName ttyFullMember :: GroupMember -> StyledString -ttyFullMember GroupMember {localDisplayName, memberProfile = Profile {fullName}} = +ttyFullMember GroupMember {localDisplayName, memberProfile = LocalProfile {fullName}} = ttyFullName localDisplayName fullName ttyFullName :: ContactName -> Text -> StyledString @@ -909,7 +997,8 @@ ttyFromContactDeleted :: ContactName -> StyledString ttyFromContactDeleted c = ttyFrom $ c <> "> [deleted] " ttyToContact' :: Contact -> StyledString -ttyToContact' Contact {localDisplayName = c} = ttyToContact c +ttyToContact' Contact {localDisplayName = c, activeConn = Connection {customUserProfileId}} = + maybe "" (const incognitoPrefix) customUserProfileId <> ttyToContact c ttyQuotedContact :: Contact -> StyledString ttyQuotedContact Contact {localDisplayName = c} = ttyFrom $ c <> ">" @@ -919,7 +1008,8 @@ ttyQuotedMember (Just GroupMember {localDisplayName = c}) = "> " <> ttyFrom c ttyQuotedMember _ = "> " <> ttyFrom "?" ttyFromContact' :: Contact -> StyledString -ttyFromContact' Contact {localDisplayName = c} = ttyFromContact c +ttyFromContact' Contact {localDisplayName = c, activeConn = Connection {customUserProfileId}} = + maybe "" (const incognitoPrefix) customUserProfileId <> ttyFromContact c ttyGroup :: GroupName -> StyledString ttyGroup g = styled (colored Blue) $ "#" <> g @@ -949,10 +1039,12 @@ ttyFrom :: Text -> StyledString ttyFrom = styled $ colored Yellow ttyFromGroup' :: GroupInfo -> GroupMember -> StyledString -ttyFromGroup' g GroupMember {localDisplayName = m} = ttyFromGroup g m +ttyFromGroup' g@GroupInfo {membership} GroupMember {localDisplayName = m} = + (if memberIncognito membership then incognitoPrefix else "") <> ttyFromGroup g m ttyToGroup :: GroupInfo -> StyledString -ttyToGroup GroupInfo {localDisplayName = g} = styled (colored Cyan) $ "#" <> g <> " " +ttyToGroup GroupInfo {localDisplayName = g, membership} = + (if memberIncognito membership then incognitoPrefix else "") <> styled (colored Cyan) ("#" <> g <> " ") ttyFilePath :: FilePath -> StyledString ttyFilePath = plain @@ -960,12 +1052,24 @@ ttyFilePath = plain optFullName :: ContactName -> Text -> StyledString optFullName localDisplayName fullName = plain $ optionalFullName localDisplayName fullName +incognitoPrefix :: StyledString +incognitoPrefix = styleIncognito' "i " + +incognitoProfile' :: Profile -> StyledString +incognitoProfile' Profile {displayName} = styleIncognito displayName + highlight :: StyledFormat a => a -> StyledString highlight = styled $ colored Cyan highlight' :: String -> StyledString highlight' = highlight +styleIncognito :: StyledFormat a => a -> StyledString +styleIncognito = styled $ colored Magenta + +styleIncognito' :: String -> StyledString +styleIncognito' = styleIncognito + styleTime :: String -> StyledString styleTime = Styled [SetColor Foreground Vivid Black] diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index c44a49bfca..4d60e6538d 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -19,7 +19,7 @@ import qualified Data.Text as T import Simplex.Chat.Call import Simplex.Chat.Controller (ChatController (..)) import Simplex.Chat.Options (ChatOpts (..)) -import Simplex.Chat.Types (ConnStatus (..), ImageData (..), Profile (..), User (..)) +import Simplex.Chat.Types (ConnStatus (..), ImageData (..), LocalProfile (..), Profile (..), User (..)) import Simplex.Messaging.Util (unlessM) import System.Directory (copyFile, doesDirectoryExist, doesFileExist) import System.FilePath (()) @@ -88,6 +88,13 @@ chatTests = do it "reject contact and delete contact link" testRejectContactAndDeleteUserContact it "delete connection requests when contact link deleted" testDeleteConnectionRequests it "auto-reply message" testAutoReplyMessage + describe "incognito mode" $ do + it "connect incognito via invitation link" testConnectIncognitoInvitationLink + it "connect incognito via contact address" testConnectIncognitoContactAddress + it "accept contact request incognito" testAcceptContactRequestIncognito + it "create group incognito" testCreateGroupIncognito + it "join group incognito" testJoinGroupIncognito + it "can't invite contact to whom user connected incognito to non incognito group" testCantInviteIncognitoConnectionNonIncognitoGroup describe "SMP servers" $ it "get and set SMP servers" testGetSetSMPServers describe "async connection handshake" $ do @@ -2045,6 +2052,394 @@ testAutoReplyMessage = testChat2 aliceProfile bobProfile $ alice <# "@bob hello!" ] +testConnectIncognitoInvitationLink :: IO () +testConnectIncognitoInvitationLink = testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + alice #$> ("/incognito on", id, "ok") + bob #$> ("/incognito on", id, "ok") + alice ##> "/c" + inv <- getInvitation alice + bob ##> ("/c " <> inv) + bob <## "confirmation sent!" + bobIncognito <- getTermLine bob + aliceIncognito <- getTermLine alice + concurrentlyN_ + [ do + bob <## (aliceIncognito <> ": contact is connected, your incognito profile for this contact is " <> bobIncognito) + bob <## ("use /info " <> aliceIncognito <> " to print out this incognito profile again"), + do + alice <## (bobIncognito <> ": contact is connected, your incognito profile for this contact is " <> aliceIncognito) + alice <## ("use /info " <> bobIncognito <> " to print out this incognito profile again") + ] + -- after turning incognito mode off conversation is incognito + alice #$> ("/incognito off", id, "ok") + bob #$> ("/incognito off", id, "ok") + alice ?#> ("@" <> bobIncognito <> " psst, I'm incognito") + bob ?<# (aliceIncognito <> "> psst, I'm incognito") + bob ?#> ("@" <> aliceIncognito <> " me too") + alice ?<# (bobIncognito <> "> me too") + -- new contact is connected non incognito + connectUsers alice cath + alice <##> cath + -- bob is not notified on profile change + alice ##> "/p alice" + concurrentlyN_ + [ alice <## "user full name removed (your contacts are notified)", + cath <## "contact alice removed full name" + ] + alice ?#> ("@" <> bobIncognito <> " do you see that I've changed profile?") + bob ?<# (aliceIncognito <> "> do you see that I've changed profile?") + bob ?#> ("@" <> aliceIncognito <> " no") + alice ?<# (bobIncognito <> "> no") + +testConnectIncognitoContactAddress :: IO () +testConnectIncognitoContactAddress = testChat2 aliceProfile bobProfile $ + \alice bob -> do + alice ##> "/ad" + cLink <- getContactLink alice True + bob #$> ("/incognito on", id, "ok") + bob ##> ("/c " <> cLink) + bobIncognito <- getTermLine bob + bob <## "connection request sent incognito!" + alice <## (bobIncognito <> " wants to connect to you!") + alice <## ("to accept: /ac " <> bobIncognito) + alice <## ("to reject: /rc " <> bobIncognito <> " (the sender will NOT be notified)") + alice ##> ("/ac " <> bobIncognito) + alice <## (bobIncognito <> ": accepting contact request...") + _ <- getTermLine bob + concurrentlyN_ + [ do + bob <## ("alice (Alice): contact is connected, your incognito profile for this contact is " <> bobIncognito) + bob <## "use /info alice to print out this incognito profile again", + alice <## (bobIncognito <> ": contact is connected") + ] + -- after turning incognito mode off conversation is incognito + alice #$> ("/incognito off", id, "ok") + bob #$> ("/incognito off", id, "ok") + alice #> ("@" <> bobIncognito <> " who are you?") + bob ?<# "alice> who are you?" + bob ?#> "@alice I'm Batman" + alice <# (bobIncognito <> "> I'm Batman") + +testAcceptContactRequestIncognito :: IO () +testAcceptContactRequestIncognito = testChat2 aliceProfile bobProfile $ + \alice bob -> do + alice ##> "/ad" + cLink <- getContactLink alice True + bob ##> ("/c " <> cLink) + alice <#? bob + alice #$> ("/incognito on", id, "ok") + alice ##> "/ac bob" + alice <## "bob (Bob): accepting contact request..." + aliceIncognito <- getTermLine alice + concurrentlyN_ + [ bob <## (aliceIncognito <> ": contact is connected"), + do + alice <## ("bob (Bob): contact is connected, your incognito profile for this contact is " <> aliceIncognito) + alice <## "use /info bob to print out this incognito profile again" + ] + -- after turning incognito mode off conversation is incognito + alice #$> ("/incognito off", id, "ok") + bob #$> ("/incognito off", id, "ok") + alice ?#> "@bob my profile is totally inconspicuous" + bob <# (aliceIncognito <> "> my profile is totally inconspicuous") + bob #> ("@" <> aliceIncognito <> " I know!") + alice ?<# "bob> I know!" + +testCreateGroupIncognito :: IO () +testCreateGroupIncognito = testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + -- non incognito connections + connectUsers alice cath + connectUsers bob cath + -- bob connected incognito to alice + alice ##> "/c" + inv <- getInvitation alice + bob #$> ("/incognito on", id, "ok") + bob ##> ("/c " <> inv) + bob <## "confirmation sent!" + bobIncognito <- getTermLine bob + concurrentlyN_ + [ do + bob <## ("alice (Alice): contact is connected, your incognito profile for this contact is " <> bobIncognito) + bob <## "use /info alice to print out this incognito profile again", + alice <## (bobIncognito <> ": contact is connected") + ] + -- alice creates group incognito + alice #$> ("/incognito on", id, "ok") + alice ##> "/g secret_club" + aliceMemIncognito <- getTermLine alice + alice <## ("group #secret_club is created incognito, your profile for this group: " <> aliceMemIncognito) + alice <## "use /a secret_club to add members" + alice ##> ("/a secret_club " <> bobIncognito) + concurrentlyN_ + [ alice <## ("invitation to join the group #secret_club incognito sent to " <> bobIncognito), + do + bob <## ("#secret_club: alice (known to the group as " <> aliceMemIncognito <> ") invites you to join the group incognito as admin") + bob <## "use /j secret_club to join this group incognito" + ] + -- bob uses different profile when joining group + bob ##> "/j secret_club" + bobMemIncognito <- getTermLine bob + concurrently_ + (alice <## ("#secret_club: " <> bobIncognito <> " joined the group incognito as " <> bobMemIncognito)) + (bob <## ("#secret_club: you joined the group incognito as " <> bobMemIncognito)) + -- cath is invited incognito + alice ##> "/a secret_club cath" + concurrentlyN_ + [ alice <## "invitation to join the group #secret_club incognito sent to cath", + do + cath <## ("#secret_club: alice (known to the group as " <> aliceMemIncognito <> ") invites you to join the group incognito as admin") + cath <## "use /j secret_club to join this group incognito" + ] + cath ##> "/j secret_club" + cathMemIncognito <- getTermLine cath + -- bob and cath don't merge contacts + concurrentlyN_ + [ alice <## ("#secret_club: cath joined the group incognito as " <> cathMemIncognito), + do + cath <## ("#secret_club: you joined the group incognito as " <> cathMemIncognito) + cath <## ("#secret_club: member " <> bobMemIncognito <> " is connected"), + do + bob <## ("#secret_club: " <> aliceMemIncognito <> " added " <> cathMemIncognito <> " to the group (connecting...)") + bob <## ("#secret_club: new member " <> cathMemIncognito <> " is connected") + ] + -- send messages - group is incognito for everybody + alice #$> ("/incognito off", id, "ok") + bob #$> ("/incognito off", id, "ok") + cath #$> ("/incognito off", id, "ok") + alice ?#> "#secret_club hello" + concurrently_ + (bob ?<# ("#secret_club " <> aliceMemIncognito <> "> hello")) + (cath ?<# ("#secret_club " <> aliceMemIncognito <> "> hello")) + bob ?#> "#secret_club hi there" + concurrently_ + (alice ?<# ("#secret_club " <> bobMemIncognito <> "> hi there")) + (cath ?<# ("#secret_club " <> bobMemIncognito <> "> hi there")) + cath ?#> "#secret_club hey" + concurrently_ + (alice ?<# ("#secret_club " <> cathMemIncognito <> "> hey")) + (bob ?<# ("#secret_club " <> cathMemIncognito <> "> hey")) + -- bob and cath can send messages via direct incognito connections + bob ?#> ("@" <> cathMemIncognito <> " hi, I'm bob") + cath ?<# (bobMemIncognito <> "> hi, I'm bob") + cath ?#> ("@" <> bobMemIncognito <> " hey, I'm cath") + bob ?<# (cathMemIncognito <> "> hey, I'm cath") + -- non incognito connections are separate + bob <##> cath + -- list groups + alice ##> "/gs" + alice <## "i #secret_club" + -- list group members + alice ##> "/ms secret_club" + alice + <### [ "i " <> aliceMemIncognito <> ": owner, you, created group", + "i " <> bobMemIncognito <> ": admin, invited, connected", + "i " <> cathMemIncognito <> ": admin, invited, connected" + ] + -- remove member + bob ##> ("/rm secret_club " <> cathMemIncognito) + concurrentlyN_ + [ bob <## ("#secret_club: you removed " <> cathMemIncognito <> " from the group"), + alice <## ("#secret_club: " <> bobMemIncognito <> " removed " <> cathMemIncognito <> " from the group"), + do + cath <## ("#secret_club: " <> bobMemIncognito <> " removed you from the group") + cath <## "use /d #secret_club to delete the group" + ] + bob ?#> "#secret_club hi" + concurrently_ + (alice ?<# ("#secret_club " <> bobMemIncognito <> "> hi")) + (cath "#secret_club hello" + concurrently_ + (bob ?<# ("#secret_club " <> aliceMemIncognito <> "> hello")) + (cath "#secret_club hello" + cath <## "you are no longer a member of the group" + bob ?#> ("@" <> cathMemIncognito <> " I removed you from group") + cath ?<# (bobMemIncognito <> "> I removed you from group") + cath ?#> ("@" <> bobMemIncognito <> " ok") + bob ?<# (cathMemIncognito <> "> ok") + +testJoinGroupIncognito :: IO () +testJoinGroupIncognito = testChat4 aliceProfile bobProfile cathProfile danProfile $ + \alice bob cath dan -> do + -- non incognito connections + connectUsers alice cath + connectUsers bob cath + connectUsers cath dan + -- bob connected incognito to alice + alice ##> "/c" + inv <- getInvitation alice + bob #$> ("/incognito on", id, "ok") + bob ##> ("/c " <> inv) + bob <## "confirmation sent!" + bobIncognito <- getTermLine bob + concurrentlyN_ + [ do + bob <## ("alice (Alice): contact is connected, your incognito profile for this contact is " <> bobIncognito) + bob <## "use /info alice to print out this incognito profile again", + alice <## (bobIncognito <> ": contact is connected") + ] + -- alice creates group non incognito + alice ##> "/g club" + alice <## "group #club is created" + alice <## "use /a club to add members" + alice ##> ("/a club " <> bobIncognito) + concurrentlyN_ + [ alice <## ("invitation to join the group #club sent to " <> bobIncognito), + do + bob <## "#club: alice invites you to join the group as admin" + bob <## "use /j club to accept" + ] + -- since bob is connected incognito to host, he uses different profile when joining group even though he turned incognito mode off + bob #$> ("/incognito off", id, "ok") + bob ##> "/j club" + bobMemIncognito <- getTermLine bob + concurrently_ + (alice <## ("#club: " <> bobIncognito <> " joined the group incognito as " <> bobMemIncognito)) + (bob <## ("#club: you joined the group incognito as " <> bobMemIncognito)) + -- cath joins incognito + alice ##> "/a club cath" + concurrentlyN_ + [ alice <## "invitation to join the group #club sent to cath", + do + cath <## "#club: alice invites you to join the group as admin" + cath <## "use /j club to accept" + ] + cath #$> ("/incognito on", id, "ok") + cath ##> "/j club" + cathMemIncognito <- getTermLine cath + -- bob and cath don't merge contacts + concurrentlyN_ + [ alice <## ("#club: cath joined the group incognito as " <> cathMemIncognito), + do + cath <## ("#club: you joined the group incognito as " <> cathMemIncognito) + cath <## ("#club: member " <> bobMemIncognito <> " is connected"), + do + bob <## ("#club: alice added " <> cathMemIncognito <> " to the group (connecting...)") + bob <## ("#club: new member " <> cathMemIncognito <> " is connected") + ] + -- cath invites dan incognito + cath ##> "/a club dan" + concurrentlyN_ + [ cath <## "invitation to join the group #club incognito sent to dan", + do + dan <## ("#club: cath (known to the group as " <> cathMemIncognito <> ") invites you to join the group incognito as admin") + dan <## "use /j club to join this group incognito" + ] + dan ##> "/j club" + danMemIncognito <- getTermLine dan + concurrentlyN_ + [ cath <## ("#club: dan joined the group incognito as " <> danMemIncognito), + do + dan <## ("#club: you joined the group incognito as " <> danMemIncognito) + dan + <### [ "#club: member alice (Alice) is connected", + "#club: member " <> bobMemIncognito <> " is connected" + ], + do + alice <## ("#club: " <> cathMemIncognito <> " added " <> danMemIncognito <> " to the group (connecting...)") + alice <## ("#club: new member " <> danMemIncognito <> " is connected"), + do + bob <## ("#club: " <> cathMemIncognito <> " added " <> danMemIncognito <> " to the group (connecting...)") + bob <## ("#club: new member " <> danMemIncognito <> " is connected") + ] + -- send messages - group is incognito for cath and dan + alice #$> ("/incognito off", id, "ok") + bob #$> ("/incognito off", id, "ok") + cath #$> ("/incognito off", id, "ok") + dan #$> ("/incognito off", id, "ok") + alice #> "#club hello" + concurrentlyN_ + [ bob ?<# "#club alice> hello", + cath ?<# "#club alice> hello", + dan ?<# "#club alice> hello" + ] + bob ?#> "#club hi there" + concurrentlyN_ + [ alice <# ("#club " <> bobMemIncognito <> "> hi there"), + cath ?<# ("#club " <> bobMemIncognito <> "> hi there"), + dan ?<# ("#club " <> bobMemIncognito <> "> hi there") + ] + cath ?#> "#club hey" + concurrentlyN_ + [ alice <# ("#club " <> cathMemIncognito <> "> hey"), + bob ?<# ("#club " <> cathMemIncognito <> "> hey"), + dan ?<# ("#club " <> cathMemIncognito <> "> hey") + ] + dan ?#> "#club how is it going?" + concurrentlyN_ + [ alice <# ("#club " <> danMemIncognito <> "> how is it going?"), + bob ?<# ("#club " <> danMemIncognito <> "> how is it going?"), + cath ?<# ("#club " <> danMemIncognito <> "> how is it going?") + ] + -- bob and cath can send messages via direct incognito connections + bob ?#> ("@" <> cathMemIncognito <> " hi, I'm bob") + cath ?<# (bobMemIncognito <> "> hi, I'm bob") + cath ?#> ("@" <> bobMemIncognito <> " hey, I'm cath") + bob ?<# (cathMemIncognito <> "> hey, I'm cath") + -- non incognito connections are separate + bob <##> cath + -- bob and dan can send messages via direct incognito connections + bob ?#> ("@" <> danMemIncognito <> " hi, I'm bob") + dan ?<# (bobMemIncognito <> "> hi, I'm bob") + dan ?#> ("@" <> bobMemIncognito <> " hey, I'm dan") + bob ?<# (danMemIncognito <> "> hey, I'm dan") + -- list group members + alice ##> "/ms club" + alice + <### [ "alice (Alice): owner, you, created group", + "i " <> bobMemIncognito <> ": admin, invited, connected", + "i " <> cathMemIncognito <> ": admin, invited, connected", + danMemIncognito <> ": admin, connected" + ] + bob ##> "/ms club" + bob + <### [ "alice (Alice): owner, host, connected", + "i " <> bobMemIncognito <> ": admin, you, connected", + cathMemIncognito <> ": admin, connected", + danMemIncognito <> ": admin, connected" + ] + cath ##> "/ms club" + cath + <### [ "alice (Alice): owner, host, connected", + bobMemIncognito <> ": admin, connected", + "i " <> cathMemIncognito <> ": admin, you, connected", + "i " <> danMemIncognito <> ": admin, invited, connected" + ] + dan ##> "/ms club" + dan + <### [ "alice (Alice): owner, connected", + bobMemIncognito <> ": admin, connected", + "i " <> cathMemIncognito <> ": admin, host, connected", + "i " <> danMemIncognito <> ": admin, you, connected" + ] + +testCantInviteIncognitoConnectionNonIncognitoGroup :: IO () +testCantInviteIncognitoConnectionNonIncognitoGroup = testChat2 aliceProfile bobProfile $ + \alice bob -> do + -- alice connected incognito to bob + alice #$> ("/incognito on", id, "ok") + alice ##> "/c" + inv <- getInvitation alice + bob ##> ("/c " <> inv) + bob <## "confirmation sent!" + aliceIncognito <- getTermLine alice + concurrentlyN_ + [ bob <## (aliceIncognito <> ": contact is connected"), + do + alice <## ("bob (Bob): contact is connected, your incognito profile for this contact is " <> aliceIncognito) + alice <## "use /info bob to print out this incognito profile again" + ] + -- alice creates group non incognito + alice #$> ("/incognito off", id, "ok") + alice ##> "/g club" + alice <## "group #club is created" + alice <## "use /a club to add members" + alice ##> "/a club bob" + alice <## "you're using main profile for this group - prohibited to invite contact to whom you are connected incognito" + testGetSetSMPServers :: IO () testGetSetSMPServers = testChat2 aliceProfile bobProfile $ @@ -2513,7 +2908,7 @@ connectUsers cc1 cc2 = do showName :: TestCC -> IO String showName (TestCC ChatController {currentUser} _ _ _ _) = do - Just User {localDisplayName, profile = Profile {fullName}} <- readTVarIO currentUser + Just User {localDisplayName, profile = LocalProfile {fullName}} <- readTVarIO currentUser pure . T.unpack $ localDisplayName <> " (" <> fullName <> ")" createGroup2 :: String -> TestCC -> TestCC -> IO () @@ -2580,6 +2975,11 @@ cc #> cmd = do cc `send` cmd cc <# cmd +(?#>) :: TestCC -> String -> IO () +cc ?#> cmd = do + cc `send` cmd + cc <# ("i " <> cmd) + (#$>) :: (Eq a, Show a) => TestCC -> (String, String -> a, a) -> Expectation cc #$> (cmd, f, res) = do cc ##> cmd @@ -2632,6 +3032,9 @@ getInAnyOrder f cc ls = do (<#) :: TestCC -> String -> Expectation cc <# line = (dropTime <$> getTermLine cc) `shouldReturn` line +(?<#) :: TestCC -> String -> Expectation +cc ?<# line = (dropTime <$> getTermLine cc) `shouldReturn` "i " <> line + ( Expectation (