IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: compatibility with GHC 8.10.7 (#3608)

Browse Source 
* 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>
This commit is contained in:
Alexander Bondarenko 2023-12-29 23:15:14 +02:00 committed by GitHub
parent 478bb32cdb
commit e253c55ba4
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
15 changed files with 207 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
.github/workflows/build.yml vendored
View File

@ -42,7 +42,7 @@ jobs:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
build: build:
name: build-${{ matrix.os }} name: build-${{ matrix.os }}-${{ matrix.ghc }}
if: always() if: always()
needs: prepare-release needs: prepare-release
runs-on: ${{ matrix.os }} runs-on: ${{ matrix.os }}
@ -51,18 +51,25 @@ jobs:
matrix: matrix:
include: include:
- os: ubuntu-20.04 - os: ubuntu-20.04
ghc: "8.10.7"
cache_path: ~/.cabal/store
- os: ubuntu-20.04
ghc: "9.6.3"
cache_path: ~/.cabal/store cache_path: ~/.cabal/store
asset_name: simplex-chat-ubuntu-20_04-x86-64 asset_name: simplex-chat-ubuntu-20_04-x86-64
desktop_asset_name: simplex-desktop-ubuntu-20_04-x86_64.deb desktop_asset_name: simplex-desktop-ubuntu-20_04-x86_64.deb
- os: ubuntu-22.04 - os: ubuntu-22.04
ghc: "9.6.3"
cache_path: ~/.cabal/store cache_path: ~/.cabal/store
asset_name: simplex-chat-ubuntu-22_04-x86-64 asset_name: simplex-chat-ubuntu-22_04-x86-64
desktop_asset_name: simplex-desktop-ubuntu-22_04-x86_64.deb desktop_asset_name: simplex-desktop-ubuntu-22_04-x86_64.deb
- os: macos-latest - os: macos-latest
ghc: "9.6.3"
cache_path: ~/.cabal/store cache_path: ~/.cabal/store
asset_name: simplex-chat-macos-x86-64 asset_name: simplex-chat-macos-x86-64
desktop_asset_name: simplex-desktop-macos-x86_64.dmg desktop_asset_name: simplex-desktop-macos-x86_64.dmg
- os: windows-latest - os: windows-latest
ghc: "9.6.3"
cache_path: C:/cabal cache_path: C:/cabal
asset_name: simplex-chat-windows-x86-64 asset_name: simplex-chat-windows-x86-64
desktop_asset_name: simplex-desktop-windows-x86_64.msi desktop_asset_name: simplex-desktop-windows-x86_64.msi
@ -81,16 +88,17 @@ jobs:
- name: Setup Haskell - name: Setup Haskell
uses: haskell-actions/setup@v2 uses: haskell-actions/setup@v2
with: with:
ghc-version: "9.6.3" ghc-version: ${{ matrix.ghc }}
cabal-version: "3.10.1.0" cabal-version: "3.10.1.0"
- name: Cache dependencies - name: Restore cached build
uses: actions/cache@v3 id: restore_cache
uses: actions/cache/restore@v3
with: with:
path: | path: |
${{ matrix.cache_path }} ${{ matrix.cache_path }}
dist-newstyle dist-newstyle
key: ${{ matrix.os }}-${{ hashFiles('cabal.project', 'simplex-chat.cabal') }} key: ${{ matrix.os }}-ghc${{ matrix.ghc }}-${{ hashFiles('cabal.project', 'simplex-chat.cabal') }}
# / Unix # / Unix
@ -105,7 +113,7 @@ jobs:
echo " flags: +openssl" >> cabal.project.local echo " flags: +openssl" >> cabal.project.local
- name: Install AppImage dependencies - 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 run: sudo apt install -y desktop-file-utils
- name: Install pkg-config for Mac - 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 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 - 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 uses: svenstaro/upload-release-action@v2
with: with:
repo_token: ${{ secrets.GITHUB_TOKEN }} repo_token: ${{ secrets.GITHUB_TOKEN }}
@ -140,7 +148,7 @@ jobs:
tag: ${{ github.ref }} tag: ${{ github.ref }}
- name: Unix update CLI binary hash - 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 uses: softprops/action-gh-release@v1
env: env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
@ -150,7 +158,7 @@ jobs:
${{ steps.unix_cli_build.outputs.bin_hash }} ${{ steps.unix_cli_build.outputs.bin_hash }}
- name: Setup Java - 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 uses: actions/setup-java@v3
with: with:
distribution: 'corretto' distribution: 'corretto'
@ -159,7 +167,7 @@ jobs:
- name: Linux build desktop - name: Linux build desktop
id: linux_desktop_build 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 shell: bash
run: | run: |
scripts/desktop/build-lib-linux.sh scripts/desktop/build-lib-linux.sh
@ -168,10 +176,10 @@ jobs:
path=$(echo $PWD/release/main/deb/simplex_*_amd64.deb) path=$(echo $PWD/release/main/deb/simplex_*_amd64.deb)
echo "package_path=$path" >> $GITHUB_OUTPUT 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 echo "package_hash=$(echo SHA2-512\(${{ matrix.desktop_asset_name }}\)= $(openssl sha512 $path | cut -d' ' -f 2))" >> $GITHUB_OUTPUT
- name: Linux make AppImage - name: Linux make AppImage
id: linux_appimage_build 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 shell: bash
run: | run: |
scripts/desktop/make-appimage-linux.sh 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 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 - 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 uses: svenstaro/upload-release-action@v2
with: with:
repo_token: ${{ secrets.GITHUB_TOKEN }} repo_token: ${{ secrets.GITHUB_TOKEN }}
@ -203,7 +211,7 @@ jobs:
tag: ${{ github.ref }} tag: ${{ github.ref }}
- name: Linux update desktop package hash - 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 uses: softprops/action-gh-release@v1
env: env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
@ -213,7 +221,7 @@ jobs:
${{ steps.linux_desktop_build.outputs.package_hash }} ${{ steps.linux_desktop_build.outputs.package_hash }}
- name: Linux upload AppImage to release - 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 uses: svenstaro/upload-release-action@v2
with: with:
repo_token: ${{ secrets.GITHUB_TOKEN }} repo_token: ${{ secrets.GITHUB_TOKEN }}
@ -222,7 +230,7 @@ jobs:
tag: ${{ github.ref }} tag: ${{ github.ref }}
- name: Linux update AppImage hash - 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 uses: softprops/action-gh-release@v1
env: env:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
@ -250,6 +258,15 @@ jobs:
body: | body: |
${{ steps.mac_desktop_build.outputs.package_hash }} ${{ 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 - name: Unix test
if: matrix.os != 'windows-latest' if: matrix.os != 'windows-latest'
timeout-minutes: 30 timeout-minutes: 30
@ -330,7 +347,7 @@ jobs:
path=$(echo $PWD/release/main/msi/*imple*.msi | sed 's#/\([a-z]\)#\1:#' | sed 's#/#\\#g') path=$(echo $PWD/release/main/msi/*imple*.msi | sed 's#/\([a-z]\)#\1:#' | sed 's#/#\\#g')
echo "package_path=$path" >> $GITHUB_OUTPUT 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 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 - name: Windows upload desktop package to release
if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'windows-latest' if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'windows-latest'
uses: svenstaro/upload-release-action@v2 uses: svenstaro/upload-release-action@v2
@ -350,4 +367,13 @@ jobs:
body: | body: |
${{ steps.windows_desktop_build.outputs.package_hash }} ${{ 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 / # Windows /

2
cabal.project
View File

@ -2,8 +2,6 @@ packages: .
-- packages: . ../simplexmq -- packages: . ../simplexmq
-- packages: . ../simplexmq ../direct-sqlcipher ../sqlcipher-simple -- packages: . ../simplexmq ../direct-sqlcipher ../sqlcipher-simple
with-compiler: ghc-9.6.3
index-state: 2023-12-12T00:00:00Z index-state: 2023-12-12T00:00:00Z
package cryptostore package cryptostore

127
src/Simplex/Chat.hs
View File

@ -5,7 +5,6 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -279,8 +278,9 @@ newChatController
where where
configServers :: DefaultAgentServers configServers :: DefaultAgentServers
configServers = configServers =
let smp' = fromMaybe (defaultServers.smp) (nonEmpty smpServers) let DefaultAgentServers {smp = defSmp, xftp = defXftp} = defaultServers
xftp' = fromMaybe (defaultServers.xftp) (nonEmpty xftpServers) smp' = fromMaybe defSmp (nonEmpty smpServers)
xftp' = fromMaybe defXftp (nonEmpty xftpServers)
in defaultServers {smp = smp', xftp = xftp', netCfg = networkConfig} in defaultServers {smp = smp', xftp = xftp', netCfg = networkConfig}
agentServers :: ChatConfig -> IO InitialAgentServers agentServers :: ChatConfig -> IO InitialAgentServers
agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do
@ -307,9 +307,9 @@ activeAgentServers ChatConfig {defaultServers} p =
. filter (\ServerCfg {enabled} -> enabled) . filter (\ServerCfg {enabled} -> enabled)
cfgServers :: UserProtocol p => SProtocolType p -> (DefaultAgentServers -> NonEmpty (ProtoServerWithAuth p)) cfgServers :: UserProtocol p => SProtocolType p -> (DefaultAgentServers -> NonEmpty (ProtoServerWithAuth p))
cfgServers p s = case p of cfgServers p DefaultAgentServers {smp, xftp} = case p of
SPSMP -> s.smp SPSMP -> smp
SPXFTP -> s.xftp SPXFTP -> xftp
startChatController :: forall m. ChatMonad' m => Bool -> Bool -> Bool -> m (Async ()) startChatController :: forall m. ChatMonad' m => Bool -> Bool -> Bool -> m (Async ())
startChatController subConns enableExpireCIs startXFTPWorkers = do startChatController subConns enableExpireCIs startXFTPWorkers = do
@ -971,7 +971,8 @@ processChatCommand' vr = \case
pure $ CRContactConnectionDeleted user conn pure $ CRContactConnectionDeleted user conn
CTGroup -> do CTGroup -> do
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user chatId 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) canDelete = isOwner || not (memberCurrent membership)
unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner
filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo
@ -1611,11 +1612,12 @@ processChatCommand' vr = \case
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db vr user groupId inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db vr user groupId
(inv,) <$> getContactViaMember db user fromMember (inv,) <$> getContactViaMember db user fromMember
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation
GroupMember {memberId = membershipMemId} = membership
Contact {activeConn} = ct Contact {activeConn} = ct
case activeConn of case activeConn of
Just Connection {peerChatVRange} -> do Just Connection {peerChatVRange} -> do
subMode <- chatReadVar subscriptionMode subMode <- chatReadVar subscriptionMode
dm <- directMessage $ XGrpAcpt membership.memberId dm <- directMessage $ XGrpAcpt membershipMemId
agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm subMode agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm subMode
withStore' $ \db -> do withStore' $ \db -> do
createMemberConnection db userId fromMember agentConnId (fromJVersionRange peerChatVRange) subMode createMemberConnection db userId fromMember agentConnId (fromJVersionRange peerChatVRange) subMode
@ -1767,12 +1769,12 @@ processChatCommand' vr = \case
pure $ CRNewMemberContact user ct g m pure $ CRNewMemberContact user ct g m
_ -> throwChatError CEGroupMemberNotActive _ -> throwChatError CEGroupMemberNotActive
APISendMemberContactInvitation contactId msgContent_ -> withUser $ \user -> do 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" when (contactGrpInvSent ct) $ throwChatError $ CECommandError "x.grp.direct.inv already sent"
case memberConn m of case memberConn m of
Just mConn -> do Just mConn -> do
let msg = XGrpDirectInv cReq msgContent_ let msg = XGrpDirectInv cReq msgContent_
(sndMsg, _) <- sendDirectMessage mConn msg (GroupId $ g.groupId) (sndMsg, _) <- sendDirectMessage mConn msg $ GroupId groupId
withStore' $ \db -> setContactGrpInvSent db ct True withStore' $ \db -> setContactGrpInvSent db ct True
let ct' = ct {contactGrpInvSent = True} let ct' = ct {contactGrpInvSent = True}
forM_ msgContent_ $ \mc -> do forM_ msgContent_ $ \mc -> do
@ -2191,7 +2193,8 @@ processChatCommand' vr = \case
when (displayName /= validName) $ throwChatError CEInvalidDisplayName {displayName, validName} when (displayName /= validName) $ throwChatError CEInvalidDisplayName {displayName, validName}
assertUserGroupRole :: GroupInfo -> GroupMemberRole -> m () assertUserGroupRole :: GroupInfo -> GroupMemberRole -> m ()
assertUserGroupRole g@GroupInfo {membership} requiredRole = do 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 (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g)
when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved
unless (memberActive membership) $ throwChatError CEGroupMemberNotActive unless (memberActive membership) $ throwChatError CEGroupMemberNotActive
@ -2235,7 +2238,7 @@ processChatCommand' vr = \case
forwardFile chatName fileId sendCommand = withUser $ \user -> do forwardFile chatName fileId sendCommand = withUser $ \user -> do
withStore (\db -> getFileTransfer db user fileId) >>= \case withStore (\db -> getFileTransfer db user fileId) >>= \case
FTRcv RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}, cryptoArgs} -> forward filePath cryptoArgs 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} _ -> throwChatError CEFileNotReceived {fileId}
where where
forward path cfArgs = processChatCommand . sendCommand chatName $ CryptoFile path cfArgs forward path cfArgs = processChatCommand . sendCommand chatName $ CryptoFile path cfArgs
@ -2327,7 +2330,7 @@ processChatCommand' vr = \case
_ -> throwChatError $ CECommandError "not supported" _ -> throwChatError $ CECommandError "not supported"
processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings
connectPlan :: User -> AConnectionRequestUri -> m ConnectionPlan 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 withStore' (\db -> getConnectionEntityByConnReq db vr user cReqSchemas) >>= \case
Nothing -> pure $ CPInvitationLink ILPOk Nothing -> pure $ CPInvitationLink ILPOk
Just (RcvDirectMsgConnection conn ct_) -> do Just (RcvDirectMsgConnection conn ct_) -> do
@ -2343,13 +2346,12 @@ processChatCommand' vr = \case
Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection" Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection"
where where
cReqSchemas :: (ConnReqInvitation, ConnReqInvitation) cReqSchemas :: (ConnReqInvitation, ConnReqInvitation)
cReqSchemas = case cReq of cReqSchemas =
(CRInvitationUri crData e2e) -> ( CRInvitationUri crData {crScheme = CRSSimplex} e2e,
( CRInvitationUri crData {crScheme = CRSSimplex} e2e, CRInvitationUri crData {crScheme = simplexChat} e2e
CRInvitationUri crData {crScheme = simplexChat} e2e )
) connectPlan user (ACR SCMContact (CRContactUri crData)) = do
connectPlan user (ACR SCMContact cReq) = do let ConnReqUriData {crClientData} = crData
let CRContactUri ConnReqUriData {crClientData} = cReq
groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli
case groupLinkId of case groupLinkId of
-- contact address -- contact address
@ -2389,11 +2391,10 @@ processChatCommand' vr = \case
| otherwise -> pure $ CPGroupLink GLPOk | otherwise -> pure $ CPGroupLink GLPOk
where where
cReqSchemas :: (ConnReqContact, ConnReqContact) cReqSchemas :: (ConnReqContact, ConnReqContact)
cReqSchemas = case cReq of cReqSchemas =
(CRContactUri crData) -> ( CRContactUri crData {crScheme = CRSSimplex},
( CRContactUri crData {crScheme = CRSSimplex}, CRContactUri crData {crScheme = simplexChat}
CRContactUri crData {crScheme = simplexChat} )
)
cReqHashes :: (ConnReqUriHash, ConnReqUriHash) cReqHashes :: (ConnReqUriHash, ConnReqUriHash)
cReqHashes = bimap hash hash cReqSchemas cReqHashes = bimap hash hash cReqSchemas
hash = ConnReqUriHash . C.sha256Hash . strEncode hash = ConnReqUriHash . C.sha256Hash . strEncode
@ -3561,9 +3562,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
case chatMsgEvent of case chatMsgEvent of
XGrpMemInfo memId _memProfile XGrpMemInfo memId _memProfile
| sameMemberId memId m -> do | sameMemberId memId m -> do
let GroupMember {memberId = membershipMemId} = membership
-- TODO update member profile -- TODO update member profile
-- [async agent commands] no continuation needed, but command should be asynchronous for stability -- [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" | otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
_ -> messageError "CONF from member must have x.grp.mem.info" _ -> messageError "CONF from member must have x.grp.mem.info"
INFO connInfo -> do INFO connInfo -> do
@ -3689,7 +3691,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
fInv = xftpFileInvitation fileName fileSize fInvDescr fInv = xftpFileInvitation fileName fileSize fInvDescr
in Just (fInv, fileDescrText) in Just (fInv, fileDescrText)
| otherwise = Nothing | 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_ = processContentItem sender ChatItem {meta, quotedItem} mc fInvDescr_ =
if isNothing fInvDescr_ && not (msgContentHasText mc) if isNothing fInvDescr_ && not (msgContentHasText mc)
then pure [] then pure []
@ -3724,17 +3726,18 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
when (memCategory == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True when (memCategory == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True
sendXGrpMemCon memCategory sendXGrpMemCon memCategory
where where
GroupMember {memberId} = m
sendXGrpMemCon = \case sendXGrpMemCon = \case
GCPreMember -> GCPreMember ->
forM_ (invitedByGroupMemberId membership) $ \hostId -> do forM_ (invitedByGroupMemberId membership) $ \hostId -> do
host <- withStore $ \db -> getGroupMember db user groupId hostId host <- withStore $ \db -> getGroupMember db user groupId hostId
forM_ (memberConn host) $ \hostConn -> forM_ (memberConn host) $ \hostConn ->
void $ sendDirectMessage hostConn (XGrpMemCon m.memberId) (GroupId groupId) void $ sendDirectMessage hostConn (XGrpMemCon memberId) (GroupId groupId)
GCPostMember -> GCPostMember ->
forM_ (invitedByGroupMemberId m) $ \invitingMemberId -> do forM_ (invitedByGroupMemberId m) $ \invitingMemberId -> do
im <- withStore $ \db -> getGroupMember db user groupId invitingMemberId im <- withStore $ \db -> getGroupMember db user groupId invitingMemberId
forM_ (memberConn im) $ \imConn -> 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" _ -> messageWarning "sendXGrpMemCon: member category GCPreMember or GCPostMember is expected"
MSG msgMeta _msgFlags msgBody -> do MSG msgMeta _msgFlags msgBody -> do
checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure () 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) Left e -> toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e)
checkSendRcpt $ rights aChatMsgs checkSendRcpt $ rights aChatMsgs
-- currently only a single message is forwarded -- 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 [Right (ACMsg _ chatMsg)] -> forwardMsg_ chatMsg
_ -> pure () _ -> pure ()
where where
@ -3807,8 +3811,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
else pure [] else pure []
-- invited members to which this member was introduced -- invited members to which this member was introduced
invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db user m highlyAvailable invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db user m highlyAvailable
let ms = introducedMembers <> invitedMembers let GroupMember {memberId} = m
msg = XGrpMsgForward m.memberId chatMsg' brokerTs ms = introducedMembers <> invitedMembers
msg = XGrpMsgForward memberId chatMsg' brokerTs
unless (null ms) . void $ unless (null ms) . void $
sendGroupMessage user gInfo ms msg sendGroupMessage user gInfo ms msg
RCVD msgMeta msgRcpt -> RCVD msgMeta msgRcpt ->
@ -4069,8 +4074,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
_ -> toView $ CRReceivedContactRequest user cReq _ -> toView $ CRReceivedContactRequest user cReq
memberCanSend :: GroupMember -> m () -> m () memberCanSend :: GroupMember -> m () -> m ()
memberCanSend mem a memberCanSend GroupMember {memberRole} a
| mem.memberRole <= GRObserver = messageError "member is not allowed to send messages" | memberRole <= GRObserver = messageError "member is not allowed to send messages"
| otherwise = a | otherwise = a
incAuthErrCounter :: ConnectionEntity -> Connection -> AgentErrorType -> m () 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 (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile -- [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) <- (gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db vr user ct inv customUserProfileId
withStore $ \db -> createGroupInvitation db vr user ct inv customUserProfileId let GroupMember {groupMemberId, memberId = membershipMemId} = membership
if sameGroupLinkId groupLinkId groupLinkId' if sameGroupLinkId groupLinkId groupLinkId'
then do then do
subMode <- chatReadVar subscriptionMode subMode <- chatReadVar subscriptionMode
dm <- directMessage $ XGrpAcpt memberId dm <- directMessage $ XGrpAcpt membershipMemId
connIds <- joinAgentConnectionAsync user True connRequest dm subMode connIds <- joinAgentConnectionAsync user True connRequest dm subMode
withStore' $ \db -> do withStore' $ \db -> do
setViaGroupLinkHash db groupId connId setViaGroupLinkHash db groupId connId
@ -5128,6 +5133,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m () xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m ()
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
let GroupMember {memberId = membershipMemId} = membership
checkHostRole m memRole checkHostRole m memRole
toMember <- toMember <-
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db user gInfo memId) >>= \case 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 withStore' $ \db -> saveMemberInvitation db toMember introInv
subMode <- chatReadVar subscriptionMode subMode <- chatReadVar subscriptionMode
-- [incognito] send membership incognito profile, create direct connection as incognito -- [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 -- [async agent commands] no continuation needed, but commands should be asynchronous for stability
groupConnIds <- joinAgentConnectionAsync user (chatHasNtfs chatSettings) groupConnReq dm subMode groupConnIds <- joinAgentConnectionAsync user (chatHasNtfs chatSettings) groupConnReq dm subMode
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user True dcr 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 :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> m ()
xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg brokerTs xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg brokerTs
| membership.memberId == memId = | membershipMemId == memId =
let gInfo' = gInfo {membership = membership {memberRole = memRole}} let gInfo' = gInfo {membership = membership {memberRole = memRole}}
in changeMemberRole gInfo' membership $ RGEUserRole memRole in changeMemberRole gInfo' membership $ RGEUserRole memRole
| otherwise = | 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 Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole
Left _ -> messageError "x.grp.mem.role with unknown member ID" Left _ -> messageError "x.grp.mem.role with unknown member ID"
where where
GroupMember {memberId = membershipMemId} = membership
changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} gEvent changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} gEvent
| senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions" | senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions"
| otherwise = do | otherwise = do
@ -5211,7 +5218,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> UTCTime -> m () xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> UTCTime -> m ()
xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId msg brokerTs = do 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 then checkRole membership $ do
deleteGroupLinkIfExists user gInfo deleteGroupLinkIfExists user gInfo
-- member records are not deleted to keep history -- 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 createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing
xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> ChatMessage 'Json -> UTCTime -> m () xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> ChatMessage 'Json -> UTCTime -> m ()
xGrpMsgForward gInfo@GroupInfo {groupId} m memberId msg msgTs = do xGrpMsgForward gInfo@GroupInfo {groupId} m@GroupMember {memberRole, localDisplayName} memberId msg msgTs = do
when (m.memberRole < GRAdmin) $ throwChatError (CEGroupContactRole m.localDisplayName) when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole localDisplayName)
author <- withStore $ \db -> getGroupMemberByMemberId db user gInfo memberId author <- withStore $ \db -> getGroupMemberByMemberId db user gInfo memberId
processForwardedMsg author msg processForwardedMsg author msg
where where
@ -5501,7 +5509,7 @@ parseFileChunk :: ChatMonad m => ByteString -> m FileChunk
parseFileChunk = liftEither . first (ChatError . CEFileRcvChunk) . smpDecode parseFileChunk = liftEither . first (ChatError . CEFileRcvChunk) . smpDecode
appendFileChunk :: forall m. ChatMonad m => RcvFileTransfer -> Integer -> ByteString -> Bool -> m () 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 case fileStatus of
RFSConnected RcvFileInfo {filePath} -> append_ filePath RFSConnected RcvFileInfo {filePath} -> append_ filePath
-- sometimes update of file transfer status to FSConnected -- sometimes update of file transfer status to FSConnected
@ -5519,7 +5527,7 @@ appendFileChunk ft@RcvFileTransfer {fileId, fileStatus, cryptoArgs} chunkNo chun
when final $ do when final $ do
closeFileHandle fileId rcvFiles closeFileHandle fileId rcvFiles
forM_ cryptoArgs $ \cfArgs -> do forM_ cryptoArgs $ \cfArgs -> do
tmpFile <- getChatTempDirectory >>= (`uniqueCombine` ft.fileInvitation.fileName) tmpFile <- getChatTempDirectory >>= (`uniqueCombine` fileName)
tryChatError (liftError encryptErr $ encryptFile fsFilePath tmpFile cfArgs) >>= \case tryChatError (liftError encryptErr $ encryptFile fsFilePath tmpFile cfArgs) >>= \case
Right () -> do Right () -> do
removeFile fsFilePath `catchChatError` \_ -> pure () removeFile fsFilePath `catchChatError` \_ -> pure ()
@ -5734,7 +5742,7 @@ sendGroupMessage user GroupInfo {groupId} members chatMsgEvent = do
data MemberSendAction = MSASend Connection | MSAPending data MemberSendAction = MSASend Connection | MSAPending
memberSendAction :: ChatMsgEvent e -> [GroupMember] -> GroupMember -> Maybe MemberSendAction 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 Nothing -> pendingOrForwarded
Just conn@Connection {connStatus} Just conn@Connection {connStatus}
| connDisabled conn || connStatus == ConnDeleted -> Nothing | connDisabled conn || connStatus == ConnDeleted -> Nothing
@ -5749,7 +5757,7 @@ memberSendAction chatMsgEvent members m = case memberConn m of
forwardSupported = forwardSupported =
let mcvr = memberChatVRange' m let mcvr = memberChatVRange' m
in isCompatibleRange mcvr groupForwardVRange && invitingMemberSupportsForward in isCompatibleRange mcvr groupForwardVRange && invitingMemberSupportsForward
invitingMemberSupportsForward = case m.invitedByGroupMemberId of invitingMemberSupportsForward = case invitedByGroupMemberId of
Just invMemberId -> Just invMemberId ->
-- can be optimized for large groups by replacing [GroupMember] with Map GroupMemberId GroupMember -- can be optimized for large groups by replacing [GroupMember] with Map GroupMemberId GroupMember
case find (\m' -> groupMemberId' m' == invMemberId) members of 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 :: (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 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 let agentMsgId = fst $ recipient agentMsgMeta
newMsg = NewRcvMessage {chatMsgEvent, msgBody} newMsg = NewRcvMessage {chatMsgEvent, msgBody}
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId}
amId = Just am'.groupMemberId
msg <- 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 `catchChatError` \e -> case e of
ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do
fm <- withStore $ \db -> getGroupMember db user groupId forwardedByGroupMemberId fm <- withStore $ \db -> getGroupMember db user groupId forwardedByGroupMemberId
forM_ (memberConn fm) $ \fmConn -> forM_ (memberConn fm) $ \fmConn ->
void $ sendDirectMessage fmConn (XGrpMemCon am'.memberId) (GroupId groupId) void $ sendDirectMessage fmConn (XGrpMemCon amMemId) (GroupId groupId)
throwError e throwError e
_ -> throwError e _ -> throwError e
pure (am', conn', msg) pure (am', conn', msg)
saveGroupFwdRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> m RcvMessage 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} let newMsg = NewRcvMessage {chatMsgEvent, msgBody}
fwdMemberId = Just $ groupMemberId' forwardingMember fwdMemberId = Just $ groupMemberId' forwardingMember
refAuthorId = Just $ groupMemberId' refAuthorMember refAuthorId = Just $ groupMemberId' refAuthorMember
withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId) withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId)
`catchChatError` \e -> case e of `catchChatError` \e -> case e of
ChatErrorStore (SEDuplicateGroupMessage _ _ (Just authorGroupMemberId) Nothing) -> do ChatErrorStore (SEDuplicateGroupMessage _ _ (Just authorGroupMemberId) Nothing) -> do
am <- withStore $ \db -> getGroupMember db user groupId authorGroupMemberId am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db user groupId authorGroupMemberId
if sameMemberId refAuthorMember.memberId am if sameMemberId refMemberId am
then forM_ (memberConn forwardingMember) $ \fmConn -> 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" else toView $ CRMessageError user "error" "saveGroupFwdRcvMsg: referenced author member id doesn't match message member id"
throwError e throwError e
_ -> throwError e _ -> throwError e
@ -5977,7 +5984,9 @@ createSndFeatureItems :: forall m. ChatMonad m => User -> Contact -> Contact ->
createSndFeatureItems user ct ct' = createSndFeatureItems user ct ct' =
createFeatureItems user ct ct' CDDirectSnd CISndChatFeature CISndChatPreference getPref createFeatureItems user ct ct' CDDirectSnd CISndChatFeature CISndChatPreference getPref
where 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 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 Left e -> putStrLn ("database error " <> show e) >> exitFailure
Right user -> pure user Right user -> pure user
selectUser :: [User] -> IO User selectUser :: [User] -> IO User
selectUser [user] = do selectUser [user@User {userId}] = do
withTransaction st (`setActiveUser` user.userId) withTransaction st (`setActiveUser` userId)
pure user pure user
selectUser users = do selectUser users = do
putStrLn "Select user profile:" putStrLn "Select user profile:"
@ -6075,8 +6084,8 @@ getCreateActiveUser st testView = do
Just n Just n
| n <= 0 || n > length users -> putStrLn "invalid user number" >> loop | n <= 0 || n > length users -> putStrLn "invalid user number" >> loop
| otherwise -> do | otherwise -> do
let user = users !! (n - 1) let user@User {userId} = users !! (n - 1)
withTransaction st (`setActiveUser` user.userId) withTransaction st (`setActiveUser` userId)
pure user pure user
userStr :: User -> String userStr :: User -> String
userStr User {localDisplayName, profile = LocalProfile {fullName}} = userStr User {localDisplayName, profile = LocalProfile {fullName}} =

5
src/Simplex/Chat/Messages.hs
View File

@ -5,7 +5,6 @@
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
@ -345,7 +344,9 @@ contactTimedTTL Contact {mergedPreferences = ContactUserPreferences {timedMessag
| forUser enabled && forContact enabled = Just ttl | forUser enabled && forContact enabled = Just ttl
| otherwise = Nothing | otherwise = Nothing
where where
TimedMessagesPreference {ttl} = userPreference.preference TimedMessagesPreference {ttl} = case userPreference of
CUPContact {preference} -> preference
CUPUser {preference} -> preference
groupTimedTTL :: GroupInfo -> Maybe (Maybe Int) groupTimedTTL :: GroupInfo -> Maybe (Maybe Int)
groupTimedTTL GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}} groupTimedTTL GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}}

1
src/Simplex/Chat/Messages/Batch.hs
View File

@ -16,7 +16,6 @@ import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..))
import Simplex.Chat.Messages import Simplex.Chat.Messages
data MsgBatch = MsgBatch Builder [SndMessage] data MsgBatch = MsgBatch Builder [SndMessage]
deriving (Show)
-- | Batches [SndMessage] into batches of ByteString builders in form of JSON arrays. -- | Batches [SndMessage] into batches of ByteString builders in form of JSON arrays.
-- Does not check if the resulting batch is a valid JSON. -- Does not check if the resulting batch is a valid JSON.

6
src/Simplex/Chat/Mobile/Shared.hs
View File

@ -16,12 +16,12 @@ type JSONByteString = LB.ByteString
getByteString :: Ptr Word8 -> CInt -> IO ByteString getByteString :: Ptr Word8 -> CInt -> IO ByteString
getByteString ptr len = do getByteString ptr len = do
fp <- newForeignPtr_ ptr fp <- newForeignPtr_ ptr
pure $ BS fp $ fromIntegral len pure $ PS fp 0 (fromIntegral len)
{-# INLINE getByteString #-} {-# INLINE getByteString #-}
putByteString :: Ptr Word8 -> ByteString -> IO () putByteString :: Ptr Word8 -> ByteString -> IO ()
putByteString ptr (BS fp len) = putByteString ptr (PS fp offset len) =
withForeignPtr fp $ \p -> memcpy ptr p len withForeignPtr fp $ \p -> memcpy ptr (p `plusPtr` offset) len
{-# INLINE putByteString #-} {-# INLINE putByteString #-}
putLazyByteString :: Ptr Word8 -> LB.ByteString -> IO () putLazyByteString :: Ptr Word8 -> LB.ByteString -> IO ()

3
src/Simplex/Chat/Store/Direct.hs
View File

@ -2,7 +2,6 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -489,7 +488,7 @@ createOrUpdateContactRequest db user@User {userId} userContactLinkId invId (Vers
ExceptT $ ExceptT $
maybeM getContactRequestByXContactId xContactId_ >>= \case maybeM getContactRequestByXContactId xContactId_ >>= \case
Nothing -> createContactRequest Nothing -> createContactRequest
Just cr -> updateContactRequest cr $> Right cr.contactRequestId Just cr@UserContactRequest {contactRequestId} -> updateContactRequest cr $> Right contactRequestId
getContactRequest db user cReqId getContactRequest db user cReqId
createContactRequest :: IO (Either StoreError Int64) createContactRequest :: IO (Either StoreError Int64)
createContactRequest = do createContactRequest = do

3
src/Simplex/Chat/Store/Files.hs
View File

@ -2,7 +2,6 @@
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -929,7 +928,7 @@ getLocalCryptoFile db userId fileId sent =
_ -> do _ -> do
unless sent $ throwError $ SEFileNotFound fileId unless sent $ throwError $ SEFileNotFound fileId
FileTransferMeta {filePath, xftpSndFile} <- getFileTransferMeta_ db userId 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 :: forall d. MsgDirectionI d => DB.Connection -> VersionRange -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
updateDirectCIFileStatus db vr user fileId fileStatus = do updateDirectCIFileStatus db vr user fileId fileStatus = do

9
src/Simplex/Chat/Store/Groups.hs
View File

@ -2,7 +2,6 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-} {-# 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 -- | 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 :: DB.Connection -> VersionRange -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName 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 liftIO getInvitationGroupId_ >>= \case
Nothing -> createGroupInvitation_ Nothing -> createGroupInvitation_
Just gId -> do 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 (?,?,?,?,?,?,?,?,?)" "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) (profileId, localDisplayName, connRequest, customUserProfileId, userId, True, currentTs, currentTs, currentTs)
insertedRowId db 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 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 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} 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] [":intro_status" := introStatus, ":updated_at" := currentTs, ":intro_id" := introId]
saveIntroInvitation :: DB.Connection -> GroupMember -> GroupMember -> IntroInvitation -> ExceptT StoreError IO GroupMemberIntro 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 intro <- getIntroduction db reMember toMember
liftIO $ do liftIO $ do
currentTs <- getCurrentTime currentTs <- getCurrentTime
@ -1056,7 +1055,7 @@ saveIntroInvitation db reMember toMember introInv = do
WHERE group_member_intro_id = :intro_id WHERE group_member_intro_id = :intro_id
|] |]
[ ":intro_status" := GMIntroInvReceived, [ ":intro_status" := GMIntroInvReceived,
":group_queue_info" := introInv.groupConnReq, ":group_queue_info" := groupConnReq,
":direct_queue_info" := directConnReq introInv, ":direct_queue_info" := directConnReq introInv,
":updated_at" := currentTs, ":updated_at" := currentTs,
":intro_id" := introId intro ":intro_id" := introId intro

15
src/Simplex/Chat/Types.hs
View File

@ -9,7 +9,6 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -61,21 +60,21 @@ class IsContact a where
preferences' :: a -> Maybe Preferences preferences' :: a -> Maybe Preferences
instance IsContact User where instance IsContact User where
contactId' u = u.userContactId contactId' User {userContactId} = userContactId
{-# INLINE contactId' #-} {-# INLINE contactId' #-}
profile' u = u.profile profile' User {profile} = profile
{-# INLINE profile' #-} {-# INLINE profile' #-}
localDisplayName' u = u.localDisplayName localDisplayName' User {localDisplayName} = localDisplayName
{-# INLINE localDisplayName' #-} {-# INLINE localDisplayName' #-}
preferences' User {profile = LocalProfile {preferences}} = preferences preferences' User {profile = LocalProfile {preferences}} = preferences
{-# INLINE preferences' #-} {-# INLINE preferences' #-}
instance IsContact Contact where instance IsContact Contact where
contactId' c = c.contactId contactId' Contact {contactId} = contactId
{-# INLINE contactId' #-} {-# INLINE contactId' #-}
profile' c = c.profile profile' Contact {profile} = profile
{-# INLINE profile' #-} {-# INLINE profile' #-}
localDisplayName' c = c.localDisplayName localDisplayName' Contact {localDisplayName} = localDisplayName
{-# INLINE localDisplayName' #-} {-# INLINE localDisplayName' #-}
preferences' Contact {profile = LocalProfile {preferences}} = preferences preferences' Contact {profile = LocalProfile {preferences}} = preferences
{-# INLINE preferences' #-} {-# INLINE preferences' #-}
@ -196,7 +195,7 @@ directOrUsed ct@Contact {contactUsed} =
contactDirect ct || contactUsed contactDirect ct || contactUsed
anyDirectOrUsed :: Contact -> Bool 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 -> Bool
contactReady Contact {activeConn} = maybe False connReady activeConn contactReady Contact {activeConn} = maybe False connReady activeConn

95
src/Simplex/Chat/Types/Preferences.hs
View File

@ -7,7 +7,6 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
@ -79,12 +78,12 @@ allChatFeatures =
] ]
chatPrefSel :: SChatFeature f -> Preferences -> Maybe (FeaturePreference f) chatPrefSel :: SChatFeature f -> Preferences -> Maybe (FeaturePreference f)
chatPrefSel f ps = case f of chatPrefSel f Preferences {timedMessages, fullDelete, reactions, voice, calls} = case f of
SCFTimedMessages -> ps.timedMessages SCFTimedMessages -> timedMessages
SCFFullDelete -> ps.fullDelete SCFFullDelete -> fullDelete
SCFReactions -> ps.reactions SCFReactions -> reactions
SCFVoice -> ps.voice SCFVoice -> voice
SCFCalls -> ps.calls SCFCalls -> calls
chatFeature :: SChatFeature f -> ChatFeature chatFeature :: SChatFeature f -> ChatFeature
chatFeature = \case chatFeature = \case
@ -104,12 +103,12 @@ instance PreferenceI (Maybe Preferences) where
getPreference f prefs = fromMaybe (getPreference f defaultChatPrefs) (chatPrefSel f =<< prefs) getPreference f prefs = fromMaybe (getPreference f defaultChatPrefs) (chatPrefSel f =<< prefs)
instance PreferenceI FullPreferences where instance PreferenceI FullPreferences where
getPreference f ps = case f of getPreference f FullPreferences {timedMessages, fullDelete, reactions, voice, calls} = case f of
SCFTimedMessages -> ps.timedMessages SCFTimedMessages -> timedMessages
SCFFullDelete -> ps.fullDelete SCFFullDelete -> fullDelete
SCFReactions -> ps.reactions SCFReactions -> reactions
SCFVoice -> ps.voice SCFVoice -> voice
SCFCalls -> ps.calls SCFCalls -> calls
{-# INLINE getPreference #-} {-# INLINE getPreference #-}
setPreference :: forall f. FeatureI f => SChatFeature f -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences 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 :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f)
groupPrefSel f ps = case f of groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, history} = case f of
SGFTimedMessages -> ps.timedMessages SGFTimedMessages -> timedMessages
SGFDirectMessages -> ps.directMessages SGFDirectMessages -> directMessages
SGFFullDelete -> ps.fullDelete SGFFullDelete -> fullDelete
SGFReactions -> ps.reactions SGFReactions -> reactions
SGFVoice -> ps.voice SGFVoice -> voice
SGFFiles -> ps.files SGFFiles -> files
SGFHistory -> ps.history SGFHistory -> history
toGroupFeature :: SGroupFeature f -> GroupFeature toGroupFeature :: SGroupFeature f -> GroupFeature
toGroupFeature = \case toGroupFeature = \case
@ -225,14 +224,14 @@ instance GroupPreferenceI (Maybe GroupPreferences) where
getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt =<< prefs) getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt =<< prefs)
instance GroupPreferenceI FullGroupPreferences where instance GroupPreferenceI FullGroupPreferences where
getGroupPreference f ps = case f of getGroupPreference f FullGroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, history} = case f of
SGFTimedMessages -> ps.timedMessages SGFTimedMessages -> timedMessages
SGFDirectMessages -> ps.directMessages SGFDirectMessages -> directMessages
SGFFullDelete -> ps.fullDelete SGFFullDelete -> fullDelete
SGFReactions -> ps.reactions SGFReactions -> reactions
SGFVoice -> ps.voice SGFVoice -> voice
SGFFiles -> ps.files SGFFiles -> files
SGFHistory -> ps.history SGFHistory -> history
{-# INLINE getGroupPreference #-} {-# INLINE getGroupPreference #-}
-- collection of optional group preferences -- collection of optional group preferences
@ -382,19 +381,19 @@ class (Eq (FeaturePreference f), HasField "allow" (FeaturePreference f) FeatureA
prefParam :: FeaturePreference f -> Maybe Int prefParam :: FeaturePreference f -> Maybe Int
instance HasField "allow" TimedMessagesPreference FeatureAllowed where 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 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 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 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 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 instance FeatureI 'CFTimedMessages where
type FeaturePreference 'CFTimedMessages = TimedMessagesPreference type FeaturePreference 'CFTimedMessages = TimedMessagesPreference
@ -461,28 +460,28 @@ class (Eq (GroupFeaturePreference f), HasField "enable" (GroupFeaturePreference
groupPrefParam :: GroupFeaturePreference f -> Maybe Int groupPrefParam :: GroupFeaturePreference f -> Maybe Int
instance HasField "enable" GroupPreference GroupFeatureEnabled where 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 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 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 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 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 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 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 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 instance GroupFeatureI 'GFTimedMessages where
type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference
@ -720,12 +719,12 @@ preferenceState pref =
in (allow, param) in (allow, param)
getContactUserPreference :: SChatFeature f -> ContactUserPreferences -> ContactUserPreference (FeaturePreference f) getContactUserPreference :: SChatFeature f -> ContactUserPreferences -> ContactUserPreference (FeaturePreference f)
getContactUserPreference f ps = case f of getContactUserPreference f ContactUserPreferences {timedMessages, fullDelete, reactions, voice, calls} = case f of
SCFTimedMessages -> ps.timedMessages SCFTimedMessages -> timedMessages
SCFFullDelete -> ps.fullDelete SCFFullDelete -> fullDelete
SCFReactions -> ps.reactions SCFReactions -> reactions
SCFVoice -> ps.voice SCFVoice -> voice
SCFCalls -> ps.calls SCFCalls -> calls
$(J.deriveJSON (enumJSON $ dropPrefix "CF") ''ChatFeature) $(J.deriveJSON (enumJSON $ dropPrefix "CF") ''ChatFeature)

13
src/Simplex/Chat/View.hs
View File

@ -3,7 +3,6 @@
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -212,7 +211,9 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
CRContactConnecting u _ -> ttyUser u [] CRContactConnecting u _ -> ttyUser u []
CRContactConnected u ct userCustomProfile -> ttyUser u $ viewContactConnected ct userCustomProfile testView CRContactConnected u ct userCustomProfile -> ttyUser u $ viewContactConnected ct userCustomProfile testView
CRContactAnotherClient u c -> ttyUser u [ttyContact' c <> ": contact is connected to another client"] 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 <> ")"] CRContactsDisconnected srv cs -> [plain $ "server disconnected " <> showSMPServer srv <> " (" <> contactList cs <> ")"]
CRContactsSubscribed srv cs -> [plain $ "server connected " <> 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] 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)"] viewGroupSubscribed g = [membershipIncognito g <> ttyFullGroup g <> ": connected to server(s)"]
showSMPServer :: SMPServer -> String showSMPServer :: SMPServer -> String
showSMPServer srv = B.unpack $ strEncode srv.host showSMPServer ProtocolServer {host} = B.unpack $ strEncode host
viewHostEvent :: AProtocolType -> TransportHost -> String viewHostEvent :: AProtocolType -> TransportHost -> String
viewHostEvent p h = map toUpper (B.unpack $ strEncode p) <> " host " <> B.unpack (strEncode h) 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 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) groupMember m = memIncognito m <> ttyFullMember m <> ": " <> plain (intercalate ", " $ [role m] <> category m <> status m <> muted m)
role :: GroupMember -> String role :: GroupMember -> String
role m = B.unpack . strEncode $ m.memberRole role GroupMember {memberRole} = B.unpack $ strEncode memberRole
category m = case memberCategory m of category m = case memberCategory m of
GCUserMember -> ["you"] GCUserMember -> ["you"]
GCInviteeMember -> ["invited"] GCInviteeMember -> ["invited"]
@ -991,7 +992,7 @@ viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <nam
viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs
where where
ldn_ :: GroupInfo -> Text ldn_ :: GroupInfo -> Text
ldn_ g = T.toLower g.localDisplayName ldn_ GroupInfo {localDisplayName} = T.toLower localDisplayName
groupSS (g@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}}, GroupSummary {currentMembers}) = groupSS (g@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}}, GroupSummary {currentMembers}) =
case memberStatus membership of case memberStatus membership of
GSMemInvited -> groupInvitation' g GSMemInvited -> groupInvitation' g
@ -1906,7 +1907,7 @@ viewChatError logLevel testView = \case
"[" <> connEntityLabel entity <> ", userContactLinkId: " <> sShow userContactLinkId <> ", connId: " <> cId conn <> "] " "[" <> connEntityLabel entity <> ", userContactLinkId: " <> sShow userContactLinkId <> ", connId: " <> cId conn <> "] "
Nothing -> "" Nothing -> ""
cId :: Connection -> StyledString cId :: Connection -> StyledString
cId conn = sShow conn.connId cId Connection {connId} = sShow connId
ChatErrorRemoteCtrl e -> [plain $ "remote controller error: " <> show e] ChatErrorRemoteCtrl e -> [plain $ "remote controller error: " <> show e]
ChatErrorRemoteHost RHNew e -> [plain $ "new remote host 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] ChatErrorRemoteHost (RHId rhId) e -> [plain $ "remote host " <> show rhId <> " error: " <> show e]

5
tests/Bots/BroadcastTests.hs
View File

@ -1,6 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Bots.BroadcastTests where module Bots.BroadcastTests where
@ -13,7 +12,7 @@ import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Exception (bracket) import Control.Exception (bracket)
import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Core import Simplex.Chat.Core
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) import Simplex.Chat.Options (CoreChatOpts (..))
import Simplex.Chat.Types (Profile (..)) import Simplex.Chat.Types (Profile (..))
import System.FilePath ((</>)) import System.FilePath ((</>))
import Test.Hspec import Test.Hspec
@ -34,7 +33,7 @@ broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadc
mkBotOpts :: FilePath -> [KnownContact] -> BroadcastBotOpts mkBotOpts :: FilePath -> [KnownContact] -> BroadcastBotOpts
mkBotOpts tmp publishers = mkBotOpts tmp publishers =
BroadcastBotOpts BroadcastBotOpts
{ coreOptions = testOpts.coreOptions {dbFilePrefix = tmp </> botDbPrefix}, { coreOptions = testCoreOpts {dbFilePrefix = tmp </> botDbPrefix},
publishers, publishers,
welcomeMessage = defaultWelcomeMessage publishers, welcomeMessage = defaultWelcomeMessage publishers,
prohibitedMessage = defaultWelcomeMessage publishers prohibitedMessage = defaultWelcomeMessage publishers

5
tests/Bots/DirectoryTests.hs
View File

@ -1,6 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-} {-# LANGUAGE PostfixOperators #-}
@ -19,7 +18,7 @@ import GHC.IO.Handle (hClose)
import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller (ChatConfig (..)) import Simplex.Chat.Controller (ChatConfig (..))
import Simplex.Chat.Core import Simplex.Chat.Core
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) import Simplex.Chat.Options (CoreChatOpts (..))
import Simplex.Chat.Types (GroupMemberRole (..), Profile (..)) import Simplex.Chat.Types (GroupMemberRole (..), Profile (..))
import System.FilePath ((</>)) import System.FilePath ((</>))
import Test.Hspec import Test.Hspec
@ -64,7 +63,7 @@ directoryProfile = Profile {displayName = "SimpleX-Directory", fullName = "", im
mkDirectoryOpts :: FilePath -> [KnownContact] -> DirectoryOpts mkDirectoryOpts :: FilePath -> [KnownContact] -> DirectoryOpts
mkDirectoryOpts tmp superUsers = mkDirectoryOpts tmp superUsers =
DirectoryOpts DirectoryOpts
{ coreOptions = testOpts.coreOptions {dbFilePrefix = tmp </> serviceDbPrefix}, { coreOptions = testCoreOpts {dbFilePrefix = tmp </> serviceDbPrefix},
superUsers, superUsers,
directoryLog = Just $ tmp </> "directory_service.log", directoryLog = Just $ tmp </> "directory_service.log",
serviceName = "SimpleX-Directory", serviceName = "SimpleX-Directory",

36
tests/ChatClient.hs
View File

@ -58,22 +58,7 @@ serverPort = "7001"
testOpts :: ChatOpts testOpts :: ChatOpts
testOpts = testOpts =
ChatOpts ChatOpts
{ coreOptions = { coreOptions = 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
},
deviceName = Nothing, deviceName = Nothing,
chatCmd = "", chatCmd = "",
chatCmdDelay = 3, chatCmdDelay = 3,
@ -87,8 +72,25 @@ testOpts =
maintenance = False 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 :: Bool -> ScrubbedBytes -> ChatOpts
getTestOpts maintenance dbKey = testOpts {maintenance, coreOptions = (coreOptions testOpts) {dbKey}} getTestOpts maintenance dbKey = testOpts {maintenance, coreOptions = testCoreOpts {dbKey}}
termSettings :: VirtualTerminalSettings termSettings :: VirtualTerminalSettings
termSettings = termSettings =