From d29f1bb0cfe4830439a65292ef363ce0fbce6374 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 26 Nov 2023 18:16:37 +0000 Subject: [PATCH] core: use fourmolu styles (#3470) --- fourmolu.yaml | 30 + src/Simplex/Chat.hs | 596 +++++++++--------- src/Simplex/Chat/Archive.hs | 2 +- src/Simplex/Chat/Bot/KnownContacts.hs | 2 +- src/Simplex/Chat/Call.hs | 1 - src/Simplex/Chat/Controller.hs | 49 +- src/Simplex/Chat/Core.hs | 6 +- src/Simplex/Chat/Files.hs | 4 +- src/Simplex/Chat/Markdown.hs | 34 +- src/Simplex/Chat/Messages.hs | 5 +- src/Simplex/Chat/Messages/CIContent.hs | 2 +- src/Simplex/Chat/Messages/CIContent/Events.hs | 6 +- src/Simplex/Chat/Mobile.hs | 9 +- src/Simplex/Chat/Mobile/Shared.hs | 2 +- src/Simplex/Chat/Mobile/WebRTC.hs | 16 +- src/Simplex/Chat/ProfileGenerator.hs | 8 +- src/Simplex/Chat/Protocol.hs | 1 - src/Simplex/Chat/Remote.hs | 78 ++- src/Simplex/Chat/Remote/AppVersion.hs | 2 +- src/Simplex/Chat/Remote/Multicast.hsc | 6 +- src/Simplex/Chat/Remote/Protocol.hs | 14 +- src/Simplex/Chat/Remote/Transport.hs | 6 +- src/Simplex/Chat/Remote/Types.hs | 28 +- src/Simplex/Chat/Store/Connections.hs | 39 +- src/Simplex/Chat/Store/Direct.hs | 24 +- src/Simplex/Chat/Store/Files.hs | 37 +- src/Simplex/Chat/Store/Groups.hs | 278 ++++---- src/Simplex/Chat/Store/Messages.hs | 116 ++-- src/Simplex/Chat/Store/Profiles.hs | 52 +- src/Simplex/Chat/Store/Shared.hs | 2 +- src/Simplex/Chat/Terminal/Input.hs | 30 +- src/Simplex/Chat/Terminal/Output.hs | 15 +- src/Simplex/Chat/Types.hs | 7 +- src/Simplex/Chat/Types/Preferences.hs | 1 - src/Simplex/Chat/Types/Util.hs | 2 +- src/Simplex/Chat/View.hs | 175 ++--- tests/ChatClient.hs | 3 +- tests/ChatTests/Direct.hs | 39 +- tests/ChatTests/Files.hs | 1 - tests/ChatTests/Groups.hs | 23 +- tests/ChatTests/Profiles.hs | 8 +- tests/ChatTests/Utils.hs | 6 +- tests/Test.hs | 2 +- 43 files changed, 902 insertions(+), 865 deletions(-) create mode 100644 fourmolu.yaml diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000000..907a25e7d6 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,30 @@ +indentation: 2 +column-limit: none +function-arrows: trailing +comma-style: trailing +import-export-style: trailing +indent-wheres: true +record-brace-space: true +newlines-between-decls: 1 +haddock-style: single-line +haddock-style-module: null +let-style: inline +in-style: right-align +single-constraint-parens: never +unicode: never +respectful: true +fixities: + - infixr 9 . + - infixr 8 .:, .:., .= + - infixr 6 <> + - infixr 5 ++ + - infixl 4 <$>, <$, $>, <$$>, <$?> + - infixl 4 <*>, <*, *>, <**> + - infix 4 ==, /= + - infixr 3 && + - infixl 3 <|> + - infixr 2 || + - infixl 1 >>, >>= + - infixr 1 =<<, >=>, <=< + - infixr 0 $, $! +reexports: [] diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index cf3767b5c9..f2ec81c6b3 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -12,7 +12,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat where @@ -105,7 +104,7 @@ import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport.Client (defaultSocksProxy) import Simplex.Messaging.Util import Simplex.Messaging.Version -import Simplex.RemoteControl.Invitation (RCSignedInvitation (..), RCInvitation (..)) +import Simplex.RemoteControl.Invitation (RCInvitation (..), RCSignedInvitation (..)) import System.Exit (ExitCode, exitFailure, exitSuccess) import System.FilePath (takeFileName, ()) import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, stdout) @@ -113,8 +112,8 @@ import System.Random (randomRIO) import Text.Read (readMaybe) import UnliftIO.Async import UnliftIO.Concurrent (forkFinally, forkIO, mkWeakThreadId, threadDelay) -import qualified UnliftIO.Exception as E import UnliftIO.Directory +import qualified UnliftIO.Exception as E import UnliftIO.IO (hClose, hSeek, hTell, openFile) import UnliftIO.STM @@ -235,8 +234,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen contactMergeEnabled <- newTVarIO True pure ChatController - { - firstTime, + { firstTime, currentUser, currentRemoteHost, smpAgent, @@ -445,7 +443,7 @@ processChatCommand = \case [] -> pure 1 users -> do when (any (\User {localDisplayName = n} -> n == displayName) users) $ - throwChatError $ CEUserExists displayName + throwChatError (CEUserExists displayName) withAgent (\a -> createUser a smp xftp) ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure user <- withStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts @@ -458,18 +456,18 @@ processChatCommand = \case chooseServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> m (NonEmpty (ProtoServerWithAuth p), [ServerCfg p]) chooseServers protocol | sameServers = - asks currentUser >>= readTVarIO >>= \case - Nothing -> throwChatError CENoActiveUser - Just user -> do - servers <- withStore' (`getProtocolServers` user) - cfg <- asks config - pure (activeAgentServers cfg protocol servers, servers) + asks currentUser >>= readTVarIO >>= \case + Nothing -> throwChatError CENoActiveUser + Just user -> do + servers <- withStore' (`getProtocolServers` user) + cfg <- asks config + pure (activeAgentServers cfg protocol servers, servers) | otherwise = do - defServers <- asks $ defaultServers . config - pure (cfgServers protocol defServers, []) + defServers <- asks $ defaultServers . config + pure (cfgServers protocol defServers, []) storeServers user servers = - unless (null servers) $ - withStore $ \db -> overwriteProtocolServers db user servers + unless (null servers) . withStore $ + \db -> overwriteProtocolServers db user servers coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day) day = 86400 ListUsers -> CRUsersList <$> withStoreCtx' (Just "ListUsers, getUsersInfo") getUsersInfo @@ -696,18 +694,18 @@ processChatCommand = \case | isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice | not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles | otherwise = do - (fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer g (length $ filter memberCurrent ms) - timed_ <- sndGroupCITimed live gInfo itemTTL - (msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership - (msg@SndMessage {sharedMsgId}, sentToMembers) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer) - ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live - withStore' $ \db -> - forM_ sentToMembers $ \GroupMember {groupMemberId} -> - createGroupSndStatus db (chatItemId' ci) groupMemberId CISSndNew - mapM_ (sendGroupFileInline ms sharedMsgId) ft_ - forM_ (timed_ >>= timedDeleteAt') $ - startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci) - pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) + (fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer g (length $ filter memberCurrent ms) + timed_ <- sndGroupCITimed live gInfo itemTTL + (msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership + (msg@SndMessage {sharedMsgId}, sentToMembers) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer) + ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live + withStore' $ \db -> + forM_ sentToMembers $ \GroupMember {groupMemberId} -> + createGroupSndStatus db (chatItemId' ci) groupMemberId CISSndNew + mapM_ (sendGroupFileInline ms sharedMsgId) ft_ + forM_ (timed_ >>= timedDeleteAt') $ + startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci) + pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) notAllowedError f = pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText f)) setupSndFileTransfer :: Group -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta)) setupSndFileTransfer g@(Group gInfo _) n = forM file_ $ \file -> do @@ -762,11 +760,11 @@ processChatCommand = \case quoteContent qmc ciFile_ | replaceContent = MCText qTextOrFile | otherwise = case qmc of - MCImage _ image -> MCImage qTextOrFile image - MCFile _ -> MCFile qTextOrFile - -- consider same for voice messages - -- MCVoice _ voice -> MCVoice qTextOrFile voice - _ -> qmc + MCImage _ image -> MCImage qTextOrFile image + MCFile _ -> MCFile qTextOrFile + -- consider same for voice messages + -- MCVoice _ voice -> MCVoice qTextOrFile voice + _ -> qmc where -- if the message we're quoting with is one of the "large" MsgContents -- we replace the quote's content with MCText @@ -780,7 +778,7 @@ processChatCommand = \case MCUnknown {} -> True qText = msgContentText qmc getFileName :: CIFile d -> String - getFileName CIFile{fileName} = fileName + getFileName CIFile {fileName} = fileName qFileName = maybe qText (T.pack . getFileName) ciFile_ qTextOrFile = if T.null qText then qFileName else qText xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) @@ -804,7 +802,8 @@ processChatCommand = \case -- we are not sending files to pending members, same as with inline files saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} = when ((connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn)) $ - withStore' $ \db -> createSndFTDescrXFTP db user (Just m) conn ft fileDescr + withStore' $ + \db -> createSndFTDescrXFTP db user (Just m) conn ft fileDescr saveMemberFD _ = pure () pure (fInv, ciFile, ft) unzipMaybe3 :: Maybe (a, b, c) -> (Maybe a, Maybe b, Maybe c) @@ -896,9 +895,9 @@ processChatCommand = \case withStore (\db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId) >>= \case (ct, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do unless (featureAllowed SCFReactions forUser ct) $ - throwChatError $ CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions) + throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)) unless (ciReactionAllowed ci) $ - throwChatError $ CECommandError "reaction not allowed - chat item has no content" + throwChatError (CECommandError "reaction not allowed - chat item has no content") rs <- withStore' $ \db -> getDirectReactions db ct itemSharedMId True checkReactionAllowed rs (SndMessage {msgId}, _) <- sendDirectContactMessage ct $ XMsgReact itemSharedMId Nothing reaction add @@ -914,9 +913,9 @@ processChatCommand = \case withStore (\db -> (,) <$> getGroup db user chatId <*> getGroupChatItem db user chatId itemId) >>= \case (Group g@GroupInfo {membership} ms, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do unless (groupFeatureAllowed SGFReactions g) $ - throwChatError $ CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions) + throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)) unless (ciReactionAllowed ci) $ - throwChatError $ CECommandError "reaction not allowed - chat item has no content" + throwChatError (CECommandError "reaction not allowed - chat item has no content") let GroupMember {memberId = itemMemberId} = chatItemMember g ci rs <- withStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True checkReactionAllowed rs @@ -934,9 +933,9 @@ processChatCommand = \case where checkReactionAllowed rs = do when ((reaction `elem` rs) == add) $ - throwChatError $ CECommandError $ "reaction already " <> if add then "added" else "removed" + throwChatError (CECommandError $ "reaction already " <> if add then "added" else "removed") when (add && length rs >= maxMsgReactions) $ - throwChatError $ CECommandError "too many reactions" + throwChatError (CECommandError "too many reactions") APIChatRead (ChatRef cType chatId) fromToIds -> withUser $ \_ -> case cType of CTDirect -> do user <- withStore $ \db -> getUserByContactId db chatId @@ -1020,13 +1019,13 @@ processChatCommand = \case delete ct | directOrUsed ct = pure [] | otherwise = - withStore' (\db -> checkContactHasGroups db user ct) >>= \case - Just _ -> pure [] - Nothing -> do - conns <- withStore' $ \db -> getContactConnections db userId ct - withStore' (\db -> setContactDeleted db user ct) - `catchChatError` (toView . CRChatError (Just user)) - pure $ map aConnId conns + withStore' (\db -> checkContactHasGroups db user ct) >>= \case + Just _ -> pure [] + Nothing -> do + conns <- withStore' $ \db -> getContactConnections db userId ct + withStore' (\db -> setContactDeleted db user ct) + `catchChatError` (toView . CRChatError (Just user)) + pure $ map aConnId conns CTContactRequest -> pure $ chatCmdError (Just user) "not supported" APIClearChat (ChatRef cType chatId) -> withUser $ \user -> case cType of CTDirect -> do @@ -1174,7 +1173,7 @@ processChatCommand = \case (NotificationInfo {ntfConnId, ntfMsgMeta}, msgs) <- withAgent $ \a -> getNotificationMessage a nonce encNtfInfo let ntfMessages = map (\SMP.SMPMsgMeta {msgTs, msgFlags} -> NtfMsgInfo {msgTs = systemToUTCTime msgTs, msgFlags}) msgs getMsgTs :: SMP.NMsgMeta -> SystemTime - getMsgTs SMP.NMsgMeta{msgTs} = msgTs + getMsgTs SMP.NMsgMeta {msgTs} = msgTs msgTs' = systemToUTCTime . getMsgTs <$> ntfMsgMeta agentConnId = AgentConnId ntfConnId user_ <- withStore' (`getUserByAConnId` agentConnId) @@ -1328,8 +1327,8 @@ processChatCommand = \case Just SecurityCode {securityCode} | sameVerificationCode code securityCode -> pure ct | otherwise -> do - withStore' $ \db -> setConnectionVerified db user connId Nothing - pure (ct :: Contact) {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} + withStore' $ \db -> setConnectionVerified db user connId Nothing + pure (ct :: Contact) {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} _ -> pure ct pure $ CRContactCode user ct' code Nothing -> throwChatError $ CEContactNotActive ct @@ -1342,8 +1341,8 @@ processChatCommand = \case Just SecurityCode {securityCode} | sameVerificationCode code securityCode -> pure m | otherwise -> do - withStore' $ \db -> setConnectionVerified db user connId Nothing - pure (m :: GroupMember) {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} + withStore' $ \db -> setConnectionVerified db user connId Nothing + pure (m :: GroupMember) {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} _ -> pure m pure $ CRGroupMemberCode user g m' code _ -> throwChatError CEGroupMemberNotActive @@ -1422,8 +1421,9 @@ processChatCommand = \case case conn'_ of Just conn' -> pure $ CRConnectionIncognitoUpdated user conn' Nothing -> throwChatError CEConnectionIncognitoChangeProhibited - APIConnectPlan userId cReqUri -> withUserId userId $ \user -> withChatLock "connectPlan" . procCmd $ - CRConnectionPlan user <$> connectPlan user cReqUri + APIConnectPlan userId cReqUri -> withUserId userId $ \user -> + withChatLock "connectPlan" . procCmd $ + CRConnectionPlan user <$> connectPlan user cReqUri APIConnect userId incognito (Just (ACR SCMInvitation cReq)) -> withUserId userId $ \user -> withChatLock "connect" . procCmd $ do subMode <- chatReadVar subscriptionMode -- [incognito] generate profile to send @@ -1623,12 +1623,12 @@ processChatCommand = \case pure $ CRSentGroupInvitation user gInfo contact member Just member@GroupMember {groupMemberId, memberStatus, memberRole = mRole} | memberStatus == GSMemInvited -> do - unless (mRole == memRole) $ withStore' $ \db -> updateGroupMemberRole db user member memRole - withStore' (\db -> getMemberInvitation db user groupMemberId) >>= \case - Just cReq -> do - sendInvitation member {memberRole = memRole} cReq - pure $ CRSentGroupInvitation user gInfo contact member {memberRole = memRole} - Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName + unless (mRole == memRole) $ withStore' $ \db -> updateGroupMemberRole db user member memRole + withStore' (\db -> getMemberInvitation db user groupMemberId) >>= \case + Just cReq -> do + sendInvitation member {memberRole = memRole} cReq + pure $ CRSentGroupInvitation user gInfo contact member {memberRole = memRole} + Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName | otherwise -> throwChatError $ CEGroupDuplicateMember cName APIJoinGroup groupId -> withUser $ \user@User {userId} -> do withChatLock "joinGroup" . procCmd $ do @@ -1885,21 +1885,21 @@ processChatCommand = \case FTSnd ftm@FileTransferMeta {xftpSndFile, cancelled} fts | cancelled -> throwChatError $ CEFileCancel fileId "file already cancelled" | not (null fts) && all fileCancelledOrCompleteSMP fts -> - throwChatError $ CEFileCancel fileId "file transfer is complete" + throwChatError $ CEFileCancel fileId "file transfer is complete" | otherwise -> do - fileAgentConnIds <- cancelSndFile user ftm fts True - deleteAgentConnectionsAsync user fileAgentConnIds - sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId - withStore (\db -> getChatRefByFileId db user fileId) >>= \case - ChatRef CTDirect contactId -> do - contact <- withStore $ \db -> getContact db user contactId - void . sendDirectContactMessage contact $ XFileCancel sharedMsgId - ChatRef CTGroup groupId -> do - Group gInfo ms <- withStore $ \db -> getGroup db user groupId - void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId - _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" - ci <- withStore $ \db -> getChatItemByFileId db user fileId - pure $ CRSndFileCancelled user ci ftm fts + fileAgentConnIds <- cancelSndFile user ftm fts True + deleteAgentConnectionsAsync user fileAgentConnIds + sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId + withStore (\db -> getChatRefByFileId db user fileId) >>= \case + ChatRef CTDirect contactId -> do + contact <- withStore $ \db -> getContact db user contactId + void . sendDirectContactMessage contact $ XFileCancel sharedMsgId + ChatRef CTGroup groupId -> do + Group gInfo ms <- withStore $ \db -> getGroup db user groupId + void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId + _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" + ci <- withStore $ \db -> getChatItemByFileId db user fileId + pure $ CRSndFileCancelled user ci ftm fts where fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} = s == FSCancelled || (s == FSComplete && isNothing xftpSndFile) @@ -1907,23 +1907,23 @@ processChatCommand = \case | cancelled -> throwChatError $ CEFileCancel fileId "file already cancelled" | rcvFileComplete fileStatus -> throwChatError $ CEFileCancel fileId "file transfer is complete" | otherwise -> case xftpRcvFile of - Nothing -> do - cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user) - ci <- withStore $ \db -> getChatItemByFileId db user fileId - pure $ CRRcvFileCancelled user ci ftr - Just XFTPRcvFile {agentRcvFileId} -> do - forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do - fsFilePath <- toFSFilePath filePath - liftIO $ removeFile fsFilePath `catchAll_` pure () - forM_ agentRcvFileId $ \(AgentRcvFileId aFileId) -> - withAgent (`xftpDeleteRcvFile` aFileId) - ci <- withStore $ \db -> do - liftIO $ do - updateCIFileStatus db user fileId CIFSRcvInvitation - updateRcvFileStatus db fileId FSNew - updateRcvFileAgentId db fileId Nothing - getChatItemByFileId db user fileId - pure $ CRRcvFileCancelled user ci ftr + Nothing -> do + cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user) + ci <- withStore $ \db -> getChatItemByFileId db user fileId + pure $ CRRcvFileCancelled user ci ftr + Just XFTPRcvFile {agentRcvFileId} -> do + forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do + fsFilePath <- toFSFilePath filePath + liftIO $ removeFile fsFilePath `catchAll_` pure () + forM_ agentRcvFileId $ \(AgentRcvFileId aFileId) -> + withAgent (`xftpDeleteRcvFile` aFileId) + ci <- withStore $ \db -> do + liftIO $ do + updateCIFileStatus db user fileId CIFSRcvInvitation + updateRcvFileStatus db fileId FSNew + updateRcvFileAgentId db fileId Nothing + getChatItemByFileId db user fileId + pure $ CRRcvFileCancelled user ci ftr FileStatus fileId -> withUser $ \user -> do ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> getChatItemByFileId db user fileId case file of @@ -1989,7 +1989,7 @@ processChatCommand = \case QuitChat -> liftIO exitSuccess ShowVersion -> do -- simplexmqCommitQ makes iOS builds crash m( - let versionInfo = coreVersionInfo "" -- $(simplexmqCommitQ) + let versionInfo = coreVersionInfo "" chatMigrations <- map upMigration <$> withStore' (Migrations.getCurrent . DB.conn) agentMigrations <- withAgent getAgentMigrations pure $ CRVersionInfo {versionInfo, chatMigrations, agentMigrations} @@ -2136,7 +2136,7 @@ processChatCommand = \case xftpCfg <- readTVarIO =<< asks userXFTPFileConfig fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cfArgs when (fromInteger fileSize > maxFileSize) $ throwChatError $ CEFileSize f - let chunks = - ((- fileSize) `div` fileChunkSize) + let chunks = -((-fileSize) `div` fileChunkSize) fileInline = inlineFileMode mc inlineFiles chunks n fileMode = case xftpCfg of Just cfg @@ -2155,18 +2155,18 @@ processChatCommand = \case updateProfile_ user@User {profile = p@LocalProfile {displayName = n}} p'@Profile {displayName = n'} updateUser | p' == fromLocalProfile p = pure $ CRUserProfileNoChange user | otherwise = do - when (n /= n') $ checkValidName n' - -- read contacts before user update to correctly merge preferences - -- [incognito] filter out contacts with whom user has incognito connections - contacts <- - filter (\ct -> contactReady ct && contactActive ct && not (contactConnIncognito ct)) - <$> withStore' (`getUserContacts` user) - user' <- updateUser - asks currentUser >>= atomically . (`writeTVar` Just user') - withChatLock "updateProfile" . procCmd $ do - ChatConfig {logLevel} <- asks config - summary <- foldM (processAndCount user' logLevel) (UserProfileUpdateSummary 0 0 0 []) contacts - pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' summary + when (n /= n') $ checkValidName n' + -- read contacts before user update to correctly merge preferences + -- [incognito] filter out contacts with whom user has incognito connections + contacts <- + filter (\ct -> contactReady ct && contactActive ct && not (contactConnIncognito ct)) + <$> withStore' (`getUserContacts` user) + user' <- updateUser + asks currentUser >>= atomically . (`writeTVar` Just user') + withChatLock "updateProfile" . procCmd $ do + ChatConfig {logLevel} <- asks config + summary <- foldM (processAndCount user' logLevel) (UserProfileUpdateSummary 0 0 0 []) contacts + pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' summary where processAndCount user' ll s@UserProfileUpdateSummary {notChanged, updateSuccesses, updateFailures, changedContacts = cts} ct = do let mergedProfile = userProfileToSend user Nothing $ Just ct @@ -2187,16 +2187,16 @@ processChatCommand = \case updateContactPrefs user@User {userId} ct@Contact {activeConn = Just Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs' | contactUserPrefs == contactUserPrefs' = pure $ CRContactPrefsUpdated user ct ct | otherwise = do - assertDirectAllowed user MDSnd ct XInfo_ - ct' <- withStore' $ \db -> updateContactUserPreferences db user ct contactUserPrefs' - incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId - let mergedProfile = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct) - mergedProfile' = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct') - when (mergedProfile' /= mergedProfile) $ - withChatLock "updateProfile" $ do - void (sendDirectContactMessage ct' $ XInfo mergedProfile') `catchChatError` (toView . CRChatError (Just user)) - when (directOrUsed ct') $ createSndFeatureItems user ct ct' - pure $ CRContactPrefsUpdated user ct ct' + assertDirectAllowed user MDSnd ct XInfo_ + ct' <- withStore' $ \db -> updateContactUserPreferences db user ct contactUserPrefs' + incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId + let mergedProfile = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct) + mergedProfile' = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct') + when (mergedProfile' /= mergedProfile) $ + withChatLock "updateProfile" $ do + void (sendDirectContactMessage ct' $ XInfo mergedProfile') `catchChatError` (toView . CRChatError (Just user)) + when (directOrUsed ct') $ createSndFeatureItems user ct ct' + pure $ CRContactPrefsUpdated user ct ct' runUpdateGroupProfile :: User -> Group -> GroupProfile -> m ChatResponse runUpdateGroupProfile user (Group g@GroupInfo {groupProfile = p@GroupProfile {displayName = n}} ms) p'@GroupProfile {displayName = n'} = do assertUserGroupRole g GROwner @@ -2241,15 +2241,15 @@ processChatCommand = \case Nothing -> throwChatError CENoCurrentCall Just call@Call {contactId} | ctId == contactId -> do - call_ <- action user ct call - case call_ of - Just call' -> do - unless (isRcvInvitation call') $ withStore' $ \db -> deleteCalls db user ctId - atomically $ TM.insert ctId call' calls - _ -> do - withStore' $ \db -> deleteCalls db user ctId - atomically $ TM.delete ctId calls - ok user + call_ <- action user ct call + case call_ of + Just call' -> do + unless (isRcvInvitation call') $ withStore' $ \db -> deleteCalls db user ctId + atomically $ TM.insert ctId call' calls + _ -> do + withStore' $ \db -> deleteCalls db user ctId + atomically $ TM.delete ctId calls + ok user | otherwise -> throwChatError $ CECallContact contactId withServerProtocol :: ProtocolTypeI p => SProtocolType p -> (UserProtocol p => m a) -> m a withServerProtocol p action = case userProtocol p of @@ -2314,12 +2314,12 @@ processChatCommand = \case setUserPrivacy :: User -> User -> m ChatResponse setUserPrivacy user@User {userId} user'@User {userId = userId'} | userId == userId' = do - asks currentUser >>= atomically . (`writeTVar` Just user') - withStore' (`updateUserPrivacy` user') - pure $ CRUserPrivacy {user = user', updatedUser = user'} + asks currentUser >>= atomically . (`writeTVar` Just user') + withStore' (`updateUserPrivacy` user') + pure $ CRUserPrivacy {user = user', updatedUser = user'} | otherwise = do - withStore' (`updateUserPrivacy` user') - pure $ CRUserPrivacy {user, updatedUser = user'} + withStore' (`updateUserPrivacy` user') + pure $ CRUserPrivacy {user, updatedUser = user'} checkDeleteChatUser :: User -> m () checkDeleteChatUser user@User {userId} = do when (activeUser user) $ throwChatError (CECantDeleteActiveUser userId) @@ -2353,13 +2353,13 @@ processChatCommand = \case Just (RcvDirectMsgConnection conn ct_) -> do let Connection {connStatus, contactConnInitiated} = conn if - | connStatus == ConnNew && contactConnInitiated -> - pure $ CPInvitationLink ILPOwnLink - | not (connReady conn) -> - pure $ CPInvitationLink (ILPConnecting ct_) - | otherwise -> case ct_ of - Just ct -> pure $ CPInvitationLink (ILPKnown ct) - Nothing -> throwChatError $ CEInternalError "ready RcvDirectMsgConnection connection should have associated contact" + | connStatus == ConnNew && contactConnInitiated -> + pure $ CPInvitationLink ILPOwnLink + | not (connReady conn) -> + pure $ CPInvitationLink (ILPConnecting ct_) + | otherwise -> case ct_ of + Just ct -> pure $ CPInvitationLink (ILPKnown ct) + Nothing -> throwChatError $ CEInternalError "ready RcvDirectMsgConnection connection should have associated contact" Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection" where cReqSchemas :: (ConnReqInvitation, ConnReqInvitation) @@ -2421,7 +2421,7 @@ processChatCommand = \case assertDirectAllowed :: ChatMonad m => User -> MsgDirection -> Contact -> CMEventTag e -> m () assertDirectAllowed user dir ct event = unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $ - throwChatError $ CEDirectMessagesProhibited dir ct + throwChatError (CEDirectMessagesProhibited dir ct) where directMessagesAllowed = any (groupFeatureAllowed' SGFDirectMessages) <$> withStore' (\db -> getContactGroupPreferences db user ct) allowedChatEvent = case event of @@ -2619,14 +2619,14 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI filePath <- getRcvFilePath fileId filePath_ fName True inline <- receiveInline if - | inline -> do + | inline -> do -- accepting inline ci <- withStoreCtx (Just "acceptFile, acceptRcvInlineFT") $ \db -> acceptRcvInlineFT db user fileId filePath sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId send $ XFileAcptInv sharedMsgId Nothing fName pure ci - | fileInline == Just IFMSent -> throwChatError $ CEFileAlreadyReceiving fName - | otherwise -> do + | fileInline == Just IFMSent -> throwChatError $ CEFileAlreadyReceiving fName + | otherwise -> do -- accepting via a new connection subMode <- chatReadVar subscriptionMode connIds <- createAgentConnectionAsync user cmdFunction True SCMInvitation subMode @@ -2638,7 +2638,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI rcvInline_ /= Just False && fileInline == Just IFMOffer && ( fileSize <= fileChunkSize * receiveChunks - || (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks) + || (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks) ) receiveViaCompleteFD :: ChatMonad m => User -> FileTransferId -> RcvFileDescr -> Maybe CryptoFileArgs -> m () @@ -2794,7 +2794,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do rs <- withAgent $ \a -> agentBatchSubscribe a conns -- send connection events to view contactSubsToView rs cts ce --- TODO possibly, we could either disable these events or replace with less noisy for API + -- TODO possibly, we could either disable these events or replace with less noisy for API contactLinkSubsToView rs ucs groupSubsToView rs gs ms ce sndFileSubsToView rs sfts @@ -2865,13 +2865,13 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do toView . CRContactSubSummary user $ map (uncurry ContactSubStatus) cRs when ce $ mapM_ (toView . uncurry (CRContactSubError user)) cErrors notifyAPI = toView . CRNetworkStatuses (Just user) . map (uncurry ConnNetworkStatus) - statuses = M.foldrWithKey' addStatus [] cts + statuses = M.foldrWithKey' addStatus [] cts where addStatus :: ConnId -> Contact -> [(AgentConnId, NetworkStatus)] -> [(AgentConnId, NetworkStatus)] addStatus _ Contact {activeConn = Nothing} nss = nss addStatus connId Contact {activeConn = Just Connection {agentConnId}} nss = let ns = (agentConnId, netStatus $ resultErr connId rs) - in ns : nss + in ns : nss netStatus :: Maybe ChatError -> NetworkStatus netStatus = maybe NSConnected $ NSError . errorNetworkStatus errorNetworkStatus :: ChatError -> String @@ -2879,7 +2879,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do ChatErrorAgent (BROKER _ NETWORK) _ -> "network" ChatErrorAgent (SMP SMP.AUTH) _ -> "contact deleted" e -> show e --- TODO possibly below could be replaced with less noisy events for API + -- TODO possibly below could be replaced with less noisy events for API contactLinkSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId UserContact -> m () contactLinkSubsToView rs = toView . CRUserContactSubSummary user . map (uncurry UserContactSubStatus) . resultsFor rs groupSubsToView :: Map ConnId (Either AgentErrorType ()) -> [Group] -> Map ConnId GroupMember -> Bool -> m () @@ -2903,9 +2903,9 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do groupEvent | memberStatus membership == GSMemInvited = CRGroupInvitation user g | all (\GroupMember {activeConn} -> isNothing activeConn) members = - if memberActive membership - then CRGroupEmpty user g - else CRGroupRemoved user g + if memberActive membership + then CRGroupEmpty user g + else CRGroupRemoved user g | otherwise = CRGroupSubscribed user g sndFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId SndFileTransfer -> m () sndFileSubsToView rs sfts = do @@ -2977,11 +2977,11 @@ cleanupManager = do `catchChatError` (toView . CRChatError (Just user)) cleanupMessages = do ts <- liftIO getCurrentTime - let cutoffTs = addUTCTime (- (30 * nominalDay)) ts + let cutoffTs = addUTCTime (-(30 * nominalDay)) ts withStoreCtx' (Just "cleanupManager, deleteOldMessages") (`deleteOldMessages` cutoffTs) cleanupProbes = do ts <- liftIO getCurrentTime - let cutoffTs = addUTCTime (- (14 * nominalDay)) ts + let cutoffTs = addUTCTime (-(14 * nominalDay)) ts withStore' (`deleteOldProbes` cutoffTs) startProximateTimedItemThread :: ChatMonad m => User -> (ChatRef, ChatItemId) -> UTCTime -> m () @@ -3159,13 +3159,13 @@ processAgentMsgSndFile _corrId aFileId msg = _ -> pure () -- TODO error? SFERR e | temporaryAgentError e -> - throwChatError $ CEXFTPSndFile fileId (AgentSndFileId aFileId) e + throwChatError $ CEXFTPSndFile fileId (AgentSndFileId aFileId) e | otherwise -> do - ci <- withStore $ \db -> do - liftIO $ updateFileCancelled db user fileId CIFSSndError - getChatItemByFileId db user fileId - withAgent (`xftpDeleteSndFileInternal` aFileId) - toView $ CRSndFileError user ci + ci <- withStore $ \db -> do + liftIO $ updateFileCancelled db user fileId CIFSSndError + getChatItemByFileId db user fileId + withAgent (`xftpDeleteSndFileInternal` aFileId) + toView $ CRSndFileError user ci where fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text fileDescrText = safeDecodeUtf8 . strEncode @@ -3220,13 +3220,13 @@ processAgentMsgRcvFile _corrId aFileId msg = toView $ CRRcvFileComplete user ci RFERR e | temporaryAgentError e -> - throwChatError $ CEXFTPRcvFile fileId (AgentRcvFileId aFileId) e + throwChatError $ CEXFTPRcvFile fileId (AgentRcvFileId aFileId) e | otherwise -> do - ci <- withStore $ \db -> do - liftIO $ updateFileCancelled db user fileId CIFSRcvError - getChatItemByFileId db user fileId - agentXFTPDeleteRcvFile aFileId fileId - toView $ CRRcvFileError user ci e + ci <- withStore $ \db -> do + liftIO $ updateFileCancelled db user fileId CIFSRcvError + getChatItemByFileId db user fileId + agentXFTPDeleteRcvFile aFileId fileId + toView $ CRRcvFileError user ci e processAgentMessageConn :: forall m. ChatMonad m => User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m () processAgentMessageConn user _ agentConnId END = @@ -3504,18 +3504,18 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do case chatMsgEvent of XGrpAcpt memId | sameMemberId memId m -> do - withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted - -- [async agent commands] no continuation needed, but command should be asynchronous for stability - allowAgentConnectionAsync user conn' confId XOk + withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted + -- [async agent commands] no continuation needed, but command should be asynchronous for stability + allowAgentConnectionAsync user conn' confId XOk | otherwise -> messageError "x.grp.acpt: memberId is different from expected" _ -> messageError "CONF from invited member must have x.grp.acpt" _ -> case chatMsgEvent of XGrpMemInfo memId _memProfile | sameMemberId memId m -> do - -- TODO update member profile - -- [async agent commands] no continuation needed, but command should be asynchronous for stability - allowAgentConnectionAsync user conn' confId $ XGrpMemInfo membership.memberId (fromLocalProfile $ memberProfile membership) + -- TODO update member profile + -- [async agent commands] no continuation needed, but command should be asynchronous for stability + allowAgentConnectionAsync user conn' confId $ XGrpMemInfo membership.memberId (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 @@ -3524,8 +3524,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do case chatMsgEvent of XGrpMemInfo memId _memProfile | sameMemberId memId m -> do - -- TODO update member profile - pure () + -- TODO update member profile + pure () | otherwise -> messageError "x.grp.mem.info: memberId is different from expected" XInfo _ -> pure () -- sent when connecting via group link XOk -> pure () @@ -3670,15 +3670,16 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do forM_ (forwardedGroupMsg chatMsg) $ \chatMsg' -> do ChatConfig {highlyAvailable} <- asks config -- members introduced to this invited member - introducedMembers <- if memberCategory m == GCInviteeMember - then withStore' $ \db -> getForwardIntroducedMembers db user m highlyAvailable - else pure [] + introducedMembers <- + if memberCategory m == GCInviteeMember + then withStore' $ \db -> getForwardIntroducedMembers db user m highlyAvailable + else pure [] -- invited members to which this member was introduced invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db user m highlyAvailable let ms = introducedMembers <> invitedMembers msg = XGrpMsgForward m.memberId chatMsg' brokerTs - unless (null ms) $ - void $ sendGroupMessage user gInfo ms msg + unless (null ms) . void $ + sendGroupMessage user gInfo ms msg RCVD msgMeta msgRcpt -> withAckMessage' agentConnId conn msgMeta $ groupMsgReceived gInfo m conn msgMeta msgRcpt @@ -3748,11 +3749,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do mdeUpdatedCI :: (MsgDecryptError, Word32) -> CChatItem c -> Maybe (ChatItem c 'MDRcv, CIContent 'MDRcv) mdeUpdatedCI (mde', n') (CChatItem _ ci@ChatItem {content = CIRcvDecryptionError mde n}) | mde == mde' = case mde of - MDERatchetHeader -> r (n + n') - MDETooManySkipped -> r n' -- the numbers are not added as sequential MDETooManySkipped will have it incremented by 1 - MDERatchetEarlier -> r (n + n') - MDEOther -> r (n + n') - MDERatchetSync -> r 0 + MDERatchetHeader -> r (n + n') + MDETooManySkipped -> r n' -- the numbers are not added as sequential MDETooManySkipped will have it incremented by 1 + MDERatchetEarlier -> r (n + n') + MDEOther -> r (n + n') + MDERatchetSync -> r 0 | otherwise = Nothing where r n'' = Just (ci, CIRcvDecryptionError mde n'') @@ -3770,9 +3771,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do -- TODO save XFileAcpt message XFileAcpt name | name == fileName -> do - withStore' $ \db -> updateSndFileStatus db ft FSAccepted - -- [async agent commands] no continuation needed, but command should be asynchronous for stability - allowAgentConnectionAsync user conn' confId XOk + withStore' $ \db -> updateSndFileStatus db ft FSAccepted + -- [async agent commands] no continuation needed, but command should be asynchronous for stability + allowAgentConnectionAsync user conn' confId XOk | otherwise -> messageError "x.file.acpt: fileName is different from expected" _ -> messageError "CONF from file connection must have x.file.acpt" CON -> do @@ -3965,8 +3966,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do case cmdData_ of Just cmdData@CommandData {cmdId, cmdConnId = Just cmdConnId', cmdFunction} | connId == cmdConnId' && (agentMsgTag == commandExpectedResponse cmdFunction || agentMsgTag == APCT SAEConn ERR_) -> do - withStore' $ \db -> deleteCommand db user cmdId - action cmdData + withStore' $ \db -> deleteCommand db user cmdId + action cmdData | otherwise -> err cmdId $ "not matching connection id or unexpected response, corrId = " <> show corrId Just CommandData {cmdId, cmdConnId = Nothing} -> err cmdId $ "no command connection id, corrId = " <> show corrId Nothing -> throwChatError . CEAgentCommandError $ "command not found, corrId = " <> show corrId @@ -4048,9 +4049,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do -- sendProbe -> sendProbeHashes (currently) -- sendProbeHashes -> sendProbe (reversed - change order in code, may add delay) sendProbe probe - cs <- if doProbeContacts - then map COMContact <$> withStore' (\db -> getMatchingContacts db user ct) - else pure [] + cs <- + if doProbeContacts + then map COMContact <$> withStore' (\db -> getMatchingContacts db user ct) + else pure [] ms <- map COMGroupMember <$> withStore' (\db -> getMatchingMembers db user ct) sendProbeHashes (cs <> ms) probe probeId else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32) @@ -4275,29 +4277,29 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do | isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice | not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles | otherwise = do - -- TODO integrity message check - -- check if message moderation event was received ahead of message - let timed_ = rcvGroupCITimed gInfo itemTTL - live = fromMaybe False live_ - withStore' (\db -> getCIModeration db user gInfo memberId sharedMsgId_) >>= \case - Just ciModeration -> do - applyModeration timed_ live ciModeration - withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_ - Nothing -> createItem timed_ live + -- TODO integrity message check + -- check if message moderation event was received ahead of message + let timed_ = rcvGroupCITimed gInfo itemTTL + live = fromMaybe False live_ + withStore' (\db -> getCIModeration db user gInfo memberId sharedMsgId_) >>= \case + Just ciModeration -> do + applyModeration timed_ live ciModeration + withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_ + Nothing -> createItem timed_ live where rejected f = void $ newChatItem (CIRcvGroupFeatureRejected f) Nothing Nothing False ExtMsgContent content fInv_ itemTTL live_ = mcExtMsgContent mc applyModeration timed_ live CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, createdByMsgId, moderatedAt} | moderatorRole < GRAdmin || moderatorRole < memberRole = - createItem timed_ live + createItem timed_ live | groupFeatureAllowed SGFFullDelete gInfo = do - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvModerated Nothing timed_ False - ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt - toView $ CRNewChatItem user $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci' + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs CIRcvModerated Nothing timed_ False + ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt + toView $ CRNewChatItem user $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci' | otherwise = do - file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content) (snd <$> file_) timed_ False - toView =<< markGroupCIDeleted user gInfo ci createdByMsgId False (Just moderator) moderatedAt + file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content) (snd <$> file_) timed_ False + toView =<< markGroupCIDeleted user gInfo ci createdByMsgId False (Just moderator) moderatedAt createItem timed_ live = do file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live @@ -4366,7 +4368,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do _ -> messageError "x.msg.del: message of another member without memberId" checkRole GroupMember {memberRole} a | senderRole < GRAdmin || senderRole < memberRole = - messageError "x.msg.del: message of another member with insufficient member permissions" + messageError "x.msg.del: message of another member with insufficient member permissions" | otherwise = a delete :: MsgDirectionI d => ChatItem 'CTGroup d -> Maybe GroupMember -> m ChatResponse delete ci byGroupMember @@ -4619,17 +4621,17 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do processContactProfileUpdate :: Contact -> Profile -> Bool -> m Contact processContactProfileUpdate c@Contact {profile = p} p' createItems | fromLocalProfile p /= p' = do - c' <- withStore $ \db -> - if userTTL == rcvTTL - then updateContactProfile db user c p' - else do - c' <- liftIO $ updateContactUserPreferences db user c ctUserPrefs' - updateContactProfile db user c' p' - when (directOrUsed c' && createItems) $ createRcvFeatureItems user c c' - toView $ CRContactUpdated user c c' - pure c' + c' <- withStore $ \db -> + if userTTL == rcvTTL + then updateContactProfile db user c p' + else do + c' <- liftIO $ updateContactUserPreferences db user c ctUserPrefs' + updateContactProfile db user c' p' + when (directOrUsed c' && createItems) $ createRcvFeatureItems user c c' + toView $ CRContactUpdated user c c' + pure c' | otherwise = - pure c + pure c where Contact {userPreferences = ctUserPrefs@Preferences {timedMessages = ctUserTMPref}} = c userTTL = prefParam $ getPreference SCFTimedMessages ctUserPrefs @@ -4707,8 +4709,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do when (contactMerge && not (contactOrMemberIncognito cgm1)) $ do cgm2Probe_ <- withStore' $ \db -> matchReceivedProbeHash db user cgm1 probeHash forM_ cgm2Probe_ $ \(cgm2, probe) -> - unless (contactOrMemberIncognito cgm2) $ - void $ probeMatch cgm1 cgm2 probe + unless (contactOrMemberIncognito cgm2) . void $ + probeMatch cgm1 cgm2 probe probeMatch :: ContactOrMember -> ContactOrMember -> Probe -> m (Maybe ContactOrMember) probeMatch cgm1 cgm2 probe = @@ -4717,21 +4719,21 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do case cgm2 of COMContact c2@Contact {contactId = cId2, profile = p2} | cId1 /= cId2 && profilesMatch p1 p2 -> do - void . sendDirectContactMessage c1 $ XInfoProbeOk probe - COMContact <$$> mergeContacts c1 c2 + void . sendDirectContactMessage c1 $ XInfoProbeOk probe + COMContact <$$> mergeContacts c1 c2 | otherwise -> messageWarning "probeMatch ignored: profiles don't match or same contact id" >> pure Nothing COMGroupMember m2@GroupMember {memberProfile = p2, memberContactId} | isNothing memberContactId && profilesMatch p1 p2 -> do - void . sendDirectContactMessage c1 $ XInfoProbeOk probe - COMContact <$$> associateMemberAndContact c1 m2 + void . sendDirectContactMessage c1 $ XInfoProbeOk probe + COMContact <$$> associateMemberAndContact c1 m2 | otherwise -> messageWarning "probeMatch ignored: profiles don't match or member already has contact" >> pure Nothing COMGroupMember GroupMember {activeConn = Nothing} -> pure Nothing COMGroupMember m1@GroupMember {groupId, memberProfile = p1, memberContactId, activeConn = Just conn} -> case cgm2 of COMContact c2@Contact {profile = p2} | memberCurrent m1 && isNothing memberContactId && profilesMatch p1 p2 -> do - void $ sendDirectMessage conn (XInfoProbeOk probe) (GroupId groupId) - COMContact <$$> associateMemberAndContact c2 m1 + void $ sendDirectMessage conn (XInfoProbeOk probe) (GroupId groupId) + COMContact <$$> associateMemberAndContact c2 m1 | otherwise -> messageWarning "probeMatch ignored: profiles don't match or member already has contact or member not current" >> pure Nothing COMGroupMember _ -> messageWarning "probeMatch ignored: members are not matched with members" >> pure Nothing @@ -4847,16 +4849,16 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do Just call@Call {contactId, callId, chatItemId} | contactId /= ctId' || callId /= callId' -> messageError $ eventName <> ": wrong contact or callId" | otherwise -> do - (call_, aciContent_) <- action call - case call_ of - Just call' -> do - unless (isRcvInvitation call') $ withStore' $ \db -> deleteCalls db user ctId' - atomically $ TM.insert ctId' call' calls - _ -> do - withStore' $ \db -> deleteCalls db user ctId' - atomically $ TM.delete ctId' calls - forM_ aciContent_ $ \aciContent -> - updateDirectChatItemView user ct chatItemId aciContent False $ Just msgId + (call_, aciContent_) <- action call + case call_ of + Just call' -> do + unless (isRcvInvitation call') $ withStore' $ \db -> deleteCalls db user ctId' + atomically $ TM.insert ctId' call' calls + _ -> do + withStore' $ \db -> deleteCalls db user ctId' + atomically $ TM.delete ctId' calls + forM_ aciContent_ $ \aciContent -> + updateDirectChatItemView user ct chatItemId aciContent False $ Just msgId msgCallStateError :: Text -> Call -> m () msgCallStateError eventName Call {callState} = @@ -4907,8 +4909,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do suffixOrd displayName localDisplayName | localDisplayName == displayName = Just 0 | otherwise = case T.stripPrefix (displayName <> "_") localDisplayName of - Just suffix -> readMaybe $ T.unpack suffix - Nothing -> Nothing + Just suffix -> readMaybe $ T.unpack suffix + Nothing -> Nothing associateMemberWithContact :: Contact -> GroupMember -> m Contact associateMemberWithContact c1 m2@GroupMember {groupId} = do @@ -4990,7 +4992,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do Right reMember -> do GroupMemberIntro {introId} <- withStore $ \db -> saveIntroInvitation db reMember m introInv void . sendGroupMessage' user [reMember] (XGrpMemFwd (memberInfo m) introInv) groupId (Just introId) $ - withStore' $ \db -> updateIntroStatus db introId GMIntroInvForwarded + withStore' $ + \db -> updateIntroStatus db introId GMIntroInvForwarded _ -> messageError "x.grp.mem.inv can be only sent by invitee member" xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m () @@ -5018,20 +5021,20 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> m () xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg brokerTs | membership.memberId == memId = - let gInfo' = gInfo {membership = membership {memberRole = memRole}} - in changeMemberRole gInfo' membership $ RGEUserRole memRole + let gInfo' = gInfo {membership = membership {memberRole = memRole}} + in changeMemberRole gInfo' membership $ RGEUserRole memRole | otherwise = - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case - Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole - Left _ -> messageError "x.grp.mem.role with unknown member ID" + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case + Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole + Left _ -> messageError "x.grp.mem.role with unknown member ID" where changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} gEvent | senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions" | otherwise = do - withStore' $ \db -> updateGroupMemberRole db user member memRole - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent) - groupMsgToView gInfo ci - toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole} + withStore' $ \db -> updateGroupMemberRole db user member memRole + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent) + groupMsgToView gInfo ci + toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole} checkHostRole :: GroupMember -> GroupMemberRole -> m () checkHostRole GroupMember {memberRole, localDisplayName} memRole = @@ -5044,9 +5047,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do (GCInviteeMember, GCInviteeMember) -> withStore' (\db -> runExceptT $ getIntroduction db refMember sendingMember) >>= \case Right intro -> inviteeXGrpMemCon intro - Left _ -> withStore' (\db -> runExceptT $ getIntroduction db sendingMember refMember) >>= \case - Right intro -> forwardMemberXGrpMemCon intro - Left _ -> messageWarning "x.grp.mem.con: no introduction" + Left _ -> + withStore' (\db -> runExceptT $ getIntroduction db sendingMember refMember) >>= \case + Right intro -> forwardMemberXGrpMemCon intro + Left _ -> messageWarning "x.grp.mem.con: no introduction" (GCInviteeMember, _) -> withStore' (\db -> runExceptT $ getIntroduction db refMember sendingMember) >>= \case Right intro -> inviteeXGrpMemCon intro @@ -5100,7 +5104,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do where checkRole GroupMember {memberRole} a | senderRole < GRAdmin || senderRole < memberRole = - messageError "x.grp.mem.del with insufficient member permissions" + messageError "x.grp.mem.del with insufficient member permissions" | otherwise = a deleteMemberItem gEvent = do ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent) @@ -5132,13 +5136,13 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do xGrpInfo g@GroupInfo {groupProfile = p} m@GroupMember {memberRole} p' msg brokerTs | memberRole < GROwner = messageError "x.grp.info with insufficient member permissions" | otherwise = unless (p == p') $ do - g' <- withStore $ \db -> updateGroupProfile db user g p' - toView $ CRGroupUpdated user g g' (Just m) - let cd = CDGroupRcv g' m - unless (sameGroupProfileInfo p p') $ do - ci <- saveRcvChatItem user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p') - groupMsgToView g' ci - createGroupFeatureChangedItems user cd CIRcvGroupFeature g g' + g' <- withStore $ \db -> updateGroupProfile db user g p' + toView $ CRGroupUpdated user g g' (Just m) + let cd = CDGroupRcv g' m + unless (sameGroupProfileInfo p p') $ do + ci <- saveRcvChatItem user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p') + groupMsgToView g' ci + createGroupFeatureChangedItems user cd CIRcvGroupFeature g g' xGrpDirectInv :: GroupInfo -> GroupMember -> Connection -> ConnReqInvitation -> Maybe MsgContent -> RcvMessage -> UTCTime -> m () xGrpDirectInv g m mConn connReq mContent_ msg brokerTs = do @@ -5236,8 +5240,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do Just (CChatItem SMDSnd ChatItem {meta = CIMeta {itemId, itemStatus}}) | itemStatus == newStatus -> pure () | otherwise -> do - chatItem <- withStore $ \db -> updateDirectChatItemStatus db user ct itemId newStatus - toView $ CRChatItemStatusUpdated user (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem) + chatItem <- withStore $ \db -> updateDirectChatItemStatus db user ct itemId newStatus + toView $ CRChatItemStatusUpdated user (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem) _ -> pure () updateGroupMemSndStatus :: ChatItemId -> GroupMemberId -> CIStatus 'MDSnd -> m Bool @@ -5378,7 +5382,7 @@ appendFileChunk ft@RcvFileTransfer {fileId, fileStatus, cryptoArgs} chunkNo chun append_ filePath = do fsFilePath <- toFSFilePath filePath h <- getFileHandle fileId fsFilePath rcvFiles AppendMode - liftIO (B.hPut h chunk >> hFlush h) `catchThrow` (fileErr . show) + liftIO (B.hPut h chunk >> hFlush h) `catchThrow` (fileErr . show) withStore' $ \db -> updatedRcvFileChunkStored db ft chunkNo when final $ do closeFileHandle fileId rcvFiles @@ -5540,17 +5544,17 @@ sendGroupMessage' user members chatMsgEvent groupId introId_ postDeliver = do Just conn@Connection {connStatus} | connDisabled conn || connStatus == ConnDeleted -> pure Nothing | connStatus == ConnSndReady || connStatus == ConnReady -> do - let tag = toCMEventTag chatMsgEvent - deliverMessage conn tag msgBody msgId >> postDeliver - pure $ Just m + let tag = toCMEventTag chatMsgEvent + deliverMessage conn tag msgBody msgId >> postDeliver + pure $ Just m | otherwise -> pendingOrForwarded where pendingOrForwarded | forwardSupported && isForwardedGroupMsg chatMsgEvent = pure Nothing | isXGrpMsgForward chatMsgEvent = pure Nothing | otherwise = do - withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_ - pure $ Just m + withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_ + pure $ Just m forwardSupported = do let mcvr = memberChatVRange' m isCompatibleRange mcvr groupForwardVRange && invitingMemberSupportsForward @@ -5609,14 +5613,15 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta newMsg = NewMessage {chatMsgEvent, msgBody} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} amId = Just am'.groupMemberId - msg <- withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery amId) - `catchChatError` \e -> case e of - ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do - fm <- withStore $ \db -> getGroupMember db user groupId forwardedByGroupMemberId - forM_ (memberConn fm) $ \fmConn -> - void $ sendDirectMessage fmConn (XGrpMemCon am'.memberId) (GroupId groupId) - throwError e - _ -> throwError e + msg <- + withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery amId) + `catchChatError` \e -> case e of + ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do + fm <- withStore $ \db -> getGroupMember db user groupId forwardedByGroupMemberId + forM_ (memberConn fm) $ \fmConn -> + void $ sendDirectMessage fmConn (XGrpMemCon am'.memberId) (GroupId groupId) + throwError e + _ -> throwError e pure (am', conn', msg) saveGroupFwdRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> m RcvMessage @@ -5874,9 +5879,9 @@ getCreateActiveUser st testView = do Just n | n <= 0 || n > length users -> putStrLn "invalid user number" >> loop | otherwise -> do - let user = users !! (n - 1) - withTransaction st (`setActiveUser` user.userId) - pure user + let user = users !! (n - 1) + withTransaction st (`setActiveUser` user.userId) + pure user userStr :: User -> String userStr User {localDisplayName, profile = LocalProfile {fullName}} = T.unpack $ localDisplayName <> if T.null fullName || localDisplayName == fullName then "" else " (" <> fullName <> ")" @@ -6329,13 +6334,14 @@ adminContactReq = either error id $ strDecode "simplex:/contact#/?v=1&smp=smp%3A%2F%2FPQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo%3D%40smp6.simplex.im%2FK1rslx-m5bpXVIdMZg9NLUZ_8JBm8xTt%23MCowBQYDK2VuAyEALDeVe-sG8mRY22LsXlPgiwTNs9dbiLrNuA7f3ZMAJ2w%3D" simplexContactProfile :: Profile -simplexContactProfile = Profile { - displayName = "SimpleX Chat team", - fullName = "", - image = Just (ImageData "data:image/jpg;base64,/9j/4AAQSkZJRgABAgAAAQABAAD/2wBDAAUDBAQEAwUEBAQFBQUGBwwIBwcHBw8KCwkMEQ8SEhEPERATFhwXExQaFRARGCEYGhwdHx8fExciJCIeJBweHx7/2wBDAQUFBQcGBw4ICA4eFBEUHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh7/wAARCAETARMDASIAAhEBAxEB/8QAHwAAAQUBAQEBAQEAAAAAAAAAAAECAwQFBgcICQoL/8QAtRAAAgEDAwIEAwUFBAQAAAF9AQIDAAQRBRIhMUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkKFhcYGRolJicoKSo0NTY3ODk6Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqDhIWGh4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uHi4+Tl5ufo6erx8vP09fb3+Pn6/8QAHwEAAwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoL/8QAtREAAgECBAQDBAcFBAQAAQJ3AAECAxEEBSExBhJBUQdhcRMiMoEIFEKRobHBCSMzUvAVYnLRChYkNOEl8RcYGRomJygpKjU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6goOEhYaHiImKkpOUlZaXmJmaoqOkpaanqKmqsrO0tba3uLm6wsPExcbHyMnK0tPU1dbX2Nna4uPk5ebn6Onq8vP09fb3+Pn6/9oADAMBAAIRAxEAPwD7LooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiivP/iF4yFvv0rSpAZek0yn7v+yPeunC4WpiqihBf8A8rOc5w2UYZ4jEPTourfZDvH3jL7MW03SpR53SWUfw+w96veA/F0erRLY3zKl6owD2k/8Ar15EWLEljknqadDK8MqyxMUdTlWB5Br66WS0Hh/ZLfv1ufiNLj7Mo5m8ZJ3g9OTpy+Xn5/pofRdFcd4B8XR6tEthfMEvVHyk9JB/jXY18fiMPUw9R06i1P3PK80w2aYaOIw8rxf3p9n5hRRRWB6AUUVDe3UFlavc3MixxIMsxppNuyJnOMIuUnZIL26gsrV7m5kWOJBlmNeU+I/Gd9e6sk1hI8FvA2Y1z973NVPGnimfXLoxRFo7JD8if3vc1zefevr8syiNKPtKyvJ9Ox+F8Ycb1cdU+rYCTjTi/iWjk1+nbue3eEPEdtrtoMER3SD95Hn9R7Vu18+6bf3On3kd1aSmOVDkEd/Y17J4P8SW2vWY6R3aD97F/Ue1eVmmVPDP2lP4fyPtODeMoZrBYXFO1Zf+Tf8AB7r5o3qKKK8Q/QgooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAqavbTXmmz20Fw1vJIhVZB1FeDa3p15pWoSWl6hWQHr2YeoNfQlY3izw9Z6/YGGZQky8xSgcqf8K9jKcyWEnyzXuv8D4njLhZ51RVSi7VYLRdGu3k+z+88HzRuq1rWmXmkX8lnexFHU8Hsw9RVLNfcxlGcVKLumfgFahUozdOorSWjT6E0M0kMqyxOyOpyrKcEGvXPAPjCPVolsb9wl6owGPAkH+NeO5p8M0kMqyxOyOpyrA4INcWPy+njKfLLfoz2+HuIMTkmI9pT1i/ij0a/wA+zPpGiuM+H/jCPV4lsL91S+QfKTwJR/jXW3t1BZWslzcyLHFGMsxNfB4jC1aFX2U1r+fof0Rl2bYXMMKsVRl7vXy7p9rBfXVvZWr3NzKscSDLMTXjnjbxVPrtyYoiY7JD8if3vc0zxv4ruNeujFEWjsoz8if3vc1zOa+synKFh0qtVe9+X/BPxvjLjKWZSeEwjtSW7/m/4H5kmaM1HmlB54r3bH51YkzXo3wz8MXMc0es3ZeED/VR5wW9z7VB8O/BpnMerarEREDuhhb+L3Pt7V6cAAAAAAOgFfL5xmqs6FH5v9D9a4H4MlzQzHGq1tYR/KT/AEXzCiiivlj9hCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxfFvh208QWBhmASdRmKUdVP+FeH63pl5pGoSWV5EUdTwezD1HtX0VWL4t8O2fiHTzBONk6g+TKByp/wr28pzZ4WXs6msH+B8NxdwhTzeDxGHVqy/8m8n59n954FmjNW9b0y80fUHsr2MpIp4PZh6iqWfevuYyjOKlF3TPwetQnRm6dRWktGmSwzSQyrLE7I6nKsDgg1teIPFOqa3a29vdy4jiUAheN7f3jWBmjNROhTnJTkrtbGtLF4ijSnRpzajPddHbuP3e9Lmo80ua0scth+a9E+HXgw3Hl6tqsZEX3oYmH3vc+1J8OPBZnKavq0eIhzDCw+9/tH29q9SAAAAGAOgr5bOM35b0KD16v8ARH6twXwXz8uPx0dN4xfXzf6IFAUAAAAdBRRRXyZ+wBRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFB4GTXyj+1p+0ONJjufA3ga6DX7qU1DUY24gB4McZH8Xqe38tqFCdefLETaSufQ3h/4geEde8Uah4a0rWra51Ow/wBfCrD8ceuO+OldRX5I+GfEWseG/ENvr2j30ttqFvJ5iSqxyT3z6g96/RH9nD41aT8U9AWGcx2fiK1QC7tC33/+mieqn07V14zL3QXNHVEQnc9dooorzjQKKKKACiis7xHrel+HdGudY1m8is7K2QvLLI2AAP600m3ZAYfxUg8Pr4VutT1+7isYbSMuLp/4Pb3z6V8++HNd0zxDpq6hpVys8DHGRwVPoR2NeIftJ/G7VPifrbWVk8lp4btZD9mtwcGU/wDPR/c9h2rgfh34z1LwdrAurV2ktZCBcW5PyyD/AB9DX2WTyqYWny1Ho+nY+C4t4Wp5tF16CtVX/k3k/Ps/vPr/ADRmsjwx4g07xFpMWpaZOJInHI/iQ9wR61qbq+mVmro/D6tCdGbp1FZrdEma6/4XafpWoa7jUpV3oA0MLdJD/ntXG5p8E0kMqyxOyOhyrKcEGsMTRlWpShGVm+p1ZbiYYPFQr1IKai72fU+nFAUAKAAOABRXEfDnxpFrMK6fqDhL9BhSeko9frXb1+a4rDVMNUdOotT+k8szLD5lh44jDu8X968n5hRRRXOegFFFFABUGoXlvYWkl1dSrHFGMliaL+7t7C0kuruVYoYxlmNeI+OvFtx4huzHFuisYz+7jz97/aNenluW1MbU00it2fM8S8SUMkoXetR/DH9X5fmeteF/E+m+IFkFoxSWMnMb9cev0rbr5t0vULrTb6K8s5TFNGcgj+R9q9w8E+KbXxDYjlY7xB+9i/qPaurNsneE/eUtYfkeTwlxjHNV9XxVo1V90vTz8vmjoqKKK8I+8CiiigAooooAKKKKACiiigD5V/a8+P0mgvdeAvCUskepFdl9eDjyQR9xPfHeviiR3lkaSR2d2OWZjkk+tfoj+058CtP+Jektq2jxRWnie2T91KMKLlR/yzf+h7V+fOuaVqGiarcaXqtpLaXls5jlikXDKRX0mWSpOlaG/U56l76lKtPwtr+reGNetdb0S8ls761cPHJG2D9D6g9MVmUV6TSasyD9Jf2cfjXpPxR0MW9w0dp4gtkAubYnHmf7aeo/lXr1fkh4W1/V/DGuW2taHey2d9bOHjkjP6H1HtX6Jfs5fGvR/inoQgmeOz8RWqD7XaE439vMT1U+navnMfgHRfPD4fyN4Tvoz12iis7xJremeHdEutZ1i7jtLK1jLyyucAAf1rzUm3ZGgeJNb0vw7otzrOs3kVpZWyF5ZZDgAD+Z9q/PL9pP436r8UNZaxs2ks/Dlq5+z24ODMf77+p9B2o/aU+N2p/FDXDZ2LS2fhy1ci3t84Mx/wCej+/oO1eNV9DgMAqS55/F+RhOd9EFFFABJwBkmvUMzqPh34y1Lwjq63FszSWshAntyeHHt719Z2EstzpVlqD2txbR3kCzxLPGUbawyODXK/slfs8nUpbXx144tGFkhElhp8q4849pHB/h9B3r608X+GLDxBpX2WRFiljX9xIowUPYfT2rGnnkMPWVJ6x6vt/XU+P4o4SjmtN4igrVV/5N5Pz7P7z56zRmrmvaVe6LqMljexMkiHg9mHqKoZr6uEozipRd0z8Rq0J0ZunUVmtGmTwTSQTJNC7JIhyrKcEGvZvhz41j1mJdP1GRUv0GFY8CX/69eJZqSCaWCVZYXZHU5VlOCDXDmGXU8bT5ZaPo+x7WQZ9iMlxHtKesX8UejX+fZn1FRXDfDbxtHrUKadqDqmoIuAx4EoHf613NfnWKwtTC1HTqKzR/QGW5lh8yw8cRh3eL+9Ps/MKr6heW1hZyXd3KsUUYyzGjUby20+zku7yZYoY13MzGvDPHvi+48RXpjiZorCM/u4/73+0feuvLMsqY6pZaRW7/AK6nlcScR0MloXetR/DH9X5D/Hni648Q3nlxlo7GM/u48/e9zXL7qZmjNfodDDwoU1TpqyR+AY7G18dXlXryvJ/19w/dVvSdRutMvo7yzlaOVDkY7+xqkDmvTPhn4HMxj1jV4v3Y+aCFh97/AGjWGPxNHDUXKrt27+R15JlWLzHFxp4XSS1v/L53PQ/C+oXGqaJb3t1bNbyyLkoe/v8AQ1p0AAAAAADoBRX5nUkpSbirLsf0lh6c6dKMJy5mkrvv5hRRRUGwUUUUAFFFFABRRRQAV4d+038CdO+JWkyavo8cdp4mtkzHIBhbkD+B/f0Ne40VpSqypSUovUTV9GfkTruk6joer3Ok6taS2d7ayGOaGVdrKRVKv0T/AGnfgXp/xK0h9Y0iOO18TWqZikAwLkD+B/6Gvz51zStQ0TVbjS9UtZbW8tnKSxSLgqRX1GExccRG636o55RcSlWp4V1/VvDGvWut6JeSWl9bOGjkQ4/A+oPpWXRXU0mrMk/RP4LftDeFvF3ge41HxDfW+lappkG+/idsBwP40HfJ7V8o/tJ/G/VPifrbWVk8tn4btn/0e2zgykfxv6n0HavGwSM4JGeuO9JXFRwFKlUc18vIpzbVgoooAJIAGSa7SQr6x/ZM/Z4k1J7Xxz44tClkMSWFhIuDL3Ejg/w+g70fsmfs8NqMtt448c2eLJCJLCwlX/WnqHcH+H0HevtFFVECIoVVGAAMACvFx+PtenTfqzWEOrEjRI41jjUIigBVAwAPSnUUV4ZsYXjLwzZeJNOaCcBLhQfJmA5U/wCFeBa/pV7ompSWF9GUkToccMOxHtX01WF4z8M2XiXTTBOAk6AmGYDlD/hXvZPnEsHL2dTWD/A+K4r4UhmsHXoK1Zf+TeT8+z+8+c80Zq5r2k3ui6jJY30ZSRTwezD1FUM1+gQlGcVKLumfiFWjOjN06is1umTwTSQTJNE7JIh3KynBBr2PwL8QrO701odbnSC5t0yZCcCUD+teK5pd1cWPy2ljoctTdbPqetkme4rJ6rqUHdPdPZ/8Mdb4/wDGFz4ivDFGxisIz+7j/ve5rls1HuozXTQw1PD01TpqyR5+OxlfHV5V68ryf9fcSZozTAa9P+GHgQzmPWdZhIjHzQQMPvf7R9qxxuMpYOk6lR/8E6MpyfEZriFQoL1fRLux/wAMvApmMesazFiP70EDfxf7R9vavWFAUAAAAcACgAAAAAAdBRX5xjsdVxtXnn8l2P3/ACXJcNlGHVGivV9W/wCugUUUVxHrhRRRQAUUUUAFFFFABRRRQAUUUUAFeH/tOfArT/iXpUmsaSsVp4mto/3UuMLcgDhH/oe1e4Vn+I9a0zw7otzrGsXkVpZWyF5ZZGwAB/WtaNSdOalDcTSa1PyZ1zStQ0TVrnStVtZLS8tnMcsUgwVIqlXp/wC0l8S7T4nePn1aw0q3srO3XyYJBGBNOoPDSHv7DtXmFfXU5SlBOSszlYUUUVYAAScDk19Zfsmfs7vqLW3jjx1ZFLMESafYSjmXuJHHZfQd6+VtLvJtO1K2v7cRtLbyrKgkQOpKnIyp4I46Gv0b/Zv+NOjfFDw+lrIIrDX7RAtzZ8AMMffj9V9u1efmVSrCn7m3Vl00m9T16NEjjWONVRFGFUDAA9KWiivmToCiiigAooooAwfGnhiy8S6cYJwEuEH7mYDlT/hXz7r+k32h6lJYahFskQ8Hsw9QfSvpjUr2106ykvLyZYYYxlmY18+/EXxa/ijU1aOMRWkGRCCBuPuT/Svr+GK2KcnTSvT/ACfl/kfmPiBhMvUI1m7Vn0XVefp0fy9Oa3UbqZmjNfa2PynlJM+9AOajzTo5GjkV0YqynIPoaVg5T1P4XeA/P8vWdaiIj+9BAw+9/tH29q9dAAAAAAHQVwPwx8dQ63Ammai6R6hGuFJ4Ew9vf2rvq/Ms5qYmeJaxGjWy6W8j+gOFcPl9LAReBd0931b8+3oFFFFeSfSBRRRQAUUUUAFFFFABRRRQAUUUUAFFFZ3iTW9L8OaJdazrN5HaWNqheWWQ4AH+NNJt2QB4l1vTPDmiXWs6xdx2llaxl5ZHOAAO3ufavzx/aT+N2qfFDWzZWbSWfhy2ci3tg2DKf77+p9B2pf2lfjdqfxQ1trGxeW08N2z/AOj2+cGYj/lo/v6DtXjVfQ4DAKkuefxfkYTnfRBRRQAScAZNeoZhRXv3w2/Zh8V+Lfh7deJprgadcvHv02zlT5rgdcsf4Qe1eHa5pWoaJq1zpWq2ktpeW0hjlikXDKwrOFanUk4xd2htNFKtTwrr+reGNdtta0S8ltL22cPHIhx07H1HtWXRWjSasxH6S/s4/GrSfijoYtp3jtfENqg+1WpON4/vp6j27V69X5IeFfEGr+F9etdc0O9ks7+1cPHKh/QjuD3Ffoj+zl8bNI+KWhLbztFZ+IraMfa7TON+Osieqn07V85j8A6L54fD+RvCd9GevUUUV5hoFVtTvrXTbGW9vJligiXczNRqd9aabYy3t7MsMEQyzMa+ffiN42uvE96YoS0OmxH91F3b/ab3r1spympmFSy0it3+i8z57iDiCjlFG71qPZfq/Id8RPGl14lvTFEzRafGf3cf97/aNclmmZozX6Xh8NTw1NU6askfheNxdbG1pV68ryY/NGTTM16R4J+GVxrGkSX+pSSWfmJ/oq45J7MR6Vni8ZRwkOes7I1y7K8TmNX2WHjd7/0zzvJozV3xDpF7oepyWF/EUkQ8HHDD1FZ+feuiEozipRd0zjq0Z0puE1ZrdE0E8sEyTQu0ciHKspwQa9z+GHjuLXIU0zUpFTUEXCseBKB/WvBs1JBPLBMk0LmORCGVlOCDXn5lllLH0uWWjWz7HsZFnlfJ6/tKesXuu6/z7M+tKK4D4X+PItdhTTNSdY9SQYVicCYDuPf2rv6/M8XhKuEqulVVmj92y7MaGYUFXoO6f4Ps/MKKKK5juCiiigAooooAKKKKACiig9KAM7xLrmleG9EudZ1q8jtLG2QvLK5wAPQep9q/PH9pP43ap8T9beyspJbTw3bSH7NbZx5pH8b+p9u1bH7YPxL8XeJPG114V1G0udH0jT5SIrNuDOR0kbs2e3pXgdfRZfgVTSqT3/IwnO+iCiigAkgAZJr1DMK+s/2TP2d31Brbxz46tNtmMSafp8i8y9/MkB6L0wO9J+yb+zwdSe28b+ObLFmpEljYSr/rT1DuP7voO9faCKqIERQqqMAAYAFeLj8fa9Om/VmsIdWEaJGixooVFGFUDAA9K8Q/ac+BWnfErSZNY0mOO08T2yZilAwtyAPuP/Q9q9worx6VWVKSlF6mrSasfkTrmlahomrXOlaray2l7bSGOaKRcMrCqVfon+098C7D4l6U+s6Skdr4mtY/3UmMC5UdI29/Q1+fOt6XqGi6rcaVqlrJa3ls5SWKQYKkV9RhMXHERut+qOeUeUpVqeFfEGreGNdttb0W7ktb22cNG6HH4H1FZdFdTSasyT9Jf2cPjVpXxR0Fbe4eK18Q2qD7Va7sbx/z0T1H8q9V1O+tdNsZb29mWGCJdzMxr8ovAOoeIdK8W2GoeF5podVhlDQtEefcH2PevsbxP4417xTp1jDq3lQGKFPOigJ2NLj5m59849K4KHD0sTX9x2h18vJHj55xDSyqhd61Hsv1fkaXxG8bXXie9MURaLTo2/dR5+9/tH3rkM1HmjNffYfC08NTVOmrJH4ljMXWxtaVau7yZJmgHmmAmvWfhN8PTceVrmuQkRDDW9uw+9/tN7Vjj8dSwNJ1ar9F3OjK8pr5nXVGivV9Eu7H/Cf4emcx63rkJEfDW9u4+9/tMPT2r2RQFAVQABwAKAAAAAAB0Aor8uzDMKuOq+0qfJdj9zyjKMPlVBUaK9X1bOf8b+FbHxRppt7gCO4UfuZwOUP9R7V86+IdHv8AQtTk0/UIikqHg9mHqD6V9VVz3jnwrY+KNMNvcKEuEBME2OUP+FenkmdywUvZVdab/A8PijheGZw9vQVqq/8AJvJ+fZnzLuo3Ve8Q6Pf6FqclhqERjkQ8Hsw9Qazs1+jwlGpFSi7pn4xVozpTcJqzW6J7eeSCZJoZGjkQhlZTgg17t8LvHsWuQppmpOseooMKxPEw/wAa8DzV3Q7fULvVIIdLWQ3ZcGMx8EH1z2rzs1y2jjaLVTRrZ9v+AezkGcYnK8SpUVzKWjj3/wCD2PrCiqOgx38Oj20eqTJNeLGBK6jAJq9X5VOPLJq9z98pyc4KTVr9H0CiiipLCiiigAooooAKKKKAPK/2hfg3o/xT8PFdsVprlupNnebec/3W9VNfnR4y8Naz4R8RXWg69ZvaXts5V1YcEdmB7g9jX6115V+0P8GtF+Knh05SO0161UmzvQuD/uP6qf0r08DjnRfJP4fyM5wvqj80RycCvrP9kz9ndtRNr458dWTLaAiTT9PlXBl9JJB/d7gd+tXv2bv2Y7yz19vEHxFs1VbKYi1sCQwlZTw7f7PcDvX2CiLGioihVUYAAwAK6cfmGns6T9WTCHVhGiRoqRqFRRgKBgAUtFFeGbBRRRQAV4h+038CtP8AiZpTatpCQ2fia2jPlS4wtyo52P8A0Pavb6K0pVZUpKUXqJq+jPyJ1zStQ0TVrnStVtJbS9tnMcsUgwVIqPS7C61O+isrKFpZ5W2qor9AP2r/AIM6J448OzeJLV7fTtesoyRO3yrcqP4H9/Q14F8OvBlp4XsvMkCTajKP3suM7f8AZX0H86+1yiDzFcy0S3Pms+zqllNLXWb2X6vyH/DnwZaeF7EPIEm1CUDzZcfd/wBke1dfmo80ua+0pUY0oqMVofjWLxNXF1XWrO8mSZozUea9N+B/hTTdau5NUv5opvsrjbak8k9mYelc+OxcMHQlWqbI1y3LqmYYmOHpbvuafwj+HhnMWva5DiMENb27D73ozD09q9oAAAAAAHQCkUBVCqAAOABS1+U5jmNXH1XUqfJdj9yyjKKGV0FRor1fVsKKKK4D1AooooA57xz4UsPFOmG3uFEdwgJgnA5Q/wBR7V84eI9Gv9A1SXT9RhMcqHg/wuOxB7ivrCud8d+E7DxTpZt51CXKDMEwHKn/AAr6LI88lgpeyq603+Hmv1Pj+J+GIZnB16KtVX/k3k/Psz5p0uxu9Tv4rGxheaeVtqIoyTX0T8OPBNp4XsRJKFm1GQfvZf7v+yvtR8OfBFn4UtDIxW41CUfvJsdB/dX0FdfWue568W3RoP3Pz/4BhwvwtHL0sTiVeq9l/L/wQooor5g+3CiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKrarf2ml2E19fTpBbwrud2OAKTVdQtNLsJb6+mWGCJcszGvm34nePLzxXfmGEtDpkTfuos/f/wBpvevZyfJ6uZVbLSC3f6LzPBz3PaOVUbvWb2X6vyH/ABM8d3fiq/MULPDpsR/dRdN3+03vXF5pm6jdX6phsLTw1JUqSskfjGLxVbGVnWrO8mSZ96M0wGnSq8UhjkRkdeCrDBFb2OXlFzWn4b1y/wBA1SPUNPmMciHkdmHoR6Vk7hS596ipTjUi4zV0y6c50pqcHZrZn1X4C8W2HizShc27BLmMATwZ5Q/4V0dfIfhvXL/w/qseo6dMY5U6js47gj0r6Y8BeLtP8WaUtzbER3KAefATyh/qPevzPPshlgJe1pa03+Hk/wBGfr/DfEkcygqNbSqv/JvNefdHSUUUV80fWhRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFVtVv7TS7CW+vp1ht4l3O7HpSatqNnpWny319OsMES7mZjXzP8UfH154tv8AyYWeDS4WPlQ5xvP95vU/yr2smyarmVWy0gt3+i8zws8zylldK71m9l+r8h/xP8eXfiy/MUJaHTIm/cxZ5b/ab3ris0zNGa/V8NhaWFpKlSVkj8bxeKrYuq61Z3kx+aX2pmTXsnwc+GrXBh8Qa/CViB3W9sw5b0Zh6e1YZhj6OAourVfourfY3y3LK+Y11Ror1fRLux3wc+GxuPK1/X4SIgQ1tbuPvf7TD09BXT/Fv4dQ6/bPqukxpFqca5KgYE4Hb6+9ekKAqhVAAHAApa/L62fYupi1ilKzWy6W7f5n63R4bwVPBPBuN0931v3/AMj4wuIZred4J42jlQlWVhgg0zNfRHxc+HUXiCB9W0mNI9TRcso4EwH9a+eLiKW2neCeNo5UO1kYYIPpX6TlOa0cypc8NJLddv8AgH5XnOS1srrck9YvZ9/+CJmtPw1rl/4f1WLUdPmMcqHkZ4Yeh9qys0Zr0qlONSLhNXTPKpznSmpwdmtmfWHgDxfp/i3SVubZhHcoAJ4CfmQ/1HvXSV8feGdd1Dw9q0WpabMY5UPIz8rr3UjuK+nPAHjDT/FulLcW7CO6QYngJ5Q/1FfmGfZBLAS9rS1pv8PJ/oz9c4c4jjmMFRraVV/5N5rz7o6WiiivmT6wKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAOY+JXhRfFvh5rAXDwTod8LA/KW9GHcV8s65pV/oupzadqNu0FxC2GVu/uPUV9m1x/xM8DWHi/TD8qw6jEP3E4HP+6fUV9Tw7n7wEvY1v4b/AAf+Xc+S4k4eWYR9vR/iL8V29ex8q5o+gq9ruk32i6nLp2oQNFPG2CCOvuPUV6v8Gvhk1w0PiDxDBiH71tbOPvejMPT2r9Cx2Z4fB4f283o9rdfQ/OMBlWIxuI+rwjZre/T1F+DPw0NwYfEPiCDEQ+a2tnH3vRmHp6Cvc1AVQqgADgAUKoVQqgAAYAHalr8lzPMq2Y1nVqv0XRI/YsryuhltBUqS9X1bCiiivOPSCvNfi98OYvEVu+raTEseqRrllHAnHoff3r0qiuvBY2tgqyq0nZr8fJnHjsDRx1F0ayun+Hmj4ruIZbad4J42ilQlWRhgg1Hmvoz4vfDiLxDA+raRGseqRjLIOBOP8a8AsdI1K91hdIgtJDetJ5ZiK4Knvn0xX6zleb0Mwoe1Ts1uu3/A8z8dzbJK+XYj2TV0/hff/g+Q3SbC81XUIbCwgee4mYKiKOpr6a+F3ga28IaaWkYTajOo8+Tsv+yvtTPhd4DtPCWnCWULNqcq/vZcfd/2V9q7avh+IeIHjG6FB/u1u+//AAD73hrhuOBSxGIV6j2X8v8AwQooor5M+xCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxdd8LaHrd/a32pWKTT2rbo2Pf2PqK2VAVQqgAAYAHalorSVWc4qMm2lt5GcKNOEnKMUm9/MKKKKzNAooooAKKKKACs+HRdLh1iXV4rKFb6VQrzBfmIrQoqozlG/K7XJlCMrOSvYKKKKkoKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooA//2Q=="), - contactLink = Just adminContactReq, - preferences = Nothing -} +simplexContactProfile = + Profile + { displayName = "SimpleX Chat team", + fullName = "", + image = Just (ImageData "data:image/jpg;base64,/9j/4AAQSkZJRgABAgAAAQABAAD/2wBDAAUDBAQEAwUEBAQFBQUGBwwIBwcHBw8KCwkMEQ8SEhEPERATFhwXExQaFRARGCEYGhwdHx8fExciJCIeJBweHx7/2wBDAQUFBQcGBw4ICA4eFBEUHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh7/wAARCAETARMDASIAAhEBAxEB/8QAHwAAAQUBAQEBAQEAAAAAAAAAAAECAwQFBgcICQoL/8QAtRAAAgEDAwIEAwUFBAQAAAF9AQIDAAQRBRIhMUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkKFhcYGRolJicoKSo0NTY3ODk6Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqDhIWGh4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uHi4+Tl5ufo6erx8vP09fb3+Pn6/8QAHwEAAwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoL/8QAtREAAgECBAQDBAcFBAQAAQJ3AAECAxEEBSExBhJBUQdhcRMiMoEIFEKRobHBCSMzUvAVYnLRChYkNOEl8RcYGRomJygpKjU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6goOEhYaHiImKkpOUlZaXmJmaoqOkpaanqKmqsrO0tba3uLm6wsPExcbHyMnK0tPU1dbX2Nna4uPk5ebn6Onq8vP09fb3+Pn6/9oADAMBAAIRAxEAPwD7LooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiivP/iF4yFvv0rSpAZek0yn7v+yPeunC4WpiqihBf8A8rOc5w2UYZ4jEPTourfZDvH3jL7MW03SpR53SWUfw+w96veA/F0erRLY3zKl6owD2k/8Ar15EWLEljknqadDK8MqyxMUdTlWB5Br66WS0Hh/ZLfv1ufiNLj7Mo5m8ZJ3g9OTpy+Xn5/pofRdFcd4B8XR6tEthfMEvVHyk9JB/jXY18fiMPUw9R06i1P3PK80w2aYaOIw8rxf3p9n5hRRRWB6AUUVDe3UFlavc3MixxIMsxppNuyJnOMIuUnZIL26gsrV7m5kWOJBlmNeU+I/Gd9e6sk1hI8FvA2Y1z973NVPGnimfXLoxRFo7JD8if3vc1zefevr8syiNKPtKyvJ9Ox+F8Ycb1cdU+rYCTjTi/iWjk1+nbue3eEPEdtrtoMER3SD95Hn9R7Vu18+6bf3On3kd1aSmOVDkEd/Y17J4P8SW2vWY6R3aD97F/Ue1eVmmVPDP2lP4fyPtODeMoZrBYXFO1Zf+Tf8AB7r5o3qKKK8Q/QgooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAqavbTXmmz20Fw1vJIhVZB1FeDa3p15pWoSWl6hWQHr2YeoNfQlY3izw9Z6/YGGZQky8xSgcqf8K9jKcyWEnyzXuv8D4njLhZ51RVSi7VYLRdGu3k+z+88HzRuq1rWmXmkX8lnexFHU8Hsw9RVLNfcxlGcVKLumfgFahUozdOorSWjT6E0M0kMqyxOyOpyrKcEGvXPAPjCPVolsb9wl6owGPAkH+NeO5p8M0kMqyxOyOpyrA4INcWPy+njKfLLfoz2+HuIMTkmI9pT1i/ij0a/wA+zPpGiuM+H/jCPV4lsL91S+QfKTwJR/jXW3t1BZWslzcyLHFGMsxNfB4jC1aFX2U1r+fof0Rl2bYXMMKsVRl7vXy7p9rBfXVvZWr3NzKscSDLMTXjnjbxVPrtyYoiY7JD8if3vc0zxv4ruNeujFEWjsoz8if3vc1zOa+synKFh0qtVe9+X/BPxvjLjKWZSeEwjtSW7/m/4H5kmaM1HmlB54r3bH51YkzXo3wz8MXMc0es3ZeED/VR5wW9z7VB8O/BpnMerarEREDuhhb+L3Pt7V6cAAAAAAOgFfL5xmqs6FH5v9D9a4H4MlzQzHGq1tYR/KT/AEXzCiiivlj9hCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxfFvh208QWBhmASdRmKUdVP+FeH63pl5pGoSWV5EUdTwezD1HtX0VWL4t8O2fiHTzBONk6g+TKByp/wr28pzZ4WXs6msH+B8NxdwhTzeDxGHVqy/8m8n59n954FmjNW9b0y80fUHsr2MpIp4PZh6iqWfevuYyjOKlF3TPwetQnRm6dRWktGmSwzSQyrLE7I6nKsDgg1teIPFOqa3a29vdy4jiUAheN7f3jWBmjNROhTnJTkrtbGtLF4ijSnRpzajPddHbuP3e9Lmo80ua0scth+a9E+HXgw3Hl6tqsZEX3oYmH3vc+1J8OPBZnKavq0eIhzDCw+9/tH29q9SAAAAGAOgr5bOM35b0KD16v8ARH6twXwXz8uPx0dN4xfXzf6IFAUAAAAdBRRRXyZ+wBRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFB4GTXyj+1p+0ONJjufA3ga6DX7qU1DUY24gB4McZH8Xqe38tqFCdefLETaSufQ3h/4geEde8Uah4a0rWra51Ow/wBfCrD8ceuO+OldRX5I+GfEWseG/ENvr2j30ttqFvJ5iSqxyT3z6g96/RH9nD41aT8U9AWGcx2fiK1QC7tC33/+mieqn07V14zL3QXNHVEQnc9dooorzjQKKKKACiis7xHrel+HdGudY1m8is7K2QvLLI2AAP600m3ZAYfxUg8Pr4VutT1+7isYbSMuLp/4Pb3z6V8++HNd0zxDpq6hpVys8DHGRwVPoR2NeIftJ/G7VPifrbWVk8lp4btZD9mtwcGU/wDPR/c9h2rgfh34z1LwdrAurV2ktZCBcW5PyyD/AB9DX2WTyqYWny1Ho+nY+C4t4Wp5tF16CtVX/k3k/Ps/vPr/ADRmsjwx4g07xFpMWpaZOJInHI/iQ9wR61qbq+mVmro/D6tCdGbp1FZrdEma6/4XafpWoa7jUpV3oA0MLdJD/ntXG5p8E0kMqyxOyOhyrKcEGsMTRlWpShGVm+p1ZbiYYPFQr1IKai72fU+nFAUAKAAOABRXEfDnxpFrMK6fqDhL9BhSeko9frXb1+a4rDVMNUdOotT+k8szLD5lh44jDu8X968n5hRRRXOegFFFFABUGoXlvYWkl1dSrHFGMliaL+7t7C0kuruVYoYxlmNeI+OvFtx4huzHFuisYz+7jz97/aNenluW1MbU00it2fM8S8SUMkoXetR/DH9X5fmeteF/E+m+IFkFoxSWMnMb9cev0rbr5t0vULrTb6K8s5TFNGcgj+R9q9w8E+KbXxDYjlY7xB+9i/qPaurNsneE/eUtYfkeTwlxjHNV9XxVo1V90vTz8vmjoqKKK8I+8CiiigAooooAKKKKACiiigD5V/a8+P0mgvdeAvCUskepFdl9eDjyQR9xPfHeviiR3lkaSR2d2OWZjkk+tfoj+058CtP+Jektq2jxRWnie2T91KMKLlR/yzf+h7V+fOuaVqGiarcaXqtpLaXls5jlikXDKRX0mWSpOlaG/U56l76lKtPwtr+reGNetdb0S8ls761cPHJG2D9D6g9MVmUV6TSasyD9Jf2cfjXpPxR0MW9w0dp4gtkAubYnHmf7aeo/lXr1fkh4W1/V/DGuW2taHey2d9bOHjkjP6H1HtX6Jfs5fGvR/inoQgmeOz8RWqD7XaE439vMT1U+navnMfgHRfPD4fyN4Tvoz12iis7xJremeHdEutZ1i7jtLK1jLyyucAAf1rzUm3ZGgeJNb0vw7otzrOs3kVpZWyF5ZZDgAD+Z9q/PL9pP436r8UNZaxs2ks/Dlq5+z24ODMf77+p9B2o/aU+N2p/FDXDZ2LS2fhy1ci3t84Mx/wCej+/oO1eNV9DgMAqS55/F+RhOd9EFFFABJwBkmvUMzqPh34y1Lwjq63FszSWshAntyeHHt719Z2EstzpVlqD2txbR3kCzxLPGUbawyODXK/slfs8nUpbXx144tGFkhElhp8q4849pHB/h9B3r608X+GLDxBpX2WRFiljX9xIowUPYfT2rGnnkMPWVJ6x6vt/XU+P4o4SjmtN4igrVV/5N5Pz7P7z56zRmrmvaVe6LqMljexMkiHg9mHqKoZr6uEozipRd0z8Rq0J0ZunUVmtGmTwTSQTJNC7JIhyrKcEGvZvhz41j1mJdP1GRUv0GFY8CX/69eJZqSCaWCVZYXZHU5VlOCDXDmGXU8bT5ZaPo+x7WQZ9iMlxHtKesX8UejX+fZn1FRXDfDbxtHrUKadqDqmoIuAx4EoHf613NfnWKwtTC1HTqKzR/QGW5lh8yw8cRh3eL+9Ps/MKr6heW1hZyXd3KsUUYyzGjUby20+zku7yZYoY13MzGvDPHvi+48RXpjiZorCM/u4/73+0feuvLMsqY6pZaRW7/AK6nlcScR0MloXetR/DH9X5D/Hni648Q3nlxlo7GM/u48/e9zXL7qZmjNfodDDwoU1TpqyR+AY7G18dXlXryvJ/19w/dVvSdRutMvo7yzlaOVDkY7+xqkDmvTPhn4HMxj1jV4v3Y+aCFh97/AGjWGPxNHDUXKrt27+R15JlWLzHFxp4XSS1v/L53PQ/C+oXGqaJb3t1bNbyyLkoe/v8AQ1p0AAAAAADoBRX5nUkpSbirLsf0lh6c6dKMJy5mkrvv5hRRRUGwUUUUAFFFFABRRRQAV4d+038CdO+JWkyavo8cdp4mtkzHIBhbkD+B/f0Ne40VpSqypSUovUTV9GfkTruk6joer3Ok6taS2d7ayGOaGVdrKRVKv0T/AGnfgXp/xK0h9Y0iOO18TWqZikAwLkD+B/6Gvz51zStQ0TVbjS9UtZbW8tnKSxSLgqRX1GExccRG636o55RcSlWp4V1/VvDGvWut6JeSWl9bOGjkQ4/A+oPpWXRXU0mrMk/RP4LftDeFvF3ge41HxDfW+lappkG+/idsBwP40HfJ7V8o/tJ/G/VPifrbWVk8tn4btn/0e2zgykfxv6n0HavGwSM4JGeuO9JXFRwFKlUc18vIpzbVgoooAJIAGSa7SQr6x/ZM/Z4k1J7Xxz44tClkMSWFhIuDL3Ejg/w+g70fsmfs8NqMtt448c2eLJCJLCwlX/WnqHcH+H0HevtFFVECIoVVGAAMACvFx+PtenTfqzWEOrEjRI41jjUIigBVAwAPSnUUV4ZsYXjLwzZeJNOaCcBLhQfJmA5U/wCFeBa/pV7ompSWF9GUkToccMOxHtX01WF4z8M2XiXTTBOAk6AmGYDlD/hXvZPnEsHL2dTWD/A+K4r4UhmsHXoK1Zf+TeT8+z+8+c80Zq5r2k3ui6jJY30ZSRTwezD1FUM1+gQlGcVKLumfiFWjOjN06is1umTwTSQTJNE7JIh3KynBBr2PwL8QrO701odbnSC5t0yZCcCUD+teK5pd1cWPy2ljoctTdbPqetkme4rJ6rqUHdPdPZ/8Mdb4/wDGFz4ivDFGxisIz+7j/ve5rls1HuozXTQw1PD01TpqyR5+OxlfHV5V68ryf9fcSZozTAa9P+GHgQzmPWdZhIjHzQQMPvf7R9qxxuMpYOk6lR/8E6MpyfEZriFQoL1fRLux/wAMvApmMesazFiP70EDfxf7R9vavWFAUAAAAcACgAAAAAAdBRX5xjsdVxtXnn8l2P3/ACXJcNlGHVGivV9W/wCugUUUVxHrhRRRQAUUUUAFFFFABRRRQAUUUUAFeH/tOfArT/iXpUmsaSsVp4mto/3UuMLcgDhH/oe1e4Vn+I9a0zw7otzrGsXkVpZWyF5ZZGwAB/WtaNSdOalDcTSa1PyZ1zStQ0TVrnStVtZLS8tnMcsUgwVIqlXp/wC0l8S7T4nePn1aw0q3srO3XyYJBGBNOoPDSHv7DtXmFfXU5SlBOSszlYUUUVYAAScDk19Zfsmfs7vqLW3jjx1ZFLMESafYSjmXuJHHZfQd6+VtLvJtO1K2v7cRtLbyrKgkQOpKnIyp4I46Gv0b/Zv+NOjfFDw+lrIIrDX7RAtzZ8AMMffj9V9u1efmVSrCn7m3Vl00m9T16NEjjWONVRFGFUDAA9KWiivmToCiiigAooooAwfGnhiy8S6cYJwEuEH7mYDlT/hXz7r+k32h6lJYahFskQ8Hsw9QfSvpjUr2106ykvLyZYYYxlmY18+/EXxa/ijU1aOMRWkGRCCBuPuT/Svr+GK2KcnTSvT/ACfl/kfmPiBhMvUI1m7Vn0XVefp0fy9Oa3UbqZmjNfa2PynlJM+9AOajzTo5GjkV0YqynIPoaVg5T1P4XeA/P8vWdaiIj+9BAw+9/tH29q9dAAAAAAHQVwPwx8dQ63Ammai6R6hGuFJ4Ew9vf2rvq/Ms5qYmeJaxGjWy6W8j+gOFcPl9LAReBd0931b8+3oFFFFeSfSBRRRQAUUUUAFFFFABRRRQAUUUUAFFFZ3iTW9L8OaJdazrN5HaWNqheWWQ4AH+NNJt2QB4l1vTPDmiXWs6xdx2llaxl5ZHOAAO3ufavzx/aT+N2qfFDWzZWbSWfhy2ci3tg2DKf77+p9B2pf2lfjdqfxQ1trGxeW08N2z/AOj2+cGYj/lo/v6DtXjVfQ4DAKkuefxfkYTnfRBRRQAScAZNeoZhRXv3w2/Zh8V+Lfh7deJprgadcvHv02zlT5rgdcsf4Qe1eHa5pWoaJq1zpWq2ktpeW0hjlikXDKwrOFanUk4xd2htNFKtTwrr+reGNdtta0S8ltL22cPHIhx07H1HtWXRWjSasxH6S/s4/GrSfijoYtp3jtfENqg+1WpON4/vp6j27V69X5IeFfEGr+F9etdc0O9ks7+1cPHKh/QjuD3Ffoj+zl8bNI+KWhLbztFZ+IraMfa7TON+Osieqn07V85j8A6L54fD+RvCd9GevUUUV5hoFVtTvrXTbGW9vJligiXczNRqd9aabYy3t7MsMEQyzMa+ffiN42uvE96YoS0OmxH91F3b/ab3r1spympmFSy0it3+i8z57iDiCjlFG71qPZfq/Id8RPGl14lvTFEzRafGf3cf97/aNclmmZozX6Xh8NTw1NU6askfheNxdbG1pV68ryY/NGTTM16R4J+GVxrGkSX+pSSWfmJ/oq45J7MR6Vni8ZRwkOes7I1y7K8TmNX2WHjd7/0zzvJozV3xDpF7oepyWF/EUkQ8HHDD1FZ+feuiEozipRd0zjq0Z0puE1ZrdE0E8sEyTQu0ciHKspwQa9z+GHjuLXIU0zUpFTUEXCseBKB/WvBs1JBPLBMk0LmORCGVlOCDXn5lllLH0uWWjWz7HsZFnlfJ6/tKesXuu6/z7M+tKK4D4X+PItdhTTNSdY9SQYVicCYDuPf2rv6/M8XhKuEqulVVmj92y7MaGYUFXoO6f4Ps/MKKKK5juCiiigAooooAKKKKACiig9KAM7xLrmleG9EudZ1q8jtLG2QvLK5wAPQep9q/PH9pP43ap8T9beyspJbTw3bSH7NbZx5pH8b+p9u1bH7YPxL8XeJPG114V1G0udH0jT5SIrNuDOR0kbs2e3pXgdfRZfgVTSqT3/IwnO+iCiigAkgAZJr1DMK+s/2TP2d31Brbxz46tNtmMSafp8i8y9/MkB6L0wO9J+yb+zwdSe28b+ObLFmpEljYSr/rT1DuP7voO9faCKqIERQqqMAAYAFeLj8fa9Om/VmsIdWEaJGixooVFGFUDAA9K8Q/ac+BWnfErSZNY0mOO08T2yZilAwtyAPuP/Q9q9worx6VWVKSlF6mrSasfkTrmlahomrXOlaray2l7bSGOaKRcMrCqVfon+098C7D4l6U+s6Skdr4mtY/3UmMC5UdI29/Q1+fOt6XqGi6rcaVqlrJa3ls5SWKQYKkV9RhMXHERut+qOeUeUpVqeFfEGreGNdttb0W7ktb22cNG6HH4H1FZdFdTSasyT9Jf2cPjVpXxR0Fbe4eK18Q2qD7Va7sbx/z0T1H8q9V1O+tdNsZb29mWGCJdzMxr8ovAOoeIdK8W2GoeF5podVhlDQtEefcH2PevsbxP4417xTp1jDq3lQGKFPOigJ2NLj5m59849K4KHD0sTX9x2h18vJHj55xDSyqhd61Hsv1fkaXxG8bXXie9MURaLTo2/dR5+9/tH3rkM1HmjNffYfC08NTVOmrJH4ljMXWxtaVau7yZJmgHmmAmvWfhN8PTceVrmuQkRDDW9uw+9/tN7Vjj8dSwNJ1ar9F3OjK8pr5nXVGivV9Eu7H/Cf4emcx63rkJEfDW9u4+9/tMPT2r2RQFAVQABwAKAAAAAAB0Aor8uzDMKuOq+0qfJdj9zyjKMPlVBUaK9X1bOf8b+FbHxRppt7gCO4UfuZwOUP9R7V86+IdHv8AQtTk0/UIikqHg9mHqD6V9VVz3jnwrY+KNMNvcKEuEBME2OUP+FenkmdywUvZVdab/A8PijheGZw9vQVqq/8AJvJ+fZnzLuo3Ve8Q6Pf6FqclhqERjkQ8Hsw9Qazs1+jwlGpFSi7pn4xVozpTcJqzW6J7eeSCZJoZGjkQhlZTgg17t8LvHsWuQppmpOseooMKxPEw/wAa8DzV3Q7fULvVIIdLWQ3ZcGMx8EH1z2rzs1y2jjaLVTRrZ9v+AezkGcYnK8SpUVzKWjj3/wCD2PrCiqOgx38Oj20eqTJNeLGBK6jAJq9X5VOPLJq9z98pyc4KTVr9H0CiiipLCiiigAooooAKKKKAPK/2hfg3o/xT8PFdsVprlupNnebec/3W9VNfnR4y8Naz4R8RXWg69ZvaXts5V1YcEdmB7g9jX6115V+0P8GtF+Knh05SO0161UmzvQuD/uP6qf0r08DjnRfJP4fyM5wvqj80RycCvrP9kz9ndtRNr458dWTLaAiTT9PlXBl9JJB/d7gd+tXv2bv2Y7yz19vEHxFs1VbKYi1sCQwlZTw7f7PcDvX2CiLGioihVUYAAwAK6cfmGns6T9WTCHVhGiRoqRqFRRgKBgAUtFFeGbBRRRQAV4h+038CtP8AiZpTatpCQ2fia2jPlS4wtyo52P8A0Pavb6K0pVZUpKUXqJq+jPyJ1zStQ0TVrnStVtJbS9tnMcsUgwVIqPS7C61O+isrKFpZ5W2qor9AP2r/AIM6J448OzeJLV7fTtesoyRO3yrcqP4H9/Q14F8OvBlp4XsvMkCTajKP3suM7f8AZX0H86+1yiDzFcy0S3Pms+zqllNLXWb2X6vyH/DnwZaeF7EPIEm1CUDzZcfd/wBke1dfmo80ua+0pUY0oqMVofjWLxNXF1XWrO8mSZozUea9N+B/hTTdau5NUv5opvsrjbak8k9mYelc+OxcMHQlWqbI1y3LqmYYmOHpbvuafwj+HhnMWva5DiMENb27D73ozD09q9oAAAAAAHQCkUBVCqAAOABS1+U5jmNXH1XUqfJdj9yyjKKGV0FRor1fVsKKKK4D1AooooA57xz4UsPFOmG3uFEdwgJgnA5Q/wBR7V84eI9Gv9A1SXT9RhMcqHg/wuOxB7ivrCud8d+E7DxTpZt51CXKDMEwHKn/AAr6LI88lgpeyq603+Hmv1Pj+J+GIZnB16KtVX/k3k/Psz5p0uxu9Tv4rGxheaeVtqIoyTX0T8OPBNp4XsRJKFm1GQfvZf7v+yvtR8OfBFn4UtDIxW41CUfvJsdB/dX0FdfWue568W3RoP3Pz/4BhwvwtHL0sTiVeq9l/L/wQooor5g+3CiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKrarf2ml2E19fTpBbwrud2OAKTVdQtNLsJb6+mWGCJcszGvm34nePLzxXfmGEtDpkTfuos/f/wBpvevZyfJ6uZVbLSC3f6LzPBz3PaOVUbvWb2X6vyH/ABM8d3fiq/MULPDpsR/dRdN3+03vXF5pm6jdX6phsLTw1JUqSskfjGLxVbGVnWrO8mSZ96M0wGnSq8UhjkRkdeCrDBFb2OXlFzWn4b1y/wBA1SPUNPmMciHkdmHoR6Vk7hS596ipTjUi4zV0y6c50pqcHZrZn1X4C8W2HizShc27BLmMATwZ5Q/4V0dfIfhvXL/w/qseo6dMY5U6js47gj0r6Y8BeLtP8WaUtzbER3KAefATyh/qPevzPPshlgJe1pa03+Hk/wBGfr/DfEkcygqNbSqv/JvNefdHSUUUV80fWhRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFVtVv7TS7CW+vp1ht4l3O7HpSatqNnpWny319OsMES7mZjXzP8UfH154tv8AyYWeDS4WPlQ5xvP95vU/yr2smyarmVWy0gt3+i8zws8zylldK71m9l+r8h/xP8eXfiy/MUJaHTIm/cxZ5b/ab3ris0zNGa/V8NhaWFpKlSVkj8bxeKrYuq61Z3kx+aX2pmTXsnwc+GrXBh8Qa/CViB3W9sw5b0Zh6e1YZhj6OAourVfourfY3y3LK+Y11Ror1fRLux3wc+GxuPK1/X4SIgQ1tbuPvf7TD09BXT/Fv4dQ6/bPqukxpFqca5KgYE4Hb6+9ekKAqhVAAHAApa/L62fYupi1ilKzWy6W7f5n63R4bwVPBPBuN0931v3/AMj4wuIZred4J42jlQlWVhgg0zNfRHxc+HUXiCB9W0mNI9TRcso4EwH9a+eLiKW2neCeNo5UO1kYYIPpX6TlOa0cypc8NJLddv8AgH5XnOS1srrck9YvZ9/+CJmtPw1rl/4f1WLUdPmMcqHkZ4Yeh9qys0Zr0qlONSLhNXTPKpznSmpwdmtmfWHgDxfp/i3SVubZhHcoAJ4CfmQ/1HvXSV8feGdd1Dw9q0WpabMY5UPIz8rr3UjuK+nPAHjDT/FulLcW7CO6QYngJ5Q/1FfmGfZBLAS9rS1pv8PJ/oz9c4c4jjmMFRraVV/5N5rz7o6WiiivmT6wKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAOY+JXhRfFvh5rAXDwTod8LA/KW9GHcV8s65pV/oupzadqNu0FxC2GVu/uPUV9m1x/xM8DWHi/TD8qw6jEP3E4HP+6fUV9Tw7n7wEvY1v4b/AAf+Xc+S4k4eWYR9vR/iL8V29ex8q5o+gq9ruk32i6nLp2oQNFPG2CCOvuPUV6v8Gvhk1w0PiDxDBiH71tbOPvejMPT2r9Cx2Z4fB4f283o9rdfQ/OMBlWIxuI+rwjZre/T1F+DPw0NwYfEPiCDEQ+a2tnH3vRmHp6Cvc1AVQqgADgAUKoVQqgAAYAHalr8lzPMq2Y1nVqv0XRI/YsryuhltBUqS9X1bCiiivOPSCvNfi98OYvEVu+raTEseqRrllHAnHoff3r0qiuvBY2tgqyq0nZr8fJnHjsDRx1F0ayun+Hmj4ruIZbad4J42ilQlWRhgg1Hmvoz4vfDiLxDA+raRGseqRjLIOBOP8a8AsdI1K91hdIgtJDetJ5ZiK4Knvn0xX6zleb0Mwoe1Ts1uu3/A8z8dzbJK+XYj2TV0/hff/g+Q3SbC81XUIbCwgee4mYKiKOpr6a+F3ga28IaaWkYTajOo8+Tsv+yvtTPhd4DtPCWnCWULNqcq/vZcfd/2V9q7avh+IeIHjG6FB/u1u+//AAD73hrhuOBSxGIV6j2X8v8AwQooor5M+xCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxdd8LaHrd/a32pWKTT2rbo2Pf2PqK2VAVQqgAAYAHalorSVWc4qMm2lt5GcKNOEnKMUm9/MKKKKzNAooooAKKKKACs+HRdLh1iXV4rKFb6VQrzBfmIrQoqozlG/K7XJlCMrOSvYKKKKkoKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooA//2Q=="), + contactLink = Just adminContactReq, + preferences = Nothing + } timeItToView :: ChatMonad' m => String -> m a -> m a timeItToView s action = do @@ -6352,15 +6358,15 @@ mkValidName = reverse . dropWhile isSpace . fst3 . foldl' addChar ("", '\NUL', 0 fst3 (x, _, _) = x addChar (r, prev, punct) c = if validChar then (c' : r, c', punct') else (r, prev, punct) where - c' = if isSpace c then ' ' else c - punct' - | isPunctuation c = punct + 1 - | isSpace c = punct - | otherwise = 0 - validChar - | c == '\'' = False - | prev == '\NUL' = c > ' ' && c /= '#' && c /= '@' && validFirstChar - | isSpace prev = validFirstChar || (punct == 0 && isPunctuation c) - | isPunctuation prev = validFirstChar || isSpace c || (punct < 3 && isPunctuation c) - | otherwise = validFirstChar || isSpace c || isMark c || isPunctuation c - validFirstChar = isLetter c || isNumber c || isSymbol c + c' = if isSpace c then ' ' else c + punct' + | isPunctuation c = punct + 1 + | isSpace c = punct + | otherwise = 0 + validChar + | c == '\'' = False + | prev == '\NUL' = c > ' ' && c /= '#' && c /= '@' && validFirstChar + | isSpace prev = validFirstChar || (punct == 0 && isPunctuation c) + | isPunctuation prev = validFirstChar || isSpace c || (punct < 3 && isPunctuation c) + | otherwise = validFirstChar || isSpace c || isMark c || isPunctuation c + validFirstChar = isLetter c || isNumber c || isSymbol c diff --git a/src/Simplex/Chat/Archive.hs b/src/Simplex/Chat/Archive.hs index dd098e016d..22e5f1ee2f 100644 --- a/src/Simplex/Chat/Archive.hs +++ b/src/Simplex/Chat/Archive.hs @@ -22,7 +22,7 @@ import qualified Data.Text as T import qualified Database.SQLite3 as SQL import Simplex.Chat.Controller import Simplex.Messaging.Agent.Client (agentClientStore) -import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), sqlString, closeSQLiteStore) +import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), closeSQLiteStore, sqlString) import Simplex.Messaging.Util import System.FilePath import UnliftIO.Directory diff --git a/src/Simplex/Chat/Bot/KnownContacts.hs b/src/Simplex/Chat/Bot/KnownContacts.hs index c079b994a6..1ea44d49be 100644 --- a/src/Simplex/Chat/Bot/KnownContacts.hs +++ b/src/Simplex/Chat/Bot/KnownContacts.hs @@ -6,8 +6,8 @@ module Simplex.Chat.Bot.KnownContacts where import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Int (Int64) import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Options.Applicative import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Util (safeDecodeUtf8) diff --git a/src/Simplex/Chat/Call.hs b/src/Simplex/Chat/Call.hs index 313442838e..115cd839e4 100644 --- a/src/Simplex/Chat/Call.hs +++ b/src/Simplex/Chat/Call.hs @@ -225,4 +225,3 @@ instance FromField CallState where fromField = fromTextField_ decodeJSON $(J.deriveJSON defaultJSON ''RcvCallInvitation) - diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 3c0054ec1b..32f58b54b2 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -426,19 +426,19 @@ data ChatCommand | SetGroupTimedMessages GroupName (Maybe Int) | SetLocalDeviceName Text | ListRemoteHosts - | StartRemoteHost (Maybe (RemoteHostId, Bool)) -- ^ Start new or known remote host with optional multicast for known host - | SwitchRemoteHost (Maybe RemoteHostId) -- ^ Switch current remote host - | StopRemoteHost RHKey -- ^ Shut down a running session - | DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data + | StartRemoteHost (Maybe (RemoteHostId, Bool)) -- Start new or known remote host with optional multicast for known host + | SwitchRemoteHost (Maybe RemoteHostId) -- Switch current remote host + | StopRemoteHost RHKey -- Shut down a running session + | DeleteRemoteHost RemoteHostId -- Unregister remote host and remove its data | StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath} | GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile} - | ConnectRemoteCtrl RCSignedInvitation -- ^ Connect new or existing controller via OOB data - | FindKnownRemoteCtrl -- ^ Start listening for announcements from all existing controllers - | ConfirmRemoteCtrl RemoteCtrlId -- ^ Confirm the connection with found controller - | VerifyRemoteCtrlSession Text -- ^ Verify remote controller session + | ConnectRemoteCtrl RCSignedInvitation -- Connect new or existing controller via OOB data + | FindKnownRemoteCtrl -- Start listening for announcements from all existing controllers + | ConfirmRemoteCtrl RemoteCtrlId -- Confirm the connection with found controller + | VerifyRemoteCtrlSession Text -- Verify remote controller session | ListRemoteCtrls - | StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session - | DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a remote controller session + | StopRemoteCtrl -- Stop listening for announcements or terminate an active session + | DeleteRemoteCtrl RemoteCtrlId -- Remove all local data associated with a remote controller session | QuitChat | ShowVersion | DebugLocks @@ -1072,13 +1072,13 @@ throwDBError = throwError . ChatErrorDatabase -- TODO review errors, some of it can be covered by HTTP2 errors data RemoteHostError - = RHEMissing -- ^ No remote session matches this identifier - | RHEInactive -- ^ A session exists, but not active - | RHEBusy -- ^ A session is already running + = RHEMissing -- No remote session matches this identifier + | RHEInactive -- A session exists, but not active + | RHEBusy -- A session is already running | RHETimeout - | RHEBadState -- ^ Illegal state transition + | RHEBadState -- Illegal state transition | RHEBadVersion {appVersion :: AppVersion} - | RHELocalCommand -- ^ Command not allowed for remote execution + | RHELocalCommand -- Command not allowed for remote execution | RHEDisconnected {reason :: Text} -- TODO should be sent when disconnected? | RHEProtocolError RemoteProtocolError deriving (Show, Exception) @@ -1091,13 +1091,14 @@ data RemoteHostStopReason -- TODO review errors, some of it can be covered by HTTP2 errors data RemoteCtrlError - = RCEInactive -- ^ No session is running - | RCEBadState -- ^ A session is in a wrong state for the current operation - | RCEBusy -- ^ A session is already running + = RCEInactive -- No session is running + | RCEBadState -- A session is in a wrong state for the current operation + | RCEBusy -- A session is already running | RCETimeout - | RCENoKnownControllers -- ^ No previously-contacted controllers to discover - | RCEBadController -- ^ Attempting to confirm a found controller with another ID - | RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller + | RCENoKnownControllers -- No previously-contacted controllers to discover + | RCEBadController -- Attempting to confirm a found controller with another ID + | -- | A session disconnected by a controller + RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} | RCEBadInvitation | RCEBadVersion {appVersion :: AppVersion} | RCEHTTP2Error {http2Error :: Text} -- TODO currently not used @@ -1223,8 +1224,8 @@ toView event = do session <- asks remoteCtrlSession atomically $ readTVar session >>= \case - Just (_, RCSessionConnected {remoteOutputQ}) | allowRemoteEvent event -> - writeTBQueue remoteOutputQ event + Just (_, RCSessionConnected {remoteOutputQ}) + | allowRemoteEvent event -> writeTBQueue remoteOutputQ event -- TODO potentially, it should hold some events while connecting _ -> writeTBQueue localQ (Nothing, Nothing, event) diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index c5eb19f286..0706dda084 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -35,9 +35,9 @@ runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController runSimplexChat ChatOpts {maintenance} u cc chat | maintenance = wait =<< async (chat u cc) | otherwise = do - a1 <- runReaderT (startChatController True True True) cc - a2 <- async $ chat u cc - waitEither_ a1 a2 + a1 <- runReaderT (startChatController True True True) cc + a2 <- async $ chat u cc + waitEither_ a1 a2 sendChatCmdStr :: ChatController -> String -> IO ChatResponse sendChatCmdStr cc s = runReaderT (execChatCommand Nothing . encodeUtf8 $ T.pack s) cc diff --git a/src/Simplex/Chat/Files.hs b/src/Simplex/Chat/Files.hs index 845b237cdf..9c6d731dd7 100644 --- a/src/Simplex/Chat/Files.hs +++ b/src/Simplex/Chat/Files.hs @@ -6,8 +6,8 @@ module Simplex.Chat.Files where import Control.Monad.IO.Class import Simplex.Chat.Controller import Simplex.Messaging.Util (ifM) -import System.FilePath (splitExtensions, combine) -import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, getHomeDirectory, doesDirectoryExist) +import System.FilePath (combine, splitExtensions) +import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getHomeDirectory, getTemporaryDirectory) uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath uniqueCombine fPath fName = tryCombine (0 :: Int) diff --git a/src/Simplex/Chat/Markdown.hs b/src/Simplex/Chat/Markdown.hs index f992b4574a..6ee4898e3d 100644 --- a/src/Simplex/Chat/Markdown.hs +++ b/src/Simplex/Chat/Markdown.hs @@ -19,7 +19,7 @@ import qualified Data.Attoparsec.Text as A import Data.Char (isDigit, isPunctuation) import Data.Either (fromRight) import Data.Functor (($>)) -import Data.List (intercalate, foldl') +import Data.List (foldl', intercalate) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe, isNothing) @@ -85,16 +85,18 @@ newtype FormatColor = FormatColor Color deriving (Eq, Show) instance FromJSON FormatColor where - parseJSON = J.withText "FormatColor" $ fmap FormatColor . \case - "red" -> pure Red - "green" -> pure Green - "blue" -> pure Blue - "yellow" -> pure Yellow - "cyan" -> pure Cyan - "magenta" -> pure Magenta - "black" -> pure Black - "white" -> pure White - unexpected -> fail $ "unexpected FormatColor: " <> show unexpected + parseJSON = + J.withText "FormatColor" $ + fmap FormatColor . \case + "red" -> pure Red + "green" -> pure Green + "blue" -> pure Blue + "yellow" -> pure Yellow + "cyan" -> pure Cyan + "magenta" -> pure Magenta + "black" -> pure Black + "white" -> pure White + unexpected -> fail $ "unexpected FormatColor: " <> show unexpected instance ToJSON FormatColor where toJSON (FormatColor c) = case c of @@ -167,14 +169,14 @@ markdownP = mconcat <$> A.many' fragmentP md :: Char -> Format -> Text -> Markdown md c f s | T.null s || T.head s == ' ' || T.last s == ' ' = - unmarked $ c `T.cons` s `T.snoc` c + unmarked $ c `T.cons` s `T.snoc` c | otherwise = markdown f s secretP :: Parser Markdown secretP = secret <$> A.takeWhile (== '#') <*> A.takeTill (== '#') <*> A.takeWhile (== '#') secret :: Text -> Text -> Text -> Markdown secret b s a | T.null a || T.null s || T.head s == ' ' || T.last s == ' ' = - unmarked $ '#' `T.cons` ss + unmarked $ '#' `T.cons` ss | otherwise = markdown Secret $ T.init ss where ss = b <> s <> a @@ -215,9 +217,9 @@ markdownP = mconcat <$> A.many' fragmentP wordMD s | T.null s = unmarked s | isUri s = - let t = T.takeWhileEnd isPunctuation s - uri = uriMarkdown $ T.dropWhileEnd isPunctuation s - in if T.null t then uri else uri :|: unmarked t + let t = T.takeWhileEnd isPunctuation s + uri = uriMarkdown $ T.dropWhileEnd isPunctuation s + in if T.null t then uri else uri :|: unmarked t | isEmail s = markdown Email s | otherwise = unmarked s uriMarkdown s = case strDecode $ encodeUtf8 s of diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 9e4c309910..77c053fdf3 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -11,7 +11,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Messages where @@ -44,7 +43,7 @@ import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptSta import Simplex.Messaging.Crypto.File (CryptoFile (..)) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, parseAll, enumJSON, sumTypeJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON) import Simplex.Messaging.Protocol (MsgBody) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) @@ -345,7 +344,7 @@ contactTimedTTL Contact {mergedPreferences = ContactUserPreferences {timedMessag | forUser enabled && forContact enabled = Just ttl | otherwise = Nothing where - TimedMessagesPreference {ttl} = userPreference.preference + TimedMessagesPreference {ttl} = userPreference.preference groupTimedTTL :: GroupInfo -> Maybe (Maybe Int) groupTimedTTL GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}} diff --git a/src/Simplex/Chat/Messages/CIContent.hs b/src/Simplex/Chat/Messages/CIContent.hs index 8d5e2ddd8b..6b7e66bdb3 100644 --- a/src/Simplex/Chat/Messages/CIContent.hs +++ b/src/Simplex/Chat/Messages/CIContent.hs @@ -311,7 +311,7 @@ profileToText Profile {displayName, fullName} = displayName <> optionalFullName msgIntegrityError :: MsgErrorType -> Text msgIntegrityError = \case MsgSkipped fromId toId -> - "skipped message ID " <> tshow fromId + ("skipped message ID " <> tshow fromId) <> if fromId == toId then "" else ".." <> tshow toId MsgBadId msgId -> "unexpected message ID " <> tshow msgId MsgBadHash -> "incorrect message hash" diff --git a/src/Simplex/Chat/Messages/CIContent/Events.hs b/src/Simplex/Chat/Messages/CIContent/Events.hs index 42a5add1d6..16851859e3 100644 --- a/src/Simplex/Chat/Messages/CIContent/Events.hs +++ b/src/Simplex/Chat/Messages/CIContent/Events.hs @@ -46,9 +46,9 @@ data SndConnEvent | SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef} deriving (Show) -data RcvDirectEvent = - -- RDEProfileChanged {...} - RDEContactDeleted +data RcvDirectEvent + = -- RDEProfileChanged {...} + RDEContactDeleted deriving (Show) -- platform-specific JSON encoding (used in API) diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 9127102543..35e673e8e6 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -4,13 +4,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -fobject-code #-} module Simplex.Chat.Mobile where import Control.Concurrent.STM -import Control.Exception (catch, SomeException) +import Control.Exception (SomeException, catch) import Control.Monad.Except import Control.Monad.Reader import qualified Data.Aeson as J @@ -31,7 +30,7 @@ import Foreign.C.Types (CInt (..)) import Foreign.Ptr import Foreign.StablePtr import Foreign.Storable (poke) -import GHC.IO.Encoding (setLocaleEncoding, setFileSystemEncoding, setForeignEncoding) +import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding) import Simplex.Chat import Simplex.Chat.Controller import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList) @@ -219,7 +218,7 @@ chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do ExceptT $ (first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey confirmMigrations) `catch` (pure . checkDBError) - `catchAll` (pure . dbError) + `catchAll` (pure . dbError) where checkDBError e = case sqlError e of DB.ErrorNotADatabase -> Left $ DBMErrorNotADatabase dbFile @@ -233,7 +232,7 @@ chatCloseStore ChatController {chatStore, smpAgent} = handleErr $ do handleErr :: IO () -> IO String handleErr a = (a $> "") `catch` (pure . show @SomeException) - + chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString chatSendCmd cc = chatSendRemoteCmd cc Nothing diff --git a/src/Simplex/Chat/Mobile/Shared.hs b/src/Simplex/Chat/Mobile/Shared.hs index d0c5b0b86e..a4961c15f3 100644 --- a/src/Simplex/Chat/Mobile/Shared.hs +++ b/src/Simplex/Chat/Mobile/Shared.hs @@ -6,8 +6,8 @@ import qualified Data.ByteString as B import Data.ByteString.Internal (ByteString (..), memcpy) import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy.Internal as LB -import Foreign.C (CInt, CString) import Foreign +import Foreign.C (CInt, CString) type CJSONString = CString diff --git a/src/Simplex/Chat/Mobile/WebRTC.hs b/src/Simplex/Chat/Mobile/WebRTC.hs index 7840a069fa..422cfd5a8c 100644 --- a/src/Simplex/Chat/Mobile/WebRTC.hs +++ b/src/Simplex/Chat/Mobile/WebRTC.hs @@ -1,12 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} -module Simplex.Chat.Mobile.WebRTC ( - cChatEncryptMedia, - cChatDecryptMedia, - chatEncryptMedia, - chatDecryptMedia, - reservedSize, -) where +module Simplex.Chat.Mobile.WebRTC + ( cChatEncryptMedia, + cChatDecryptMedia, + chatEncryptMedia, + chatDecryptMedia, + reservedSize, + ) where import Control.Monad import Control.Monad.Except @@ -21,8 +21,8 @@ import Data.Either (fromLeft) import Data.Word (Word8) import Foreign.C (CInt, CString, newCAString) import Foreign.Ptr (Ptr) -import qualified Simplex.Messaging.Crypto as C import Simplex.Chat.Mobile.Shared +import qualified Simplex.Messaging.Crypto as C cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString cChatEncryptMedia = cTransformMedia chatEncryptMedia diff --git a/src/Simplex/Chat/ProfileGenerator.hs b/src/Simplex/Chat/ProfileGenerator.hs index 55a051ad80..95f5f16207 100644 --- a/src/Simplex/Chat/ProfileGenerator.hs +++ b/src/Simplex/Chat/ProfileGenerator.hs @@ -18,10 +18,10 @@ generateRandomProfile = do pickNoun adjective n | n == 0 = pick nouns | otherwise = do - noun <- pick nouns - if noun == adjective - then pickNoun adjective (n - 1) - else pure noun + noun <- pick nouns + if noun == adjective + then pickNoun adjective (n - 1) + else pure noun adjectives :: [Text] adjectives = diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index d955c4d259..3de7c03e86 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -13,7 +13,6 @@ {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Protocol where diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index e2137b35a2..98d7289f9c 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -97,24 +97,26 @@ discoveryTimeout = 60000000 getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient getRemoteHostClient rhId = do sessions <- asks remoteHostSessions - liftIOEither . atomically $ TM.lookup rhKey sessions >>= \case - Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient - Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState - Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing + liftIOEither . atomically $ + TM.lookup rhKey sessions >>= \case + Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient + Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState + Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing where rhKey = RHId rhId withRemoteHostSession :: ChatMonad m => RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a withRemoteHostSession rhKey sseq f = do sessions <- asks remoteHostSessions - r <- atomically $ - TM.lookup rhKey sessions >>= \case - Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing - Just (stateSeq, state) - | stateSeq /= sseq -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState - | otherwise -> case f state of - Right (r, newState) -> Right r <$ TM.insert rhKey (sseq, newState) sessions - Left ce -> pure $ Left ce + r <- + atomically $ + TM.lookup rhKey sessions >>= \case + Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing + Just (stateSeq, state) + | stateSeq /= sseq -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState + | otherwise -> case f state of + Right (r, newState) -> Right r <$ TM.insert rhKey (sseq, newState) sessions + Left ce -> pure $ Left ce liftEither r -- | Transition session state with a 'RHNew' ID to an assigned 'RemoteHostId' @@ -167,14 +169,16 @@ startRemoteHost rh_ = do when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding pure hostInfo handleConnectError :: ChatMonad m => RHKey -> SessionSeq -> m a -> m a - handleConnectError rhKey sessSeq action = action `catchChatError` \err -> do - logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err - cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey - throwError err + handleConnectError rhKey sessSeq action = + action `catchChatError` \err -> do + logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err + cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey + throwError err handleHostError :: ChatMonad m => SessionSeq -> TVar RHKey -> m () -> m () - handleHostError sessSeq rhKeyVar action = action `catchChatError` \err -> do - logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err - readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err)) + handleHostError sessSeq rhKeyVar action = + action `catchChatError` \err -> do + logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err + readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err)) waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m () waitForHostSession remoteHost_ rhKey sseq rhKeyVar vars = do (sessId, tls, vars') <- timeoutThrow (ChatErrorRemoteHost rhKey RHETimeout) 60000000 $ takeRCStep vars @@ -250,14 +254,15 @@ cancelRemoteHostSession :: ChatMonad m => Maybe (SessionSeq, RemoteHostStopReaso cancelRemoteHostSession handlerInfo_ rhKey = do sessions <- asks remoteHostSessions crh <- asks currentRemoteHost - deregistered <- atomically $ - TM.lookup rhKey sessions >>= \case - Nothing -> pure Nothing - Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler - Just (_, rhs) -> do - TM.delete rhKey sessions - modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH - pure $ Just rhs + deregistered <- + atomically $ + TM.lookup rhKey sessions >>= \case + Nothing -> pure Nothing + Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler + Just (_, rhs) -> do + TM.delete rhKey sessions + modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH + pure $ Just rhs forM_ deregistered $ \session -> do liftIO $ cancelRemoteHost handlingError session `catchAny` (logError . tshow) forM_ (snd <$> handlerInfo_) $ \rhStopReason -> @@ -401,9 +406,10 @@ findKnownRemoteCtrl = do (RCCtrlPairing {ctrlFingerprint}, inv@(RCVerifiedInvitation RCInvitation {app})) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings ctrlAppInfo_ <- (Just <$> parseCtrlAppInfo app) `catchChatError` const (pure Nothing) - rc <- withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case - Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl" - Just rc -> pure rc + rc <- + withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case + Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl" + Just rc -> pure rc atomically $ putTMVar foundCtrl (rc, inv) let compatible = isJust $ compatibleAppVersion hostAppVersionRange . appVersionRange =<< ctrlAppInfo_ toView CRRemoteCtrlFound {remoteCtrl = remoteCtrlInfo rc (Just RCSSearching), ctrlAppInfo_, appVersion = currentAppVersion, compatible} @@ -422,7 +428,7 @@ confirmRemoteCtrl rcId = do pure $ Right (sseq, action, foundCtrl) _ -> pure . Left $ ChatErrorRemoteCtrl RCEBadState uninterruptibleCancel listener - (RemoteCtrl{remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found + (RemoteCtrl {remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found unless (rcId == foundRcId) $ throwError $ ChatErrorRemoteCtrl RCEBadController connectRemoteCtrl verifiedInv sseq >>= \case (Nothing, _) -> throwChatError $ CEInternalError "connecting with a stored ctrl" @@ -647,10 +653,12 @@ handleCtrlError sseq mkReason name action = cancelActiveRemoteCtrl :: ChatMonad m => Maybe (SessionSeq, RemoteCtrlStopReason) -> m () cancelActiveRemoteCtrl handlerInfo_ = handleAny (logError . tshow) $ do var <- asks remoteCtrlSession - session_ <- atomically $ readTVar var >>= \case - Nothing -> pure Nothing - Just (oldSeq, _) | maybe False (/= oldSeq) (fst <$> handlerInfo_) -> pure Nothing - Just (_, s) -> Just s <$ writeTVar var Nothing + session_ <- + atomically $ + readTVar var >>= \case + Nothing -> pure Nothing + Just (oldSeq, _) | (maybe False ((oldSeq /=) . fst) handlerInfo_) -> pure Nothing + Just (_, s) -> Just s <$ writeTVar var Nothing forM_ session_ $ \session -> do liftIO $ cancelRemoteCtrl handlingError session forM_ (snd <$> handlerInfo_) $ \rcStopReason -> diff --git a/src/Simplex/Chat/Remote/AppVersion.hs b/src/Simplex/Chat/Remote/AppVersion.hs index e39a64b0a3..ad9f16e1be 100644 --- a/src/Simplex/Chat/Remote/AppVersion.hs +++ b/src/Simplex/Chat/Remote/AppVersion.hs @@ -11,7 +11,7 @@ module Simplex.Chat.Remote.AppVersion compatibleAppVersion, isAppCompatible, ) - where +where import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J diff --git a/src/Simplex/Chat/Remote/Multicast.hsc b/src/Simplex/Chat/Remote/Multicast.hsc index 3919b4423f..2303bd970d 100644 --- a/src/Simplex/Chat/Remote/Multicast.hsc +++ b/src/Simplex/Chat/Remote/Multicast.hsc @@ -6,10 +6,8 @@ import Network.Socket #include -{- | Toggle multicast group membership. - -NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups. --} +-- | Toggle multicast group membership. +-- NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups. setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ()) setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do #{poke struct ip_mreq, imr_multiaddr} mReqPtr group diff --git a/src/Simplex/Chat/Remote/Protocol.hs b/src/Simplex/Chat/Remote/Protocol.hs index c1acee1e0f..af4c7d33ec 100644 --- a/src/Simplex/Chat/Remote/Protocol.hs +++ b/src/Simplex/Chat/Remote/Protocol.hs @@ -6,8 +6,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module Simplex.Chat.Remote.Protocol where @@ -41,16 +41,16 @@ import Simplex.FileTransfer.Description (FileDigest (..)) import Simplex.Messaging.Agent.Client (agentDRG) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..)) -import Simplex.Messaging.Crypto.Lazy (LazyByteString) +import Simplex.Messaging.Crypto.Lazy (LazyByteString) import Simplex.Messaging.Encoding import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON, pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag) import Simplex.Messaging.Transport.Buffer (getBuffered) import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect) import Simplex.Messaging.Util (liftEitherError, liftEitherWith, liftError, tshow) -import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode) import Simplex.RemoteControl.Client (xrcpBlockSize) import qualified Simplex.RemoteControl.Client as RC +import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode) import System.FilePath (takeFileName, ()) import UnliftIO @@ -64,10 +64,10 @@ data RemoteCommand data RemoteResponse = RRChatResponse {chatResponse :: ChatResponse} - | RRChatEvent {chatEvent :: Maybe ChatResponse} -- ^ 'Nothing' on poll timeout + | RRChatEvent {chatEvent :: Maybe ChatResponse} -- 'Nothing' on poll timeout | RRFileStored {filePath :: String} | RRFile {fileSize :: Word32, fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest - | RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- ^ The protocol error happened on the server side + | RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- The protocol error happened on the server side deriving (Show) -- Force platform-independent encoding as the types aren't UI-visible @@ -126,7 +126,7 @@ remoteStoreFile c localPath fileName = do r -> badResponse r remoteGetFile :: RemoteHostClient -> FilePath -> RemoteFile -> ExceptT RemoteProtocolError IO () -remoteGetFile c@RemoteHostClient{encryption} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} = +remoteGetFile c@RemoteHostClient {encryption} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} = sendRemoteCommand c Nothing RCGetFile {file = rf} >>= \case (getChunk, RRFile {fileSize, fileDigest}) -> do -- TODO we could optimize by checking size and hash before receiving the file @@ -140,7 +140,7 @@ sendRemoteCommand' c attachment_ rc = snd <$> sendRemoteCommand c attachment_ rc sendRemoteCommand :: RemoteHostClient -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO (Int -> IO ByteString, RemoteResponse) sendRemoteCommand RemoteHostClient {httpClient, hostEncoding, encryption} file_ cmd = do - encFile_ <- mapM (prepareEncryptedFile encryption) file_ + encFile_ <- mapM (prepareEncryptedFile encryption) file_ req <- httpRequest encFile_ <$> encryptEncodeHTTP2Body encryption (J.encode cmd) HTTP2Response {response, respBody} <- liftEitherError (RPEHTTP2 . tshow) $ sendRequestDirect httpClient req Nothing (header, getNext) <- parseDecryptHTTP2Body encryption response respBody diff --git a/src/Simplex/Chat/Remote/Transport.hs b/src/Simplex/Chat/Remote/Transport.hs index c5ddfbdb8f..ccd10b328a 100644 --- a/src/Simplex/Chat/Remote/Transport.hs +++ b/src/Simplex/Chat/Remote/Transport.hs @@ -5,15 +5,15 @@ module Simplex.Chat.Remote.Transport where import Control.Monad import Control.Monad.Except -import Data.ByteString.Builder (Builder, byteString) import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder, byteString) import qualified Data.ByteString.Lazy as LB import Data.Word (Word32) -import Simplex.FileTransfer.Description (FileDigest (..)) import Simplex.Chat.Remote.Types +import Simplex.FileTransfer.Description (FileDigest (..)) +import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC -import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile) import Simplex.Messaging.Encoding import Simplex.Messaging.Util (liftEitherError, liftEitherWith) import Simplex.RemoteControl.Types (RCErrorType (..)) diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index 783a083e55..8411ceea0c 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -21,13 +21,13 @@ import Data.Text (Text) import Simplex.Chat.Remote.AppVersion import Simplex.Chat.Types (verificationCode) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.File (CryptoFile) import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON) +import Simplex.Messaging.Transport (TLS (..)) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) import Simplex.RemoteControl.Client import Simplex.RemoteControl.Types -import Simplex.Messaging.Crypto.File (CryptoFile) -import Simplex.Messaging.Transport (TLS (..)) data RemoteHostClient = RemoteHostClient { hostEncoding :: PlatformEncoding, @@ -48,13 +48,13 @@ data RemoteCrypto = RemoteCrypto data RemoteSignatures = RSSign - { idPrivKey :: C.PrivateKeyEd25519, - sessPrivKey :: C.PrivateKeyEd25519 - } + { idPrivKey :: C.PrivateKeyEd25519, + sessPrivKey :: C.PrivateKeyEd25519 + } | RSVerify - { idPubKey :: C.PublicKeyEd25519, - sessPubKey :: C.PublicKeyEd25519 - } + { idPubKey :: C.PublicKeyEd25519, + sessPubKey :: C.PublicKeyEd25519 + } type SessionSeq = Int @@ -71,12 +71,12 @@ data RemoteHostSession | RHSessionPendingConfirmation {sessionCode :: Text, tls :: TLS, rhPendingSession :: RHPendingSession} | RHSessionConfirmed {tls :: TLS, rhPendingSession :: RHPendingSession} | RHSessionConnected - { rchClient :: RCHostClient, - tls :: TLS, - rhClient :: RemoteHostClient, - pollAction :: Async (), - storePath :: FilePath - } + { rchClient :: RCHostClient, + tls :: TLS, + rhClient :: RemoteHostClient, + pollAction :: Async (), + storePath :: FilePath + } data RemoteHostSessionState = RHSStarting diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index 53c7d249a6..a72b23886f 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -4,7 +4,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeOperators #-} - {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Store.Connections @@ -25,11 +24,11 @@ import Data.Text (Text) import Data.Time.Clock (UTCTime (..)) import Database.SQLite.Simple (Only (..), (:.) (..)) import Database.SQLite.Simple.QQ (sql) +import Simplex.Chat.Protocol import Simplex.Chat.Store.Files import Simplex.Chat.Store.Groups import Simplex.Chat.Store.Profiles import Simplex.Chat.Store.Shared -import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Messaging.Agent.Protocol (ConnId) @@ -157,8 +156,9 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity) getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do - connId_ <- maybeFirstRow fromOnly $ - DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2) + connId_ <- + maybeFirstRow fromOnly $ + DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2) maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_ -- search connection for connection plan: @@ -167,21 +167,22 @@ getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = -- deleted connections are filtered out to allow re-connecting via same contact address getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity) getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do - connId_ <- maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT agent_conn_id FROM ( - SELECT - agent_conn_id, - (CASE WHEN contact_id IS NOT NULL THEN 1 ELSE 0 END) AS conn_ord - FROM connections - WHERE user_id = ? AND via_contact_uri_hash IN (?,?) AND conn_status != ? - ORDER BY conn_ord DESC, created_at DESC - LIMIT 1 - ) - |] - (userId, cReqHash1, cReqHash2, ConnDeleted) + connId_ <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT agent_conn_id FROM ( + SELECT + agent_conn_id, + (CASE WHEN contact_id IS NOT NULL THEN 1 ELSE 0 END) AS conn_ord + FROM connections + WHERE user_id = ? AND via_contact_uri_hash IN (?,?) AND conn_status != ? + ORDER BY conn_ord DESC, created_at DESC + LIMIT 1 + ) + |] + (userId, cReqHash1, cReqHash2, ConnDeleted) maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_ getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity]) diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index bfc29fcd29..67044d81a7 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -1,13 +1,12 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} - {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Store.Direct @@ -310,14 +309,14 @@ deleteUnusedProfile_ db userId profileId = updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact updateContactProfile db user@User {userId} c p' | displayName == newName = do - liftIO $ updateContactProfile_ db userId profileId p' - pure c {profile, mergedPreferences} + liftIO $ updateContactProfile_ db userId profileId p' + pure c {profile, mergedPreferences} | otherwise = - ExceptT . withLocalDisplayName db userId newName $ \ldn -> do - currentTs <- getCurrentTime - updateContactProfile_' db userId profileId p' currentTs - updateContact_ db userId contactId localDisplayName ldn currentTs - pure $ Right c {localDisplayName = ldn, profile, mergedPreferences} + ExceptT . withLocalDisplayName db userId newName $ \ldn -> do + currentTs <- getCurrentTime + updateContactProfile_' db userId profileId p' currentTs + updateContact_ db userId contactId localDisplayName ldn currentTs + pure $ Right c {localDisplayName = ldn, profile, mergedPreferences} where Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, userPreferences} = c Profile {displayName = newName, preferences} = p' @@ -784,10 +783,8 @@ updateConnectionStatus :: DB.Connection -> Connection -> ConnStatus -> IO () updateConnectionStatus db Connection {connId} connStatus = do currentTs <- getCurrentTime if connStatus == ConnReady - then - DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ?, conn_req_inv = NULL WHERE connection_id = ?" (connStatus, currentTs, connId) - else - DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId) + then DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ?, conn_req_inv = NULL WHERE connection_id = ?" (connStatus, currentTs, connId) + else DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId) updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO () updateContactSettings db User {userId} contactId ChatSettings {enableNtfs, sendRcpts, favorite} = @@ -816,4 +813,3 @@ resetContactConnInitiated db User {userId} Connection {connId} = do WHERE user_id = ? AND connection_id = ? |] (updatedAt, userId, connId) - diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs index a42e55a25c..8fe97896c8 100644 --- a/src/Simplex/Chat/Store/Files.hs +++ b/src/Simplex/Chat/Store/Files.hs @@ -109,7 +109,7 @@ import Simplex.Messaging.Protocol (SubscriptionMode (..)) getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer] getLiveSndFileTransfers db User {userId} = do - cutoffTs <- addUTCTime (- week) <$> getCurrentTime + cutoffTs <- addUTCTime (-week) <$> getCurrentTime fileIds :: [Int64] <- map fromOnly <$> DB.query @@ -132,7 +132,7 @@ getLiveSndFileTransfers db User {userId} = do getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer] getLiveRcvFileTransfers db user@User {userId} = do - cutoffTs <- addUTCTime (- week) <$> getCurrentTime + cutoffTs <- addUTCTime (-week) <$> getCurrentTime fileIds :: [Int64] <- map fromOnly <$> DB.query @@ -234,11 +234,12 @@ createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Conn updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> ExceptT StoreError IO () updateSndDirectFTDelivery _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName -updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = liftIO $ - DB.execute - db - "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" - (msgDeliveryId, connId, fileId) +updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = + liftIO $ + DB.execute + db + "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" + (msgDeliveryId, connId, fileId) updateSndGroupFTDelivery :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> Int64 -> IO () updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} FileTransferMeta {fileId} msgDeliveryId = @@ -724,7 +725,7 @@ removeFileCryptoArgs db fileId = do getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer] getRcvFilesToReceive db user@User {userId} = do - cutoffTs <- addUTCTime (- (2 * nominalDay)) <$> getCurrentTime + cutoffTs <- addUTCTime (-(2 * nominalDay)) <$> getCurrentTime fileIds :: [Int64] <- map fromOnly <$> DB.query @@ -768,20 +769,20 @@ createRcvFileChunk db RcvFileTransfer {fileId, fileInvitation = FileInvitation { pure $ case map fromOnly ns of [] | chunkNo == 1 -> - if chunkSize >= fileSize - then RcvChunkFinal - else RcvChunkOk + if chunkSize >= fileSize + then RcvChunkFinal + else RcvChunkOk | otherwise -> RcvChunkError n : _ | chunkNo == n -> RcvChunkDuplicate | chunkNo == n + 1 -> - let prevSize = n * chunkSize - in if prevSize >= fileSize - then RcvChunkError - else - if prevSize + chunkSize >= fileSize - then RcvChunkFinal - else RcvChunkOk + let prevSize = n * chunkSize + in if prevSize >= fileSize + then RcvChunkError + else + if prevSize + chunkSize >= fileSize + then RcvChunkFinal + else RcvChunkOk | otherwise -> RcvChunkError updatedRcvFileChunkStored :: DB.Connection -> RcvFileTransfer -> Integer -> IO () diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 673ef4d805..75df495615 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -2,14 +2,13 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedRecordDot #-} - {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Store.Groups @@ -122,7 +121,7 @@ import Crypto.Random (ChaChaDRG) import Data.Either (rights) import Data.Int (Int64) import Data.List (partition, sortOn) -import Data.Maybe (fromMaybe, isNothing, catMaybes, isJust) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) import Data.Ord (Down (..)) import Data.Text (Text) import Data.Time.Clock (UTCTime (..), getCurrentTime) @@ -446,39 +445,39 @@ createGroupInvitedViaLink void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs supportedChatVRange liftIO $ setViaGroupLinkHash db groupId connId (,) <$> getGroupInfo db user groupId <*> getGroupMemberById db user hostMemberId - where - insertGroup_ currentTs = ExceptT $ do - let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile - withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do - liftIO $ do - DB.execute - db - "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - "INSERT INTO groups (group_profile_id, local_display_name, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?)" - (profileId, localDisplayName, customUserProfileId, userId, True, currentTs, currentTs, currentTs) - insertedRowId db - insertHost_ currentTs groupId = ExceptT $ do - let fromMemberProfile = profileFromName fromMemberName - withLocalDisplayName db userId fromMemberName $ \localDisplayName -> runExceptT $ do - (_, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs - let MemberIdRole {memberId, memberRole} = fromMember - liftIO $ do - 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, GCHostMember, GSMemAccepted, fromInvitedBy userContactId IBUnknown) - :. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs) - ) - insertedRowId db + where + insertGroup_ currentTs = ExceptT $ do + let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile + withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do + liftIO $ do + DB.execute + db + "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + "INSERT INTO groups (group_profile_id, local_display_name, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?)" + (profileId, localDisplayName, customUserProfileId, userId, True, currentTs, currentTs, currentTs) + insertedRowId db + insertHost_ currentTs groupId = ExceptT $ do + let fromMemberProfile = profileFromName fromMemberName + withLocalDisplayName db userId fromMemberName $ \localDisplayName -> runExceptT $ do + (_, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs + let MemberIdRole {memberId, memberRole} = fromMember + liftIO $ do + 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, GCHostMember, GSMemAccepted, fromInvitedBy userContactId IBUnknown) + :. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs) + ) + insertedRowId db setViaGroupLinkHash :: DB.Connection -> GroupId -> Int64 -> IO () setViaGroupLinkHash db groupId connId = @@ -814,22 +813,22 @@ createAcceptedMember insertMember_ (MemberId memId) createdAt groupMemberId <- liftIO $ insertedRowId db pure (groupMemberId, MemberId memId) - where - JVersionRange (VersionRange minV maxV) = cReqChatVRange - insertMember_ memberId createdAt = - DB.execute - db - [sql| - INSERT INTO group_members - ( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id, - user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at, - peer_chat_min_version, peer_chat_max_version) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (groupId, memberId, memberRole, GCInviteeMember, GSMemAccepted, fromInvitedBy userContactId IBUser, groupMemberId' membership) - :. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, createdAt, createdAt) - :. (minV, maxV) - ) + where + JVersionRange (VersionRange minV maxV) = cReqChatVRange + insertMember_ memberId createdAt = + DB.execute + db + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id, + user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at, + peer_chat_min_version, peer_chat_max_version) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, GCInviteeMember, GSMemAccepted, fromInvitedBy userContactId IBUser, groupMemberId' membership) + :. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, createdAt, createdAt) + :. (minV, maxV) + ) createAcceptedMemberConnection :: DB.Connection -> User -> (CommandId, ConnId) -> UserContactRequest -> GroupMemberId -> SubscriptionMode -> IO () createAcceptedMemberConnection @@ -957,23 +956,24 @@ createNewMember_ :. (minV, maxV) ) groupMemberId <- insertedRowId db - pure GroupMember { - groupMemberId, - groupId, - memberId, - memberRole, - memberCategory, - memberStatus, - memberSettings = defaultMemberSettings, - invitedBy, - invitedByGroupMemberId = memInvitedByGroupMemberId, - localDisplayName, - memberProfile = toLocalProfile memberContactProfileId memberProfile "", - memberContactId, - memberContactProfileId, - activeConn, - memberChatVRange = JVersionRange mcvr - } + pure + GroupMember + { groupMemberId, + groupId, + memberId, + memberRole, + memberCategory, + memberStatus, + memberSettings = defaultMemberSettings, + invitedBy, + invitedByGroupMemberId = memInvitedByGroupMemberId, + localDisplayName, + memberProfile = toLocalProfile memberContactProfileId memberProfile "", + memberContactId, + memberContactProfileId, + activeConn, + memberChatVRange = JVersionRange mcvr + } checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId) checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} = @@ -1104,41 +1104,41 @@ getForwardIntroducedMembers :: DB.Connection -> User -> GroupMember -> Bool -> I getForwardIntroducedMembers db user invitee highlyAvailable = do memberIds <- map fromOnly <$> query filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds - where - mId = groupMemberId' invitee - query - | highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected) - | otherwise = - DB.query - db - (q <> " AND intro_chat_protocol_version >= ?") - (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange) - q = - [sql| - SELECT re_group_member_id - FROM group_member_intros - WHERE to_group_member_id = ? AND intro_status NOT IN (?,?,?) - |] + where + mId = groupMemberId' invitee + query + | highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected) + | otherwise = + DB.query + db + (q <> " AND intro_chat_protocol_version >= ?") + (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange) + q = + [sql| + SELECT re_group_member_id + FROM group_member_intros + WHERE to_group_member_id = ? AND intro_status NOT IN (?,?,?) + |] getForwardInvitedMembers :: DB.Connection -> User -> GroupMember -> Bool -> IO [GroupMember] getForwardInvitedMembers db user forwardMember highlyAvailable = do memberIds <- map fromOnly <$> query filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds - where - mId = groupMemberId' forwardMember - query - | highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected) - | otherwise = - DB.query - db - (q <> " AND intro_chat_protocol_version >= ?") - (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange) - q = - [sql| - SELECT to_group_member_id - FROM group_member_intros - WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?) - |] + where + mId = groupMemberId' forwardMember + query + | highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected) + | otherwise = + DB.query + db + (q <> " AND intro_chat_protocol_version >= ?") + (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange) + q = + [sql| + SELECT to_group_member_id + FROM group_member_intros + WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?) + |] createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do @@ -1263,15 +1263,15 @@ getViaGroupContact db user@User {userId} GroupMember {groupMemberId} = do updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, description, image, groupPreferences} | displayName == newName = liftIO $ do - currentTs <- getCurrentTime - updateGroupProfile_ currentTs - pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences} - | otherwise = - ExceptT . withLocalDisplayName db userId newName $ \ldn -> do currentTs <- getCurrentTime updateGroupProfile_ currentTs - updateGroup_ ldn currentTs - pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences} + pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences} + | otherwise = + ExceptT . withLocalDisplayName db userId newName $ \ldn -> do + currentTs <- getCurrentTime + updateGroupProfile_ currentTs + updateGroup_ ldn currentTs + pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences} where fullGroupPreferences = mergeGroupPreferences groupPreferences updateGroupProfile_ currentTs = @@ -1317,31 +1317,33 @@ getGroupInfo db User {userId, userContactId} groupId = getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo) getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do - groupId_ <- maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT group_id - FROM user_contact_links - WHERE user_id = ? AND conn_req_contact IN (?,?) - |] - (userId, cReqSchema1, cReqSchema2) + groupId_ <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT group_id + FROM user_contact_links + WHERE user_id = ? AND conn_req_contact IN (?,?) + |] + (userId, cReqSchema1, cReqSchema2) maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_ getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo) getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do - groupId_ <- maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT g.group_id - FROM groups g - JOIN group_members mu ON mu.group_id = g.group_id - WHERE g.user_id = ? AND g.via_group_link_uri_hash IN (?,?) - AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?) - LIMIT 1 - |] - (userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) + groupId_ <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT g.group_id + FROM groups g + JOIN group_members mu ON mu.group_id = g.group_id + WHERE g.user_id = ? AND g.via_group_link_uri_hash IN (?,?) + AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?) + LIMIT 1 + |] + (userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_ getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId @@ -1935,18 +1937,18 @@ createMemberContactConn_ updateMemberProfile :: DB.Connection -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember updateMemberProfile db User {userId} m p' | displayName == newName = do - liftIO $ updateContactProfile_ db userId profileId p' - pure m {memberProfile = profile} + liftIO $ updateContactProfile_ db userId profileId p' + pure m {memberProfile = profile} | otherwise = - ExceptT . withLocalDisplayName db userId newName $ \ldn -> do - currentTs <- getCurrentTime - updateContactProfile_' db userId profileId p' currentTs - DB.execute - db - "UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?" - (ldn, currentTs, userId, groupMemberId) - DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) - pure $ Right m {localDisplayName = ldn, memberProfile = profile} + ExceptT . withLocalDisplayName db userId newName $ \ldn -> do + currentTs <- getCurrentTime + updateContactProfile_' db userId profileId p' currentTs + DB.execute + db + "UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?" + (ldn, currentTs, userId, groupMemberId) + DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) + pure $ Right m {localDisplayName = ldn, memberProfile = profile} where GroupMember {groupMemberId, localDisplayName, memberProfile = LocalProfile {profileId, displayName, localAlias}} = m Profile {displayName = newName} = p' diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index b6d455fe86..82a5114d9a 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -10,7 +10,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} - {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Store.Messages @@ -199,40 +198,41 @@ createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMs createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs pure msg -createNewRcvMessage :: forall e. (MsgEncodingI e) => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage -createNewRcvMessage db connOrGroupId NewMessage{chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember = +createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage +createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember = case connOrGroupId of ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing GroupId groupId -> case sharedMsgId_ of - Just sharedMsgId -> liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case - Just (duplAuthorId, duplFwdMemberId) -> - throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId - Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId + Just sharedMsgId -> + liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case + Just (duplAuthorId, duplFwdMemberId) -> + throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId + Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId - where - duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId)) - duplicateGroupMsgMemberIds groupId sharedMsgId = - maybeFirstRow id - $ DB.query + where + duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId)) + duplicateGroupMsgMemberIds groupId sharedMsgId = + maybeFirstRow id $ + DB.query + db + [sql| + SELECT author_group_member_id, forwarded_by_group_member_id + FROM messages + WHERE group_id = ? AND shared_msg_id = ? LIMIT 1 + |] + (groupId, sharedMsgId) + insertRcvMsg connId_ groupId_ = do + currentTs <- getCurrentTime + DB.execute db [sql| - SELECT author_group_member_id, forwarded_by_group_member_id - FROM messages - WHERE group_id = ? AND shared_msg_id = ? LIMIT 1 + INSERT INTO messages + (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id) + VALUES (?,?,?,?,?,?,?,?,?,?) |] - (groupId, sharedMsgId) - insertRcvMsg connId_ groupId_ = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - INSERT INTO messages - (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id) - VALUES (?,?,?,?,?,?,?,?,?,?) - |] - (MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember) - msgId <- insertedRowId db - pure RcvMessage{msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember} + (MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember) + msgId <- insertedRowId db + pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember} createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO () createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do @@ -1802,22 +1802,22 @@ getDirectReactions db ct itemSharedMId sent = setDirectReaction :: DB.Connection -> Contact -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs | add = - DB.execute - db - [sql| - INSERT INTO chat_item_reactions - (contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) - VALUES (?,?,?,?,?,?) - |] - (contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs) + DB.execute + db + [sql| + INSERT INTO chat_item_reactions + (contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) + VALUES (?,?,?,?,?,?) + |] + (contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs) | otherwise = - DB.execute - db - [sql| - DELETE FROM chat_item_reactions - WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ? - |] - (contactId' ct, itemSharedMId, sent, reaction) + DB.execute + db + [sql| + DELETE FROM chat_item_reactions + WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ? + |] + (contactId' ct, itemSharedMId, sent, reaction) getGroupReactions :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> IO [MsgReaction] getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent = @@ -1834,22 +1834,22 @@ getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent = setGroupReaction :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reaction add msgId reactionTs | add = - DB.execute - db - [sql| - INSERT INTO chat_item_reactions - (group_id, group_member_id, item_member_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) - VALUES (?,?,?,?,?,?,?,?) - |] - (groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs) + DB.execute + db + [sql| + INSERT INTO chat_item_reactions + (group_id, group_member_id, item_member_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) + VALUES (?,?,?,?,?,?,?,?) + |] + (groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs) | otherwise = - DB.execute - db - [sql| - DELETE FROM chat_item_reactions - WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ? - |] - (groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction) + DB.execute + db + [sql| + DELETE FROM chat_item_reactions + WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ? + |] + (groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction) getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)] getTimedItems db User {userId} startTimedThreadCutoff = diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 611faf90c6..c51a3e4997 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -8,7 +8,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} - {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Store.Profiles @@ -66,9 +65,9 @@ import Control.Monad.IO.Class import qualified Data.Aeson.TH as J import Data.Functor (($>)) import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe) -import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (UTCTime (..), getCurrentTime) @@ -89,7 +88,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode) import Simplex.Messaging.Transport.Client (TransportHost) -import Simplex.Messaging.Util (safeDecodeUtf8, eitherToMaybe) +import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8) createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime @@ -248,19 +247,19 @@ updateUserGroupReceipts db User {userId} UserMsgReceiptSettings {enable, clearOv updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User updateUserProfile db user p' | displayName == newName = do - liftIO $ updateContactProfile_ db userId profileId p' - pure user {profile, fullPreferences} + liftIO $ updateContactProfile_ db userId profileId p' + pure user {profile, fullPreferences} | otherwise = - checkConstraint SEDuplicateName . liftIO $ do - currentTs <- getCurrentTime - DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId) - DB.execute - 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 profileId p' currentTs - updateContact_ db userId userContactId localDisplayName newName currentTs - pure user {localDisplayName = newName, profile, fullPreferences} + checkConstraint SEDuplicateName . liftIO $ do + currentTs <- getCurrentTime + DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId) + DB.execute + 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 profileId p' currentTs + updateContact_ db userId userContactId localDisplayName newName currentTs + pure user {localDisplayName = newName, profile, fullPreferences} where User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} = user Profile {displayName = newName, preferences} = p' @@ -457,17 +456,18 @@ getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) = getContactWithoutConnViaAddress :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact) getContactWithoutConnViaAddress db user@User {userId} (cReqSchema1, cReqSchema2) = do - ctId_ <- maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT ct.contact_id - FROM contacts ct - JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id - LEFT JOIN connections c ON c.contact_id = ct.contact_id - WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL - |] - (userId, cReqSchema1, cReqSchema2) + ctId_ <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT ct.contact_id + FROM contacts ct + JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id + LEFT JOIN connections c ON c.contact_id = ct.contact_id + WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL + |] + (userId, cReqSchema1, cReqSchema2) maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db user) ctId_ updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index af8220d8ea..93c3ab197c 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -101,7 +101,7 @@ data StoreError | SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId} | SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, authorGroupMemberId :: Maybe GroupMemberId, forwardedByGroupMemberId :: Maybe GroupMemberId} | SERemoteHostNotFound {remoteHostId :: RemoteHostId} - | SERemoteHostUnknown -- ^ attempting to store KnownHost without a known fingerprint + | SERemoteHostUnknown -- attempting to store KnownHost without a known fingerprint | SERemoteHostDuplicateCA | SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId} | SERemoteCtrlDuplicateCA diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 085f6b0936..7b96abc1ce 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -194,19 +194,19 @@ receiveFromTTY cc@ChatController {inputQ, currentUser, currentRemoteHost, chatSt case lm_ of Just LiveMessage {chatName} | live -> do - writeTVar termState ts' {previousInput} - writeTBQueue inputQ $ "/live " <> chatNameStr chatName + writeTVar termState ts' {previousInput} + writeTBQueue inputQ $ "/live " <> chatNameStr chatName | otherwise -> - writeTVar termState ts' {inputPrompt = "> ", previousInput} + writeTVar termState ts' {inputPrompt = "> ", previousInput} where previousInput = chatNameStr chatName <> " " <> s _ | live -> when (isSend s) $ do - writeTVar termState ts' {previousInput = s} - writeTBQueue inputQ $ "/live " <> s + writeTVar termState ts' {previousInput = s} + writeTBQueue inputQ $ "/live " <> s | otherwise -> do - writeTVar termState ts' {inputPrompt = "> ", previousInput = s} - writeTBQueue inputQ s + writeTVar termState ts' {inputPrompt = "> ", previousInput = s} + writeTBQueue inputQ s pure $ (s,) <$> lm_ where isSend s = length s > 1 && (head s == '@' || head s == '#') @@ -343,9 +343,9 @@ updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputStr charsWithContact cs | live = cs | null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" && cs /= "+" && cs /= "-" = - chatPrefix <> cs + chatPrefix <> cs | (s == ">" || s == "\\" || s == "!") && cs == " " = - cs <> chatPrefix + cs <> chatPrefix | otherwise = cs insertChars = ts' . if p >= length s then append else insert append cs = let s' = s <> cs in (s', length s') @@ -381,13 +381,13 @@ updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputStr prevWordPos | p == 0 || null s = p | otherwise = - let before = take p s - beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before - in max 0 $ p - length before + length beforeWord + let before = take p s + beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before + in max 0 $ p - length before + length beforeWord nextWordPos | p >= length s || null s = p | otherwise = - let after = drop p s - afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after - in min (length s) $ p + length after - length afterWord + let after = drop p s + afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after + in min (length s) $ p + length after - length afterWord ts' (s', p') = ts {inputString = s', inputPosition = p', autoComplete = acp {acTabPressed = False}} diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index 0adb4999a4..4fa6931f57 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -24,7 +24,7 @@ import Simplex.Chat (execChatCommand, processChatCommand) import Simplex.Chat.Controller import Simplex.Chat.Markdown import Simplex.Chat.Messages -import Simplex.Chat.Messages.CIContent (CIContent(..), SMsgDirection (..)) +import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..)) import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgContent (..), msgContentText) import Simplex.Chat.Remote.Types (RHKey (..), RemoteHostId, RemoteHostInfo (..), RemoteHostSession (..)) @@ -167,9 +167,10 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc _ -> pure () logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s - getRemoteUser rhId = runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case - CRActiveUser {user} -> updateRemoteUser ct user rhId - cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr + getRemoteUser rhId = + runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case + CRActiveUser {user} -> updateRemoteUser ct user rhId + cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct) responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO () @@ -326,9 +327,9 @@ updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessag clearLines from till | from >= till = return () | otherwise = do - setCursorPosition $ Position {row = from, col = 0} - eraseInLine EraseForward - clearLines (from + 1) till + setCursorPosition $ Position {row = from, col = 0} + eraseInLine EraseForward + clearLines (from + 1) till inputHeight :: TerminalState -> Int inputHeight ts = length (autoCompletePrefix ts <> inputPrompt ts <> inputString ts) `div` width + 1 autoCompletePrefix :: TerminalState -> String diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index d96bddb8b7..3f66aa3212 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -17,7 +17,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} - {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use newtype instead of data" #-} @@ -40,7 +39,7 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime) import Data.Typeable (Typeable) import Database.SQLite.Simple (ResultError (..), SQLData (..)) -import Database.SQLite.Simple.FromField (returnError, FromField(..)) +import Database.SQLite.Simple.FromField (FromField (..), returnError) import Database.SQLite.Simple.Internal (Field (..)) import Database.SQLite.Simple.Ok import Database.SQLite.Simple.ToField (ToField (..)) @@ -50,7 +49,7 @@ import Simplex.FileTransfer.Description (FileDigest) import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId) import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON, enumJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON) import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI) import Simplex.Messaging.Util ((<$?>)) import Simplex.Messaging.Version @@ -498,7 +497,7 @@ data LocalProfile = LocalProfile deriving (Eq, Show) localProfileId :: LocalProfile -> ProfileId -localProfileId LocalProfile{profileId} = profileId +localProfileId LocalProfile {profileId} = profileId toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile toLocalProfile profileId Profile {displayName, fullName, image, contactLink, preferences} localAlias = diff --git a/src/Simplex/Chat/Types/Preferences.hs b/src/Simplex/Chat/Types/Preferences.hs index da13da742f..46ac4d2ab7 100644 --- a/src/Simplex/Chat/Types/Preferences.hs +++ b/src/Simplex/Chat/Types/Preferences.hs @@ -14,7 +14,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} - {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} diff --git a/src/Simplex/Chat/Types/Util.hs b/src/Simplex/Chat/Types/Util.hs index fffdd24b9e..0f41931acf 100644 --- a/src/Simplex/Chat/Types/Util.hs +++ b/src/Simplex/Chat/Types/Util.hs @@ -2,7 +2,7 @@ module Simplex.Chat.Types.Util where -import Data.Aeson (ToJSON, FromJSON) +import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 4dbda6da69..c49076d0cb 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -14,8 +14,8 @@ module Simplex.Chat.View where import qualified Data.Aeson as J import qualified Data.Aeson.TH as JQ -import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isSpace, toUpper) import Data.Function (on) @@ -44,8 +44,8 @@ import Simplex.Chat.Markdown import Simplex.Chat.Messages hiding (NewChatItem (..)) import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol +import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange) import Simplex.Chat.Remote.Types -import Simplex.Chat.Remote.AppVersion (pattern AppVersionRange, AppVersion (..)) import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..)) import Simplex.Chat.Styled import Simplex.Chat.Types @@ -308,10 +308,10 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe <> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_ CRRemoteCtrlList cs -> viewRemoteCtrls cs CRRemoteCtrlFound {remoteCtrl = RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName}, ctrlAppInfo_, appVersion, compatible} -> - [ "remote controller " <> sShow remoteCtrlId <> " found: " + [ ("remote controller " <> sShow remoteCtrlId <> " found: ") <> maybe (deviceName <> "not compatible") (\info -> viewRemoteCtrl info appVersion compatible) ctrlAppInfo_ ] - <> [ "use " <> highlight ("/confirm remote ctrl " <> show remoteCtrlId) <> " to connect" | isJust ctrlAppInfo_ && compatible] + <> ["use " <> highlight ("/confirm remote ctrl " <> show remoteCtrlId) <> " to connect" | isJust ctrlAppInfo_ && compatible] where deviceName = if T.null ctrlDeviceName then "" else plain ctrlDeviceName <> ", " CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion} -> @@ -511,42 +511,43 @@ viewChats ts tz = concatMap chatPreview . reverse viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString] viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, content, quotedItem, file} doShow ts tz = - withGroupMsgForwarded . withItemDeleted <$> (case chat of - DirectChat c -> case chatDir of - CIDirectSnd -> case content of - CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc - CISndGroupEvent {} -> showSndItemProhibited to - _ -> showSndItem to - where - to = ttyToContact' c - CIDirectRcv -> case content of - CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc - CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta - CIRcvGroupEvent {} -> showRcvItemProhibited from - _ -> showRcvItem from - where - from = ttyFromContact c - where - quote = maybe [] (directQuote chatDir) quotedItem - GroupChat g -> case chatDir of - CIGroupSnd -> case content of - CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc - CISndGroupInvitation {} -> showSndItemProhibited to - _ -> showSndItem to - where - to = ttyToGroup g - CIGroupRcv m -> case content of - CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc - CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta - CIRcvGroupInvitation {} -> showRcvItemProhibited from - CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False - _ -> showRcvItem from - where - from = ttyFromGroup g m - where - quote = maybe [] (groupQuote g) quotedItem - _ -> []) + withGroupMsgForwarded . withItemDeleted <$> viewCI where + viewCI = case chat of + DirectChat c -> case chatDir of + CIDirectSnd -> case content of + CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc + CISndGroupEvent {} -> showSndItemProhibited to + _ -> showSndItem to + where + to = ttyToContact' c + CIDirectRcv -> case content of + CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc + CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta + CIRcvGroupEvent {} -> showRcvItemProhibited from + _ -> showRcvItem from + where + from = ttyFromContact c + where + quote = maybe [] (directQuote chatDir) quotedItem + GroupChat g -> case chatDir of + CIGroupSnd -> case content of + CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc + CISndGroupInvitation {} -> showSndItemProhibited to + _ -> showSndItem to + where + to = ttyToGroup g + CIGroupRcv m -> case content of + CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc + CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta + CIRcvGroupInvitation {} -> showRcvItemProhibited from + CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False + _ -> showRcvItem from + where + from = ttyFromGroup g m + where + quote = maybe [] (groupQuote g) quotedItem + _ -> [] withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of Nothing -> item Just t -> item <> styled (colored Red) (" [" <> t <> "]") @@ -667,15 +668,15 @@ viewItemDelete chat ci@ChatItem {chatDir, meta, content = deletedContent} toItem | timed = [plain ("timed message deleted: " <> T.unpack (ciContentToText deletedContent)) | testView] | byUser = [plain $ "message " <> T.unpack (fromMaybe "deleted" deletedText_)] -- deletedText_ Nothing should be impossible here | otherwise = case chat of - DirectChat c -> case (chatDir, deletedContent) of - (CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c deletedText_) [] mc ts tz meta + DirectChat c -> case (chatDir, deletedContent) of + (CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c deletedText_) [] mc ts tz meta + _ -> prohibited + GroupChat g -> case ciMsgContent deletedContent of + Just mc -> + let m = chatItemMember g ci + in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta + _ -> prohibited _ -> prohibited - GroupChat g -> case ciMsgContent deletedContent of - Just mc -> - let m = chatItemMember g ci - in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta - _ -> prohibited - _ -> prohibited where deletedText_ :: Maybe Text deletedText_ = case toItem of @@ -788,7 +789,7 @@ viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of viewContactsList :: [Contact] -> [StyledString] viewContactsList = let getLDN :: Contact -> ContactName - getLDN Contact{localDisplayName} = localDisplayName + getLDN Contact {localDisplayName} = localDisplayName ldn = T.toLower . getLDN in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn where @@ -823,8 +824,8 @@ simplexChatContact (CRContactUri crData) = CRContactUri crData {crScheme = simpl autoAcceptStatus_ :: Maybe AutoAccept -> [StyledString] autoAcceptStatus_ = \case Just AutoAccept {acceptIncognito, autoReply} -> - ("auto_accept on" <> if acceptIncognito then ", incognito" else "") : - maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply + ("auto_accept on" <> if acceptIncognito then ", incognito" else "") + : maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply _ -> ["auto_accept off"] groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> GroupMemberRole -> [StyledString] @@ -907,10 +908,10 @@ viewJoinedGroupMember g m = viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString] viewReceivedGroupInvitation g c role = - ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role) : - case incognitoMembershipProfile g of - Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)] - Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"] + ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role) + : case incognitoMembershipProfile g of + Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)] + Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"] groupPreserved :: GroupInfo -> [StyledString] groupPreserved g = ["use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the group"] @@ -996,13 +997,13 @@ viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs GSMemRemoved -> delete "you are removed" GSMemLeft -> delete "you left" GSMemGroupDeleted -> delete "group deleted" - _ -> " (" <> memberCount <> - case enableNtfs of - MFAll -> ")" - MFNone -> ", muted, " <> unmute - MFMentions -> ", mentions only, " <> unmute + _ -> " (" <> memberCount <> viewNtf <> ")" where - unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")" + viewNtf = case enableNtfs of + MFAll -> "" + MFNone -> ", muted, " <> unmute + MFMentions -> ", mentions only, " <> unmute + unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g) delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")" memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s" @@ -1028,9 +1029,9 @@ viewContactsMerged c1 c2 ct' = viewContactAndMemberAssociated :: Contact -> GroupInfo -> GroupMember -> Contact -> [StyledString] viewContactAndMemberAssociated ct g m ct' = - [ "contact and member are merged: " <> ttyContact' ct <> ", " <> ttyGroup' g <> " " <> ttyMember m, - "use " <> ttyToContact' ct' <> highlight' "" <> " to send messages" - ] + [ "contact and member are merged: " <> ttyContact' ct <> ", " <> ttyGroup' g <> " " <> ttyMember m, + "use " <> ttyToContact' ct' <> highlight' "" <> " to send messages" + ] viewUserProfile :: Profile -> [StyledString] viewUserProfile Profile {displayName, fullName} = @@ -1396,14 +1397,14 @@ viewContactUpdated Contact {localDisplayName = n', profile = LocalProfile {fullName = fullName', contactLink = contactLink'}} | n == n' && fullName == fullName' && contactLink == contactLink' = [] | n == n' && fullName == fullName' = - if isNothing contactLink' - then [ttyContact n <> " removed contact address"] - else [ttyContact n <> " set new contact address, use " <> highlight ("/info " <> n) <> " to view"] + if isNothing contactLink' + then [ttyContact n <> " removed contact address"] + else [ttyContact n <> " set new contact address, use " <> highlight ("/info " <> n) <> " to view"] | n == n' = ["contact " <> ttyContact n <> fullNameUpdate] | otherwise = - [ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName', - "use " <> ttyToContact n' <> highlight' "" <> " to send messages" - ] + [ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName', + "use " <> ttyToContact n' <> highlight' "" <> " to send messages" + ] where fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName' @@ -1428,11 +1429,11 @@ receivedWithTime_ ts tz from quote CIMeta {itemId, itemTs, itemEdited, itemDelet live | itemEdited || isJust itemDeleted = "" | otherwise = case itemLive of - Just True - | updated -> ttyFrom "[LIVE] " - | otherwise -> ttyFrom "[LIVE started]" <> " use " <> highlight' ("/show [on/off/" <> show itemId <> "] ") - Just False -> ttyFrom "[LIVE ended] " - _ -> "" + Just True + | updated -> ttyFrom "[LIVE] " + | otherwise -> ttyFrom "[LIVE started]" <> " use " <> highlight' ("/show [on/off/" <> show itemId <> "] ") + Just False -> ttyFrom "[LIVE ended] " + _ -> "" ttyMsgTime :: CurrentTime -> TimeZone -> UTCTime -> StyledString ttyMsgTime now tz time = @@ -1458,9 +1459,9 @@ viewSentMessage to quote mc ts tz meta@CIMeta {itemEdited, itemDeleted, itemLive live | itemEdited || isJust itemDeleted = "" | otherwise = case itemLive of - Just True -> ttyTo "[LIVE started] " - Just False -> ttyTo "[LIVE] " - _ -> "" + Just True -> ttyTo "[LIVE started] " + Just False -> ttyTo "[LIVE] " + _ -> "" viewSentBroadcast :: MsgContent -> Int -> Int -> CurrentTime -> TimeZone -> UTCTime -> [StyledString] viewSentBroadcast mc s f ts tz time = prependFirst (highlight' "/feed" <> " (" <> sShow s <> failures <> ") " <> ttyMsgTime ts tz time <> " ") (ttyMsgContent mc) @@ -1551,11 +1552,12 @@ receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIF cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"] cfArgsStr _ = [] getRemoteFileStr = case hu of - (Just rhId, Just User {userId}) | status == "completed" -> - [ "File received to connected remote host " <> sShow rhId, - "To download to this device use:", - highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f})) - ] + (Just rhId, Just User {userId}) + | status == "completed" -> + [ "File received to connected remote host " <> sShow rhId, + "To download to this device use:", + highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f})) + ] _ -> [] receivingFile_' _ _ status _ = [plain status <> " receiving file"] -- shouldn't happen @@ -1591,7 +1593,7 @@ viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksN [recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus] recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses fs :: SndFileTransfer -> FileStatus - fs SndFileTransfer{fileStatus} = fileStatus + fs SndFileTransfer {fileStatus} = fileStatus recipientsTransferStatus [] = [] recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts] where @@ -1763,9 +1765,10 @@ viewChatError logLevel testView = \case CEEmptyUserPassword _ -> ["user password is required"] CEUserAlreadyHidden _ -> ["user is already hidden"] CEUserNotHidden _ -> ["user is not hidden"] - CEInvalidDisplayName {displayName, validName} -> map plain $ - ["invalid display name: " <> viewName displayName] - <> ["you could use this one: " <> viewName validName | not (T.null validName)] + CEInvalidDisplayName {displayName, validName} -> + map plain $ + ["invalid display name: " <> viewName displayName] + <> ["you could use this one: " <> viewName validName | not (T.null validName)] CEChatNotStarted -> ["error: chat not started"] CEChatNotStopped -> ["error: chat not stopped"] CEChatStoreChanged -> ["error: chat store changed, please restart chat"] diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index b75fa38419..53101cd073 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -5,7 +5,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module ChatClient where @@ -276,7 +275,7 @@ getTermLine cc = Just s -> do -- remove condition to always echo virtual terminal when (printOutput cc) $ do - -- when True $ do + -- when True $ do name <- userName cc putStrLn $ name <> ": " <> s pure s diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 1a133fd8e3..d7c8ff4586 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -259,7 +259,6 @@ testPlanInvitationLinkOk = bob ##> ("/_connect plan 1 " <> inv) bob <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection - alice <##> bob testPlanInvitationLinkOwn :: HasCallStack => FilePath -> IO () @@ -283,7 +282,6 @@ testPlanInvitationLinkOwn tmp = alice ##> ("/_connect plan 1 " <> inv) alice <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection - alice @@@ [("@alice_1", lastChatFeature), ("@alice_2", lastChatFeature)] alice `send` "@alice_2 hi" alice @@ -1213,31 +1211,34 @@ testMuteGroup = cath `send` "> #team (hello) hello too!" cath <# "#team > bob hello" cath <## " hello too!" - concurrently_ - (bob > bob hello" - alice <## " hello too!" - ) + concurrentlyN_ + [ (bob > bob hello" + alice <## " hello too!" + ] bob ##> "/unmute mentions #team" bob <## "ok" alice `send` "> #team @bob (hello) hey bob!" alice <# "#team > bob hello" alice <## " hey bob!" - concurrently_ - ( do bob <# "#team alice> > bob hello" - bob <## " hey bob!" - ) - ( do cath <# "#team alice> > bob hello" - cath <## " hey bob!" - ) + concurrentlyN_ + [ do + bob <# "#team alice> > bob hello" + bob <## " hey bob!", + do + cath <# "#team alice> > bob hello" + cath <## " hey bob!" + ] alice `send` "> #team @cath (hello) hey cath!" alice <# "#team > cath hello too!" alice <## " hey cath!" - concurrently_ - (bob > cath hello too!" - cath <## " hey cath!" - ) + concurrentlyN_ + [ (bob > cath hello too!" + cath <## " hey cath!" + ] bob ##> "/gs" bob <## "#team (3 members, mentions only, you can /unmute #team)" bob ##> "/unmute #team" diff --git a/tests/ChatTests/Files.hs b/tests/ChatTests/Files.hs index 03a5d6acfb..4396a900dc 100644 --- a/tests/ChatTests/Files.hs +++ b/tests/ChatTests/Files.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PostfixOperators #-} - {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module ChatTests.Files where diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 03ddf7d57b..8686310244 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -7,7 +7,7 @@ import ChatClient import ChatTests.Utils import Control.Concurrent (threadDelay) import Control.Concurrent.Async (concurrently_) -import Control.Monad (when, void) +import Control.Monad (void, when) import qualified Data.ByteString as B import Data.List (isInfixOf) import qualified Data.Text as T @@ -122,7 +122,8 @@ chatGroupTests = do -- because host uses current code and sends version in MemberInfo testNoDirect vrMem2 vrMem3 noConns = it - ( "host " <> vRangeStr supportedChatVRange + ( "host " + <> vRangeStr supportedChatVRange <> (", 2nd mem " <> vRangeStr vrMem2) <> (", 3rd mem " <> vRangeStr vrMem3) <> (if noConns then " : 2 3" else " : 2 <##> 3") @@ -3859,11 +3860,9 @@ testMemberContactProfileUpdate = bob #> "#team hello too" alice <# "#team rob> hello too" cath <# "#team bob> hello too" -- not updated profile - cath #> "#team hello there" alice <# "#team kate> hello there" bob <# "#team cath> hello there" -- not updated profile - bob `send` "@cath hi" bob <### [ "member #team cath does not have direct connection, creating", @@ -3903,7 +3902,6 @@ testMemberContactProfileUpdate = bob #> "#team hello too" alice <# "#team rob> hello too" cath <# "#team rob> hello too" -- updated profile - cath #> "#team hello there" alice <# "#team kate> hello there" bob <# "#team kate> hello there" -- updated profile @@ -3911,7 +3909,7 @@ testMemberContactProfileUpdate = testGroupMsgForward :: HasCallStack => FilePath -> IO () testGroupMsgForward = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> do + \alice bob cath -> do setupGroupForwarding3 "team" alice bob cath bob #> "#team hi there" @@ -3941,7 +3939,6 @@ setupGroupForwarding3 gName alice bob cath = do createGroup3 gName alice bob cath threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected - void $ withCCTransaction bob $ \db -> DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3" void $ withCCTransaction cath $ \db -> @@ -3956,7 +3953,6 @@ testGroupMsgForwardDeduplicate = createGroup3 "team" alice bob cath threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected - void $ withCCTransaction alice $ \db -> DB.execute_ db "UPDATE group_member_intros SET intro_status='fwd'" @@ -3990,7 +3986,7 @@ testGroupMsgForwardDeduplicate = testGroupMsgForwardEdit :: HasCallStack => FilePath -> IO () testGroupMsgForwardEdit = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> do + \alice bob cath -> do setupGroupForwarding3 "team" alice bob cath bob #> "#team hi there" @@ -4001,7 +3997,6 @@ testGroupMsgForwardEdit = bob <# "#team [edited] hello there" alice <# "#team bob> [edited] hello there" cath <# "#team bob> [edited] hello there" -- TODO show as forwarded - alice ##> "/tail #team 1" alice <# "#team bob> hello there" @@ -4014,7 +4009,7 @@ testGroupMsgForwardEdit = testGroupMsgForwardReaction :: HasCallStack => FilePath -> IO () testGroupMsgForwardReaction = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> do + \alice bob cath -> do setupGroupForwarding3 "team" alice bob cath bob #> "#team hi there" @@ -4031,7 +4026,7 @@ testGroupMsgForwardReaction = testGroupMsgForwardDeletion :: HasCallStack => FilePath -> IO () testGroupMsgForwardDeletion = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> do + \alice bob cath -> do setupGroupForwarding3 "team" alice bob cath bob #> "#team hi there" @@ -4073,7 +4068,7 @@ testGroupMsgForwardFile = testGroupMsgForwardChangeRole :: HasCallStack => FilePath -> IO () testGroupMsgForwardChangeRole = testChat3 aliceProfile bobProfile cathProfile $ - \alice bob cath -> do + \alice bob cath -> do setupGroupForwarding3 "team" alice bob cath cath ##> "/mr #team bob member" @@ -4084,7 +4079,7 @@ testGroupMsgForwardChangeRole = testGroupMsgForwardNewMember :: HasCallStack => FilePath -> IO () testGroupMsgForwardNewMember = testChat4 aliceProfile bobProfile cathProfile danProfile $ - \alice bob cath dan -> do + \alice bob cath dan -> do setupGroupForwarding3 "team" alice bob cath connectUsers cath dan diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 0a45a74ade..b9a908005d 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -7,16 +7,16 @@ import ChatClient import ChatTests.Utils import Control.Concurrent (threadDelay) import Control.Concurrent.Async (concurrently_) +import Control.Monad import Control.Monad.Except import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import qualified Data.Text as T +import Simplex.Chat.Store.Shared (createContact) import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), Profile (..)) +import Simplex.Messaging.Encoding.String (StrEncoding (..)) import System.Directory (copyFile, createDirectoryIfMissing) import Test.Hspec -import Simplex.Chat.Store.Shared (createContact) -import Control.Monad -import Simplex.Messaging.Encoding.String (StrEncoding(..)) chatProfileTests :: SpecWith FilePath chatProfileTests = do @@ -633,7 +633,7 @@ testPlanAddressOwn tmp = alice <## "alice_1 (Alice) wants to connect to you!" alice <## "to accept: /ac alice_1" alice <## "to reject: /rc alice_1 (the sender will NOT be notified)" - alice @@@ [("<@alice_1", ""), (":2","")] + alice @@@ [("<@alice_1", ""), (":2", "")] alice ##> "/ac alice_1" alice <## "alice_1 (Alice): accepting contact request..." alice diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 40fe0e6dab..3f89e9b177 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -310,7 +310,7 @@ getInAnyOrder f cc ls = do Predicate p -> p l filterFirst :: (a -> Bool) -> [a] -> [a] filterFirst _ [] = [] - filterFirst p (x:xs) + filterFirst p (x : xs) | p x = xs | otherwise = x : filterFirst p xs @@ -593,7 +593,7 @@ vRangeStr (VersionRange minVer maxVer) = "(" <> show minVer <> ", " <> show maxV linkAnotherSchema :: String -> String linkAnotherSchema link | "https://simplex.chat/" `isPrefixOf` link = - T.unpack $ T.replace "https://simplex.chat/" "simplex:/" $ T.pack link + T.unpack $ T.replace "https://simplex.chat/" "simplex:/" $ T.pack link | "simplex:/" `isPrefixOf` link = - T.unpack $ T.replace "simplex:/" "https://simplex.chat/" $ T.pack link + T.unpack $ T.replace "simplex:/" "https://simplex.chat/" $ T.pack link | otherwise = error "link starts with neither https://simplex.chat/ nor simplex:/" diff --git a/tests/Test.hs b/tests/Test.hs index 568f9688d0..ee5804aa9a 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -13,8 +13,8 @@ import RemoteTests import SchemaDump import Test.Hspec import UnliftIO.Temporary (withTempDirectory) -import ViewTests import ValidNames +import ViewTests import WebRTCTests main :: IO ()