Compare commits

...

16 commits

Author SHA1 Message Date
Evgeny Poberezkin
6a578cfe3c Merge branch 'master-ghc8107' into master-android 2023-09-25 16:53:04 +01:00
Evgeny Poberezkin
dacc075fe8 Merge branch 'master' into master-ghc8107 2023-09-25 16:52:33 +01:00
spaced4ndy
55418e2bc0 Merge branch 'master-ghc8107' into master-android 2023-09-25 17:43:59 +04:00
spaced4ndy
f2b5c0f3a8 Merge branch 'master' into master-ghc8107 2023-09-25 17:43:37 +04:00
spaced4ndy
5ebdf5dba9 Merge branch 'master-ghc8107' into master-android 2023-09-25 17:07:14 +04:00
spaced4ndy
8e045764df Merge branch 'master' into master-ghc8107 2023-09-25 16:40:08 +04:00
Evgeny Poberezkin
503d3d77e6 Merge branch 'master' into master-ghc8107 2023-09-23 08:47:28 +01:00
Evgeny Poberezkin
81bd7d97c5 Merge branch 'master' into master-ghc8107 2023-09-22 17:21:54 +01:00
Evgeny Poberezkin
8f57925067 compatibility with GHC 8.10.7 2023-09-22 14:01:25 +01:00
Evgeny Poberezkin
9bf99db82e Merge branch 'master' into master-ghc8107 2023-09-22 13:46:50 +01:00
Evgeny Poberezkin
5615cdbf1a Merge branch 'master' into master-android 2023-09-21 17:04:47 +01:00
Evgeny Poberezkin
d802ae0058 Merge branch 'master' into master-android 2023-09-21 12:06:10 +01:00
Evgeny Poberezkin
8f2278198c Merge branch 'master' into master-android 2023-09-20 14:55:25 +01:00
spaced4ndy
10937a5a4e Merge branch 'master' into master-android 2023-09-20 17:36:53 +04:00
Evgeny Poberezkin
6aff6e9804 Merge branch 'master-ghc9' into master-ghc8107 2023-09-18 21:56:35 +01:00
Evgeny Poberezkin
95477cae7e core: use commit from simplexmq branch master-ghc8107 2023-09-18 21:45:50 +01:00
40 changed files with 200 additions and 307 deletions

View file

@ -79,10 +79,10 @@ jobs:
uses: actions/checkout@v3 uses: actions/checkout@v3
- name: Setup Haskell - name: Setup Haskell
uses: haskell-actions/setup@v2 uses: haskell/actions/setup@v2
with: with:
ghc-version: "9.6.2" ghc-version: "8.10.7"
cabal-version: "3.10.1.0" cabal-version: "latest"
- name: Cache dependencies - name: Cache dependencies
uses: actions/cache@v3 uses: actions/cache@v3
@ -188,7 +188,7 @@ jobs:
APPLE_SIMPLEX_NOTARIZATION_APPLE_ID: ${{ secrets.APPLE_SIMPLEX_NOTARIZATION_APPLE_ID }} APPLE_SIMPLEX_NOTARIZATION_APPLE_ID: ${{ secrets.APPLE_SIMPLEX_NOTARIZATION_APPLE_ID }}
APPLE_SIMPLEX_NOTARIZATION_PASSWORD: ${{ secrets.APPLE_SIMPLEX_NOTARIZATION_PASSWORD }} APPLE_SIMPLEX_NOTARIZATION_PASSWORD: ${{ secrets.APPLE_SIMPLEX_NOTARIZATION_PASSWORD }}
run: | run: |
scripts/ci/build-desktop-mac.sh scripts/build-desktop-mac.sh
path=$(echo $PWD/apps/multiplatform/release/main/dmg/SimpleX-*.dmg) path=$(echo $PWD/apps/multiplatform/release/main/dmg/SimpleX-*.dmg)
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
@ -259,15 +259,15 @@ jobs:
# Unix / # Unix /
# / Windows # / Windows
# rm -rf dist-newstyle/src/direct-sq* is here because of the bug in cabal's dependency which prevents second build from finishing
# * In powershell multiline commands do not fail if individual commands fail - https://github.community/t/multiline-commands-on-windows-do-not-fail-if-individual-commands-fail/16753
# * And GitHub Actions does not support parameterizing shell in a matrix job - https://github.community/t/using-matrix-to-specify-shell-is-it-possible/17065
- name: Windows build - name: Windows build
id: windows_build id: windows_build
if: matrix.os == 'windows-latest' if: matrix.os == 'windows-latest'
shell: bash shell: cmd
run: | run: |
rm -rf dist-newstyle/src/direct-sq*
sed -i "s/, unix /--, unix /" simplex-chat.cabal
cabal build --enable-tests cabal build --enable-tests
rm -rf dist-newstyle/src/direct-sq* rm -rf dist-newstyle/src/direct-sq*
path=$(cabal list-bin simplex-chat | tail -n 1) path=$(cabal list-bin simplex-chat | tail -n 1)

View file

@ -67,7 +67,7 @@ if(NOT APPLE)
else() else()
# Without direct linking it can't find hs_init in linking step # Without direct linking it can't find hs_init in linking step
add_library( rts SHARED IMPORTED ) add_library( rts SHARED IMPORTED )
FILE(GLOB RTSLIB ${CMAKE_SOURCE_DIR}/libs/${OS_LIB_PATH}-${OS_LIB_ARCH}/deps/libHSrts*_thr-*.${OS_LIB_EXT}) FILE(GLOB RTSLIB ${CMAKE_SOURCE_DIR}/libs/${OS_LIB_PATH}-${OS_LIB_ARCH}/deps/libHSrts_thr-*.${OS_LIB_EXT})
set_target_properties( rts PROPERTIES IMPORTED_LOCATION ${RTSLIB}) set_target_properties( rts PROPERTIES IMPORTED_LOCATION ${RTSLIB})
target_link_libraries(app-lib rts simplex) target_link_libraries(app-lib rts simplex)

View file

@ -8,7 +8,7 @@ module Main where
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad import Control.Monad.Reader
import qualified Data.Text as T import qualified Data.Text as T
import Simplex.Chat.Bot import Simplex.Chat.Bot
import Simplex.Chat.Controller import Simplex.Chat.Controller

View file

@ -9,7 +9,7 @@ module Broadcast.Bot where
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad import Control.Monad.Reader
import qualified Data.Text as T import qualified Data.Text as T
import Broadcast.Options import Broadcast.Options
import Simplex.Chat.Bot import Simplex.Chat.Bot

View file

@ -8,7 +8,6 @@
module Server where module Server where
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Reader import Control.Monad.Reader
import Data.Aeson (FromJSON, ToJSON) import Data.Aeson (FromJSON, ToJSON)

View file

@ -15,7 +15,7 @@ where
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad import Control.Monad.Reader
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Data.List (sortOn) import Data.List (sortOn)
import Data.Maybe (fromMaybe, maybeToList) import Data.Maybe (fromMaybe, maybeToList)

View file

@ -2,14 +2,14 @@ packages: .
-- packages: . ../simplexmq -- packages: . ../simplexmq
-- packages: . ../simplexmq ../direct-sqlcipher ../sqlcipher-simple -- packages: . ../simplexmq ../direct-sqlcipher ../sqlcipher-simple
with-compiler: ghc-9.6.2 with-compiler: ghc-8.10.7
constraints: zip +disable-bzip2 +disable-zstd constraints: zip +disable-bzip2 +disable-zstd
source-repository-package source-repository-package
type: git type: git
location: https://github.com/simplex-chat/simplexmq.git location: https://github.com/simplex-chat/simplexmq.git
tag: 8d47f690838371bc848e4b31a4b09ef6bf67ccc5 tag: 53c793d5590d3c781aa3fbf72993eee262c7aa83
source-repository-package source-repository-package
type: git type: git
@ -24,17 +24,17 @@ source-repository-package
source-repository-package source-repository-package
type: git type: git
location: https://github.com/simplex-chat/direct-sqlcipher.git location: https://github.com/simplex-chat/direct-sqlcipher.git
tag: f814ee68b16a9447fbb467ccc8f29bdd3546bfd9 tag: 34309410eb2069b029b8fc1872deb1e0db123294
source-repository-package source-repository-package
type: git type: git
location: https://github.com/simplex-chat/sqlcipher-simple.git location: https://github.com/simplex-chat/sqlcipher-simple.git
tag: a46bd361a19376c5211f1058908fc0ae6bf42446 tag: 5e154a2aeccc33ead6c243ec07195ab673137221
source-repository-package source-repository-package
type: git type: git
location: https://github.com/simplex-chat/aeson.git location: https://github.com/simplex-chat/aeson.git
tag: 68330dce8208173c6acf5f62b23acb500ab5d873 tag: 3eb66f9a68f103b5f1489382aad89f5712a64db7
source-repository-package source-repository-package
type: git type: git
@ -43,10 +43,5 @@ source-repository-package
source-repository-package source-repository-package
type: git type: git
location: https://github.com/simplex-chat/android-support.git location: https://github.com/zw3rk/android-support.git
tag: 9aa09f148089d6752ce563b14c2df1895718d806 tag: 3c3a5ab0b8b137a072c98d3d0937cbdc96918ddb
source-repository-package
type: git
location: https://github.com/simplex-chat/network-transport.git
tag: 0013798272a683e35ca38d2fdaf480942311fba8

View file

@ -13,25 +13,25 @@ extra-source-files:
- cabal.project - cabal.project
dependencies: dependencies:
- aeson == 2.2.* - aeson == 2.0.*
- ansi-terminal >= 0.10 && < 0.12 - ansi-terminal >= 0.10 && < 0.12
- async == 2.2.* - async == 2.2.*
- attoparsec == 0.14.* - attoparsec == 0.14.*
- base >= 4.7 && < 5 - base >= 4.7 && < 5
- base64-bytestring >= 1.0 && < 1.3 - base64-bytestring >= 1.0 && < 1.3
- bytestring == 0.11.* - bytestring == 0.10.*
- composition == 1.0.* - composition == 1.0.*
- constraints >= 0.12 && < 0.14 - constraints >= 0.12 && < 0.14
- containers == 0.6.* - containers == 0.6.*
- cryptonite == 0.30.* - cryptonite >= 0.27 && < 0.30
- directory == 1.3.* - directory == 1.3.*
- direct-sqlcipher == 2.3.* - direct-sqlcipher == 2.3.*
- email-validate == 2.3.* - email-validate == 2.3.*
- exceptions == 0.10.* - exceptions == 0.10.*
- filepath == 1.4.* - filepath == 1.4.*
- http-types == 0.12.* - http-types == 0.12.*
- memory == 0.18.* - memory == 0.15.*
- mtl == 2.3.* - mtl == 2.2.*
- network >= 3.1.2.7 && < 3.2 - network >= 3.1.2.7 && < 3.2
- optparse-applicative >= 0.15 && < 0.17 - optparse-applicative >= 0.15 && < 0.17
- process == 1.6.* - process == 1.6.*
@ -42,13 +42,13 @@ dependencies:
- socks == 0.6.* - socks == 0.6.*
- sqlcipher-simple == 0.4.* - sqlcipher-simple == 0.4.*
- stm == 2.5.* - stm == 2.5.*
- template-haskell == 2.20.* - template-haskell == 2.16.*
- terminal == 0.2.* - terminal == 0.2.*
- text == 2.0.* - text == 1.2.*
- time == 1.9.* - time == 1.9.*
- unliftio == 0.2.* - unliftio == 0.2.*
- unliftio-core == 0.2.* - unliftio-core == 0.2.*
- zip == 2.0.* - zip == 1.7.*
flags: flags:
swift: swift:
@ -118,7 +118,7 @@ tests:
- simplex-chat - simplex-chat
- async == 2.2.* - async == 2.2.*
- deepseq == 1.4.* - deepseq == 1.4.*
- hspec == 2.11.* - hspec == 2.7.*
- network == 3.1.* - network == 3.1.*
- silently == 1.2.* - silently == 1.2.*
- stm == 2.5.* - stm == 2.5.*

View file

@ -1,10 +0,0 @@
#!/bin/bash
security create-keychain -p "" simplex.keychain
security set-keychain-settings -u simplex.keychain
security add-certificates -k simplex.keychain "Developer ID Application: SimpleX Chat Ltd (5NN7GUYB6T).cer"
security add-certificates -k simplex.keychain "Developer ID Certification Authority.cer"
# Private key with access from any app
security import "SimpleX Chat.p12" -P "" -k simplex.keychain -A
# Public key
security import "SimpleX Chat.pem" -k simplex.keychain

View file

@ -2,7 +2,7 @@
set -e set -e
trap "rm apps/multiplatform/local.properties 2> /dev/null || true; rm local.properties 2> /dev/null || true; rm /tmp/simplex.keychain" EXIT trap "rm apps/multiplatform/local.properties || true; rm local.properties || true; rm /tmp/simplex.keychain || true" EXIT
echo "desktop.mac.signing.identity=Developer ID Application: SimpleX Chat Ltd (5NN7GUYB6T)" >> apps/multiplatform/local.properties echo "desktop.mac.signing.identity=Developer ID Application: SimpleX Chat Ltd (5NN7GUYB6T)" >> apps/multiplatform/local.properties
echo "desktop.mac.signing.keychain=/tmp/simplex.keychain" >> apps/multiplatform/local.properties echo "desktop.mac.signing.keychain=/tmp/simplex.keychain" >> apps/multiplatform/local.properties
echo "desktop.mac.notarization.apple_id=$APPLE_SIMPLEX_NOTARIZATION_APPLE_ID" >> apps/multiplatform/local.properties echo "desktop.mac.notarization.apple_id=$APPLE_SIMPLEX_NOTARIZATION_APPLE_ID" >> apps/multiplatform/local.properties
@ -10,10 +10,6 @@ echo "desktop.mac.notarization.password=$APPLE_SIMPLEX_NOTARIZATION_PASSWORD" >>
echo "desktop.mac.notarization.team_id=5NN7GUYB6T" >> apps/multiplatform/local.properties echo "desktop.mac.notarization.team_id=5NN7GUYB6T" >> apps/multiplatform/local.properties
echo "$APPLE_SIMPLEX_SIGNING_KEYCHAIN" | base64 --decode - > /tmp/simplex.keychain echo "$APPLE_SIMPLEX_SIGNING_KEYCHAIN" | base64 --decode - > /tmp/simplex.keychain
security unlock-keychain -p "" /tmp/simplex.keychain
# Adding keychain to the list of keychains.
# Otherwise, it can find cert but exits while signing with "error: The specified item could not be found in the keychain."
security list-keychains -s `security list-keychains | xargs` /tmp/simplex.keychain
scripts/desktop/build-lib-mac.sh scripts/desktop/build-lib-mac.sh
cd apps/multiplatform cd apps/multiplatform
./gradlew packageDmg ./gradlew packageDmg

View file

@ -2,12 +2,12 @@
OS=linux OS=linux
ARCH=${1:-`uname -a | rev | cut -d' ' -f2 | rev`} ARCH=${1:-`uname -a | rev | cut -d' ' -f2 | rev`}
GHC_VERSION=9.6.2 GHC_VERSION=8.10.7
BUILD_DIR=dist-newstyle/build/$ARCH-$OS/ghc-${GHC_VERSION}/simplex-chat-* BUILD_DIR=dist-newstyle/build/$ARCH-$OS/ghc-${GHC_VERSION}/simplex-chat-*
rm -rf $BUILD_DIR rm -rf $BUILD_DIR
cabal build lib:simplex-chat --ghc-options='-optl-Wl,-rpath,$ORIGIN -flink-rts -threaded' cabal build lib:simplex-chat --ghc-options='-optl-Wl,-rpath,$ORIGIN' --ghc-options="-optl-L$(ghc --print-libdir)/rts -optl-Wl,--as-needed,-lHSrts_thr-ghc$GHC_VERSION"
cd $BUILD_DIR/build cd $BUILD_DIR/build
#patchelf --add-needed libHSrts_thr-ghc${GHC_VERSION}.so libHSsimplex-chat-*-inplace-ghc${GHC_VERSION}.so #patchelf --add-needed libHSrts_thr-ghc${GHC_VERSION}.so libHSsimplex-chat-*-inplace-ghc${GHC_VERSION}.so
#patchelf --add-rpath '$ORIGIN' libHSsimplex-chat-*-inplace-ghc${GHC_VERSION}.so #patchelf --add-rpath '$ORIGIN' libHSsimplex-chat-*-inplace-ghc${GHC_VERSION}.so

View file

@ -2,12 +2,9 @@
OS=mac OS=mac
ARCH="${1:-`uname -a | rev | cut -d' ' -f1 | rev`}" ARCH="${1:-`uname -a | rev | cut -d' ' -f1 | rev`}"
GHC_VERSION=9.6.2
if [ "$ARCH" == "arm64" ]; then if [ "$ARCH" == "arm64" ]; then
ARCH=aarch64 ARCH=aarch64
fi fi
LIB_EXT=dylib LIB_EXT=dylib
LIB=libHSsimplex-chat-*-inplace-ghc*.$LIB_EXT LIB=libHSsimplex-chat-*-inplace-ghc*.$LIB_EXT
GHC_LIBS_DIR=$(ghc --print-libdir) GHC_LIBS_DIR=$(ghc --print-libdir)
@ -15,26 +12,13 @@ GHC_LIBS_DIR=$(ghc --print-libdir)
BUILD_DIR=dist-newstyle/build/$ARCH-*/ghc-*/simplex-chat-* BUILD_DIR=dist-newstyle/build/$ARCH-*/ghc-*/simplex-chat-*
rm -rf $BUILD_DIR rm -rf $BUILD_DIR
cabal build lib:simplex-chat lib:simplex-chat --ghc-options="-optl-Wl,-rpath,@loader_path -optl-Wl,-L$GHC_LIBS_DIR/$ARCH-osx-ghc-$GHC_VERSION -optl-lHSrts_thr-ghc$GHC_VERSION -optl-lffi" cabal build lib:simplex-chat lib:simplex-chat --ghc-options="-optl-Wl,-rpath,@loader_path -optl-Wl,-L$GHC_LIBS_DIR/rts -optl-lHSrts_thr-ghc8.10.7 -optl-lffi"
cd $BUILD_DIR/build cd $BUILD_DIR/build
mkdir deps 2> /dev/null mkdir deps 2> /dev/null
# It's not included by default for some reason. Compiled lib tries to find system one but it's not always available # It's not included by default for some reason. Compiled lib tries to find system one but it's not always available
#cp $GHC_LIBS_DIR/libffi.dylib ./deps cp $GHC_LIBS_DIR/rts/libffi.dylib ./deps
(
BUILD=$PWD
cp /tmp/libffi-3.4.4/*-apple-darwin*/.libs/libffi.dylib $BUILD/deps || \
( \
cd /tmp && \
curl "https://gitlab.haskell.org/ghc/libffi-tarballs/-/raw/libffi-3.4.4/libffi-3.4.4.tar.gz?inline=false" -o libffi.tar.gz && \
tar -xzvf libffi.tar.gz && \
cd "libffi-3.4.4" && \
./configure && \
make && \
cp *-apple-darwin*/.libs/libffi.dylib $BUILD/deps \
)
)
DYLIBS=`otool -L $LIB | grep @rpath | tail -n +2 | cut -d' ' -f 1 | cut -d'/' -f2` DYLIBS=`otool -L $LIB | grep @rpath | tail -n +2 | cut -d' ' -f 1 | cut -d'/' -f2`
RPATHS=`otool -l $LIB | grep "path "| cut -d' ' -f11` RPATHS=`otool -l $LIB | grep "path "| cut -d' ' -f11`
@ -75,13 +59,11 @@ function copy_deps() {
} }
copy_deps $LIB copy_deps $LIB
# Special case
cp $(ghc --print-libdir)/$ARCH-osx-ghc-$GHC_VERSION/libHSghc-boot-th-$GHC_VERSION-ghc$GHC_VERSION.dylib deps
rm deps/`basename $LIB` rm deps/`basename $LIB`
if [ -e deps/libHSdrct-*.$LIB_EXT ]; then if [ -e deps/libHSdrct-*.$LIB_EXT ]; then
LIBCRYPTO_PATH=$(otool -l deps/libHSdrct-*.$LIB_EXT | grep libcrypto | cut -d' ' -f11) LIBCRYPTO_PATH=$(otool -l deps/libHSdrct-*.$LIB_EXT | grep libcrypto | cut -d' ' -f11)
install_name_tool -change $LIBCRYPTO_PATH @rpath/libcrypto.1.1.$LIB_EXT deps/libHSdrct-*.$LIB_EXT install_name_tool -change $LIBCRYPTO_PATH @rpath/libcrypto.1.1.$LIB_EXT deps/libHSdrct*.$LIB_EXT
cp $LIBCRYPTO_PATH deps/libcrypto.1.1.$LIB_EXT cp $LIBCRYPTO_PATH deps/libcrypto.1.1.$LIB_EXT
chmod 755 deps/libcrypto.1.1.$LIB_EXT chmod 755 deps/libcrypto.1.1.$LIB_EXT
fi fi

View file

@ -1,11 +1,10 @@
{ {
"https://github.com/simplex-chat/simplexmq.git"."8d47f690838371bc848e4b31a4b09ef6bf67ccc5" = "1pwasv22ii3wy4xchaknlwczmy5ws7adx7gg2g58lxzrgdjm3650"; "https://github.com/simplex-chat/simplexmq.git"."53c793d5590d3c781aa3fbf72993eee262c7aa83" = "0f0ldlgqwrapgfw5gnaj00xvb14c8nykyjr9fhy79h4r16g614x8";
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb"; "https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "0kiwhvml42g9anw4d2v0zd1fpc790pj9syg5x3ik4l97fnkbbwpp"; "https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; "https://github.com/simplex-chat/sqlcipher-simple.git"."5e154a2aeccc33ead6c243ec07195ab673137221" = "1d1gc5wax4vqg0801ajsmx1sbwvd9y7p7b8mmskvqsmpbwgbh0m0";
"https://github.com/simplex-chat/aeson.git"."68330dce8208173c6acf5f62b23acb500ab5d873" = "1l51p1v54c88c1jmxcvbz4gy0cns7l46ihzzfjwxxrvcrrrxgcjp"; "https://github.com/simplex-chat/aeson.git"."3eb66f9a68f103b5f1489382aad89f5712a64db7" = "0kilkx59fl6c3qy3kjczqvm8c3f4n3p0bdk9biyflf51ljnzp4yp";
"https://github.com/simplex-chat/haskell-terminal.git"."f708b00009b54890172068f168bf98508ffcd495" = "0zmq7lmfsk8m340g47g5963yba7i88n4afa6z93sg9px5jv1mijj"; "https://github.com/simplex-chat/haskell-terminal.git"."f708b00009b54890172068f168bf98508ffcd495" = "0zmq7lmfsk8m340g47g5963yba7i88n4afa6z93sg9px5jv1mijj";
"https://github.com/simplex-chat/android-support.git"."9aa09f148089d6752ce563b14c2df1895718d806" = "0pbf2pf13v2kjzi397nr13f1h3jv0imvsq8rpiyy2qyx5vd50pqn"; "https://github.com/zw3rk/android-support.git"."3c3a5ab0b8b137a072c98d3d0937cbdc96918ddb" = "1r6jyxbim3dsvrmakqfyxbd6ms6miaghpbwyl0sr6dzwpgaprz97";
"https://github.com/simplex-chat/network-transport.git"."0013798272a683e35ca38d2fdaf480942311fba8" = "0dnn62apgvc248df0m8ib7phrzn63wm0xs71xvlypv52j6cgwzkb";
} }

View file

@ -145,25 +145,25 @@ library
src src
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns
build-depends: build-depends:
aeson ==2.2.* aeson ==2.0.*
, ansi-terminal >=0.10 && <0.12 , ansi-terminal >=0.10 && <0.12
, async ==2.2.* , async ==2.2.*
, attoparsec ==0.14.* , attoparsec ==0.14.*
, base >=4.7 && <5 , base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3 , base64-bytestring >=1.0 && <1.3
, bytestring ==0.11.* , bytestring ==0.10.*
, composition ==1.0.* , composition ==1.0.*
, constraints >=0.12 && <0.14 , constraints >=0.12 && <0.14
, containers ==0.6.* , containers ==0.6.*
, cryptonite ==0.30.* , cryptonite >=0.27 && <0.30
, direct-sqlcipher ==2.3.* , direct-sqlcipher ==2.3.*
, directory ==1.3.* , directory ==1.3.*
, email-validate ==2.3.* , email-validate ==2.3.*
, exceptions ==0.10.* , exceptions ==0.10.*
, filepath ==1.4.* , filepath ==1.4.*
, http-types ==0.12.* , http-types ==0.12.*
, memory ==0.18.* , memory ==0.15.*
, mtl ==2.3.* , mtl ==2.2.*
, network >=3.1.2.7 && <3.2 , network >=3.1.2.7 && <3.2
, optparse-applicative >=0.15 && <0.17 , optparse-applicative >=0.15 && <0.17
, process ==1.6.* , process ==1.6.*
@ -174,13 +174,13 @@ library
, socks ==0.6.* , socks ==0.6.*
, sqlcipher-simple ==0.4.* , sqlcipher-simple ==0.4.*
, stm ==2.5.* , stm ==2.5.*
, template-haskell ==2.20.* , template-haskell ==2.16.*
, terminal ==0.2.* , terminal ==0.2.*
, text ==2.0.* , text ==1.2.*
, time ==1.9.* , time ==1.9.*
, unliftio ==0.2.* , unliftio ==0.2.*
, unliftio-core ==0.2.* , unliftio-core ==0.2.*
, zip ==2.0.* , zip ==1.7.*
default-language: Haskell2010 default-language: Haskell2010
if flag(swift) if flag(swift)
cpp-options: -DswiftJSON cpp-options: -DswiftJSON
@ -193,25 +193,25 @@ executable simplex-bot
apps/simplex-bot apps/simplex-bot
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
build-depends: build-depends:
aeson ==2.2.* aeson ==2.0.*
, ansi-terminal >=0.10 && <0.12 , ansi-terminal >=0.10 && <0.12
, async ==2.2.* , async ==2.2.*
, attoparsec ==0.14.* , attoparsec ==0.14.*
, base >=4.7 && <5 , base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3 , base64-bytestring >=1.0 && <1.3
, bytestring ==0.11.* , bytestring ==0.10.*
, composition ==1.0.* , composition ==1.0.*
, constraints >=0.12 && <0.14 , constraints >=0.12 && <0.14
, containers ==0.6.* , containers ==0.6.*
, cryptonite ==0.30.* , cryptonite >=0.27 && <0.30
, direct-sqlcipher ==2.3.* , direct-sqlcipher ==2.3.*
, directory ==1.3.* , directory ==1.3.*
, email-validate ==2.3.* , email-validate ==2.3.*
, exceptions ==0.10.* , exceptions ==0.10.*
, filepath ==1.4.* , filepath ==1.4.*
, http-types ==0.12.* , http-types ==0.12.*
, memory ==0.18.* , memory ==0.15.*
, mtl ==2.3.* , mtl ==2.2.*
, network >=3.1.2.7 && <3.2 , network >=3.1.2.7 && <3.2
, optparse-applicative >=0.15 && <0.17 , optparse-applicative >=0.15 && <0.17
, process ==1.6.* , process ==1.6.*
@ -223,13 +223,13 @@ executable simplex-bot
, socks ==0.6.* , socks ==0.6.*
, sqlcipher-simple ==0.4.* , sqlcipher-simple ==0.4.*
, stm ==2.5.* , stm ==2.5.*
, template-haskell ==2.20.* , template-haskell ==2.16.*
, terminal ==0.2.* , terminal ==0.2.*
, text ==2.0.* , text ==1.2.*
, time ==1.9.* , time ==1.9.*
, unliftio ==0.2.* , unliftio ==0.2.*
, unliftio-core ==0.2.* , unliftio-core ==0.2.*
, zip ==2.0.* , zip ==1.7.*
default-language: Haskell2010 default-language: Haskell2010
if flag(swift) if flag(swift)
cpp-options: -DswiftJSON cpp-options: -DswiftJSON
@ -242,25 +242,25 @@ executable simplex-bot-advanced
apps/simplex-bot-advanced apps/simplex-bot-advanced
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
build-depends: build-depends:
aeson ==2.2.* aeson ==2.0.*
, ansi-terminal >=0.10 && <0.12 , ansi-terminal >=0.10 && <0.12
, async ==2.2.* , async ==2.2.*
, attoparsec ==0.14.* , attoparsec ==0.14.*
, base >=4.7 && <5 , base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3 , base64-bytestring >=1.0 && <1.3
, bytestring ==0.11.* , bytestring ==0.10.*
, composition ==1.0.* , composition ==1.0.*
, constraints >=0.12 && <0.14 , constraints >=0.12 && <0.14
, containers ==0.6.* , containers ==0.6.*
, cryptonite ==0.30.* , cryptonite >=0.27 && <0.30
, direct-sqlcipher ==2.3.* , direct-sqlcipher ==2.3.*
, directory ==1.3.* , directory ==1.3.*
, email-validate ==2.3.* , email-validate ==2.3.*
, exceptions ==0.10.* , exceptions ==0.10.*
, filepath ==1.4.* , filepath ==1.4.*
, http-types ==0.12.* , http-types ==0.12.*
, memory ==0.18.* , memory ==0.15.*
, mtl ==2.3.* , mtl ==2.2.*
, network >=3.1.2.7 && <3.2 , network >=3.1.2.7 && <3.2
, optparse-applicative >=0.15 && <0.17 , optparse-applicative >=0.15 && <0.17
, process ==1.6.* , process ==1.6.*
@ -272,13 +272,13 @@ executable simplex-bot-advanced
, socks ==0.6.* , socks ==0.6.*
, sqlcipher-simple ==0.4.* , sqlcipher-simple ==0.4.*
, stm ==2.5.* , stm ==2.5.*
, template-haskell ==2.20.* , template-haskell ==2.16.*
, terminal ==0.2.* , terminal ==0.2.*
, text ==2.0.* , text ==1.2.*
, time ==1.9.* , time ==1.9.*
, unliftio ==0.2.* , unliftio ==0.2.*
, unliftio-core ==0.2.* , unliftio-core ==0.2.*
, zip ==2.0.* , zip ==1.7.*
default-language: Haskell2010 default-language: Haskell2010
if flag(swift) if flag(swift)
cpp-options: -DswiftJSON cpp-options: -DswiftJSON
@ -293,25 +293,25 @@ executable simplex-broadcast-bot
apps/simplex-broadcast-bot/src apps/simplex-broadcast-bot/src
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
build-depends: build-depends:
aeson ==2.2.* aeson ==2.0.*
, ansi-terminal >=0.10 && <0.12 , ansi-terminal >=0.10 && <0.12
, async ==2.2.* , async ==2.2.*
, attoparsec ==0.14.* , attoparsec ==0.14.*
, base >=4.7 && <5 , base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3 , base64-bytestring >=1.0 && <1.3
, bytestring ==0.11.* , bytestring ==0.10.*
, composition ==1.0.* , composition ==1.0.*
, constraints >=0.12 && <0.14 , constraints >=0.12 && <0.14
, containers ==0.6.* , containers ==0.6.*
, cryptonite ==0.30.* , cryptonite >=0.27 && <0.30
, direct-sqlcipher ==2.3.* , direct-sqlcipher ==2.3.*
, directory ==1.3.* , directory ==1.3.*
, email-validate ==2.3.* , email-validate ==2.3.*
, exceptions ==0.10.* , exceptions ==0.10.*
, filepath ==1.4.* , filepath ==1.4.*
, http-types ==0.12.* , http-types ==0.12.*
, memory ==0.18.* , memory ==0.15.*
, mtl ==2.3.* , mtl ==2.2.*
, network >=3.1.2.7 && <3.2 , network >=3.1.2.7 && <3.2
, optparse-applicative >=0.15 && <0.17 , optparse-applicative >=0.15 && <0.17
, process ==1.6.* , process ==1.6.*
@ -323,13 +323,13 @@ executable simplex-broadcast-bot
, socks ==0.6.* , socks ==0.6.*
, sqlcipher-simple ==0.4.* , sqlcipher-simple ==0.4.*
, stm ==2.5.* , stm ==2.5.*
, template-haskell ==2.20.* , template-haskell ==2.16.*
, terminal ==0.2.* , terminal ==0.2.*
, text ==2.0.* , text ==1.2.*
, time ==1.9.* , time ==1.9.*
, unliftio ==0.2.* , unliftio ==0.2.*
, unliftio-core ==0.2.* , unliftio-core ==0.2.*
, zip ==2.0.* , zip ==1.7.*
default-language: Haskell2010 default-language: Haskell2010
if flag(swift) if flag(swift)
cpp-options: -DswiftJSON cpp-options: -DswiftJSON
@ -343,25 +343,25 @@ executable simplex-chat
apps/simplex-chat apps/simplex-chat
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
build-depends: build-depends:
aeson ==2.2.* aeson ==2.0.*
, ansi-terminal >=0.10 && <0.12 , ansi-terminal >=0.10 && <0.12
, async ==2.2.* , async ==2.2.*
, attoparsec ==0.14.* , attoparsec ==0.14.*
, base >=4.7 && <5 , base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3 , base64-bytestring >=1.0 && <1.3
, bytestring ==0.11.* , bytestring ==0.10.*
, composition ==1.0.* , composition ==1.0.*
, constraints >=0.12 && <0.14 , constraints >=0.12 && <0.14
, containers ==0.6.* , containers ==0.6.*
, cryptonite ==0.30.* , cryptonite >=0.27 && <0.30
, direct-sqlcipher ==2.3.* , direct-sqlcipher ==2.3.*
, directory ==1.3.* , directory ==1.3.*
, email-validate ==2.3.* , email-validate ==2.3.*
, exceptions ==0.10.* , exceptions ==0.10.*
, filepath ==1.4.* , filepath ==1.4.*
, http-types ==0.12.* , http-types ==0.12.*
, memory ==0.18.* , memory ==0.15.*
, mtl ==2.3.* , mtl ==2.2.*
, network ==3.1.* , network ==3.1.*
, optparse-applicative >=0.15 && <0.17 , optparse-applicative >=0.15 && <0.17
, process ==1.6.* , process ==1.6.*
@ -373,14 +373,14 @@ executable simplex-chat
, socks ==0.6.* , socks ==0.6.*
, sqlcipher-simple ==0.4.* , sqlcipher-simple ==0.4.*
, stm ==2.5.* , stm ==2.5.*
, template-haskell ==2.20.* , template-haskell ==2.16.*
, terminal ==0.2.* , terminal ==0.2.*
, text ==2.0.* , text ==1.2.*
, time ==1.9.* , time ==1.9.*
, unliftio ==0.2.* , unliftio ==0.2.*
, unliftio-core ==0.2.* , unliftio-core ==0.2.*
, websockets ==0.12.* , websockets ==0.12.*
, zip ==2.0.* , zip ==1.7.*
default-language: Haskell2010 default-language: Haskell2010
if flag(swift) if flag(swift)
cpp-options: -DswiftJSON cpp-options: -DswiftJSON
@ -397,25 +397,25 @@ executable simplex-directory-service
apps/simplex-directory-service/src apps/simplex-directory-service/src
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
build-depends: build-depends:
aeson ==2.2.* aeson ==2.0.*
, ansi-terminal >=0.10 && <0.12 , ansi-terminal >=0.10 && <0.12
, async ==2.2.* , async ==2.2.*
, attoparsec ==0.14.* , attoparsec ==0.14.*
, base >=4.7 && <5 , base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3 , base64-bytestring >=1.0 && <1.3
, bytestring ==0.11.* , bytestring ==0.10.*
, composition ==1.0.* , composition ==1.0.*
, constraints >=0.12 && <0.14 , constraints >=0.12 && <0.14
, containers ==0.6.* , containers ==0.6.*
, cryptonite ==0.30.* , cryptonite >=0.27 && <0.30
, direct-sqlcipher ==2.3.* , direct-sqlcipher ==2.3.*
, directory ==1.3.* , directory ==1.3.*
, email-validate ==2.3.* , email-validate ==2.3.*
, exceptions ==0.10.* , exceptions ==0.10.*
, filepath ==1.4.* , filepath ==1.4.*
, http-types ==0.12.* , http-types ==0.12.*
, memory ==0.18.* , memory ==0.15.*
, mtl ==2.3.* , mtl ==2.2.*
, network >=3.1.2.7 && <3.2 , network >=3.1.2.7 && <3.2
, optparse-applicative >=0.15 && <0.17 , optparse-applicative >=0.15 && <0.17
, process ==1.6.* , process ==1.6.*
@ -427,13 +427,13 @@ executable simplex-directory-service
, socks ==0.6.* , socks ==0.6.*
, sqlcipher-simple ==0.4.* , sqlcipher-simple ==0.4.*
, stm ==2.5.* , stm ==2.5.*
, template-haskell ==2.20.* , template-haskell ==2.16.*
, terminal ==0.2.* , terminal ==0.2.*
, text ==2.0.* , text ==1.2.*
, time ==1.9.* , time ==1.9.*
, unliftio ==0.2.* , unliftio ==0.2.*
, unliftio-core ==0.2.* , unliftio-core ==0.2.*
, zip ==2.0.* , zip ==1.7.*
default-language: Haskell2010 default-language: Haskell2010
if flag(swift) if flag(swift)
cpp-options: -DswiftJSON cpp-options: -DswiftJSON
@ -470,27 +470,27 @@ test-suite simplex-chat-test
apps/simplex-directory-service/src apps/simplex-directory-service/src
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
build-depends: build-depends:
aeson ==2.2.* aeson ==2.0.*
, ansi-terminal >=0.10 && <0.12 , ansi-terminal >=0.10 && <0.12
, async ==2.2.* , async ==2.2.*
, attoparsec ==0.14.* , attoparsec ==0.14.*
, base >=4.7 && <5 , base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3 , base64-bytestring >=1.0 && <1.3
, bytestring ==0.11.* , bytestring ==0.10.*
, composition ==1.0.* , composition ==1.0.*
, constraints >=0.12 && <0.14 , constraints >=0.12 && <0.14
, containers ==0.6.* , containers ==0.6.*
, cryptonite ==0.30.* , cryptonite >=0.27 && <0.30
, deepseq ==1.4.* , deepseq ==1.4.*
, direct-sqlcipher ==2.3.* , direct-sqlcipher ==2.3.*
, directory ==1.3.* , directory ==1.3.*
, email-validate ==2.3.* , email-validate ==2.3.*
, exceptions ==0.10.* , exceptions ==0.10.*
, filepath ==1.4.* , filepath ==1.4.*
, hspec ==2.11.* , hspec ==2.7.*
, http-types ==0.12.* , http-types ==0.12.*
, memory ==0.18.* , memory ==0.15.*
, mtl ==2.3.* , mtl ==2.2.*
, network ==3.1.* , network ==3.1.*
, optparse-applicative >=0.15 && <0.17 , optparse-applicative >=0.15 && <0.17
, process ==1.6.* , process ==1.6.*
@ -503,13 +503,13 @@ test-suite simplex-chat-test
, socks ==0.6.* , socks ==0.6.*
, sqlcipher-simple ==0.4.* , sqlcipher-simple ==0.4.*
, stm ==2.5.* , stm ==2.5.*
, template-haskell ==2.20.* , template-haskell ==2.16.*
, terminal ==0.2.* , terminal ==0.2.*
, text ==2.0.* , text ==1.2.*
, time ==1.9.* , time ==1.9.*
, unliftio ==0.2.* , unliftio ==0.2.*
, unliftio-core ==0.2.* , unliftio-core ==0.2.*
, zip ==2.0.* , zip ==1.7.*
default-language: Haskell2010 default-language: Haskell2010
if flag(swift) if flag(swift)
cpp-options: -DswiftJSON cpp-options: -DswiftJSON

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 #-}
@ -13,15 +12,12 @@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat where module Simplex.Chat where
import Control.Applicative (optional, (<|>)) import Control.Applicative (optional, (<|>))
import Control.Concurrent.STM (retry) import Control.Concurrent.STM (retry, stateTVar)
import qualified Control.Exception as E import qualified Control.Exception as E
import Control.Logger.Simple import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Unlift import Control.Monad.IO.Unlift
import Control.Monad.Reader import Control.Monad.Reader
@ -217,8 +213,8 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
where where
configServers :: DefaultAgentServers configServers :: DefaultAgentServers
configServers = configServers =
let smp' = fromMaybe (defaultServers.smp) (nonEmpty smpServers) let smp' = fromMaybe (smp (defaultServers :: DefaultAgentServers)) (nonEmpty smpServers)
xftp' = fromMaybe (defaultServers.xftp) (nonEmpty xftpServers) xftp' = fromMaybe (xftp (defaultServers :: DefaultAgentServers)) (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
@ -245,9 +241,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 = \case
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
@ -703,9 +699,7 @@ processChatCommand = \case
MCVoice {} -> False MCVoice {} -> False
MCUnknown {} -> True MCUnknown {} -> True
qText = msgContentText qmc qText = msgContentText qmc
getFileName :: CIFile d -> String qFileName = maybe qText (T.pack . (fileName :: CIFile d -> String)) ciFile_
getFileName CIFile{fileName} = fileName
qFileName = maybe qText (T.pack . getFileName) ciFile_
qTextOrFile = if T.null qText then qFileName else qText qTextOrFile = if T.null qText then qFileName else qText
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup = do xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup = do
@ -918,7 +912,7 @@ processChatCommand = \case
pure $ CRContactConnectionDeleted user conn pure $ CRContactConnectionDeleted user conn
CTGroup -> do CTGroup -> do
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user chatId Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user chatId
let isOwner = membership.memberRole == GROwner let isOwner = memberRole (membership :: GroupMember) == 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
@ -1095,9 +1089,7 @@ processChatCommand = \case
APIGetNtfMessage nonce encNtfInfo -> withUser $ \_ -> do APIGetNtfMessage nonce encNtfInfo -> withUser $ \_ -> do
(NotificationInfo {ntfConnId, ntfMsgMeta}, msgs) <- withAgent $ \a -> getNotificationMessage a nonce encNtfInfo (NotificationInfo {ntfConnId, ntfMsgMeta}, msgs) <- withAgent $ \a -> getNotificationMessage a nonce encNtfInfo
let ntfMessages = map (\SMP.SMPMsgMeta {msgTs, msgFlags} -> NtfMsgInfo {msgTs = systemToUTCTime msgTs, msgFlags}) msgs let ntfMessages = map (\SMP.SMPMsgMeta {msgTs, msgFlags} -> NtfMsgInfo {msgTs = systemToUTCTime msgTs, msgFlags}) msgs
getMsgTs :: SMP.NMsgMeta -> SystemTime msgTs' = systemToUTCTime . (SMP.msgTs :: SMP.NMsgMeta -> SystemTime) <$> ntfMsgMeta
getMsgTs SMP.NMsgMeta{msgTs} = msgTs
msgTs' = systemToUTCTime . getMsgTs <$> ntfMsgMeta
agentConnId = AgentConnId ntfConnId agentConnId = AgentConnId ntfConnId
user_ <- withStore' (`getUserByAConnId` agentConnId) user_ <- withStore' (`getUserByAConnId` agentConnId)
connEntity <- connEntity <-
@ -1504,7 +1496,7 @@ processChatCommand = \case
Contact {activeConn = Connection {peerChatVRange}} = ct Contact {activeConn = Connection {peerChatVRange}} = ct
withChatLock "joinGroup" . procCmd $ do withChatLock "joinGroup" . procCmd $ do
subMode <- chatReadVar subscriptionMode subMode <- chatReadVar subscriptionMode
dm <- directMessage $ XGrpAcpt membership.memberId dm <- directMessage $ XGrpAcpt (memberId (membership :: GroupMember))
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
@ -1658,7 +1650,7 @@ processChatCommand = \case
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 (g :: GroupInfo))
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
@ -2022,7 +2014,7 @@ processChatCommand = \case
pure $ CRGroupUpdated user g g' Nothing pure $ CRGroupUpdated user g g' Nothing
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 when (memberRole (membership :: GroupMember) < 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
@ -2040,7 +2032,7 @@ processChatCommand = \case
runUpdateGroupProfile user g $ update p runUpdateGroupProfile user g $ update p
isReady :: Contact -> Bool isReady :: Contact -> Bool
isReady ct = isReady ct =
let s = connStatus $ ct.activeConn let s = connStatus $ activeConn (ct :: Contact)
in s == ConnReady || s == ConnSndReady in s == ConnReady || s == ConnSndReady
withCurrentCall :: ContactId -> (User -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse withCurrentCall :: ContactId -> (User -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse
withCurrentCall ctId action = do withCurrentCall ctId action = do
@ -3222,7 +3214,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
| sameMemberId memId m -> do | sameMemberId memId m -> do
-- 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 (memberId (membership :: GroupMember)) (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
@ -3261,7 +3253,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected} toView $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected}
whenGroupNtfs user gInfo $ do whenGroupNtfs user gInfo $ do
setActive $ ActiveG gName setActive $ ActiveG gName
showToast ("#" <> gName) $ "member " <> m.localDisplayName <> " is connected" showToast ("#" <> gName) $ "member " <> localDisplayName (m :: GroupMember) <> " is connected"
intros <- withStore' $ \db -> createIntroductions db members m intros <- withStore' $ \db -> createIntroductions db members m
void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m
forM_ intros $ \intro -> forM_ intros $ \intro ->
@ -3321,9 +3313,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
&& hasDeliveryReceipt (toCMEventTag event) && hasDeliveryReceipt (toCMEventTag event)
&& currentMemCount <= smallGroupsRcptsMemLimit && currentMemCount <= smallGroupsRcptsMemLimit
where where
canSend :: GroupMember -> m () -> m ()
canSend mem a canSend mem a
| mem.memberRole <= GRObserver = messageError "member is not allowed to send messages" | memberRole (mem :: GroupMember) <= GRObserver = messageError "member is not allowed to send messages"
| otherwise = a | otherwise = a
RCVD msgMeta msgRcpt -> RCVD msgMeta msgRcpt ->
withAckMessage' agentConnId conn msgMeta $ withAckMessage' agentConnId conn msgMeta $
@ -4520,7 +4511,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
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 (memberId (membership :: GroupMember)) (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 enableNtfs groupConnReq dm subMode groupConnIds <- joinAgentConnectionAsync user enableNtfs groupConnReq dm subMode
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user enableNtfs dcr dm subMode directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user enableNtfs dcr dm subMode
@ -4530,7 +4521,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> MsgMeta -> m () xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> MsgMeta -> m ()
xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg msgMeta xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg msgMeta
| membership.memberId == memId = | memberId (membership :: GroupMember) == 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 = do | otherwise = do
@ -4554,7 +4545,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> MsgMeta -> m () xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> MsgMeta -> m ()
xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId msg msgMeta = do xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId msg msgMeta = do
members <- withStore' $ \db -> getGroupMembers db user gInfo members <- withStore' $ \db -> getGroupMembers db user gInfo
if membership.memberId == memId if memberId (membership :: GroupMember) == 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
@ -4796,7 +4787,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, fileInvitation, fileStatus, cryptoArgs} 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
@ -4814,7 +4805,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 (fileInvitation :: FileInvitation))
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 ()
@ -5153,7 +5144,7 @@ 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 = (preference :: ContactUserPref (FeaturePreference f) -> FeaturePreference f) . userPreference
type FeatureContent a d = ChatFeature -> a -> Maybe Int -> CIContent d type FeatureContent a d = ChatFeature -> a -> Maybe Int -> CIContent d
@ -5238,7 +5229,7 @@ getCreateActiveUser st testView = do
Right user -> pure user Right user -> pure user
selectUser :: [User] -> IO User selectUser :: [User] -> IO User
selectUser [user] = do selectUser [user] = do
withTransaction st (`setActiveUser` user.userId) withTransaction st (`setActiveUser` userId (user :: User))
pure user pure user
selectUser users = do selectUser users = do
putStrLn "Select user profile:" putStrLn "Select user profile:"
@ -5253,7 +5244,7 @@ getCreateActiveUser st testView = do
| 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 = users !! (n - 1)
withTransaction st (`setActiveUser` user.userId) withTransaction st (`setActiveUser` userId (user :: User))
pure user pure user
userStr :: User -> String userStr :: User -> String
userStr User {localDisplayName, profile = LocalProfile {fullName}} = userStr User {localDisplayName, profile = LocalProfile {fullName}} =

View file

@ -13,7 +13,6 @@ module Simplex.Chat.Archive
where where
import qualified Codec.Archive.Zip as Z import qualified Codec.Archive.Zip as Z
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Reader import Control.Monad.Reader
import Data.Functor (($>)) import Data.Functor (($>))

View file

@ -8,7 +8,7 @@ module Simplex.Chat.Bot where
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad import Control.Monad.Reader
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T import qualified Data.Text as T
import Simplex.Chat.Controller import Simplex.Chat.Controller

View file

@ -6,14 +6,11 @@
{-# 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 #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Messages where module Simplex.Chat.Messages where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
@ -376,7 +373,7 @@ 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} = preference (userPreference :: ContactUserPref TimedMessagesPreference)
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}}}

View file

@ -16,9 +16,7 @@ module Simplex.Chat.Mobile.File
) )
where where
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Class
import Data.Aeson (ToJSON) import Data.Aeson (ToJSON)
import qualified Data.Aeson as J import qualified Data.Aeson as J
import Data.ByteString (ByteString) import Data.ByteString (ByteString)

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 ()

View file

@ -8,9 +8,7 @@ module Simplex.Chat.Mobile.WebRTC (
reservedSize, reservedSize,
) where ) where
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Class
import qualified Crypto.Cipher.Types as AES import qualified Crypto.Cipher.Types as AES
import Data.Bifunctor (bimap) import Data.Bifunctor (bimap)
import qualified Data.ByteArray as BA import qualified Data.ByteArray as BA

View file

@ -13,8 +13,6 @@
{-# LANGUAGE StrictData #-} {-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Protocol where module Simplex.Chat.Protocol where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))

View file

@ -5,8 +5,6 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Connections module Simplex.Chat.Store.Connections
( getConnectionEntity, ( getConnectionEntity,
getConnectionsToSubscribe, getConnectionsToSubscribe,
@ -15,7 +13,6 @@ module Simplex.Chat.Store.Connections
where where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Data.Int (Int64) import Data.Int (Int64)
import Data.Maybe (catMaybes, fromMaybe) import Data.Maybe (catMaybes, fromMaybe)

View file

@ -1,5 +1,4 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
@ -8,8 +7,6 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Direct module Simplex.Chat.Store.Direct
( updateContact_, ( updateContact_,
updateContactProfile_, updateContactProfile_,
@ -64,9 +61,7 @@ module Simplex.Chat.Store.Direct
) )
where where
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Class
import Data.Either (rights) import Data.Either (rights)
import Data.Functor (($>)) import Data.Functor (($>))
import Data.Int (Int64) import Data.Int (Int64)
@ -461,7 +456,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 -> updateContactRequest cr $> Right (contactRequestId (cr :: UserContactRequest))
getContactRequest db user cReqId getContactRequest db user cReqId
createContactRequest :: IO (Either StoreError Int64) createContactRequest :: IO (Either StoreError Int64)
createContactRequest = do createContactRequest = do

View file

@ -76,9 +76,7 @@ module Simplex.Chat.Store.Files
where where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Class
import Data.Either (rights) import Data.Either (rights)
import Data.Int (Int64) import Data.Int (Int64)
import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.Maybe (fromMaybe, isJust, listToMaybe)
@ -486,7 +484,7 @@ createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation ->
createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
currentTs <- liftIO getCurrentTime currentTs <- liftIO getCurrentTime
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_ let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_
-- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it -- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_ xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_
fileProtocol = if isJust rfd_ then FPXFTP else FPSMP fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
@ -507,7 +505,7 @@ createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvi
createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
currentTs <- liftIO getCurrentTime currentTs <- liftIO getCurrentTime
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_ let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_
-- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it -- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_ xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_
fileProtocol = if isJust rfd_ then FPXFTP else FPSMP fileProtocol = if isJust rfd_ then FPXFTP else FPSMP

View file

@ -8,9 +8,6 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Groups module Simplex.Chat.Store.Groups
( -- * Util methods ( -- * Util methods
@ -98,9 +95,7 @@ module Simplex.Chat.Store.Groups
) )
where where
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Class
import Crypto.Random (ChaChaDRG) import Crypto.Random (ChaChaDRG)
import Data.Either (rights) import Data.Either (rights)
import Data.Int (Int64) import Data.Int (Int64)
@ -890,7 +885,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 (introInv :: IntroInvitation),
":direct_queue_info" := directConnReq introInv, ":direct_queue_info" := directConnReq introInv,
":updated_at" := currentTs, ":updated_at" := currentTs,
":intro_id" := introId intro ":intro_id" := introId intro
@ -938,7 +933,7 @@ getIntroduction_ db reMember toMember = ExceptT $ do
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do
let mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange let mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
cLevel = 1 + maybe 0 (\Connection {connLevel} -> connLevel) activeConn cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
currentTs <- liftIO getCurrentTime currentTs <- liftIO getCurrentTime
newMember <- case directConnIds of newMember <- case directConnIds of
Just (directCmdId, directAgentConnId) -> do Just (directCmdId, directAgentConnId) -> do
@ -957,7 +952,7 @@ createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupM
createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> VersionRange -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> IO () createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> VersionRange -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> IO ()
createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} mcvr (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} mcvr (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do
let cLevel = 1 + maybe 0 (\Connection {connLevel} -> connLevel) activeConn let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
currentTs <- getCurrentTime currentTs <- getCurrentTime
Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId mcvr viaContactId cLevel currentTs subMode Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId mcvr viaContactId cLevel currentTs subMode
setCommandConnId db user groupCmdId groupConnId setCommandConnId db user groupCmdId groupConnId

View file

@ -10,8 +10,6 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Messages module Simplex.Chat.Store.Messages
( getContactConnIds_, ( getContactConnIds_,
getDirectChatReactions_, getDirectChatReactions_,
@ -98,9 +96,7 @@ module Simplex.Chat.Store.Messages
) )
where where
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Class
import Crypto.Random (ChaChaDRG) import Crypto.Random (ChaChaDRG)
import Data.Bifunctor (first) import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)

View file

@ -7,8 +7,6 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Profiles module Simplex.Chat.Store.Profiles
( AutoAccept (..), ( AutoAccept (..),
UserMsgReceiptSettings (..), UserMsgReceiptSettings (..),
@ -56,9 +54,7 @@ module Simplex.Chat.Store.Profiles
) )
where where
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Class
import Data.Aeson (ToJSON) import Data.Aeson (ToJSON)
import qualified Data.Aeson as J import qualified Data.Aeson as J
import Data.Functor (($>)) import Data.Functor (($>))
@ -294,7 +290,7 @@ getUserContactProfiles db User {userId} =
|] |]
(Only userId) (Only userId)
where where
toContactProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences) -> Profile toContactProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences) -> (Profile)
toContactProfile (displayName, fullName, image, contactLink, preferences) = Profile {displayName, fullName, image, contactLink, preferences} toContactProfile (displayName, fullName, image, contactLink, preferences) = Profile {displayName, fullName, image, contactLink, preferences}
createUserContactLink :: DB.Connection -> User -> ConnId -> ConnReqContact -> SubscriptionMode -> ExceptT StoreError IO () createUserContactLink :: DB.Connection -> User -> ConnId -> ConnReqContact -> SubscriptionMode -> ExceptT StoreError IO ()

View file

@ -10,11 +10,10 @@
module Simplex.Chat.Store.Shared where module Simplex.Chat.Store.Shared where
import Control.Concurrent.STM (stateTVar)
import Control.Exception (Exception) import Control.Exception (Exception)
import qualified Control.Exception as E import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Class
import Crypto.Random (ChaChaDRG, randomBytesGenerate) import Crypto.Random (ChaChaDRG, randomBytesGenerate)
import Data.Aeson (ToJSON) import Data.Aeson (ToJSON)
import qualified Data.Aeson as J import qualified Data.Aeson as J

View file

@ -5,7 +5,7 @@
module Simplex.Chat.Terminal where module Simplex.Chat.Terminal where
import Control.Exception (handle, throwIO) import Control.Exception (handle, throwIO)
import Control.Monad import Control.Monad.Except
import qualified Data.List.NonEmpty as L import qualified Data.List.NonEmpty as L
import Database.SQLite.Simple (SQLError (..)) import Database.SQLite.Simple (SQLError (..))
import qualified Database.SQLite.Simple as DB import qualified Database.SQLite.Simple as DB

View file

@ -12,7 +12,6 @@ module Simplex.Chat.Terminal.Input where
import Control.Applicative (optional, (<|>)) import Control.Applicative (optional, (<|>))
import Control.Concurrent (forkFinally, forkIO, killThread, mkWeakThreadId, threadDelay) import Control.Concurrent (forkFinally, forkIO, killThread, mkWeakThreadId, threadDelay)
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Reader import Control.Monad.Reader
import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Attoparsec.ByteString.Char8 as A

View file

@ -9,7 +9,6 @@
module Simplex.Chat.Terminal.Output where module Simplex.Chat.Terminal.Output where
import Control.Concurrent (ThreadId) import Control.Concurrent (ThreadId)
import Control.Monad
import Control.Monad.Catch (MonadMask) import Control.Monad.Catch (MonadMask)
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Reader import Control.Monad.Reader

View file

@ -16,8 +16,6 @@
{-# LANGUAGE StrictData #-} {-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use newtype instead of data" #-} {-# HLINT ignore "Use newtype instead of data" #-}
@ -58,21 +56,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' = userContactId
{-# INLINE contactId' #-} {-# INLINE contactId' #-}
profile' u = u.profile profile' = profile
{-# INLINE profile' #-} {-# INLINE profile' #-}
localDisplayName' u = u.localDisplayName 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' = contactId
{-# INLINE contactId' #-} {-# INLINE contactId' #-}
profile' c = c.profile profile' = profile
{-# INLINE profile' #-} {-# INLINE profile' #-}
localDisplayName' c = c.localDisplayName localDisplayName' = localDisplayName
{-# INLINE localDisplayName' #-} {-# INLINE localDisplayName' #-}
preferences' Contact {profile = LocalProfile {preferences}} = preferences preferences' Contact {profile = LocalProfile {preferences}} = preferences
{-# INLINE preferences' #-} {-# INLINE preferences' #-}
@ -185,7 +183,7 @@ instance ToJSON Contact where
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
contactConn :: Contact -> Connection contactConn :: Contact -> Connection
contactConn Contact{activeConn} = activeConn contactConn = activeConn
contactConnId :: Contact -> ConnId contactConnId :: Contact -> ConnId
contactConnId = aConnId . contactConn contactConnId = aConnId . contactConn
@ -468,7 +466,7 @@ instance ToJSON LocalProfile where
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
localProfileId :: LocalProfile -> ProfileId localProfileId :: LocalProfile -> ProfileId
localProfileId LocalProfile{profileId} = profileId localProfileId = profileId
toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile
toLocalProfile profileId Profile {displayName, fullName, image, contactLink, preferences} localAlias = toLocalProfile profileId Profile {displayName, fullName, image, contactLink, preferences} localAlias =
@ -629,7 +627,7 @@ groupMemberRef GroupMember {groupMemberId, memberProfile = p} =
GroupMemberRef {groupMemberId, profile = fromLocalProfile p} GroupMemberRef {groupMemberId, profile = fromLocalProfile p}
memberConn :: GroupMember -> Maybe Connection memberConn :: GroupMember -> Maybe Connection
memberConn GroupMember{activeConn} = activeConn memberConn = activeConn
memberConnId :: GroupMember -> Maybe ConnId memberConnId :: GroupMember -> Maybe ConnId
memberConnId GroupMember {activeConn} = aConnId <$> activeConn memberConnId GroupMember {activeConn} = aConnId <$> activeConn

View file

@ -8,15 +8,12 @@
{-# 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 #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
{-# HLINT ignore "Use newtype instead of data" #-} {-# HLINT ignore "Use newtype instead of data" #-}
@ -88,12 +85,12 @@ allChatFeatures =
] ]
chatPrefSel :: SChatFeature f -> Preferences -> Maybe (FeaturePreference f) chatPrefSel :: SChatFeature f -> Preferences -> Maybe (FeaturePreference f)
chatPrefSel f ps = case f of chatPrefSel = \case
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
@ -113,12 +110,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 = \case
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
@ -218,13 +215,13 @@ allGroupFeatures =
] ]
groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f) groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f)
groupPrefSel f ps = case f of groupPrefSel = \case
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
toGroupFeature :: SGroupFeature f -> GroupFeature toGroupFeature :: SGroupFeature f -> GroupFeature
toGroupFeature = \case toGroupFeature = \case
@ -245,13 +242,13 @@ 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 = \case
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
{-# INLINE getGroupPreference #-} {-# INLINE getGroupPreference #-}
-- collection of optional group preferences -- collection of optional group preferences
@ -431,19 +428,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 = (\allow -> p {allow}, allow (p :: TimedMessagesPreference))
instance HasField "allow" FullDeletePreference FeatureAllowed where instance HasField "allow" FullDeletePreference FeatureAllowed where
hasField p = (\allow -> p {allow}, p.allow) hasField p = (\allow -> p {allow}, allow (p :: FullDeletePreference))
instance HasField "allow" ReactionsPreference FeatureAllowed where instance HasField "allow" ReactionsPreference FeatureAllowed where
hasField p = (\allow -> p {allow}, p.allow) hasField p = (\allow -> p {allow}, allow (p :: ReactionsPreference))
instance HasField "allow" VoicePreference FeatureAllowed where instance HasField "allow" VoicePreference FeatureAllowed where
hasField p = (\allow -> p {allow}, p.allow) hasField p = (\allow -> p {allow}, allow (p :: VoicePreference))
instance HasField "allow" CallsPreference FeatureAllowed where instance HasField "allow" CallsPreference FeatureAllowed where
hasField p = (\allow -> p {allow}, p.allow) hasField p = (\allow -> p {allow}, allow (p :: CallsPreference))
instance FeatureI 'CFTimedMessages where instance FeatureI 'CFTimedMessages where
type FeaturePreference 'CFTimedMessages = TimedMessagesPreference type FeaturePreference 'CFTimedMessages = TimedMessagesPreference
@ -520,25 +517,25 @@ 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 = (\enable -> p {enable}, enable (p :: GroupPreference))
instance HasField "enable" TimedMessagesGroupPreference GroupFeatureEnabled where instance HasField "enable" TimedMessagesGroupPreference GroupFeatureEnabled where
hasField p = (\enable -> p {enable}, p.enable) hasField p = (\enable -> p {enable}, enable (p :: TimedMessagesGroupPreference))
instance HasField "enable" DirectMessagesGroupPreference GroupFeatureEnabled where instance HasField "enable" DirectMessagesGroupPreference GroupFeatureEnabled where
hasField p = (\enable -> p {enable}, p.enable) hasField p = (\enable -> p {enable}, enable (p :: DirectMessagesGroupPreference))
instance HasField "enable" ReactionsGroupPreference GroupFeatureEnabled where instance HasField "enable" ReactionsGroupPreference GroupFeatureEnabled where
hasField p = (\enable -> p {enable}, p.enable) hasField p = (\enable -> p {enable}, enable (p :: ReactionsGroupPreference))
instance HasField "enable" FullDeleteGroupPreference GroupFeatureEnabled where instance HasField "enable" FullDeleteGroupPreference GroupFeatureEnabled where
hasField p = (\enable -> p {enable}, p.enable) hasField p = (\enable -> p {enable}, enable (p :: FullDeleteGroupPreference))
instance HasField "enable" VoiceGroupPreference GroupFeatureEnabled where instance HasField "enable" VoiceGroupPreference GroupFeatureEnabled where
hasField p = (\enable -> p {enable}, p.enable) hasField p = (\enable -> p {enable}, enable (p :: VoiceGroupPreference))
instance HasField "enable" FilesGroupPreference GroupFeatureEnabled where instance HasField "enable" FilesGroupPreference GroupFeatureEnabled where
hasField p = (\enable -> p {enable}, p.enable) hasField p = (\enable -> p {enable}, enable (p :: FilesGroupPreference))
instance GroupFeatureI 'GFTimedMessages where instance GroupFeatureI 'GFTimedMessages where
type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference
@ -773,9 +770,9 @@ 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 = \case
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

View file

@ -7,7 +7,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedRecordDot #-}
module Simplex.Chat.View where module Simplex.Chat.View where
@ -192,7 +191,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
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 -> ttyUser u [sShow (connId (entityConnection acEntity :: Connection)) <> ": 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]
@ -687,9 +686,7 @@ viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of
viewContactsList :: [Contact] -> [StyledString] viewContactsList :: [Contact] -> [StyledString]
viewContactsList = viewContactsList =
let getLDN :: Contact -> ContactName let ldn = T.toLower . (localDisplayName :: Contact -> ContactName)
getLDN Contact{localDisplayName} = localDisplayName
ldn = T.toLower . getLDN
in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn
where where
muted' Contact {chatSettings, localDisplayName = ldn} muted' Contact {chatSettings, localDisplayName = ldn}
@ -827,8 +824,7 @@ viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filt
where where
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 <> ": " <> role m <> ", " <> category m <> status m groupMember m = memIncognito m <> ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m
role :: GroupMember -> StyledString role m = plain . strEncode $ memberRole (m :: GroupMember)
role m = plain . strEncode $ m.memberRole
category m = case memberCategory m of category m = case memberCategory m of
GCUserMember -> "you, " GCUserMember -> "you, "
GCInviteeMember -> "invited, " GCInviteeMember -> "invited, "
@ -860,10 +856,9 @@ viewContactConnected ct@Contact {localDisplayName} userIncognitoProfile testView
viewGroupsList :: [(GroupInfo, GroupSummary)] -> [StyledString] viewGroupsList :: [(GroupInfo, GroupSummary)] -> [StyledString]
viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"] viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"]
viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs viewGroupsList gs = map groupSS $ sortOn ldn_ gs
where where
ldn_ :: GroupInfo -> Text ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName) . fst
ldn_ g = T.toLower g.localDisplayName
groupSS (g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership, chatSettings}, GroupSummary {currentMembers}) = groupSS (g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership, chatSettings}, GroupSummary {currentMembers}) =
case memberStatus membership of case memberStatus membership of
GSMemInvited -> groupInvitation' g GSMemInvited -> groupInvitation' g
@ -1411,8 +1406,7 @@ viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksN
case concatMap recipientsTransferStatus $ groupBy ((==) `on` fs) $ sortOn fs fts of case concatMap recipientsTransferStatus $ groupBy ((==) `on` fs) $ sortOn fs fts of
[recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus] [recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus]
recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses
fs :: SndFileTransfer -> FileStatus fs = fileStatus :: SndFileTransfer -> FileStatus
fs SndFileTransfer{fileStatus} = fileStatus
recipientsTransferStatus [] = [] recipientsTransferStatus [] = []
recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts] recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts]
where where
@ -1675,8 +1669,7 @@ viewChatError logLevel = \case
Just entity@(UserContactConnection conn UserContact {userContactLinkId}) -> Just entity@(UserContactConnection conn UserContact {userContactLinkId}) ->
"[" <> connEntityLabel entity <> ", userContactLinkId: " <> sShow userContactLinkId <> ", connId: " <> cId conn <> "] " "[" <> connEntityLabel entity <> ", userContactLinkId: " <> sShow userContactLinkId <> ", connId: " <> cId conn <> "] "
Nothing -> "" Nothing -> ""
cId :: Connection -> StyledString cId conn = sShow (connId (conn :: Connection))
cId conn = sShow conn.connId
where where
fileNotFound fileId = ["file " <> sShow fileId <> " not found"] fileNotFound fileId = ["file " <> sShow fileId <> " not found"]
sqliteError' = \case sqliteError' = \case

View file

@ -49,24 +49,20 @@ extra-deps:
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561 # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
# - ../simplexmq # - ../simplexmq
- github: simplex-chat/simplexmq - github: simplex-chat/simplexmq
commit: 8d47f690838371bc848e4b31a4b09ef6bf67ccc5 commit: 53c793d5590d3c781aa3fbf72993eee262c7aa83
- github: kazu-yamamoto/http2 - github: kazu-yamamoto/http2
commit: b5a1b7200cf5bc7044af34ba325284271f6dff25 commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
# - ../direct-sqlcipher # - ../direct-sqlcipher
- github: simplex-chat/direct-sqlcipher - github: simplex-chat/direct-sqlcipher
commit: f814ee68b16a9447fbb467ccc8f29bdd3546bfd9 commit: 34309410eb2069b029b8fc1872deb1e0db123294
# - ../sqlcipher-simple # - ../sqlcipher-simple
- github: simplex-chat/sqlcipher-simple - github: simplex-chat/sqlcipher-simple
commit: a46bd361a19376c5211f1058908fc0ae6bf42446 commit: 5e154a2aeccc33ead6c243ec07195ab673137221
# - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977 # - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977
- github: simplex-chat/aeson - github: simplex-chat/aeson
commit: 68330dce8208173c6acf5f62b23acb500ab5d873 commit: 3eb66f9a68f103b5f1489382aad89f5712a64db7
- github: simplex-chat/haskell-terminal - github: simplex-chat/haskell-terminal
commit: f708b00009b54890172068f168bf98508ffcd495 commit: f708b00009b54890172068f168bf98508ffcd495
- github: simplex-chat/android-support
commit: 9aa09f148089d6752ce563b14c2df1895718d806
- github: simplex-chat/network-transport
commit: 0013798272a683e35ca38d2fdaf480942311fba8
# #
# extra-deps: [] # extra-deps: []

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
@ -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 = (coreOptions (testOpts :: ChatOpts)) {dbFilePrefix = tmp </> botDbPrefix},
publishers, publishers,
welcomeMessage = defaultWelcomeMessage publishers, welcomeMessage = defaultWelcomeMessage publishers,
prohibitedMessage = defaultWelcomeMessage publishers prohibitedMessage = defaultWelcomeMessage publishers

View file

@ -1,6 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-} {-# LANGUAGE PostfixOperators #-}
@ -61,7 +60,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 = (coreOptions (testOpts :: ChatOpts)) {dbFilePrefix = tmp </> serviceDbPrefix},
superUsers, superUsers,
directoryLog = Just $ tmp </> "directory_service.log", directoryLog = Just $ tmp </> "directory_service.log",
serviceName = "SimpleX-Directory", serviceName = "SimpleX-Directory",

View file

@ -6,15 +6,12 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module ChatClient where module ChatClient where
import Control.Concurrent (forkIOWithUnmask, killThread, threadDelay) import Control.Concurrent (forkIOWithUnmask, killThread, threadDelay)
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Exception (bracket, bracket_) import Control.Exception (bracket, bracket_)
import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Data.Functor (($>)) import Data.Functor (($>))
import Data.List (dropWhileEnd, find) import Data.List (dropWhileEnd, find)

View file

@ -2,8 +2,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-} {-# LANGUAGE PostfixOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module ChatTests.Files where module ChatTests.Files where
import ChatClient import ChatClient