mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-06-28 20:29:53 +00:00
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>
This commit is contained in:
Alexander Bondarenko
GitHub
parent
478bb32cdb
commit
e253c55ba4
15 changed files with 207 additions and 178 deletions
60
.github/workflows/build.yml
vendored
60
.github/workflows/build.yml
vendored
|
|
@ -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 /
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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}} =
|
||||
|
|
|
|||
|
|
@ -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}}}
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <nam
|
|||
viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs
|
||||
where
|
||||
ldn_ :: GroupInfo -> 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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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",
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue