From e253c55ba41f9158b695413f2151d091b0f5cad4 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Fri, 29 Dec 2023 23:15:14 +0200 Subject: [PATCH] core: compatibility with GHC 8.10.7 (#3608) * GHC-8.10 compatibility * tweak setters * restore membership * remove Show Batch * fix bytestring-10 compat * preserve membership qualifier in names * a few more memberships * rename * remove with-compiler * ci: add 8.10 builds, limit releases to 9.6 * use matrix.asset_name as release guard * fix windows_build * actually use ghc version from matrix * fix typo * revert build/hash split * add ghc to cache key * Force cache between build and tests * use explicit caching steps * skip unneeded tasks --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Co-authored-by: Avently <7953703+avently@users.noreply.github.com> --- .github/workflows/build.yml | 60 ++++++++---- cabal.project | 2 - src/Simplex/Chat.hs | 127 ++++++++++++++------------ src/Simplex/Chat/Messages.hs | 5 +- src/Simplex/Chat/Messages/Batch.hs | 1 - src/Simplex/Chat/Mobile/Shared.hs | 6 +- src/Simplex/Chat/Store/Direct.hs | 3 +- src/Simplex/Chat/Store/Files.hs | 3 +- src/Simplex/Chat/Store/Groups.hs | 9 +- src/Simplex/Chat/Types.hs | 15 ++- src/Simplex/Chat/Types/Preferences.hs | 95 ++++++++++--------- src/Simplex/Chat/View.hs | 13 +-- tests/Bots/BroadcastTests.hs | 5 +- tests/Bots/DirectoryTests.hs | 5 +- tests/ChatClient.hs | 36 ++++---- 15 files changed, 207 insertions(+), 178 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index afdb9bea1..2727fc4ad 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -42,7 +42,7 @@ jobs: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} build: - name: build-${{ matrix.os }} + name: build-${{ matrix.os }}-${{ matrix.ghc }} if: always() needs: prepare-release runs-on: ${{ matrix.os }} @@ -51,18 +51,25 @@ jobs: matrix: include: - os: ubuntu-20.04 + ghc: "8.10.7" + cache_path: ~/.cabal/store + - os: ubuntu-20.04 + ghc: "9.6.3" cache_path: ~/.cabal/store asset_name: simplex-chat-ubuntu-20_04-x86-64 desktop_asset_name: simplex-desktop-ubuntu-20_04-x86_64.deb - os: ubuntu-22.04 + ghc: "9.6.3" cache_path: ~/.cabal/store asset_name: simplex-chat-ubuntu-22_04-x86-64 desktop_asset_name: simplex-desktop-ubuntu-22_04-x86_64.deb - os: macos-latest + ghc: "9.6.3" cache_path: ~/.cabal/store asset_name: simplex-chat-macos-x86-64 desktop_asset_name: simplex-desktop-macos-x86_64.dmg - os: windows-latest + ghc: "9.6.3" cache_path: C:/cabal asset_name: simplex-chat-windows-x86-64 desktop_asset_name: simplex-desktop-windows-x86_64.msi @@ -81,16 +88,17 @@ jobs: - name: Setup Haskell uses: haskell-actions/setup@v2 with: - ghc-version: "9.6.3" + ghc-version: ${{ matrix.ghc }} cabal-version: "3.10.1.0" - - name: Cache dependencies - uses: actions/cache@v3 + - name: Restore cached build + id: restore_cache + uses: actions/cache/restore@v3 with: path: | ${{ matrix.cache_path }} dist-newstyle - key: ${{ matrix.os }}-${{ hashFiles('cabal.project', 'simplex-chat.cabal') }} + key: ${{ matrix.os }}-ghc${{ matrix.ghc }}-${{ hashFiles('cabal.project', 'simplex-chat.cabal') }} # / Unix @@ -105,7 +113,7 @@ jobs: echo " flags: +openssl" >> cabal.project.local - name: Install AppImage dependencies - if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04' + if: startsWith(github.ref, 'refs/tags/v') && matrix.asset_name && matrix.os == 'ubuntu-20.04' run: sudo apt install -y desktop-file-utils - name: Install pkg-config for Mac @@ -131,7 +139,7 @@ jobs: echo "bin_hash=$(echo SHA2-512\(${{ matrix.asset_name }}\)= $(openssl sha512 $path | cut -d' ' -f 2))" >> $GITHUB_OUTPUT - name: Unix upload CLI binary to release - if: startsWith(github.ref, 'refs/tags/v') && matrix.os != 'windows-latest' + if: startsWith(github.ref, 'refs/tags/v') && matrix.asset_name && matrix.os != 'windows-latest' uses: svenstaro/upload-release-action@v2 with: repo_token: ${{ secrets.GITHUB_TOKEN }} @@ -140,7 +148,7 @@ jobs: tag: ${{ github.ref }} - name: Unix update CLI binary hash - if: startsWith(github.ref, 'refs/tags/v') && matrix.os != 'windows-latest' + if: startsWith(github.ref, 'refs/tags/v') && matrix.asset_name && matrix.os != 'windows-latest' uses: softprops/action-gh-release@v1 env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} @@ -150,7 +158,7 @@ jobs: ${{ steps.unix_cli_build.outputs.bin_hash }} - name: Setup Java - if: startsWith(github.ref, 'refs/tags/v') + if: startsWith(github.ref, 'refs/tags/v') && matrix.asset_name uses: actions/setup-java@v3 with: distribution: 'corretto' @@ -159,7 +167,7 @@ jobs: - name: Linux build desktop id: linux_desktop_build - if: startsWith(github.ref, 'refs/tags/v') && (matrix.os == 'ubuntu-20.04' || matrix.os == 'ubuntu-22.04') + if: startsWith(github.ref, 'refs/tags/v') && matrix.asset_name && (matrix.os == 'ubuntu-20.04' || matrix.os == 'ubuntu-22.04') shell: bash run: | scripts/desktop/build-lib-linux.sh @@ -168,10 +176,10 @@ jobs: path=$(echo $PWD/release/main/deb/simplex_*_amd64.deb) echo "package_path=$path" >> $GITHUB_OUTPUT echo "package_hash=$(echo SHA2-512\(${{ matrix.desktop_asset_name }}\)= $(openssl sha512 $path | cut -d' ' -f 2))" >> $GITHUB_OUTPUT - + - name: Linux make AppImage id: linux_appimage_build - if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04' + if: startsWith(github.ref, 'refs/tags/v') && matrix.asset_name && matrix.os == 'ubuntu-20.04' shell: bash run: | scripts/desktop/make-appimage-linux.sh @@ -194,7 +202,7 @@ jobs: echo "package_hash=$(echo SHA2-512\(${{ matrix.desktop_asset_name }}\)= $(openssl sha512 $path | cut -d' ' -f 2))" >> $GITHUB_OUTPUT - name: Linux upload desktop package to release - if: startsWith(github.ref, 'refs/tags/v') && (matrix.os == 'ubuntu-20.04' || matrix.os == 'ubuntu-22.04') + if: startsWith(github.ref, 'refs/tags/v') && matrix.asset_name && (matrix.os == 'ubuntu-20.04' || matrix.os == 'ubuntu-22.04') uses: svenstaro/upload-release-action@v2 with: repo_token: ${{ secrets.GITHUB_TOKEN }} @@ -203,7 +211,7 @@ jobs: tag: ${{ github.ref }} - name: Linux update desktop package hash - if: startsWith(github.ref, 'refs/tags/v') && (matrix.os == 'ubuntu-20.04' || matrix.os == 'ubuntu-22.04') + if: startsWith(github.ref, 'refs/tags/v') && matrix.asset_name && (matrix.os == 'ubuntu-20.04' || matrix.os == 'ubuntu-22.04') uses: softprops/action-gh-release@v1 env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} @@ -213,7 +221,7 @@ jobs: ${{ steps.linux_desktop_build.outputs.package_hash }} - name: Linux upload AppImage to release - if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04' + if: startsWith(github.ref, 'refs/tags/v') && matrix.asset_name && matrix.os == 'ubuntu-20.04' uses: svenstaro/upload-release-action@v2 with: repo_token: ${{ secrets.GITHUB_TOKEN }} @@ -222,7 +230,7 @@ jobs: tag: ${{ github.ref }} - name: Linux update AppImage hash - if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04' + if: startsWith(github.ref, 'refs/tags/v') && matrix.asset_name && matrix.os == 'ubuntu-20.04' uses: softprops/action-gh-release@v1 env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} @@ -250,6 +258,15 @@ jobs: body: | ${{ steps.mac_desktop_build.outputs.package_hash }} + - name: Cache unix build + uses: actions/cache/save@v3 + if: matrix.os != 'windows-latest' + with: + path: | + ${{ matrix.cache_path }} + dist-newstyle + key: ${{ steps.restore_cache.outputs.cache-primary-key }} + - name: Unix test if: matrix.os != 'windows-latest' timeout-minutes: 30 @@ -330,7 +347,7 @@ jobs: path=$(echo $PWD/release/main/msi/*imple*.msi | sed 's#/\([a-z]\)#\1:#' | sed 's#/#\\#g') echo "package_path=$path" >> $GITHUB_OUTPUT echo "package_hash=$(echo SHA2-512\(${{ matrix.desktop_asset_name }}\)= $(openssl sha512 $path | cut -d' ' -f 2))" >> $GITHUB_OUTPUT - + - name: Windows upload desktop package to release if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'windows-latest' uses: svenstaro/upload-release-action@v2 @@ -350,4 +367,13 @@ jobs: body: | ${{ steps.windows_desktop_build.outputs.package_hash }} + - name: Cache windows build + uses: actions/cache/save@v3 + if: matrix.os == 'windows-latest' + with: + path: | + ${{ matrix.cache_path }} + dist-newstyle + key: ${{ steps.restore_cache.outputs.cache-primary-key }} + # Windows / diff --git a/cabal.project b/cabal.project index baf7d5c4c..dbd050bcf 100644 --- a/cabal.project +++ b/cabal.project @@ -2,8 +2,6 @@ packages: . -- packages: . ../simplexmq -- packages: . ../simplexmq ../direct-sqlcipher ../sqlcipher-simple -with-compiler: ghc-9.6.3 - index-state: 2023-12-12T00:00:00Z package cryptostore diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 9d7f5bccc..d61fc5f5a 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -5,7 +5,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -279,8 +278,9 @@ newChatController where configServers :: DefaultAgentServers configServers = - let smp' = fromMaybe (defaultServers.smp) (nonEmpty smpServers) - xftp' = fromMaybe (defaultServers.xftp) (nonEmpty xftpServers) + let DefaultAgentServers {smp = defSmp, xftp = defXftp} = defaultServers + smp' = fromMaybe defSmp (nonEmpty smpServers) + xftp' = fromMaybe defXftp (nonEmpty xftpServers) in defaultServers {smp = smp', xftp = xftp', netCfg = networkConfig} agentServers :: ChatConfig -> IO InitialAgentServers agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do @@ -307,9 +307,9 @@ activeAgentServers ChatConfig {defaultServers} p = . filter (\ServerCfg {enabled} -> enabled) cfgServers :: UserProtocol p => SProtocolType p -> (DefaultAgentServers -> NonEmpty (ProtoServerWithAuth p)) -cfgServers p s = case p of - SPSMP -> s.smp - SPXFTP -> s.xftp +cfgServers p DefaultAgentServers {smp, xftp} = case p of + SPSMP -> smp + SPXFTP -> xftp startChatController :: forall m. ChatMonad' m => Bool -> Bool -> Bool -> m (Async ()) startChatController subConns enableExpireCIs startXFTPWorkers = do @@ -971,7 +971,8 @@ processChatCommand' vr = \case pure $ CRContactConnectionDeleted user conn CTGroup -> do Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user chatId - let isOwner = membership.memberRole == GROwner + let GroupMember {memberRole = membershipMemRole} = membership + let isOwner = membershipMemRole == GROwner canDelete = isOwner || not (memberCurrent membership) unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo @@ -1611,11 +1612,12 @@ processChatCommand' vr = \case inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db vr user groupId (inv,) <$> getContactViaMember db user fromMember let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation + GroupMember {memberId = membershipMemId} = membership Contact {activeConn} = ct case activeConn of Just Connection {peerChatVRange} -> do subMode <- chatReadVar subscriptionMode - dm <- directMessage $ XGrpAcpt membership.memberId + dm <- directMessage $ XGrpAcpt membershipMemId agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm subMode withStore' $ \db -> do createMemberConnection db userId fromMember agentConnId (fromJVersionRange peerChatVRange) subMode @@ -1767,12 +1769,12 @@ processChatCommand' vr = \case pure $ CRNewMemberContact user ct g m _ -> throwChatError CEGroupMemberNotActive APISendMemberContactInvitation contactId msgContent_ -> withUser $ \user -> do - (g, m, ct, cReq) <- withStore $ \db -> getMemberContact db vr user contactId + (g@GroupInfo {groupId}, m, ct, cReq) <- withStore $ \db -> getMemberContact db vr user contactId when (contactGrpInvSent ct) $ throwChatError $ CECommandError "x.grp.direct.inv already sent" case memberConn m of Just mConn -> do let msg = XGrpDirectInv cReq msgContent_ - (sndMsg, _) <- sendDirectMessage mConn msg (GroupId $ g.groupId) + (sndMsg, _) <- sendDirectMessage mConn msg $ GroupId groupId withStore' $ \db -> setContactGrpInvSent db ct True let ct' = ct {contactGrpInvSent = True} forM_ msgContent_ $ \mc -> do @@ -2191,7 +2193,8 @@ processChatCommand' vr = \case when (displayName /= validName) $ throwChatError CEInvalidDisplayName {displayName, validName} assertUserGroupRole :: GroupInfo -> GroupMemberRole -> m () assertUserGroupRole g@GroupInfo {membership} requiredRole = do - when (membership.memberRole < requiredRole) $ throwChatError $ CEGroupUserRole g requiredRole + let GroupMember {memberRole = membershipMemRole} = membership + when (membershipMemRole < requiredRole) $ throwChatError $ CEGroupUserRole g requiredRole when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g) when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved unless (memberActive membership) $ throwChatError CEGroupMemberNotActive @@ -2235,7 +2238,7 @@ processChatCommand' vr = \case forwardFile chatName fileId sendCommand = withUser $ \user -> do withStore (\db -> getFileTransfer db user fileId) >>= \case FTRcv RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}, cryptoArgs} -> forward filePath cryptoArgs - FTSnd {fileTransferMeta = FileTransferMeta {filePath, xftpSndFile}} -> forward filePath $ xftpSndFile >>= \f -> f.cryptoArgs + FTSnd {fileTransferMeta = FileTransferMeta {filePath, xftpSndFile}} -> forward filePath $ xftpSndFile >>= \XFTPSndFile {cryptoArgs} -> cryptoArgs _ -> throwChatError CEFileNotReceived {fileId} where forward path cfArgs = processChatCommand . sendCommand chatName $ CryptoFile path cfArgs @@ -2327,7 +2330,7 @@ processChatCommand' vr = \case _ -> throwChatError $ CECommandError "not supported" processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings connectPlan :: User -> AConnectionRequestUri -> m ConnectionPlan - connectPlan user (ACR SCMInvitation cReq) = do + connectPlan user (ACR SCMInvitation (CRInvitationUri crData e2e)) = do withStore' (\db -> getConnectionEntityByConnReq db vr user cReqSchemas) >>= \case Nothing -> pure $ CPInvitationLink ILPOk Just (RcvDirectMsgConnection conn ct_) -> do @@ -2343,13 +2346,12 @@ processChatCommand' vr = \case Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection" where cReqSchemas :: (ConnReqInvitation, ConnReqInvitation) - cReqSchemas = case cReq of - (CRInvitationUri crData e2e) -> - ( CRInvitationUri crData {crScheme = CRSSimplex} e2e, - CRInvitationUri crData {crScheme = simplexChat} e2e - ) - connectPlan user (ACR SCMContact cReq) = do - let CRContactUri ConnReqUriData {crClientData} = cReq + cReqSchemas = + ( CRInvitationUri crData {crScheme = CRSSimplex} e2e, + CRInvitationUri crData {crScheme = simplexChat} e2e + ) + connectPlan user (ACR SCMContact (CRContactUri crData)) = do + let ConnReqUriData {crClientData} = crData groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli case groupLinkId of -- contact address @@ -2389,11 +2391,10 @@ processChatCommand' vr = \case | otherwise -> pure $ CPGroupLink GLPOk where cReqSchemas :: (ConnReqContact, ConnReqContact) - cReqSchemas = case cReq of - (CRContactUri crData) -> - ( CRContactUri crData {crScheme = CRSSimplex}, - CRContactUri crData {crScheme = simplexChat} - ) + cReqSchemas = + ( CRContactUri crData {crScheme = CRSSimplex}, + CRContactUri crData {crScheme = simplexChat} + ) cReqHashes :: (ConnReqUriHash, ConnReqUriHash) cReqHashes = bimap hash hash cReqSchemas hash = ConnReqUriHash . C.sha256Hash . strEncode @@ -3561,9 +3562,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = case chatMsgEvent of XGrpMemInfo memId _memProfile | sameMemberId memId m -> do + let GroupMember {memberId = membershipMemId} = 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) + allowAgentConnectionAsync user conn' confId $ XGrpMemInfo membershipMemId (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 @@ -3689,7 +3691,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = fInv = xftpFileInvitation fileName fileSize fInvDescr in Just (fInv, fileDescrText) | otherwise = Nothing - processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> m [ChatMsgEvent Json] + processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> m [ChatMsgEvent 'Json] processContentItem sender ChatItem {meta, quotedItem} mc fInvDescr_ = if isNothing fInvDescr_ && not (msgContentHasText mc) then pure [] @@ -3724,17 +3726,18 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = when (memCategory == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True sendXGrpMemCon memCategory where + GroupMember {memberId} = m sendXGrpMemCon = \case GCPreMember -> forM_ (invitedByGroupMemberId membership) $ \hostId -> do host <- withStore $ \db -> getGroupMember db user groupId hostId forM_ (memberConn host) $ \hostConn -> - void $ sendDirectMessage hostConn (XGrpMemCon m.memberId) (GroupId groupId) + void $ sendDirectMessage hostConn (XGrpMemCon memberId) (GroupId groupId) GCPostMember -> forM_ (invitedByGroupMemberId m) $ \invitingMemberId -> do im <- withStore $ \db -> getGroupMember db user groupId invitingMemberId forM_ (memberConn im) $ \imConn -> - void $ sendDirectMessage imConn (XGrpMemCon m.memberId) (GroupId groupId) + void $ sendDirectMessage imConn (XGrpMemCon memberId) (GroupId groupId) _ -> messageWarning "sendXGrpMemCon: member category GCPreMember or GCPostMember is expected" MSG msgMeta _msgFlags msgBody -> do checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure () @@ -3747,7 +3750,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = Left e -> toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e) checkSendRcpt $ rights aChatMsgs -- currently only a single message is forwarded - when (membership.memberRole >= GRAdmin) $ case aChatMsgs of + let GroupMember {memberRole = membershipMemRole} = membership + when (membershipMemRole >= GRAdmin) $ case aChatMsgs of [Right (ACMsg _ chatMsg)] -> forwardMsg_ chatMsg _ -> pure () where @@ -3807,8 +3811,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = 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 + let GroupMember {memberId} = m + ms = introducedMembers <> invitedMembers + msg = XGrpMsgForward memberId chatMsg' brokerTs unless (null ms) . void $ sendGroupMessage user gInfo ms msg RCVD msgMeta msgRcpt -> @@ -4069,8 +4074,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> toView $ CRReceivedContactRequest user cReq memberCanSend :: GroupMember -> m () -> m () - memberCanSend mem a - | mem.memberRole <= GRObserver = messageError "member is not allowed to send messages" + memberCanSend GroupMember {memberRole} a + | memberRole <= GRObserver = messageError "member is not allowed to send messages" | otherwise = a incAuthErrCounter :: ConnectionEntity -> Connection -> AgentErrorType -> m () @@ -4692,12 +4697,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c) when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId -- [incognito] if direct connection with host is incognito, create membership using the same incognito profile - (gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = membership@GroupMember {groupMemberId, memberId}}, hostId) <- - withStore $ \db -> createGroupInvitation db vr user ct inv customUserProfileId + (gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db vr user ct inv customUserProfileId + let GroupMember {groupMemberId, memberId = membershipMemId} = membership if sameGroupLinkId groupLinkId groupLinkId' then do subMode <- chatReadVar subscriptionMode - dm <- directMessage $ XGrpAcpt memberId + dm <- directMessage $ XGrpAcpt membershipMemId connIds <- joinAgentConnectionAsync user True connRequest dm subMode withStore' $ \db -> do setViaGroupLinkHash db groupId connId @@ -5128,6 +5133,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m () xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do + let GroupMember {memberId = membershipMemId} = membership checkHostRole m memRole toMember <- withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case @@ -5140,7 +5146,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = withStore' $ \db -> saveMemberInvitation db toMember introInv subMode <- chatReadVar subscriptionMode -- [incognito] send membership incognito profile, create direct connection as incognito - dm <- directMessage $ XGrpMemInfo membership.memberId (fromLocalProfile $ memberProfile membership) + dm <- directMessage $ XGrpMemInfo membershipMemId (fromLocalProfile $ memberProfile membership) -- [async agent commands] no continuation needed, but commands should be asynchronous for stability groupConnIds <- joinAgentConnectionAsync user (chatHasNtfs chatSettings) groupConnReq dm subMode directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user True dcr dm subMode @@ -5150,7 +5156,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> m () xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg brokerTs - | membership.memberId == memId = + | membershipMemId == memId = let gInfo' = gInfo {membership = membership {memberRole = memRole}} in changeMemberRole gInfo' membership $ RGEUserRole memRole | otherwise = @@ -5158,6 +5164,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole Left _ -> messageError "x.grp.mem.role with unknown member ID" where + GroupMember {memberId = membershipMemId} = membership changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} gEvent | senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions" | otherwise = do @@ -5211,7 +5218,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> UTCTime -> m () xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId msg brokerTs = do - if membership.memberId == memId + let GroupMember {memberId = membershipMemId} = membership + if membershipMemId == memId then checkRole membership $ do deleteGroupLinkIfExists user gInfo -- member records are not deleted to keep history @@ -5323,8 +5331,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> ChatMessage 'Json -> UTCTime -> m () - xGrpMsgForward gInfo@GroupInfo {groupId} m memberId msg msgTs = do - when (m.memberRole < GRAdmin) $ throwChatError (CEGroupContactRole m.localDisplayName) + xGrpMsgForward gInfo@GroupInfo {groupId} m@GroupMember {memberRole, localDisplayName} memberId msg msgTs = do + when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole localDisplayName) author <- withStore $ \db -> getGroupMemberByMemberId db user gInfo memberId processForwardedMsg author msg where @@ -5501,7 +5509,7 @@ parseFileChunk :: ChatMonad m => ByteString -> m FileChunk parseFileChunk = liftEither . first (ChatError . CEFileRcvChunk) . smpDecode appendFileChunk :: forall m. ChatMonad m => RcvFileTransfer -> Integer -> ByteString -> Bool -> m () -appendFileChunk ft@RcvFileTransfer {fileId, fileStatus, cryptoArgs} chunkNo chunk final = +appendFileChunk ft@RcvFileTransfer {fileId, fileStatus, cryptoArgs, fileInvitation = FileInvitation {fileName}} chunkNo chunk final = case fileStatus of RFSConnected RcvFileInfo {filePath} -> append_ filePath -- sometimes update of file transfer status to FSConnected @@ -5519,7 +5527,7 @@ appendFileChunk ft@RcvFileTransfer {fileId, fileStatus, cryptoArgs} chunkNo chun when final $ do closeFileHandle fileId rcvFiles forM_ cryptoArgs $ \cfArgs -> do - tmpFile <- getChatTempDirectory >>= (`uniqueCombine` ft.fileInvitation.fileName) + tmpFile <- getChatTempDirectory >>= (`uniqueCombine` fileName) tryChatError (liftError encryptErr $ encryptFile fsFilePath tmpFile cfArgs) >>= \case Right () -> do removeFile fsFilePath `catchChatError` \_ -> pure () @@ -5734,7 +5742,7 @@ sendGroupMessage user GroupInfo {groupId} members chatMsgEvent = do data MemberSendAction = MSASend Connection | MSAPending memberSendAction :: ChatMsgEvent e -> [GroupMember] -> GroupMember -> Maybe MemberSendAction -memberSendAction chatMsgEvent members m = case memberConn m of +memberSendAction chatMsgEvent members m@GroupMember {invitedByGroupMemberId} = case memberConn m of Nothing -> pendingOrForwarded Just conn@Connection {connStatus} | connDisabled conn || connStatus == ConnDeleted -> Nothing @@ -5749,7 +5757,7 @@ memberSendAction chatMsgEvent members m = case memberConn m of forwardSupported = let mcvr = memberChatVRange' m in isCompatibleRange mcvr groupForwardVRange && invitingMemberSupportsForward - invitingMemberSupportsForward = case m.invitedByGroupMemberId of + invitingMemberSupportsForward = case invitedByGroupMemberId of Just invMemberId -> -- can be optimized for large groups by replacing [GroupMember] with Map GroupMemberId GroupMember case find (\m' -> groupMemberId' m' == invMemberId) members of @@ -5804,34 +5812,33 @@ saveDirectRcvMSG conn@Connection {connId} agentMsgMeta agentAckCmdId msgBody = saveGroupRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> CommandId -> MsgBody -> ChatMessage e -> m (GroupMember, Connection, RcvMessage) saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta agentAckCmdId msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do - (am', conn') <- updateMemberChatVRange authorMember conn chatVRange + (am'@GroupMember {memberId = amMemId, groupMemberId = amGroupMemId}, conn') <- updateMemberChatVRange authorMember conn chatVRange let agentMsgId = fst $ recipient agentMsgMeta newMsg = NewRcvMessage {chatMsgEvent, msgBody} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} - amId = Just am'.groupMemberId msg <- - withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery amId) + withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery $ Just amGroupMemId) `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) + void $ sendDirectMessage fmConn (XGrpMemCon amMemId) (GroupId groupId) throwError e _ -> throwError e pure (am', conn', msg) saveGroupFwdRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> m RcvMessage -saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} = do +saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember@GroupMember {memberId = refMemberId} msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} = do let newMsg = NewRcvMessage {chatMsgEvent, msgBody} fwdMemberId = Just $ groupMemberId' forwardingMember refAuthorId = Just $ groupMemberId' refAuthorMember withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId) `catchChatError` \e -> case e of ChatErrorStore (SEDuplicateGroupMessage _ _ (Just authorGroupMemberId) Nothing) -> do - am <- withStore $ \db -> getGroupMember db user groupId authorGroupMemberId - if sameMemberId refAuthorMember.memberId am + am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db user groupId authorGroupMemberId + if sameMemberId refMemberId am then forM_ (memberConn forwardingMember) $ \fmConn -> - void $ sendDirectMessage fmConn (XGrpMemCon am.memberId) (GroupId groupId) + void $ sendDirectMessage fmConn (XGrpMemCon amMemberId) (GroupId groupId) else toView $ CRMessageError user "error" "saveGroupFwdRcvMsg: referenced author member id doesn't match message member id" throwError e _ -> throwError e @@ -5977,7 +5984,9 @@ createSndFeatureItems :: forall m. ChatMonad m => User -> Contact -> Contact -> createSndFeatureItems user ct ct' = createFeatureItems user ct ct' CDDirectSnd CISndChatFeature CISndChatPreference getPref where - getPref u = (userPreference u).preference + getPref ContactUserPreference {userPreference} = case userPreference of + CUPContact {preference} -> preference + CUPUser {preference} -> preference type FeatureContent a d = ChatFeature -> a -> Maybe Int -> CIContent d @@ -6060,8 +6069,8 @@ getCreateActiveUser st testView = do Left e -> putStrLn ("database error " <> show e) >> exitFailure Right user -> pure user selectUser :: [User] -> IO User - selectUser [user] = do - withTransaction st (`setActiveUser` user.userId) + selectUser [user@User {userId}] = do + withTransaction st (`setActiveUser` userId) pure user selectUser users = do putStrLn "Select user profile:" @@ -6075,8 +6084,8 @@ 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) + let user@User {userId} = users !! (n - 1) + withTransaction st (`setActiveUser` userId) pure user userStr :: User -> String userStr User {localDisplayName, profile = LocalProfile {fullName}} = diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 74b41dc9f..4ee2e9cc1 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -5,7 +5,6 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -345,7 +344,9 @@ contactTimedTTL Contact {mergedPreferences = ContactUserPreferences {timedMessag | forUser enabled && forContact enabled = Just ttl | otherwise = Nothing where - TimedMessagesPreference {ttl} = userPreference.preference + TimedMessagesPreference {ttl} = case userPreference of + CUPContact {preference} -> preference + CUPUser {preference} -> preference groupTimedTTL :: GroupInfo -> Maybe (Maybe Int) groupTimedTTL GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}} diff --git a/src/Simplex/Chat/Messages/Batch.hs b/src/Simplex/Chat/Messages/Batch.hs index 8b06873a3..3e3a1fd0b 100644 --- a/src/Simplex/Chat/Messages/Batch.hs +++ b/src/Simplex/Chat/Messages/Batch.hs @@ -16,7 +16,6 @@ import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..)) import Simplex.Chat.Messages data MsgBatch = MsgBatch Builder [SndMessage] - deriving (Show) -- | Batches [SndMessage] into batches of ByteString builders in form of JSON arrays. -- Does not check if the resulting batch is a valid JSON. diff --git a/src/Simplex/Chat/Mobile/Shared.hs b/src/Simplex/Chat/Mobile/Shared.hs index a4961c15f..5f13f58c7 100644 --- a/src/Simplex/Chat/Mobile/Shared.hs +++ b/src/Simplex/Chat/Mobile/Shared.hs @@ -16,12 +16,12 @@ type JSONByteString = LB.ByteString getByteString :: Ptr Word8 -> CInt -> IO ByteString getByteString ptr len = do fp <- newForeignPtr_ ptr - pure $ BS fp $ fromIntegral len + pure $ PS fp 0 (fromIntegral len) {-# INLINE getByteString #-} putByteString :: Ptr Word8 -> ByteString -> IO () -putByteString ptr (BS fp len) = - withForeignPtr fp $ \p -> memcpy ptr p len +putByteString ptr (PS fp offset len) = + withForeignPtr fp $ \p -> memcpy ptr (p `plusPtr` offset) len {-# INLINE putByteString #-} putLazyByteString :: Ptr Word8 -> LB.ByteString -> IO () diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index 7504f19c9..422299465 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -489,7 +488,7 @@ createOrUpdateContactRequest db user@User {userId} userContactLinkId invId (Vers ExceptT $ maybeM getContactRequestByXContactId xContactId_ >>= \case Nothing -> createContactRequest - Just cr -> updateContactRequest cr $> Right cr.contactRequestId + Just cr@UserContactRequest {contactRequestId} -> updateContactRequest cr $> Right contactRequestId getContactRequest db user cReqId createContactRequest :: IO (Either StoreError Int64) createContactRequest = do diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs index 4d419c572..8789ccd86 100644 --- a/src/Simplex/Chat/Store/Files.hs +++ b/src/Simplex/Chat/Store/Files.hs @@ -2,7 +2,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -929,7 +928,7 @@ getLocalCryptoFile db userId fileId sent = _ -> do unless sent $ throwError $ SEFileNotFound fileId FileTransferMeta {filePath, xftpSndFile} <- getFileTransferMeta_ db userId fileId - pure $ CryptoFile filePath $ xftpSndFile >>= \f -> f.cryptoArgs + pure $ CryptoFile filePath $ xftpSndFile >>= \XFTPSndFile {cryptoArgs} -> cryptoArgs updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> VersionRange -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem updateDirectCIFileStatus db vr user fileId fileStatus = do diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 206662636..e9ec8be28 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} @@ -320,7 +319,7 @@ createNewGroup db vr gVar user@User {userId} groupProfile incognitoProfile = Exc -- | creates a new group record for the group the current user was invited to, or returns an existing one createGroupInvitation :: DB.Connection -> VersionRange -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId) createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName -createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activeConn = Just hostConn@Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do +createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activeConn = Just Connection {customUserProfileId, peerChatVRange}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do liftIO getInvitationGroupId_ >>= \case Nothing -> createGroupInvitation_ Just gId -> do @@ -358,7 +357,7 @@ createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activ "INSERT INTO groups (group_profile_id, local_display_name, inv_queue_info, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?,?)" (profileId, localDisplayName, connRequest, customUserProfileId, userId, True, currentTs, currentTs, currentTs) insertedRowId db - let JVersionRange hostVRange = hostConn.peerChatVRange + let JVersionRange hostVRange = peerChatVRange GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs hostVRange membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs vr let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False} @@ -1041,7 +1040,7 @@ updateIntroStatus db introId introStatus = do [":intro_status" := introStatus, ":updated_at" := currentTs, ":intro_id" := introId] saveIntroInvitation :: DB.Connection -> GroupMember -> GroupMember -> IntroInvitation -> ExceptT StoreError IO GroupMemberIntro -saveIntroInvitation db reMember toMember introInv = do +saveIntroInvitation db reMember toMember introInv@IntroInvitation {groupConnReq} = do intro <- getIntroduction db reMember toMember liftIO $ do currentTs <- getCurrentTime @@ -1056,7 +1055,7 @@ saveIntroInvitation db reMember toMember introInv = do WHERE group_member_intro_id = :intro_id |] [ ":intro_status" := GMIntroInvReceived, - ":group_queue_info" := introInv.groupConnReq, + ":group_queue_info" := groupConnReq, ":direct_queue_info" := directConnReq introInv, ":updated_at" := currentTs, ":intro_id" := introId intro diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index de2dfa8b5..dd832d6fa 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -9,7 +9,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -61,21 +60,21 @@ class IsContact a where preferences' :: a -> Maybe Preferences instance IsContact User where - contactId' u = u.userContactId + contactId' User {userContactId} = userContactId {-# INLINE contactId' #-} - profile' u = u.profile + profile' User {profile} = profile {-# INLINE profile' #-} - localDisplayName' u = u.localDisplayName + localDisplayName' User {localDisplayName} = localDisplayName {-# INLINE localDisplayName' #-} preferences' User {profile = LocalProfile {preferences}} = preferences {-# INLINE preferences' #-} instance IsContact Contact where - contactId' c = c.contactId + contactId' Contact {contactId} = contactId {-# INLINE contactId' #-} - profile' c = c.profile + profile' Contact {profile} = profile {-# INLINE profile' #-} - localDisplayName' c = c.localDisplayName + localDisplayName' Contact {localDisplayName} = localDisplayName {-# INLINE localDisplayName' #-} preferences' Contact {profile = LocalProfile {preferences}} = preferences {-# INLINE preferences' #-} @@ -196,7 +195,7 @@ directOrUsed ct@Contact {contactUsed} = contactDirect ct || contactUsed anyDirectOrUsed :: Contact -> Bool -anyDirectOrUsed Contact {contactUsed, activeConn} = ((\c -> c.connLevel) <$> activeConn) == Just 0 || contactUsed +anyDirectOrUsed Contact {contactUsed, activeConn} = ((\Connection {connLevel} -> connLevel) <$> activeConn) == Just 0 || contactUsed contactReady :: Contact -> Bool contactReady Contact {activeConn} = maybe False connReady activeConn diff --git a/src/Simplex/Chat/Types/Preferences.hs b/src/Simplex/Chat/Types/Preferences.hs index 5c79680c5..2286ae8f4 100644 --- a/src/Simplex/Chat/Types/Preferences.hs +++ b/src/Simplex/Chat/Types/Preferences.hs @@ -7,7 +7,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -79,12 +78,12 @@ allChatFeatures = ] chatPrefSel :: SChatFeature f -> Preferences -> Maybe (FeaturePreference f) -chatPrefSel f ps = case f of - SCFTimedMessages -> ps.timedMessages - SCFFullDelete -> ps.fullDelete - SCFReactions -> ps.reactions - SCFVoice -> ps.voice - SCFCalls -> ps.calls +chatPrefSel f Preferences {timedMessages, fullDelete, reactions, voice, calls} = case f of + SCFTimedMessages -> timedMessages + SCFFullDelete -> fullDelete + SCFReactions -> reactions + SCFVoice -> voice + SCFCalls -> calls chatFeature :: SChatFeature f -> ChatFeature chatFeature = \case @@ -104,12 +103,12 @@ instance PreferenceI (Maybe Preferences) where getPreference f prefs = fromMaybe (getPreference f defaultChatPrefs) (chatPrefSel f =<< prefs) instance PreferenceI FullPreferences where - getPreference f ps = case f of - SCFTimedMessages -> ps.timedMessages - SCFFullDelete -> ps.fullDelete - SCFReactions -> ps.reactions - SCFVoice -> ps.voice - SCFCalls -> ps.calls + getPreference f FullPreferences {timedMessages, fullDelete, reactions, voice, calls} = case f of + SCFTimedMessages -> timedMessages + SCFFullDelete -> fullDelete + SCFReactions -> reactions + SCFVoice -> voice + SCFCalls -> calls {-# INLINE getPreference #-} setPreference :: forall f. FeatureI f => SChatFeature f -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences @@ -196,14 +195,14 @@ allGroupFeatures = ] groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f) -groupPrefSel f ps = case f of - SGFTimedMessages -> ps.timedMessages - SGFDirectMessages -> ps.directMessages - SGFFullDelete -> ps.fullDelete - SGFReactions -> ps.reactions - SGFVoice -> ps.voice - SGFFiles -> ps.files - SGFHistory -> ps.history +groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, history} = case f of + SGFTimedMessages -> timedMessages + SGFDirectMessages -> directMessages + SGFFullDelete -> fullDelete + SGFReactions -> reactions + SGFVoice -> voice + SGFFiles -> files + SGFHistory -> history toGroupFeature :: SGroupFeature f -> GroupFeature toGroupFeature = \case @@ -225,14 +224,14 @@ instance GroupPreferenceI (Maybe GroupPreferences) where getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt =<< prefs) instance GroupPreferenceI FullGroupPreferences where - getGroupPreference f ps = case f of - SGFTimedMessages -> ps.timedMessages - SGFDirectMessages -> ps.directMessages - SGFFullDelete -> ps.fullDelete - SGFReactions -> ps.reactions - SGFVoice -> ps.voice - SGFFiles -> ps.files - SGFHistory -> ps.history + getGroupPreference f FullGroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, history} = case f of + SGFTimedMessages -> timedMessages + SGFDirectMessages -> directMessages + SGFFullDelete -> fullDelete + SGFReactions -> reactions + SGFVoice -> voice + SGFFiles -> files + SGFHistory -> history {-# INLINE getGroupPreference #-} -- collection of optional group preferences @@ -382,19 +381,19 @@ class (Eq (FeaturePreference f), HasField "allow" (FeaturePreference f) FeatureA prefParam :: FeaturePreference f -> Maybe Int instance HasField "allow" TimedMessagesPreference FeatureAllowed where - hasField p = (\allow -> p {allow}, p.allow) + hasField p@TimedMessagesPreference {allow} = (\a -> p {allow = a}, allow) instance HasField "allow" FullDeletePreference FeatureAllowed where - hasField p = (\allow -> p {allow}, p.allow) + hasField p@FullDeletePreference {allow} = (\a -> p {allow = a}, allow) instance HasField "allow" ReactionsPreference FeatureAllowed where - hasField p = (\allow -> p {allow}, p.allow) + hasField p@ReactionsPreference {allow} = (\a -> p {allow = a}, allow) instance HasField "allow" VoicePreference FeatureAllowed where - hasField p = (\allow -> p {allow}, p.allow) + hasField p@VoicePreference {allow} = (\a -> p {allow = a}, allow) instance HasField "allow" CallsPreference FeatureAllowed where - hasField p = (\allow -> p {allow}, p.allow) + hasField p@CallsPreference {allow} = (\a -> p {allow = a}, allow) instance FeatureI 'CFTimedMessages where type FeaturePreference 'CFTimedMessages = TimedMessagesPreference @@ -461,28 +460,28 @@ class (Eq (GroupFeaturePreference f), HasField "enable" (GroupFeaturePreference groupPrefParam :: GroupFeaturePreference f -> Maybe Int instance HasField "enable" GroupPreference GroupFeatureEnabled where - hasField p = (\enable -> p {enable}, p.enable) + hasField p@GroupPreference {enable} = (\e -> p {enable = e}, enable) instance HasField "enable" TimedMessagesGroupPreference GroupFeatureEnabled where - hasField p = (\enable -> p {enable}, p.enable) + hasField p@TimedMessagesGroupPreference {enable} = (\e -> p {enable = e}, enable) instance HasField "enable" DirectMessagesGroupPreference GroupFeatureEnabled where - hasField p = (\enable -> p {enable}, p.enable) + hasField p@DirectMessagesGroupPreference {enable} = (\e -> p {enable = e}, enable) instance HasField "enable" ReactionsGroupPreference GroupFeatureEnabled where - hasField p = (\enable -> p {enable}, p.enable) + hasField p@ReactionsGroupPreference {enable} = (\e -> p {enable = e}, enable) instance HasField "enable" FullDeleteGroupPreference GroupFeatureEnabled where - hasField p = (\enable -> p {enable}, p.enable) + hasField p@FullDeleteGroupPreference {enable} = (\e -> p {enable = e}, enable) instance HasField "enable" VoiceGroupPreference GroupFeatureEnabled where - hasField p = (\enable -> p {enable}, p.enable) + hasField p@VoiceGroupPreference {enable} = (\e -> p {enable = e}, enable) instance HasField "enable" FilesGroupPreference GroupFeatureEnabled where - hasField p = (\enable -> p {enable}, p.enable) + hasField p@FilesGroupPreference {enable} = (\e -> p {enable = e}, enable) instance HasField "enable" HistoryGroupPreference GroupFeatureEnabled where - hasField p = (\enable -> p {enable}, p.enable) + hasField p@HistoryGroupPreference {enable} = (\e -> p {enable = e}, enable) instance GroupFeatureI 'GFTimedMessages where type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference @@ -720,12 +719,12 @@ preferenceState pref = in (allow, param) getContactUserPreference :: SChatFeature f -> ContactUserPreferences -> ContactUserPreference (FeaturePreference f) -getContactUserPreference f ps = case f of - SCFTimedMessages -> ps.timedMessages - SCFFullDelete -> ps.fullDelete - SCFReactions -> ps.reactions - SCFVoice -> ps.voice - SCFCalls -> ps.calls +getContactUserPreference f ContactUserPreferences {timedMessages, fullDelete, reactions, voice, calls} = case f of + SCFTimedMessages -> timedMessages + SCFFullDelete -> fullDelete + SCFReactions -> reactions + SCFVoice -> voice + SCFCalls -> calls $(J.deriveJSON (enumJSON $ dropPrefix "CF") ''ChatFeature) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index b0408690a..bc1743276 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -3,7 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -212,7 +211,9 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRContactConnecting u _ -> ttyUser u [] CRContactConnected u ct userCustomProfile -> ttyUser u $ viewContactConnected ct userCustomProfile testView CRContactAnotherClient u c -> ttyUser u [ttyContact' c <> ": contact is connected to another client"] - CRSubscriptionEnd u acEntity -> ttyUser u [sShow ((entityConnection acEntity).connId) <> ": END"] + CRSubscriptionEnd u acEntity -> + let Connection {connId} = entityConnection acEntity + in ttyUser u [sShow connId <> ": END"] CRContactsDisconnected srv cs -> [plain $ "server disconnected " <> showSMPServer srv <> " (" <> contactList cs <> ")"] CRContactsSubscribed srv cs -> [plain $ "server connected " <> showSMPServer srv <> " (" <> contactList cs <> ")"] CRContactSubError u c e -> ttyUser u [ttyContact' c <> ": contact error " <> sShow e] @@ -494,7 +495,7 @@ viewGroupSubscribed :: GroupInfo -> [StyledString] viewGroupSubscribed g = [membershipIncognito g <> ttyFullGroup g <> ": connected to server(s)"] showSMPServer :: SMPServer -> String -showSMPServer srv = B.unpack $ strEncode srv.host +showSMPServer ProtocolServer {host} = B.unpack $ strEncode host viewHostEvent :: AProtocolType -> TransportHost -> String viewHostEvent p h = map toUpper (B.unpack $ strEncode p) <> " host " <> B.unpack (strEncode h) @@ -953,7 +954,7 @@ viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filt removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft groupMember m = memIncognito m <> ttyFullMember m <> ": " <> plain (intercalate ", " $ [role m] <> category m <> status m <> muted m) role :: GroupMember -> String - role m = B.unpack . strEncode $ m.memberRole + role GroupMember {memberRole} = B.unpack $ strEncode memberRole category m = case memberCategory m of GCUserMember -> ["you"] GCInviteeMember -> ["invited"] @@ -991,7 +992,7 @@ viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g Text - ldn_ g = T.toLower g.localDisplayName + ldn_ GroupInfo {localDisplayName} = T.toLower localDisplayName groupSS (g@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}}, GroupSummary {currentMembers}) = case memberStatus membership of GSMemInvited -> groupInvitation' g @@ -1906,7 +1907,7 @@ viewChatError logLevel testView = \case "[" <> connEntityLabel entity <> ", userContactLinkId: " <> sShow userContactLinkId <> ", connId: " <> cId conn <> "] " Nothing -> "" cId :: Connection -> StyledString - cId conn = sShow conn.connId + cId Connection {connId} = sShow connId ChatErrorRemoteCtrl e -> [plain $ "remote controller error: " <> show e] ChatErrorRemoteHost RHNew e -> [plain $ "new remote host error: " <> show e] ChatErrorRemoteHost (RHId rhId) e -> [plain $ "remote host " <> show rhId <> " error: " <> show e] diff --git a/tests/Bots/BroadcastTests.hs b/tests/Bots/BroadcastTests.hs index ed0b9e069..6eee414c3 100644 --- a/tests/Bots/BroadcastTests.hs +++ b/tests/Bots/BroadcastTests.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} module Bots.BroadcastTests where @@ -13,7 +12,7 @@ import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Exception (bracket) import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Core -import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) +import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Types (Profile (..)) import System.FilePath (()) import Test.Hspec @@ -34,7 +33,7 @@ broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadc mkBotOpts :: FilePath -> [KnownContact] -> BroadcastBotOpts mkBotOpts tmp publishers = BroadcastBotOpts - { coreOptions = testOpts.coreOptions {dbFilePrefix = tmp botDbPrefix}, + { coreOptions = testCoreOpts {dbFilePrefix = tmp botDbPrefix}, publishers, welcomeMessage = defaultWelcomeMessage publishers, prohibitedMessage = defaultWelcomeMessage publishers diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 3c6991bb5..4ddf9fff1 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PostfixOperators #-} @@ -19,7 +18,7 @@ import GHC.IO.Handle (hClose) import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Controller (ChatConfig (..)) import Simplex.Chat.Core -import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) +import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Types (GroupMemberRole (..), Profile (..)) import System.FilePath (()) import Test.Hspec @@ -64,7 +63,7 @@ directoryProfile = Profile {displayName = "SimpleX-Directory", fullName = "", im mkDirectoryOpts :: FilePath -> [KnownContact] -> DirectoryOpts mkDirectoryOpts tmp superUsers = DirectoryOpts - { coreOptions = testOpts.coreOptions {dbFilePrefix = tmp serviceDbPrefix}, + { coreOptions = testCoreOpts {dbFilePrefix = tmp serviceDbPrefix}, superUsers, directoryLog = Just $ tmp "directory_service.log", serviceName = "SimpleX-Directory", diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index d2165db04..942f43bbe 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -58,22 +58,7 @@ serverPort = "7001" testOpts :: ChatOpts testOpts = ChatOpts - { coreOptions = - CoreChatOpts - { dbFilePrefix = undefined, - dbKey = "", - -- dbKey = "this is a pass-phrase to encrypt the database", - smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"], - xftpServers = ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"], - networkConfig = defaultNetworkConfig, - logLevel = CLLImportant, - logConnections = False, - logServerHosts = False, - logAgent = Nothing, - logFile = Nothing, - tbqSize = 16, - highlyAvailable = False - }, + { coreOptions = testCoreOpts, deviceName = Nothing, chatCmd = "", chatCmdDelay = 3, @@ -87,8 +72,25 @@ testOpts = maintenance = False } +testCoreOpts :: CoreChatOpts +testCoreOpts = CoreChatOpts + { dbFilePrefix = undefined, + dbKey = "", + -- dbKey = "this is a pass-phrase to encrypt the database", + smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"], + xftpServers = ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"], + networkConfig = defaultNetworkConfig, + logLevel = CLLImportant, + logConnections = False, + logServerHosts = False, + logAgent = Nothing, + logFile = Nothing, + tbqSize = 16, + highlyAvailable = False + } + getTestOpts :: Bool -> ScrubbedBytes -> ChatOpts -getTestOpts maintenance dbKey = testOpts {maintenance, coreOptions = (coreOptions testOpts) {dbKey}} +getTestOpts maintenance dbKey = testOpts {maintenance, coreOptions = testCoreOpts {dbKey}} termSettings :: VirtualTerminalSettings termSettings =