mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
Compare commits
23 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
| 433200bab9 | |||
| 9513a47860 | |||
| 96176936e6 | |||
| 20e7feb953 | |||
| 7fa671f829 | |||
| 1c2e49ae83 | |||
| 2e56b3cb58 | |||
| 642cec3092 | |||
| 1564424f0d | |||
| 177c007edc | |||
| d279c144a6 | |||
| ba2378e5d6 | |||
| b7b393b993 | |||
| d5e66e2284 | |||
| 2ce3cd2fad | |||
| e4328cb98d | |||
| 498181b2e9 | |||
| 6c8fb9e6d0 | |||
| e5f13adc2a | |||
| d9b3742f62 | |||
| 800a4f90bf | |||
| deaea44024 | |||
| 23468f0afd |
@@ -0,0 +1,36 @@
|
||||
name: "CLA Assistant"
|
||||
on:
|
||||
issue_comment:
|
||||
types: [created]
|
||||
pull_request_target:
|
||||
types: [opened, closed, synchronize]
|
||||
|
||||
jobs:
|
||||
CLAssistant:
|
||||
runs-on: ubuntu-latest
|
||||
steps:
|
||||
- name: "CLA Assistant"
|
||||
if: (github.event.comment.body == 'recheck' || github.event.comment.body == 'I have read the CLA Document and I hereby sign the CLA') || github.event_name == 'pull_request'
|
||||
# Beta Release
|
||||
uses: cla-assistant/github-action@v2.1.3-beta
|
||||
env:
|
||||
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
|
||||
# the below token should have repo scope and must be manually added by you in the repository's secret
|
||||
PERSONAL_ACCESS_TOKEN : ${{ secrets.PERSONAL_ACCESS_TOKEN }}
|
||||
with:
|
||||
path-to-signatures: 'signatures/v1.1/cla.json'
|
||||
path-to-document: 'https://github.com/simplex-chat/cla/blob/master/CLA.md'
|
||||
# branch should not be protected
|
||||
remote-organization-name: simplex-chat
|
||||
remote-repository-name: cla
|
||||
branch: 'master'
|
||||
# allowlist: user1,bot*
|
||||
|
||||
#below are the optional inputs - If the optional inputs are not given, then default values will be taken
|
||||
#create-file-commit-message: 'For example: Creating file for storing CLA Signatures'
|
||||
#signed-commit-message: 'For example: $contributorName has signed the CLA in #$pullRequestNo'
|
||||
#custom-notsigned-prcomment: 'pull request comment with Introductory message to ask new contributors to sign'
|
||||
#custom-pr-sign-comment: 'The signature to be committed in order to sign the CLA'
|
||||
#custom-allsigned-prcomment: 'pull request comment when all contributors has signed, defaults to **CLA Assistant Lite bot** All Contributors have signed the CLA.'
|
||||
#lock-pullrequest-aftermerge: false - if you don't want this bot to automatically lock the pull request after merging (default - true)
|
||||
#use-dco-flag: true - If you are using DCO instead of CLA
|
||||
@@ -1,19 +1,44 @@
|
||||
<img align="right" src="images/logo.svg" alt="SimpleX logo" height="90">
|
||||
<img src="images/simplex-chat-logo.svg" alt="SimpleX logo" width="100%">
|
||||
|
||||
# SimpleX chat
|
||||
# SimpleX Chat
|
||||
|
||||
## Private, secure, decentralized
|
||||
**The world's most private and secure chat** - open-source, decentralized, and without global identities of any kind.
|
||||
|
||||
[](https://github.com/simplex-chat/simplex-chat/actions?query=workflow%3Abuild)
|
||||
[](https://github.com/simplex-chat/simplex-chat/releases)
|
||||
[](https://github.com/simplex-chat/simplex-chat/releases)
|
||||
[](https://twitter.com/simplexchat)
|
||||
[](https://www.reddit.com/r/SimpleXChat)
|
||||
|
||||
> **NEW in v0.4: [groups](#groups) and [sending files](#sending-files)!**
|
||||
SimpleX chat prototype is a thin terminal UI on top of [SimpleXMQ](https://github.com/simplex-chat/simplexmq) message broker that uses [SMP protocols](https://github.com/simplex-chat/simplexmq/blob/master/protocol). The motivation for SimpleX chat is [presented here](./simplex.md). See [simplex.chat](https://simplex.chat) website for chat demo and the explanations of the system and how SMP protocol works.
|
||||
|
||||
The motivation for SimpleX chat is [presented here](./simplex.md).
|
||||
**NEW in v0.5.0: [user contact addresses](#user-contact-addresses-alpha)!**
|
||||
|
||||
SimpleX chat prototype is a thin terminal UI on top of [SimpleXMQ](https://github.com/simplex-chat/simplexmq) message broker that uses [SMP protocols](https://github.com/simplex-chat/simplexmq/blob/master/protocol).
|
||||
**Please note**: v0.5.0 of SimpleX Chat works with the same database, but the connection links are not compatible with the previous version - please ask all your contacts to upgrade!
|
||||
|
||||
See [simplex.chat](https://simplex.chat) website for chat demo and the explanations of the system and how SMP protocol works.
|
||||
### :zap: Quick installation
|
||||
|
||||
```sh
|
||||
curl -o- https://raw.githubusercontent.com/simplex-chat/simplex-chat/master/install.sh | bash
|
||||
```
|
||||
|
||||
Once the chat client is installed, simply run `simplex-chat` from your terminal.
|
||||
|
||||
### :wave: Welcome
|
||||
|
||||
**We are building the world's most private and secure chat**. If you would like to support it, you can do so in the following ways:
|
||||
|
||||
- 🌟 **Star it on GitHub** - it helps us raise the visibility of the project.
|
||||
|
||||
- **Install the chat and try it out** - if you spot a bug, please [raise an issue](https://github.com/simplex-chat/simplex-chat/issues).
|
||||
|
||||
- :speech_balloon: **Spread the word** - terminal chat is an [early-stage product](#disclaimer) while we stabilize the protocol - you can invite your friends for some fun chat inside your terminal. We're using it right inside our IDEs as we are coding it 👨💻
|
||||
|
||||
- **Make a donation** via [opencollective](https://opencollective.com/simplex-chat) - every donation helps, however large or small!
|
||||
|
||||
- **Make a contribution to the project** - we're constantly moving the project forward and there are always lots of things to do!
|
||||
|
||||
We appreciate all the help from our contributors, thank you!
|
||||
|
||||

|
||||
|
||||
@@ -22,8 +47,11 @@ See [simplex.chat](https://simplex.chat) website for chat demo and the explanati
|
||||
- [Disclaimer](#disclaimer)
|
||||
- [Network topology](#network-topology)
|
||||
- [Terminal chat features](#terminal-chat-features)
|
||||
- [Installation](#installation)
|
||||
- [Installation](#🚀-installation)
|
||||
- [Download chat client](#download-chat-client)
|
||||
- [Linux and MacOS](#linux-and-macos)
|
||||
- [Troubleshooting on Unix](#troubleshooting-on-unix)
|
||||
- [Windows](#windows)
|
||||
- [Build from source](#build-from-source)
|
||||
- [Using Docker](#using-docker)
|
||||
- [Using Haskell stack](#using-haskell-stack)
|
||||
@@ -32,25 +60,26 @@ See [simplex.chat](https://simplex.chat) website for chat demo and the explanati
|
||||
- [How to use SimpleX chat](#how-to-use-simplex-chat)
|
||||
- [Groups](#groups)
|
||||
- [Sending files](#sending-files)
|
||||
- [User contact addresses](#user-contact-addresses-alpha)
|
||||
- [Access chat history](#access-chat-history)
|
||||
- [Future roadmap](#future-roadmap)
|
||||
- [Roadmap](#Roadmap)
|
||||
- [License](#license)
|
||||
|
||||
## Disclaimer
|
||||
|
||||
This is WIP implementation of SimpleX chat that implements a new network topology for asynchronous communication combining the advantages and avoiding the disadvantages of federated and P2P networks.
|
||||
This is WIP implementation of SimpleX Chat that implements a new network topology for asynchronous communication combining the advantages and avoiding the disadvantages of federated and P2P networks.
|
||||
|
||||
If you expect a software being reliable most of the time and doing something useful, then this is probably not ready for you yet. We do use it for terminal chat though, and it seems to work most of the time - we would really appreciate if you try it and give us your feedback.
|
||||
If you expect software to be reliable most of the time, then this is probably not ready for you yet. We use it ourselves for terminal chat and it seems to work most of the time - we would really appreciate if you try SimpleX Chat and give us your feedback!
|
||||
|
||||
**Please note:** The main differentiation of SimpleX network is the approach to internet message routing rather than encryption; for that reason no sufficient attention was paid to either TCP transport level encryption or to E2E encryption protocols - they are implemented in an ad hoc way based on RSA and AES algorithms. See [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a) on TCP transport encryption protocol (AEAD-GCM scheme, with an AES key negotiation based on RSA key hash known to the client in advance) and [this section](https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-01-26-crypto.md#e2e-encryption) on E2E encryption protocol (an ad hoc hybrid scheme a la PGP). These protocols will change in a consumer ready version to something more robust.
|
||||
> :warning: **Please note:** The main differentiation of SimpleX network is the approach to internet message routing rather than encryption; for that reason no sufficient attention was paid to either TCP transport level encryption or to E2E encryption protocols - they are implemented in an ad hoc way based on RSA and AES algorithms. See [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a) on TCP transport encryption protocol (AEAD-GCM scheme, with an AES key negotiation based on RSA key hash known to the client in advance) and [this section](https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-01-26-crypto.md#e2e-encryption) on E2E encryption protocol (an ad hoc hybrid scheme a la PGP). These protocols will change in a consumer ready version to something more robust.
|
||||
|
||||
## Network topology
|
||||
|
||||
SimpleX is a decentralized client-server network that uses redundant, disposable nodes to asynchronously pass the messages via message queues, providing receiver and sender anonymity.
|
||||
SimpleX is a decentralized client-server network that uses redundant, disposable nodes to asynchronously pass messages via message queues, providing receiver and sender anonymity.
|
||||
|
||||
Unlike P2P networks, all messages are passed through one or several (for redundancy) servers, that do not even need to have persistence (in fact, the current [SMP server implementation](https://github.com/simplex-chat/simplexmq#smp-server) uses in-memory message storage, persisting only the queue records) - it provides better metadata protection than P2P designs, as no global participant ID is required, and avoids many [problems of P2P networks](https://github.com/simplex-chat/simplex-chat/blob/master/simplex.md#comparison-with-p2p-messaging-protocols).
|
||||
|
||||
Unlike federated networks, the participating server nodes do NOT have records of the users, do NOT communicate with each other, do NOT store messages after they are delivered to the recipients, and there is no way to discover the full list of participating servers - it avoids the problem of metadata visibility that federated networks suffer from and better protects the network, as servers do not communicate with each other. Each server node provides unidirectional "dumb pipes" to the users, that do authorization without authentication, having no knowledge of the the users or their contacts. Each queue is assigned two RSA keys - one for receiver and one for sender - and each queue access is authorized with a signature created using a respective key's private counterpart.
|
||||
Unlike federated networks, the participating server nodes **do not have records of the users**, **do not communicate with each other**, **do not store messages** after they are delivered to the recipients, and there is no way to discover the full list of participating servers. SimpleX network avoids the problem of metadata visibility that federated networks suffer from and better protects the network, as servers do not communicate with each other. Each server node provides unidirectional "dumb pipes" to the users, that do authorization without authentication, having no knowledge of the the users or their contacts. Each queue is assigned two RSA keys - one for receiver and one for sender - and each queue access is authorized with a signature created using a respective key's private counterpart.
|
||||
|
||||
The routing of messages relies on the knowledge of client devices how user contacts and groups map at any given moment of time to these disposable queues on server nodes.
|
||||
|
||||
@@ -59,6 +88,7 @@ The routing of messages relies on the knowledge of client devices how user conta
|
||||
- 1-to-1 chat with multiple people in the same terminal window.
|
||||
- Group messaging.
|
||||
- Sending files to contacts and groups.
|
||||
- User contact addresses - establish connections via multiple-use contact links.
|
||||
- Auto-populated recipient name - just type your messages to reply to the sender once the connection is established.
|
||||
- Demo SMP servers available and pre-configured in the app - or you can [deploy your own server](https://github.com/simplex-chat/simplexmq#using-smp-server-and-smp-agent).
|
||||
- No global identity or any names visible to the server(s), ensuring full privacy of your contacts and conversations.
|
||||
@@ -70,23 +100,61 @@ The routing of messages relies on the knowledge of client devices how user conta
|
||||
|
||||
RSA keys are not used as identity, they are randomly generated for each contact.
|
||||
|
||||
## Installation
|
||||
<a name="🚀-installation"></a>
|
||||
|
||||
## 🚀 Installation
|
||||
|
||||
### Download chat client
|
||||
|
||||
Download the chat binary for your system from the [latest stable release](https://github.com/simplex-chat/simplex-chat/releases) and make it executable as shown below.
|
||||
|
||||
#### Linux and MacOS
|
||||
|
||||
To **install** or **update** `simplex-chat`, you should run the install script. To do that, use the following cURL or Wget command:
|
||||
|
||||
```sh
|
||||
curl -o- https://raw.githubusercontent.com/simplex-chat/simplex-chat/master/install.sh | bash
|
||||
```
|
||||
|
||||
```sh
|
||||
wget -qO- https://raw.githubusercontent.com/simplex-chat/simplex-chat/master/install.sh | bash
|
||||
```
|
||||
|
||||
Once the chat client downloads, you can run it with `simplex-chat` command in your terminal.
|
||||
|
||||
Alternatively, you can manually download the chat binary for your system from the [latest stable release](https://github.com/simplex-chat/simplex-chat/releases) and make it executable as shown below.
|
||||
|
||||
```sh
|
||||
chmod +x <binary>
|
||||
mv <binary> ~/.local/bin/simplex-chat
|
||||
```
|
||||
|
||||
(or any other preferred location on PATH).
|
||||
(or any other preferred location on `PATH`).
|
||||
|
||||
On MacOS you also need to [allow Gatekeeper to run it](https://support.apple.com/en-us/HT202491).
|
||||
|
||||
##### Troubleshooting on Unix
|
||||
|
||||
If you get `simplex-chat: command not found` when executing the downloaded binary, you need to add the directory containing it to the [`PATH` variable](https://man7.org/linux/man-pages/man7/environ.7.html) (find "PATH" in page). To modify `PATH` for future sessions, put `PATH="$PATH:/path/to/dir"` in `~/.profile`, or in `~/.bash_profile` if that's what you have. See [this answer](https://unix.stackexchange.com/a/26059) for the detailed explanation on the appropriate place to define environment variables for `bash` and other shells.
|
||||
|
||||
For example, if you followed the previous instructions, open `~/.profile` for editing:
|
||||
|
||||
```sh
|
||||
vi ~/.profile
|
||||
```
|
||||
|
||||
And add the following line to the end:
|
||||
|
||||
```sh
|
||||
PATH="$PATH:$HOME/.local/bin"
|
||||
```
|
||||
|
||||
Note that this will not automatically update your `PATH` for the remainder of the session. To do this, you should run:
|
||||
|
||||
```sh
|
||||
source ~/.profile
|
||||
```
|
||||
|
||||
Or restart your terminal to start a new session.
|
||||
|
||||
#### Windows
|
||||
|
||||
```sh
|
||||
@@ -105,7 +173,7 @@ $ cd simplex-chat
|
||||
$ DOCKER_BUILDKIT=1 docker build --output ~/.local/bin .
|
||||
```
|
||||
|
||||
> **Please note:** If you encounter ``version `GLIBC_2.28' not found`` error, rebuild it with `haskell:8.8.4-stretch` base image (change it in your local [Dockerfile](Dockerfile)).
|
||||
> **Please note:** If you encounter `` version `GLIBC_2.28' not found `` error, rebuild it with `haskell:8.10.4-stretch` base image (change it in your local [Dockerfile](Dockerfile)).
|
||||
|
||||
#### Using Haskell stack
|
||||
|
||||
@@ -127,7 +195,7 @@ $ stack install
|
||||
|
||||
### Running the chat client
|
||||
|
||||
To start the chat client, run `simplex-chat` from the terminal.
|
||||
To start the chat client, run `simplex-chat` from the terminal. If you get `simplex-chat: command not found`, see [Troubleshooting on Unix](#troubleshooting-on-unix).
|
||||
|
||||
By default, app data directory is created in the home directory (`~/.simplex`, or `%APPDATA%/simplex` on Windows), and two SQLite database files `simplex.chat.db` and `simplex.agent.db` are initialized in it.
|
||||
|
||||
@@ -155,9 +223,9 @@ Run `simplex-chat -h` to see all available options.
|
||||
|
||||
### How to use SimpleX chat
|
||||
|
||||
Once you have started the chat, you will be prompted to specify your "display name" and an optional "full name" to create a local chat profile. Your display name is an alias for your contacts to refer to you by - it is not unique and does not serve as a global identity. In case different contacts chose the same display name, the chat client adds a numeric suffix to their local display names.
|
||||
Once you have started the chat, you will be prompted to specify your "display name" and an optional "full name" to create a local chat profile. Your display name is an alias for your contacts to refer to you by - it is not unique and does not serve as a global identity. If some of your contacts chose the same display name, the chat client adds a numeric suffix to their local display name.
|
||||
|
||||
This diagram shows how to connect and message a contact:
|
||||
The diagram below shows how to connect and message a contact:
|
||||
|
||||
<div align="center">
|
||||
<img align="center" src="images/how-to-use-simplex.svg">
|
||||
@@ -177,7 +245,7 @@ Use `/help` in chat to see the list of available commands.
|
||||
|
||||
### Groups
|
||||
|
||||
To create a group use `/g <group>`, then add contacts to it with `/a <group> <name>`and send messages with `#<group> <message>`. Use `/help groups` for other commands.
|
||||
To create a group use `/g <group>`, then add contacts to it with `/a <group> <name>`. You can then send messages to the group by entering `#<group> <message>`. Use `/help groups` for other commands.
|
||||
|
||||

|
||||
|
||||
@@ -191,9 +259,23 @@ You can send a file to your contact with `/f @<contact> <file_path>` - the recip
|
||||
|
||||
You can send files to a group with `/f #<group> <file_path>`.
|
||||
|
||||
### User contact addresses (alpha)
|
||||
|
||||
As an alternative to one-time invitation links, you can create a long-term address with `/ad` (for `/address`). The created address can then be shared via any channel, and used by other users as a link to make a contact request with `/c <user_contact_address>`.
|
||||
|
||||
You can accept or reject incoming requests with `/ac <name>` and `/rc <name>` commands.
|
||||
|
||||
User address is "long-term" in a sense that it is a multiple-use connection link - it can be used until it is deleted by the user, in which case all established connections would still remain active (unlike how it works with email, when changing the address results in people not being able to message you).
|
||||
|
||||
Use `/help address` for other commands.
|
||||
|
||||
> :warning: **Please note:** This is an "alpha" feature - at the moment there is nothing to prevent someone who has obtained this address from spamming you with connection requests; countermeasures will be added soon! (In the short term, you can simply delete the long-term address you created if it starts getting abused.)
|
||||
|
||||

|
||||
|
||||
### Access chat history
|
||||
|
||||
> 🚧 **Section currently out of date - will be updated soon** 🏗
|
||||
> 🚧 **Section currently out of date** 🏗
|
||||
|
||||
SimpleX chat stores all your contacts and conversations in a local database file, making it private and portable by design, fully owned and controlled by you.
|
||||
|
||||
@@ -214,16 +296,16 @@ order by internal_id desc;
|
||||
|
||||
> **Please note:** SQLite foreign key constraints are disabled by default, and must be **[enabled separately for each database connection](https://sqlite.org/foreignkeys.html#fk_enable)**. The latter can be achieved by running `PRAGMA foreign_keys = ON;` command on an open database connection. By running data altering queries without enabling foreign keys prior to that, you may risk putting your database in an inconsistent state.
|
||||
|
||||
## Future roadmap
|
||||
## Roadmap
|
||||
|
||||
1. Mobile and desktop apps (in progress).
|
||||
2. SMP protocol improvements:
|
||||
- SMP queue redundancy and rotation.
|
||||
- Message delivery confirmation.
|
||||
- Support multiple devices.
|
||||
- SMP queue redundancy and rotation.
|
||||
- Message delivery confirmation.
|
||||
- Support multiple devices.
|
||||
3. Privacy-preserving identity server for optional DNS-based contact/group addresses to simplify connection and discovery, but not used to deliver messages:
|
||||
- keep all your contacts and groups even if you lose the domain.
|
||||
- the server doesn't have information about your contacts and groups.
|
||||
- keep all your contacts and groups even if you lose the domain.
|
||||
- the server doesn't have information about your contacts and groups.
|
||||
4. Media server to optimize sending large files to groups.
|
||||
5. Channels server for large groups and broadcast channels.
|
||||
|
||||
|
||||
@@ -1,119 +0,0 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Demo where
|
||||
|
||||
import Simplex.Chat.Styled
|
||||
import System.Console.ANSI.Types
|
||||
import System.Terminal
|
||||
|
||||
someViewUpdate :: Monad m => m ()
|
||||
someViewUpdate = pure ()
|
||||
|
||||
chatLayoutDemo :: MonadTerminal m => m ()
|
||||
chatLayoutDemo =
|
||||
mapM_
|
||||
putStyledLn
|
||||
[ " search " <> Styled gray "(ctrl-s) " <> lineV <> Styled toContact " @bob " <> "Bob Roberts " <> Styled greenColor "@john" <> "",
|
||||
" " <> lineV <> Styled gray " 14:15 online profile (ctrl-p)",
|
||||
lineH 20 <> crossover <> lineH 59,
|
||||
"* " <> Styled [SetConsoleIntensity BoldIntensity] "all chats " <> " " <> lineV <> "",
|
||||
Styled gray " (ctrl-a) " <> lineV <> "",
|
||||
"*" <> Styled toContact " @alice " <> Styled darkGray "14:37 " <> lineV <> "",
|
||||
Styled gray " Hello there! ... " <> lineV <> "",
|
||||
Styled selected " " <> Styled (toContact <> selected) " @bob " <> Styled (selected <> gray) "12:35 " <> lineV <> "",
|
||||
Styled selected " All good, John... " <> lineV <> "",
|
||||
"*" <> Styled group " #team " <> Styled darkGray "10:55 " <> lineV <> "",
|
||||
Styled gray " What's up ther... " <> lineV <> "",
|
||||
" " <> Styled toContact " @tom " <> Styled darkGray "Wed " <> lineV <> "",
|
||||
Styled gray " Have you seen ... " <> lineV <> "",
|
||||
" " <> lineV,
|
||||
" " <> lineV,
|
||||
" " <> lineV,
|
||||
" " <> lineV,
|
||||
" " <> lineV,
|
||||
" " <> lineV <> Styled greenColor " ✔︎" <> Styled darkGray " 12:30" <> Styled toContact " @bob" <> " hey bob - how is it going?",
|
||||
" " <> lineV <> Styled greenColor " ✔︎" <> Styled darkGray " " <> Styled toContact " " <> " let's meet soon!",
|
||||
" " <> lineV <> " *" <> Styled darkGray " 12:35" <> Styled contact " bob>" <> " All good, John! How are you?",
|
||||
" " <> teeL <> lineH 59,
|
||||
" " <> lineV <> " > " <> Styled toContact "@bob" <> " 😀 This is the message that will be sent to @bob"
|
||||
]
|
||||
>> putStyled (Styled ctrlKeys " help (ctrl-h) new contact (ctrl-n) choose chat (ctrl-↓↑) new group (ctrl-g) ")
|
||||
|
||||
contact :: [SGR]
|
||||
contact = [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Yellow]
|
||||
|
||||
toContact :: [SGR]
|
||||
toContact = [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan]
|
||||
|
||||
group :: [SGR]
|
||||
group = [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan]
|
||||
|
||||
selected :: [SGR]
|
||||
selected = [SetColor Background Vivid Black]
|
||||
|
||||
ctrlKeys :: [SGR]
|
||||
ctrlKeys = [SetColor Background Dull White, SetColor Foreground Dull Black]
|
||||
|
||||
gray :: [SGR]
|
||||
gray = [SetColor Foreground Dull White]
|
||||
|
||||
darkGray :: [SGR]
|
||||
darkGray = [SetColor Foreground Vivid Black]
|
||||
|
||||
greenColor :: [SGR]
|
||||
greenColor = [SetColor Foreground Vivid Green]
|
||||
|
||||
lineV :: StyledString
|
||||
lineV = Styled selected " " -- "\x2502"
|
||||
|
||||
lineH :: Int -> StyledString
|
||||
lineH n = Styled darkGray $ replicate n '\x2500'
|
||||
|
||||
teeL :: StyledString
|
||||
teeL = Styled selected " " -- "\x251C"
|
||||
|
||||
crossover :: StyledString
|
||||
crossover = Styled selected " " -- "\x253C"
|
||||
|
||||
putStyledLn :: MonadTerminal m => StyledString -> m ()
|
||||
putStyledLn s = putStyled s >> putLn
|
||||
|
||||
putStyled :: MonadTerminal m => StyledString -> m ()
|
||||
putStyled (s1 :<>: s2) = putStyled s1 >> putStyled s2
|
||||
putStyled (Styled [] s) = putString s
|
||||
putStyled (Styled sgr s) = setSGR sgr >> putString s >> resetAttributes
|
||||
|
||||
setSGR :: MonadTerminal m => [SGR] -> m ()
|
||||
setSGR = mapM_ $ \case
|
||||
Reset -> resetAttributes
|
||||
SetConsoleIntensity BoldIntensity -> setAttribute bold
|
||||
SetConsoleIntensity _ -> resetAttribute bold
|
||||
SetItalicized True -> setAttribute italic
|
||||
SetItalicized _ -> resetAttribute italic
|
||||
SetUnderlining NoUnderline -> resetAttribute underlined
|
||||
SetUnderlining _ -> setAttribute underlined
|
||||
SetSwapForegroundBackground True -> setAttribute inverted
|
||||
SetSwapForegroundBackground _ -> resetAttribute inverted
|
||||
SetColor l i c -> setAttribute . layer l . intensity i $ color c
|
||||
SetBlinkSpeed _ -> pure ()
|
||||
SetVisible _ -> pure ()
|
||||
SetRGBColor _ _ -> pure ()
|
||||
SetPaletteColor _ _ -> pure ()
|
||||
SetDefaultColor _ -> pure ()
|
||||
where
|
||||
layer = \case
|
||||
Foreground -> foreground
|
||||
Background -> background
|
||||
intensity = \case
|
||||
Dull -> id
|
||||
Vivid -> bright
|
||||
color = \case
|
||||
Black -> black
|
||||
Red -> red
|
||||
Green -> green
|
||||
Yellow -> yellow
|
||||
Blue -> blue
|
||||
Magenta -> magenta
|
||||
Cyan -> cyan
|
||||
White -> white
|
||||
@@ -6,6 +6,7 @@
|
||||
module Main where
|
||||
|
||||
import Simplex.Chat
|
||||
import Simplex.Chat.Controller (versionNumber)
|
||||
import Simplex.Chat.Options
|
||||
import System.Directory (getAppUserDataDirectory)
|
||||
import System.Terminal (withTerminal)
|
||||
@@ -20,39 +21,7 @@ welcomeGetOpts :: IO ChatOpts
|
||||
welcomeGetOpts = do
|
||||
appDir <- getAppUserDataDirectory "simplex"
|
||||
opts@ChatOpts {dbFile} <- getChatOpts appDir
|
||||
putStrLn "SimpleX chat prototype v0.4.0"
|
||||
putStrLn $ "SimpleX Chat v" ++ versionNumber
|
||||
putStrLn $ "db: " <> dbFile <> ".chat.db, " <> dbFile <> ".agent.db"
|
||||
putStrLn "type \"/help\" or \"/h\" for usage info"
|
||||
pure opts
|
||||
|
||||
-- defaultSettings :: C.Size -> C.VirtualTerminalSettings
|
||||
-- defaultSettings size =
|
||||
-- C.VirtualTerminalSettings
|
||||
-- { C.virtualType = "xterm",
|
||||
-- C.virtualWindowSize = pure size,
|
||||
-- C.virtualEvent = retry,
|
||||
-- C.virtualInterrupt = retry
|
||||
-- }
|
||||
|
||||
-- main :: IO ()
|
||||
-- main = do
|
||||
-- void $ createStore "simplex-chat.db" 4
|
||||
|
||||
-- hFlush stdout
|
||||
-- -- ChatTerminal {termSize} <- newChatTerminal
|
||||
-- -- pos <- C.withVirtualTerminal (defaultSettings termSize) $
|
||||
-- -- \t -> runTerminalT (C.setAlternateScreenBuffer True >> C.putString "a" >> C.flush >> C.getCursorPosition) t
|
||||
-- -- print pos
|
||||
-- -- race_ (printEvents t) (updateTerminal t)
|
||||
-- void . withTerminal . runTerminalT $ chatLayoutDemo >> C.flush >> C.awaitEvent
|
||||
|
||||
-- printEvents :: C.VirtualTerminal -> IO ()
|
||||
-- printEvents t = forever $ do
|
||||
-- event <- withTerminal . runTerminalT $ C.flush >> C.awaitEvent
|
||||
-- runTerminalT (putStringLn $ show event) t
|
||||
|
||||
-- updateTerminal :: C.VirtualTerminal -> IO ()
|
||||
-- updateTerminal t = forever $ do
|
||||
-- threadDelay 10000
|
||||
-- win <- readTVarIO $ C.virtualWindow t
|
||||
-- withTerminal . runTerminalT $ mapM_ C.putStringLn win >> C.flush
|
||||
|
||||
File diff suppressed because one or more lines are too long
|
After Width: | Height: | Size: 83 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 5.7 MiB |
Executable
+48
@@ -0,0 +1,48 @@
|
||||
set -eu
|
||||
|
||||
APP_NAME="simplex-chat"
|
||||
TARGET_DIR="$HOME/.local/bin"
|
||||
PLATFORM="$(uname)"
|
||||
|
||||
if [ $PLATFORM == "Darwin" ]; then
|
||||
PLATFORM="macos-x86-64"
|
||||
elif [ $PLATFORM == "Linux" ]; then
|
||||
PLATFORM="ubuntu-20_04-x86-64"
|
||||
else
|
||||
echo "Scripted installation on your platform is not supported."
|
||||
echo "See compiled binaries in the latest release: https://github.com/simplex-chat/simplex-chat/releases/latest"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
[ ! -d $TARGET_DIR ] && mkdir -p $TARGET_DIR
|
||||
|
||||
if [ -n "$(command -v curl)" ]; then
|
||||
curl -L -o $TARGET_DIR/$APP_NAME "https://github.com/$APP_NAME/$APP_NAME/releases/latest/download/$APP_NAME-$PLATFORM"
|
||||
elif [ -n "$(command -v wget)" ]; then
|
||||
wget -O $TARGET_DIR/$APP_NAME "https://github.com/$APP_NAME/$APP_NAME/releases/latest/download/$APP_NAME-$PLATFORM"
|
||||
else
|
||||
echo "Cannot download simplex-chat - please install curl or wget"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
chmod +x $TARGET_DIR/$APP_NAME
|
||||
|
||||
echo "$APP_NAME installed sucesfully!"
|
||||
|
||||
if [ -z "$(command -v simplex-chat)" ]; then
|
||||
if [ -n "$($SHELL -c 'echo $ZSH_VERSION')" ]; then
|
||||
SHELL_FILE="$HOME/.zshrc"
|
||||
elif [ -n "$($SHELL -c 'echo $BASH_VERSION')" ]; then
|
||||
SHELL_FILE="$HOME/.bashrc"
|
||||
else
|
||||
echo "Unknown shell - cannot add simplex-chat folder to PATH"
|
||||
echo "Please add $TARGET_DIR to PATH variable"
|
||||
echo "Or you can run simplex-chat via full path: $TARGET_DIR/simplex-chat"
|
||||
fi
|
||||
if [ -n "$SHELL_FILE" ]; then
|
||||
echo "export PATH=\$PATH:$TARGET_DIR" >> $SHELL_FILE
|
||||
echo "Source your $SHELL_FILE or open a new shell and type simplex-chat to run it"
|
||||
fi
|
||||
else
|
||||
echo "Type simplex-chat in your terminal to run it"
|
||||
fi
|
||||
@@ -0,0 +1,29 @@
|
||||
CREATE TABLE user_contact_links (
|
||||
user_contact_link_id INTEGER PRIMARY KEY,
|
||||
conn_req_contact BLOB NOT NULL,
|
||||
local_display_name TEXT NOT NULL DEFAULT '',
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
user_id INTEGER NOT NULL REFERENCES users,
|
||||
UNIQUE (user_id, local_display_name)
|
||||
);
|
||||
|
||||
CREATE TABLE contact_requests (
|
||||
contact_request_id INTEGER PRIMARY KEY,
|
||||
user_contact_link_id INTEGER NOT NULL REFERENCES user_contact_links
|
||||
ON UPDATE CASCADE ON DELETE CASCADE,
|
||||
agent_invitation_id BLOB NOT NULL,
|
||||
contact_profile_id INTEGER REFERENCES contact_profiles
|
||||
DEFERRABLE INITIALLY DEFERRED, -- NULL if it's an incognito profile
|
||||
local_display_name TEXT NOT NULL,
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
user_id INTEGER NOT NULL REFERENCES users,
|
||||
FOREIGN KEY (user_id, local_display_name)
|
||||
REFERENCES display_names (user_id, local_display_name)
|
||||
ON UPDATE CASCADE
|
||||
DEFERRABLE INITIALLY DEFERRED,
|
||||
UNIQUE (user_id, local_display_name),
|
||||
UNIQUE (user_id, contact_profile_id)
|
||||
);
|
||||
|
||||
ALTER TABLE connections ADD user_contact_link_id INTEGER
|
||||
REFERENCES user_contact_links ON DELETE RESTRICT;
|
||||
+2
-2
@@ -1,5 +1,5 @@
|
||||
name: simplex-chat
|
||||
version: 0.4.2
|
||||
version: 0.5.1
|
||||
#synopsis:
|
||||
#description:
|
||||
homepage: https://github.com/simplex-chat/simplex-chat#readme
|
||||
@@ -29,7 +29,7 @@ dependencies:
|
||||
- optparse-applicative == 0.15.*
|
||||
- process == 1.6.*
|
||||
- simple-logger == 0.1.*
|
||||
- simplexmq == 0.4.*
|
||||
- simplexmq == 0.5.*
|
||||
- sqlite-simple == 0.4.*
|
||||
- stm == 2.5.*
|
||||
- terminal == 0.2.*
|
||||
|
||||
+157
-54
@@ -24,6 +24,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (isSpace)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find)
|
||||
@@ -43,7 +44,7 @@ import Simplex.Chat.Store
|
||||
import Simplex.Chat.Styled (plain)
|
||||
import Simplex.Chat.Terminal
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Util (ifM, unlessM)
|
||||
import Simplex.Chat.Util (ifM, unlessM, whenM)
|
||||
import Simplex.Chat.View
|
||||
import Simplex.Messaging.Agent
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), defaultAgentConfig)
|
||||
@@ -67,10 +68,20 @@ data ChatCommand
|
||||
= ChatHelp
|
||||
| FilesHelp
|
||||
| GroupsHelp
|
||||
| MyAddressHelp
|
||||
| MarkdownHelp
|
||||
| Welcome
|
||||
| AddContact
|
||||
| Connect SMPQueueInfo
|
||||
| Connect AConnectionRequest
|
||||
| ConnectAdmin
|
||||
| SendAdminWelcome ContactName
|
||||
| DeleteContact ContactName
|
||||
| ListContacts
|
||||
| CreateMyAddress
|
||||
| DeleteMyAddress
|
||||
| ShowMyAddress
|
||||
| AcceptContact ContactName
|
||||
| RejectContact ContactName
|
||||
| SendMessage ContactName ByteString
|
||||
| NewGroup GroupProfile
|
||||
| AddMember GroupName ContactName GroupMemberRole
|
||||
@@ -80,6 +91,7 @@ data ChatCommand
|
||||
| LeaveGroup GroupName
|
||||
| DeleteGroup GroupName
|
||||
| ListMembers GroupName
|
||||
| ListGroups
|
||||
| SendGroupMessage GroupName ByteString
|
||||
| SendFile ContactName FilePath
|
||||
| SendGroupFile GroupName FilePath
|
||||
@@ -89,6 +101,7 @@ data ChatCommand
|
||||
| UpdateProfile Profile
|
||||
| ShowProfile
|
||||
| QuitChat
|
||||
| ShowVersion
|
||||
deriving (Show)
|
||||
|
||||
defaultChatConfig :: ChatConfig
|
||||
@@ -119,7 +132,9 @@ simplexChat cfg opts t =
|
||||
|
||||
newChatController :: WithTerminal t => ChatConfig -> ChatOpts -> t -> (Notification -> IO ()) -> IO ChatController
|
||||
newChatController config@ChatConfig {agentConfig = cfg, dbPoolSize, tbqSize} ChatOpts {dbFile, smpServers} t sendNotification = do
|
||||
chatStore <- createStore (dbFile <> ".chat.db") dbPoolSize
|
||||
let f = chatStoreFile dbFile
|
||||
firstTime <- not <$> doesFileExist f
|
||||
chatStore <- createStore f dbPoolSize
|
||||
currentUser <- newTVarIO =<< getCreateActiveUser chatStore
|
||||
chatTerminal <- newChatTerminal t
|
||||
smpAgent <- getSMPAgentClient cfg {dbFile = dbFile <> ".agent.db", smpServers}
|
||||
@@ -132,7 +147,10 @@ newChatController config@ChatConfig {agentConfig = cfg, dbPoolSize, tbqSize} Cha
|
||||
pure ChatController {..}
|
||||
|
||||
runSimplexChat :: ChatController -> IO ()
|
||||
runSimplexChat = runReaderT (race_ runTerminalInput runChatController)
|
||||
runSimplexChat = runReaderT $ do
|
||||
user <- readTVarIO =<< asks currentUser
|
||||
whenM (asks firstTime) . printToView . chatWelcome user $ Onboarding 0 0 0 0 0
|
||||
race_ runTerminalInput runChatController
|
||||
|
||||
runChatController :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
runChatController =
|
||||
@@ -157,7 +175,7 @@ inputSubscriber = do
|
||||
atomically (readTBQueue q) >>= \case
|
||||
InputControl _ -> pure ()
|
||||
InputCommand s ->
|
||||
case parseAll chatCommandP . encodeUtf8 $ T.pack s of
|
||||
case parseAll chatCommandP . B.dropWhileEnd isSpace . encodeUtf8 $ T.pack s of
|
||||
Left e -> printToView [plain s, "invalid input: " <> plain e]
|
||||
Right cmd -> do
|
||||
case cmd of
|
||||
@@ -165,6 +183,7 @@ inputSubscriber = do
|
||||
SendGroupMessage g msg -> showSentGroupMessage g msg
|
||||
SendFile c f -> showSentFileInvitation c f
|
||||
SendGroupFile g f -> showSentGroupFileInvitation g f
|
||||
SendAdminWelcome c -> forM_ adminWelcomeMessages $ showSentMessage c
|
||||
_ -> printToView [plain s]
|
||||
user <- readTVarIO =<< asks currentUser
|
||||
withAgentLock a . withLock l . void . runExceptT $
|
||||
@@ -175,14 +194,19 @@ processChatCommand user@User {userId, profile} = \case
|
||||
ChatHelp -> printToView chatHelpInfo
|
||||
FilesHelp -> printToView filesHelpInfo
|
||||
GroupsHelp -> printToView groupsHelpInfo
|
||||
MyAddressHelp -> printToView myAddressHelpInfo
|
||||
MarkdownHelp -> printToView markdownInfo
|
||||
Welcome -> do
|
||||
ob <- withStore (`getOnboarding` userId)
|
||||
printToView $ chatWelcome user ob
|
||||
AddContact -> do
|
||||
(connId, qInfo) <- withAgent createConnection
|
||||
withStore $ \st -> createDirectConnection st userId connId
|
||||
showInvitation qInfo
|
||||
Connect qInfo -> do
|
||||
connId <- withAgent $ \a -> joinConnection a qInfo . directMessage $ XInfo profile
|
||||
(connId, cReq) <- withAgent (`createConnection` SCMInvitation)
|
||||
withStore $ \st -> createDirectConnection st userId connId
|
||||
showInvitation cReq
|
||||
Connect (ACR SCMInvitation cReq) -> connect cReq (XInfo profile) >> showSentConfirmation
|
||||
Connect (ACR SCMContact cReq) -> connect cReq (XContact profile Nothing) >> showSentInvitation
|
||||
ConnectAdmin -> connect adminContactReq (XContact profile Nothing) >> showSentInvitation
|
||||
SendAdminWelcome cName -> forM_ adminWelcomeMessages $ sendMessageCmd cName
|
||||
DeleteContact cName ->
|
||||
withStore (\st -> getContactGroupNames st userId cName) >>= \case
|
||||
[] -> do
|
||||
@@ -193,11 +217,33 @@ processChatCommand user@User {userId, profile} = \case
|
||||
unsetActive $ ActiveC cName
|
||||
showContactDeleted cName
|
||||
gs -> showContactGroups cName gs
|
||||
SendMessage cName msg -> do
|
||||
contact <- withStore $ \st -> getContact st userId cName
|
||||
let msgEvent = XMsgNew $ MsgContent MTText [] [MsgContentBody {contentType = SimplexContentType XCText, contentData = msg}]
|
||||
sendDirectMessage (contactConnId contact) msgEvent
|
||||
setActive $ ActiveC cName
|
||||
ListContacts -> withStore (`getUserContacts` user) >>= showContactsList
|
||||
CreateMyAddress -> do
|
||||
(connId, cReq) <- withAgent (`createConnection` SCMContact)
|
||||
withStore $ \st -> createUserContactLink st userId connId cReq
|
||||
showUserContactLinkCreated cReq
|
||||
DeleteMyAddress -> do
|
||||
conns <- withStore $ \st -> getUserContactLinkConnections st userId
|
||||
withAgent $ \a -> forM_ conns $ \Connection {agentConnId} ->
|
||||
deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
|
||||
withStore $ \st -> deleteUserContactLink st userId
|
||||
showUserContactLinkDeleted
|
||||
ShowMyAddress -> do
|
||||
cReq <- withStore $ \st -> getUserContactLink st userId
|
||||
showUserContactLink cReq
|
||||
AcceptContact cName -> do
|
||||
UserContactRequest {agentInvitationId, profileId} <- withStore $ \st ->
|
||||
getContactRequest st userId cName
|
||||
connId <- withAgent $ \a -> acceptContact a agentInvitationId . directMessage $ XInfo profile
|
||||
withStore $ \st -> createAcceptedContact st userId connId cName profileId
|
||||
showAcceptingContactRequest cName
|
||||
RejectContact cName -> do
|
||||
UserContactRequest {agentContactConnId, agentInvitationId} <- withStore $ \st ->
|
||||
getContactRequest st userId cName
|
||||
`E.finally` deleteContactRequest st userId cName
|
||||
withAgent $ \a -> rejectContact a agentContactConnId agentInvitationId
|
||||
showContactRequestRejected cName
|
||||
SendMessage cName msg -> sendMessageCmd cName msg
|
||||
NewGroup gProfile -> do
|
||||
gVar <- asks idsDrg
|
||||
group <- withStore $ \st -> createNewGroup st gVar user gProfile
|
||||
@@ -212,15 +258,15 @@ processChatCommand user@User {userId, profile} = \case
|
||||
unless (memberActive membership) $ chatError CEGroupMemberNotActive
|
||||
when (isJust $ contactMember contact members) $ chatError (CEGroupDuplicateMember cName)
|
||||
gVar <- asks idsDrg
|
||||
(agentConnId, qInfo) <- withAgent createConnection
|
||||
(agentConnId, cReq) <- withAgent (`createConnection` SCMInvitation)
|
||||
GroupMember {memberId} <- withStore $ \st -> createContactGroupMember st gVar user groupId contact memRole agentConnId
|
||||
let msg = XGrpInv $ GroupInvitation (userMemberId, userRole) (memberId, memRole) qInfo groupProfile
|
||||
let msg = XGrpInv $ GroupInvitation (userMemberId, userRole) (memberId, memRole) cReq groupProfile
|
||||
sendDirectMessage (contactConnId contact) msg
|
||||
showSentGroupInvitation gName cName
|
||||
setActive $ ActiveG gName
|
||||
JoinGroup gName -> do
|
||||
ReceivedGroupInvitation {fromMember, userMember, queueInfo} <- withStore $ \st -> getGroupInvitation st user gName
|
||||
agentConnId <- withAgent $ \a -> joinConnection a queueInfo . directMessage . XGrpAcpt $ memberId userMember
|
||||
ReceivedGroupInvitation {fromMember, userMember, connRequest} <- withStore $ \st -> getGroupInvitation st user gName
|
||||
agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage . XGrpAcpt $ memberId userMember
|
||||
withStore $ \st -> do
|
||||
createMemberConnection st userId fromMember agentConnId
|
||||
updateGroupMemberStatus st userId fromMember GSMemAccepted
|
||||
@@ -257,6 +303,7 @@ processChatCommand user@User {userId, profile} = \case
|
||||
ListMembers gName -> do
|
||||
group <- withStore $ \st -> getGroup st user gName
|
||||
showGroupMembers group
|
||||
ListGroups -> withStore (`getUserGroupNames` userId) >>= showGroupsList
|
||||
SendGroupMessage gName msg -> do
|
||||
-- TODO save sent messages
|
||||
-- TODO save pending message delivery for members without connections
|
||||
@@ -268,8 +315,8 @@ processChatCommand user@User {userId, profile} = \case
|
||||
SendFile cName f -> do
|
||||
(fileSize, chSize) <- checkSndFile f
|
||||
contact <- withStore $ \st -> getContact st userId cName
|
||||
(agentConnId, fileQInfo) <- withAgent createConnection
|
||||
let fileInv = FileInvitation {fileName = takeFileName f, fileSize, fileQInfo}
|
||||
(agentConnId, fileConnReq) <- withAgent (`createConnection` SCMInvitation)
|
||||
let fileInv = FileInvitation {fileName = takeFileName f, fileSize, fileConnReq}
|
||||
SndFileTransfer {fileId} <- withStore $ \st ->
|
||||
createSndFileTransfer st userId contact f fileInv agentConnId chSize
|
||||
sendDirectMessage (contactConnId contact) $ XFile fileInv
|
||||
@@ -281,17 +328,17 @@ processChatCommand user@User {userId, profile} = \case
|
||||
unless (memberActive membership) $ chatError CEGroupMemberUserRemoved
|
||||
let fileName = takeFileName f
|
||||
ms <- forM (filter memberActive members) $ \m -> do
|
||||
(connId, fileQInfo) <- withAgent createConnection
|
||||
pure (m, connId, FileInvitation {fileName, fileSize, fileQInfo})
|
||||
(connId, fileConnReq) <- withAgent (`createConnection` SCMInvitation)
|
||||
pure (m, connId, FileInvitation {fileName, fileSize, fileConnReq})
|
||||
fileId <- withStore $ \st -> createSndGroupFileTransfer st userId group ms f fileSize chSize
|
||||
forM_ ms $ \(m, _, fileInv) ->
|
||||
traverse (`sendDirectMessage` XFile fileInv) $ memberConnId m
|
||||
showSentFileInfo fileId
|
||||
setActive $ ActiveG gName
|
||||
ReceiveFile fileId filePath_ -> do
|
||||
ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileQInfo}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId
|
||||
ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileConnReq}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId
|
||||
unless (fileStatus == RFSNew) . chatError $ CEFileAlreadyReceiving fileName
|
||||
tryError (withAgent $ \a -> joinConnection a fileQInfo . directMessage $ XFileAcpt fileName) >>= \case
|
||||
tryError (withAgent $ \a -> joinConnection a fileConnReq . directMessage $ XFileAcpt fileName) >>= \case
|
||||
Right agentConnId -> do
|
||||
filePath <- getRcvFilePath fileId filePath_ fileName
|
||||
withStore $ \st -> acceptRcvFileTransfer st userId fileId agentConnId filePath
|
||||
@@ -317,7 +364,18 @@ processChatCommand user@User {userId, profile} = \case
|
||||
showUserProfileUpdated user user'
|
||||
ShowProfile -> showUserProfile profile
|
||||
QuitChat -> liftIO exitSuccess
|
||||
ShowVersion -> printToView clientVersionInfo
|
||||
where
|
||||
connect :: ConnectionRequest c -> ChatMsgEvent -> m ()
|
||||
connect cReq msg = do
|
||||
connId <- withAgent $ \a -> joinConnection a cReq $ directMessage msg
|
||||
withStore $ \st -> createDirectConnection st userId connId
|
||||
sendMessageCmd :: ContactName -> ByteString -> m ()
|
||||
sendMessageCmd cName msg = do
|
||||
contact <- withStore $ \st -> getContact st userId cName
|
||||
let msgEvent = XMsgNew $ MsgContent MTText [] [MsgContentBody {contentType = SimplexContentType XCText, contentData = msg}]
|
||||
sendDirectMessage (contactConnId contact) msgEvent
|
||||
setActive $ ActiveC cName
|
||||
contactMember :: Contact -> [GroupMember] -> Maybe GroupMember
|
||||
contactMember Contact {contactId} =
|
||||
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
|
||||
@@ -376,6 +434,7 @@ subscribeUserConnections = void . runExceptT $ do
|
||||
subscribeGroups user
|
||||
subscribeFiles user
|
||||
subscribePendingConnections user
|
||||
subscribeUserContactLink user
|
||||
where
|
||||
subscribeContacts user = do
|
||||
contacts <- withStore (`getUserContacts` user)
|
||||
@@ -416,10 +475,17 @@ subscribeUserConnections = void . runExceptT $ do
|
||||
resume RcvFileInfo {agentConnId} =
|
||||
subscribe agentConnId `catchError` showRcvFileSubError ft
|
||||
subscribePendingConnections user = do
|
||||
connections <- withStore (`getPendingConnections` user)
|
||||
forM_ connections $ \Connection {agentConnId} ->
|
||||
subscribe agentConnId `catchError` \_ -> pure ()
|
||||
cs <- withStore (`getPendingConnections` user)
|
||||
subscribeConns cs `catchError` \_ -> pure ()
|
||||
subscribeUserContactLink User {userId} = do
|
||||
cs <- withStore (`getUserContactLinkConnections` userId)
|
||||
(subscribeConns cs >> showUserContactLinkSubscribed)
|
||||
`catchError` showUserContactLinkSubError
|
||||
subscribe cId = withAgent (`subscribeConnection` cId)
|
||||
subscribeConns conns =
|
||||
withAgent $ \a ->
|
||||
forM_ conns $ \Connection {agentConnId} ->
|
||||
subscribeConnection a agentConnId
|
||||
|
||||
processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agent -> m ()
|
||||
processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
@@ -435,6 +501,8 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
processRcvFileConn agentMessage conn ft
|
||||
SndFileConnection conn ft ->
|
||||
processSndFileConn agentMessage conn ft
|
||||
UserContactConnection conn uc ->
|
||||
processUserContactRequest agentMessage conn uc
|
||||
where
|
||||
isMember :: MemberId -> Group -> Bool
|
||||
isMember memId Group {membership, members} =
|
||||
@@ -448,7 +516,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
|
||||
agentMsgConnStatus :: ACommand 'Agent -> Maybe ConnStatus
|
||||
agentMsgConnStatus = \case
|
||||
REQ _ _ -> Just ConnRequested
|
||||
CONF {} -> Just ConnRequested
|
||||
INFO _ -> Just ConnSndReady
|
||||
CON -> Just ConnReady
|
||||
_ -> Nothing
|
||||
@@ -456,9 +524,9 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
processDirectMessage :: ACommand 'Agent -> Connection -> Maybe Contact -> m ()
|
||||
processDirectMessage agentMsg conn = \case
|
||||
Nothing -> case agentMsg of
|
||||
REQ confId connInfo -> do
|
||||
CONF confId connInfo -> do
|
||||
saveConnInfo conn connInfo
|
||||
acceptAgentConnection conn confId $ XInfo profile
|
||||
allowAgentConnection conn confId $ XInfo profile
|
||||
INFO connInfo ->
|
||||
saveConnInfo conn connInfo
|
||||
MSG meta _ ->
|
||||
@@ -476,15 +544,15 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
XInfoProbeCheck probeHash -> xInfoProbeCheck ct probeHash
|
||||
XInfoProbeOk probe -> xInfoProbeOk ct probe
|
||||
_ -> pure ()
|
||||
REQ confId connInfo -> do
|
||||
CONF confId connInfo -> do
|
||||
-- confirming direct connection with a member
|
||||
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
|
||||
case chatMsgEvent of
|
||||
XGrpMemInfo _memId _memProfile -> do
|
||||
-- TODO check member ID
|
||||
-- TODO update member profile
|
||||
acceptAgentConnection conn confId XOk
|
||||
_ -> messageError "REQ from member must have x.grp.mem.info"
|
||||
allowAgentConnection conn confId XOk
|
||||
_ -> messageError "CONF from member must have x.grp.mem.info"
|
||||
INFO connInfo -> do
|
||||
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
|
||||
case chatMsgEvent of
|
||||
@@ -492,8 +560,11 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
-- TODO check member ID
|
||||
-- TODO update member profile
|
||||
pure ()
|
||||
XInfo _profile -> do
|
||||
-- TODO update contact profile
|
||||
pure ()
|
||||
XOk -> pure ()
|
||||
_ -> messageError "INFO from member must have x.grp.mem.info or x.ok"
|
||||
_ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
|
||||
CON ->
|
||||
withStore (\st -> getViaGroupMember st user ct) >>= \case
|
||||
Nothing -> do
|
||||
@@ -519,7 +590,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
|
||||
processGroupMessage :: ACommand 'Agent -> Connection -> GroupName -> GroupMember -> m ()
|
||||
processGroupMessage agentMsg conn gName m = case agentMsg of
|
||||
REQ confId connInfo -> do
|
||||
CONF confId connInfo -> do
|
||||
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
|
||||
case memberCategory m of
|
||||
GCInviteeMember ->
|
||||
@@ -527,18 +598,18 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
XGrpAcpt memId
|
||||
| memId == memberId m -> do
|
||||
withStore $ \st -> updateGroupMemberStatus st userId m GSMemAccepted
|
||||
acceptAgentConnection conn confId XOk
|
||||
allowAgentConnection conn confId XOk
|
||||
| otherwise -> messageError "x.grp.acpt: memberId is different from expected"
|
||||
_ -> messageError "REQ from invited member must have x.grp.acpt"
|
||||
_ -> messageError "CONF from invited member must have x.grp.acpt"
|
||||
_ ->
|
||||
case chatMsgEvent of
|
||||
XGrpMemInfo memId _memProfile
|
||||
| memId == memberId m -> do
|
||||
-- TODO update member profile
|
||||
Group {membership} <- withStore $ \st -> getGroup st user gName
|
||||
acceptAgentConnection conn confId $ XGrpMemInfo (memberId membership) profile
|
||||
allowAgentConnection conn confId $ XGrpMemInfo (memberId membership) profile
|
||||
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
|
||||
_ -> messageError "REQ from member must have x.grp.mem.info"
|
||||
_ -> messageError "CONF from member must have x.grp.mem.info"
|
||||
INFO connInfo -> do
|
||||
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
|
||||
case chatMsgEvent of
|
||||
@@ -601,15 +672,15 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
processSndFileConn :: ACommand 'Agent -> Connection -> SndFileTransfer -> m ()
|
||||
processSndFileConn agentMsg conn ft@SndFileTransfer {fileId, fileName, fileStatus} =
|
||||
case agentMsg of
|
||||
REQ confId connInfo -> do
|
||||
CONF confId connInfo -> do
|
||||
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
|
||||
case chatMsgEvent of
|
||||
XFileAcpt name
|
||||
| name == fileName -> do
|
||||
withStore $ \st -> updateSndFileStatus st ft FSAccepted
|
||||
acceptAgentConnection conn confId XOk
|
||||
allowAgentConnection conn confId XOk
|
||||
| otherwise -> messageError "x.file.acpt: fileName is different from expected"
|
||||
_ -> messageError "REQ from file connection must have x.file.acpt"
|
||||
_ -> messageError "CONF from file connection must have x.file.acpt"
|
||||
CON -> do
|
||||
withStore $ \st -> updateSndFileStatus st ft FSConnected
|
||||
showSndFileStart ft
|
||||
@@ -663,6 +734,22 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo
|
||||
_ -> pure ()
|
||||
|
||||
processUserContactRequest :: ACommand 'Agent -> Connection -> UserContact -> m ()
|
||||
processUserContactRequest agentMsg _conn UserContact {userContactLinkId} = case agentMsg of
|
||||
REQ invId connInfo -> do
|
||||
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
|
||||
case chatMsgEvent of
|
||||
XContact p _ -> profileContactRequest invId p
|
||||
XInfo p -> profileContactRequest invId p
|
||||
-- TODO show/log error, other events in contact request
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
where
|
||||
profileContactRequest :: InvitationId -> Profile -> m ()
|
||||
profileContactRequest invId p = do
|
||||
cName <- withStore $ \st -> createContactRequest st userId userContactLinkId invId p
|
||||
showReceivedContactRequest cName p
|
||||
|
||||
withAckMessage :: ConnId -> MsgMeta -> m () -> m ()
|
||||
withAckMessage cId MsgMeta {recipient = (msgId, _)} action =
|
||||
action `E.finally` withAgent (\a -> ackMessage a cId msgId `catchError` \_ -> pure ())
|
||||
@@ -801,10 +888,10 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
if isMember memId group
|
||||
then messageWarning "x.grp.mem.intro ignored: member already exists"
|
||||
else do
|
||||
(groupConnId, groupQInfo) <- withAgent createConnection
|
||||
(directConnId, directQInfo) <- withAgent createConnection
|
||||
(groupConnId, groupConnReq) <- withAgent (`createConnection` SCMInvitation)
|
||||
(directConnId, directConnReq) <- withAgent (`createConnection` SCMInvitation)
|
||||
newMember <- withStore $ \st -> createIntroReMember st user group m memInfo groupConnId directConnId
|
||||
let msg = XGrpMemInv memId IntroInvitation {groupQInfo, directQInfo}
|
||||
let msg = XGrpMemInv memId IntroInvitation {groupConnReq, directConnReq}
|
||||
sendDirectMessage agentConnId msg
|
||||
withStore $ \st -> updateGroupMemberStatus st userId newMember GSMemIntroInvited
|
||||
_ -> messageError "x.grp.mem.intro can be only sent by host member"
|
||||
@@ -826,7 +913,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
|
||||
|
||||
xGrpMemFwd :: GroupName -> GroupMember -> MemberInfo -> IntroInvitation -> m ()
|
||||
xGrpMemFwd gName m memInfo@(MemberInfo memId _ _) introInv@IntroInvitation {groupQInfo, directQInfo} = do
|
||||
xGrpMemFwd gName m memInfo@(MemberInfo memId _ _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
|
||||
group@Group {membership} <- withStore $ \st -> getGroup st user gName
|
||||
toMember <- case find ((== memId) . memberId) $ members group of
|
||||
-- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent
|
||||
@@ -837,8 +924,8 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
Just m' -> pure m'
|
||||
withStore $ \st -> saveMemberInvitation st toMember introInv
|
||||
let msg = XGrpMemInfo (memberId membership) profile
|
||||
groupConnId <- withAgent $ \a -> joinConnection a groupQInfo $ directMessage msg
|
||||
directConnId <- withAgent $ \a -> joinConnection a directQInfo $ directMessage msg
|
||||
groupConnId <- withAgent $ \a -> joinConnection a groupConnReq $ directMessage msg
|
||||
directConnId <- withAgent $ \a -> joinConnection a directConnReq $ directMessage msg
|
||||
withStore $ \st -> createIntroToMemberContact st userId m toMember groupConnId directConnId
|
||||
|
||||
xGrpMemDel :: GroupName -> GroupMember -> MemberId -> m ()
|
||||
@@ -998,9 +1085,9 @@ sendGroupMessage members chatMsgEvent = do
|
||||
forM_ (filter memberActive members) $
|
||||
traverse (\connId -> sendMessage a connId msg) . memberConnId
|
||||
|
||||
acceptAgentConnection :: ChatMonad m => Connection -> ConfirmationId -> ChatMsgEvent -> m ()
|
||||
acceptAgentConnection conn@Connection {agentConnId} confId msg = do
|
||||
withAgent $ \a -> acceptConnection a agentConnId confId $ directMessage msg
|
||||
allowAgentConnection :: ChatMonad m => Connection -> ConfirmationId -> ChatMsgEvent -> m ()
|
||||
allowAgentConnection conn@Connection {agentConnId} confId msg = do
|
||||
withAgent $ \a -> allowConnection a agentConnId confId $ directMessage msg
|
||||
withStore $ \st -> updateConnectionStatus st conn ConnAccepted
|
||||
|
||||
getCreateActiveUser :: SQLiteStore -> IO User
|
||||
@@ -1088,6 +1175,7 @@ chatCommandP :: Parser ChatCommand
|
||||
chatCommandP =
|
||||
("/help files" <|> "/help file" <|> "/hf") $> FilesHelp
|
||||
<|> ("/help groups" <|> "/help group" <|> "/hg") $> GroupsHelp
|
||||
<|> ("/help address" <|> "/ha") $> MyAddressHelp
|
||||
<|> ("/help" <|> "/h") $> ChatHelp
|
||||
<|> ("/group #" <|> "/group " <|> "/g #" <|> "/g ") *> (NewGroup <$> groupProfile)
|
||||
<|> ("/add #" <|> "/add " <|> "/a #" <|> "/a ") *> (AddMember <$> displayName <* A.space <*> displayName <*> memberRole)
|
||||
@@ -1096,8 +1184,10 @@ chatCommandP =
|
||||
<|> ("/leave #" <|> "/leave " <|> "/l #" <|> "/l ") *> (LeaveGroup <$> displayName)
|
||||
<|> ("/delete #" <|> "/d #") *> (DeleteGroup <$> displayName)
|
||||
<|> ("/members #" <|> "/members " <|> "/ms #" <|> "/ms ") *> (ListMembers <$> displayName)
|
||||
<|> ("/groups" <|> "/gs") $> ListGroups
|
||||
<|> A.char '#' *> (SendGroupMessage <$> displayName <* A.space <*> A.takeByteString)
|
||||
<|> ("/connect " <|> "/c ") *> (Connect <$> smpQueueInfoP)
|
||||
<|> ("/contacts" <|> "/cs") $> ListContacts
|
||||
<|> ("/connect " <|> "/c ") *> (Connect <$> connReqP)
|
||||
<|> ("/connect" <|> "/c") $> AddContact
|
||||
<|> ("/delete @" <|> "/delete " <|> "/d @" <|> "/d ") *> (DeleteContact <$> displayName)
|
||||
<|> A.char '@' *> (SendMessage <$> displayName <*> (A.space *> A.takeByteString))
|
||||
@@ -1106,10 +1196,19 @@ chatCommandP =
|
||||
<|> ("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> optional (A.space *> filePath))
|
||||
<|> ("/fcancel " <|> "/fc ") *> (CancelFile <$> A.decimal)
|
||||
<|> ("/fstatus " <|> "/fs ") *> (FileStatus <$> A.decimal)
|
||||
<|> "/admin_welcome " *> (SendAdminWelcome <$> displayName)
|
||||
<|> "/admin" $> ConnectAdmin
|
||||
<|> ("/address" <|> "/ad") $> CreateMyAddress
|
||||
<|> ("/delete_address" <|> "/da") $> DeleteMyAddress
|
||||
<|> ("/show_address" <|> "/sa") $> ShowMyAddress
|
||||
<|> ("/accept @" <|> "/accept " <|> "/ac @" <|> "/ac ") *> (AcceptContact <$> displayName)
|
||||
<|> ("/reject @" <|> "/reject " <|> "/rc @" <|> "/rc ") *> (RejectContact <$> displayName)
|
||||
<|> ("/markdown" <|> "/m") $> MarkdownHelp
|
||||
<|> ("/welcome" <|> "/w") $> Welcome
|
||||
<|> ("/profile " <|> "/p ") *> (UpdateProfile <$> userProfile)
|
||||
<|> ("/profile" <|> "/p") $> ShowProfile
|
||||
<|> ("/quit" <|> "/q") $> QuitChat
|
||||
<|> ("/quit" <|> "/q" <|> "/exit") $> QuitChat
|
||||
<|> ("/version" <|> "/v") $> ShowVersion
|
||||
where
|
||||
displayName = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' '))
|
||||
refChar c = c > ' ' && c /= '#' && c /= '@'
|
||||
@@ -1130,3 +1229,7 @@ chatCommandP =
|
||||
<|> (" admin" $> GRAdmin)
|
||||
<|> (" member" $> GRMember)
|
||||
<|> pure GRAdmin
|
||||
|
||||
adminContactReq :: ConnectionRequest 'CMContact
|
||||
adminContactReq =
|
||||
either error id $ parseAll connReqP' "https://simplex.chat/contact#/?smp=smp%3A%2F%2Fnxc7HnrnM8dOKgkMp008ub_9o9LXJlxlMrMpR-mfMQw%3D%40smp3.simplex.im%2F-TXnePw5eH5-4L7B%23&e2e=rsa%3AMIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEA6vpcsZggnYL38Qa2G5YU0W5uqnV8WAq_S3flIFU2kx4qW-aokVT8fo0CLJXv9aagdHObFfhc9SXcZPcm4T2NLnafKTgQa_HYFfj764l6cHkbSI-4JBE1gyhtaapsvrDGIdoiGDLgsF3AJVjqs8gavkuTsmw035aWMH-pkpc4qGlEWpNWp1Nn-7O4sdIIQ7yN48jsdCfeIY-BIk3kFR6s4oQOgiOcnir8e3x5tTuRMX1KWSiuzuqLHqgmcI1IqcPJPrBoTQLbXXEMGG1RsvIudxR03jejXXbQvlxXlNNrxwkniEe-P0rApGuCyv2NRMb4n0Wd3ZwewH7X-xtr16XNbQKBgDouGUHD1C55jB-w8W8VJRhFZS2xIYka9gJH1jjCFxHFzgjo69A_sObIamND1pF_JOzj_XCoA1fDICF95XbfS0rq9iS6xvX6M8Muq8QiJsfD5bRt5nh-Y3GK5rAFXS0ZtyOeh07iMLAMJ_EFxBQuKKDRu9_9KAvLL_plU0PuaMH3"
|
||||
|
||||
@@ -25,6 +25,9 @@ import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
|
||||
import System.IO (Handle)
|
||||
import UnliftIO.STM
|
||||
|
||||
versionNumber :: String
|
||||
versionNumber = "0.5.1"
|
||||
|
||||
data ChatConfig = ChatConfig
|
||||
{ agentConfig :: AgentConfig,
|
||||
dbPoolSize :: Int,
|
||||
@@ -34,6 +37,7 @@ data ChatConfig = ChatConfig
|
||||
|
||||
data ChatController = ChatController
|
||||
{ currentUser :: TVar User,
|
||||
firstTime :: Bool,
|
||||
smpAgent :: AgentClient,
|
||||
chatTerminal :: ChatTerminal,
|
||||
chatStore :: SQLiteStore,
|
||||
|
||||
+83
-14
@@ -1,17 +1,24 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Help
|
||||
( chatHelpInfo,
|
||||
( chatWelcome,
|
||||
adminWelcomeMessages,
|
||||
chatHelpInfo,
|
||||
filesHelpInfo,
|
||||
groupsHelpInfo,
|
||||
myAddressHelpInfo,
|
||||
markdownInfo,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.List (intersperse)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Types (Onboarding (..), Profile (..), User (..))
|
||||
import System.Console.ANSI.Types
|
||||
|
||||
highlight :: Text -> Markdown
|
||||
@@ -26,15 +33,60 @@ indent = " "
|
||||
listHighlight :: [Text] -> Markdown
|
||||
listHighlight = mconcat . intersperse ", " . map highlight
|
||||
|
||||
chatWelcome :: User -> Onboarding -> [StyledString]
|
||||
chatWelcome user Onboarding {contactsCount, createdGroups, membersCount, filesSentCount, addressCount} =
|
||||
map
|
||||
styleMarkdown
|
||||
[ " __ __",
|
||||
" ___ ___ __ __ ___ _ ___" <> "\\ \\ / /" <> " ___ _ _ _ _____",
|
||||
" / __|_ _| \\/ | _ \\ | | __ " <> "\\ V /" <> " / __| || | /_\\_ _|",
|
||||
" \\__ \\| || |\\/| | _/ |__| _|" <> " / . \\" <> "| (__| __ |/ _ \\| |",
|
||||
" |___/___|_| |_|_| |____|___" <> "/_/ \\_\\" <> "\\___|_||_/_/ \\_\\_|",
|
||||
"",
|
||||
"Welcome " <> green userName <> "!",
|
||||
"Thank you for installing SimpleX Chat!",
|
||||
"",
|
||||
"We have created several groups that you can join to play with SimpleX Chat:",
|
||||
highlight "#simplex" <> " (SimpleX Engineers 💻) - technical questions about running or contributing to SimpleX Chat",
|
||||
highlight "#hacks" <> " (Ethical Hacking 🔓) - chatting about privacy, security, announced vulnerabilities etc.",
|
||||
highlight "#music" <> " (Music 🎸) - favorite music of our team and users",
|
||||
highlight "#rand" <> " (Random 😇) - anything interesting, just keep it decent and friendly please :)",
|
||||
"",
|
||||
"Connect to our groups admin to be added to these groups - " <> highlight "/admin",
|
||||
"",
|
||||
"To continue:",
|
||||
"[" <> check (contactsCount >= 2) <> "] " <> highlight "/connect" <> " with 2 friends - " <> highlight "/help" <> " for instructions",
|
||||
"[" <> check (createdGroups >= 1 && membersCount >= 2) <> "] create a " <> highlight "/group" <> " with them - " <> highlight "/g #friends",
|
||||
"[" <> check (filesSentCount >= 1) <> "] send " <> highlight "/file" <> ", e.g. your photo, to the group - " <> highlight "/f #friends ./photo.jpg",
|
||||
"[" <> check (addressCount >= 1) <> "] create your optional chat " <> highlight "/address" <> " and share it with your friends - " <> highlight "/ad",
|
||||
"",
|
||||
"To help us build SimpleX Chat:",
|
||||
"> star GitHub repo: https://github.com/simplex-chat/simplex-chat",
|
||||
"> join Reddit group: https://www.reddit.com/r/SimpleXChat/",
|
||||
"",
|
||||
"To show this message again - " <> highlight "/welcome" <> " (or " <> highlight "/w" <> ")"
|
||||
]
|
||||
where
|
||||
User {profile = Profile {displayName, fullName}} = user
|
||||
userName = if T.null fullName then displayName else fullName
|
||||
check c = if c then green "*" else " "
|
||||
|
||||
adminWelcomeMessages :: [ByteString]
|
||||
adminWelcomeMessages =
|
||||
[ "Hello - and welcome to SimpleX Chat!",
|
||||
"Which community groups you'd you like to join:",
|
||||
"!5 #simplex!, !5 #hacks!, !5 #music! or !5 #rand!"
|
||||
]
|
||||
|
||||
chatHelpInfo :: [StyledString]
|
||||
chatHelpInfo =
|
||||
map
|
||||
styleMarkdown
|
||||
[ highlight "Using SimpleX chat prototype",
|
||||
[ highlight "Using SimpleX Chat",
|
||||
"Follow these steps to set up a connection:",
|
||||
"",
|
||||
green "Step 1: " <> highlight "/connect" <> " - Alice adds a contact.",
|
||||
indent <> "Alice should send the invitation printed by the /add command",
|
||||
indent <> "Alice should send the one-time invitation printed by the /connect command",
|
||||
indent <> "to her contact, Bob, out-of-band, via any trusted channel.",
|
||||
"",
|
||||
green "Step 2: " <> highlight "/connect <invitation>" <> " - Bob accepts the invitation.",
|
||||
@@ -45,22 +97,22 @@ chatHelpInfo =
|
||||
indent <> highlight "@bob Hello, Bob!" <> " - Alice messages Bob (assuming Bob has display name 'bob').",
|
||||
indent <> highlight "@alice Hey, Alice!" <> " - Bob replies to Alice.",
|
||||
"",
|
||||
green "To send file:",
|
||||
indent <> highlight "/file bob ./photo.jpg" <> " - Alice sends file to Bob",
|
||||
indent <> "File commands: " <> highlight "/help files",
|
||||
green "Send file: " <> highlight "/file bob ./photo.jpg",
|
||||
"",
|
||||
green "To create group:",
|
||||
indent <> highlight "/group team" <> " - create group #team",
|
||||
indent <> "Group commands: " <> highlight "/help groups",
|
||||
green "Create group: " <> highlight "/group team",
|
||||
"",
|
||||
green "Create your address: " <> highlight "/address",
|
||||
"",
|
||||
green "Other commands:",
|
||||
indent <> highlight "/profile " <> " - show user profile",
|
||||
indent <> highlight "/profile <name> [<full_name>]" <> " - update user profile",
|
||||
indent <> highlight "/help <topic> " <> " - help on: files, groups, address",
|
||||
indent <> highlight "/profile " <> " - show / update user profile",
|
||||
indent <> highlight "/delete <contact>" <> " - delete contact and all messages with them",
|
||||
indent <> highlight "/markdown " <> " - show supported markdown syntax",
|
||||
indent <> highlight "/contacts " <> " - list contacts",
|
||||
indent <> highlight "/markdown " <> " - supported markdown syntax",
|
||||
indent <> highlight "/version " <> " - SimpleX Chat version",
|
||||
indent <> highlight "/quit " <> " - quit chat",
|
||||
"",
|
||||
"The commands may be abbreviated to a single letter: " <> listHighlight ["/c", "/f", "/g", "/p", "/h"] <> ", etc."
|
||||
"The commands may be abbreviated: " <> listHighlight ["/c", "/f", "/g", "/p", "/ad"] <> ", etc."
|
||||
]
|
||||
|
||||
filesHelpInfo :: [StyledString]
|
||||
@@ -89,9 +141,26 @@ groupsHelpInfo =
|
||||
indent <> highlight "/leave <group> " <> " - leave group",
|
||||
indent <> highlight "/delete <group> " <> " - delete group",
|
||||
indent <> highlight "/members <group> " <> " - list group members",
|
||||
indent <> highlight "/groups " <> " - list groups",
|
||||
indent <> highlight "#<group> <message> " <> " - send message to group",
|
||||
"",
|
||||
"The commands may be abbreviated: " <> listHighlight ["/g", "/a", "/j", "/rm", "/l", "/d", "/ms"]
|
||||
"The commands may be abbreviated: " <> listHighlight ["/g", "/a", "/j", "/rm", "/l", "/d", "/ms", "/gs"]
|
||||
]
|
||||
|
||||
myAddressHelpInfo :: [StyledString]
|
||||
myAddressHelpInfo =
|
||||
map
|
||||
styleMarkdown
|
||||
[ green "Your contact address commands:",
|
||||
indent <> highlight "/address " <> " - create your address",
|
||||
indent <> highlight "/delete_address" <> " - delete your address (accepted contacts will remain connected)",
|
||||
indent <> highlight "/show_address " <> " - show your address",
|
||||
indent <> highlight "/accept <name> " <> " - accept contact request",
|
||||
indent <> highlight "/reject <name> " <> " - reject contact request",
|
||||
"",
|
||||
"Please note: you can receive spam contact requests, but it's safe to delete the address!",
|
||||
"",
|
||||
"The commands may be abbreviated: " <> listHighlight ["/ad", "/da", "/sa", "/ac", "/rc"]
|
||||
]
|
||||
|
||||
markdownInfo :: [StyledString]
|
||||
|
||||
@@ -11,7 +11,7 @@
|
||||
module Simplex.Chat.Protocol where
|
||||
|
||||
import Control.Applicative (optional)
|
||||
import Control.Monad ((<=<))
|
||||
import Control.Monad ((<=<), (>=>))
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
@@ -21,7 +21,7 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find)
|
||||
import Data.List (find, findIndex)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
@@ -38,6 +38,7 @@ data ChatDirection (p :: AParty) where
|
||||
SentGroupMessage :: GroupName -> ChatDirection 'Client
|
||||
SndFileConnection :: Connection -> SndFileTransfer -> ChatDirection 'Agent
|
||||
RcvFileConnection :: Connection -> RcvFileTransfer -> ChatDirection 'Agent
|
||||
UserContactConnection :: Connection -> UserContact -> ChatDirection 'Agent
|
||||
|
||||
deriving instance Eq (ChatDirection p)
|
||||
|
||||
@@ -49,12 +50,14 @@ fromConnection = \case
|
||||
ReceivedGroupMessage conn _ _ -> conn
|
||||
SndFileConnection conn _ -> conn
|
||||
RcvFileConnection conn _ -> conn
|
||||
UserContactConnection conn _ -> conn
|
||||
|
||||
data ChatMsgEvent
|
||||
= XMsgNew MsgContent
|
||||
| XFile FileInvitation
|
||||
| XFileAcpt String
|
||||
| XInfo Profile
|
||||
| XContact Profile (Maybe MsgContent)
|
||||
| XGrpInv GroupInvitation
|
||||
| XGrpAcpt MemberId
|
||||
| XGrpMemNew MemberInfo
|
||||
@@ -107,34 +110,42 @@ toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBod
|
||||
case (chatMsgEvent, chatMsgParams) of
|
||||
("x.msg.new", mt : rawFiles) -> do
|
||||
t <- toMsgType mt
|
||||
files <- mapM (toContentInfo <=< parseAll contentInfoP) rawFiles
|
||||
files <- toFiles rawFiles
|
||||
chatMsg . XMsgNew $ MsgContent {messageType = t, files, content = body}
|
||||
("x.file", [name, size, qInfo]) -> do
|
||||
("x.file", [name, size, cReq]) -> do
|
||||
let fileName = T.unpack $ safeDecodeUtf8 name
|
||||
fileSize <- parseAll A.decimal size
|
||||
fileQInfo <- parseAll smpQueueInfoP qInfo
|
||||
chatMsg . XFile $ FileInvitation {fileName, fileSize, fileQInfo}
|
||||
fileConnReq <- parseAll connReqP' cReq
|
||||
chatMsg . XFile $ FileInvitation {fileName, fileSize, fileConnReq}
|
||||
("x.file.acpt", [name]) ->
|
||||
chatMsg . XFileAcpt . T.unpack $ safeDecodeUtf8 name
|
||||
("x.info", []) -> do
|
||||
profile <- getJSON body
|
||||
chatMsg $ XInfo profile
|
||||
("x.grp.inv", [fromMemId, fromRole, memId, role, qInfo]) -> do
|
||||
("x.con", []) -> do
|
||||
profile <- getJSON body
|
||||
chatMsg $ XContact profile Nothing
|
||||
("x.con", mt : rawFiles) -> do
|
||||
(profile, body') <- extractJSON body
|
||||
t <- toMsgType mt
|
||||
files <- toFiles rawFiles
|
||||
chatMsg . XContact profile $ Just MsgContent {messageType = t, files, content = body'}
|
||||
("x.grp.inv", [fromMemId, fromRole, memId, role, cReq]) -> do
|
||||
fromMem <- (,) <$> B64.decode fromMemId <*> toMemberRole fromRole
|
||||
invitedMem <- (,) <$> B64.decode memId <*> toMemberRole role
|
||||
groupQInfo <- parseAll smpQueueInfoP qInfo
|
||||
groupConnReq <- parseAll connReqP' cReq
|
||||
profile <- getJSON body
|
||||
chatMsg . XGrpInv $ GroupInvitation fromMem invitedMem groupQInfo profile
|
||||
chatMsg . XGrpInv $ GroupInvitation fromMem invitedMem groupConnReq profile
|
||||
("x.grp.acpt", [memId]) ->
|
||||
chatMsg . XGrpAcpt =<< B64.decode memId
|
||||
("x.grp.mem.new", [memId, role]) -> do
|
||||
chatMsg . XGrpMemNew =<< toMemberInfo memId role body
|
||||
("x.grp.mem.intro", [memId, role]) ->
|
||||
chatMsg . XGrpMemIntro =<< toMemberInfo memId role body
|
||||
("x.grp.mem.inv", [memId, groupQInfo, directQInfo]) ->
|
||||
chatMsg =<< (XGrpMemInv <$> B64.decode memId <*> toIntroInv groupQInfo directQInfo)
|
||||
("x.grp.mem.fwd", [memId, role, groupQInfo, directQInfo]) -> do
|
||||
chatMsg =<< (XGrpMemFwd <$> toMemberInfo memId role body <*> toIntroInv groupQInfo directQInfo)
|
||||
("x.grp.mem.inv", [memId, groupConnReq, directConnReq]) ->
|
||||
chatMsg =<< (XGrpMemInv <$> B64.decode memId <*> toIntroInv groupConnReq directConnReq)
|
||||
("x.grp.mem.fwd", [memId, role, groupConnReq, directConnReq]) -> do
|
||||
chatMsg =<< (XGrpMemFwd <$> toMemberInfo memId role body <*> toIntroInv groupConnReq directConnReq)
|
||||
("x.grp.mem.info", [memId]) ->
|
||||
chatMsg =<< (XGrpMemInfo <$> B64.decode memId <*> getJSON body)
|
||||
("x.grp.mem.con", [memId]) ->
|
||||
@@ -164,11 +175,18 @@ toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBod
|
||||
toMemberInfo :: ByteString -> ByteString -> [MsgContentBody] -> Either String MemberInfo
|
||||
toMemberInfo memId role body = MemberInfo <$> B64.decode memId <*> toMemberRole role <*> getJSON body
|
||||
toIntroInv :: ByteString -> ByteString -> Either String IntroInvitation
|
||||
toIntroInv groupQInfo directQInfo = IntroInvitation <$> parseAll smpQueueInfoP groupQInfo <*> parseAll smpQueueInfoP directQInfo
|
||||
toIntroInv groupConnReq directConnReq = IntroInvitation <$> parseAll connReqP' groupConnReq <*> parseAll connReqP' directConnReq
|
||||
toContentInfo :: (RawContentType, Int) -> Either String (ContentType, Int)
|
||||
toContentInfo (rawType, size) = (,size) <$> toContentType rawType
|
||||
toFiles :: [ByteString] -> Either String [(ContentType, Int)]
|
||||
toFiles = mapM $ toContentInfo <=< parseAll contentInfoP
|
||||
getJSON :: FromJSON a => [MsgContentBody] -> Either String a
|
||||
getJSON = J.eitherDecodeStrict' <=< getSimplexContentType XCJson
|
||||
extractJSON :: FromJSON a => [MsgContentBody] -> Either String (a, [MsgContentBody])
|
||||
extractJSON =
|
||||
extractSimplexContentType XCJson >=> \(a, bs) -> do
|
||||
j <- J.eitherDecodeStrict' a
|
||||
pure (j, bs)
|
||||
|
||||
isContentType :: ContentType -> MsgContentBody -> Bool
|
||||
isContentType t MsgContentBody {contentType = t'} = t == t'
|
||||
@@ -181,28 +199,41 @@ getContentType t body = case find (isContentType t) body of
|
||||
Just MsgContentBody {contentData} -> Right contentData
|
||||
Nothing -> Left "no required content type"
|
||||
|
||||
extractContentType :: ContentType -> [MsgContentBody] -> Either String (ByteString, [MsgContentBody])
|
||||
extractContentType t body = case findIndex (isContentType t) body of
|
||||
Just i -> case splitAt i body of
|
||||
(b, el : a) -> Right (contentData (el :: MsgContentBody), b ++ a)
|
||||
(_, []) -> Left "no required content type" -- this can only happen if findIndex returns incorrect result
|
||||
Nothing -> Left "no required content type"
|
||||
|
||||
getSimplexContentType :: XContentType -> [MsgContentBody] -> Either String ByteString
|
||||
getSimplexContentType = getContentType . SimplexContentType
|
||||
|
||||
extractSimplexContentType :: XContentType -> [MsgContentBody] -> Either String (ByteString, [MsgContentBody])
|
||||
extractSimplexContentType = extractContentType . SimplexContentType
|
||||
|
||||
rawChatMessage :: ChatMessage -> RawChatMessage
|
||||
rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
|
||||
case chatMsgEvent of
|
||||
XMsgNew MsgContent {messageType = t, files, content} ->
|
||||
let rawFiles = map (serializeContentInfo . rawContentInfo) files
|
||||
in rawMsg "x.msg.new" (rawMsgType t : rawFiles) content
|
||||
XFile FileInvitation {fileName, fileSize, fileQInfo} ->
|
||||
rawMsg "x.file" [encodeUtf8 $ T.pack fileName, bshow fileSize, serializeSmpQueueInfo fileQInfo] []
|
||||
rawMsg "x.msg.new" (rawMsgType t : toRawFiles files) content
|
||||
XFile FileInvitation {fileName, fileSize, fileConnReq} ->
|
||||
rawMsg "x.file" [encodeUtf8 $ T.pack fileName, bshow fileSize, serializeConnReq' fileConnReq] []
|
||||
XFileAcpt fileName ->
|
||||
rawMsg "x.file.acpt" [encodeUtf8 $ T.pack fileName] []
|
||||
XInfo profile ->
|
||||
rawMsg "x.info" [] [jsonBody profile]
|
||||
XGrpInv (GroupInvitation (fromMemId, fromRole) (memId, role) qInfo groupProfile) ->
|
||||
XContact profile Nothing ->
|
||||
rawMsg "x.con" [] [jsonBody profile]
|
||||
XContact profile (Just MsgContent {messageType = t, files, content}) ->
|
||||
rawMsg "x.con" (rawMsgType t : toRawFiles files) (jsonBody profile : content)
|
||||
XGrpInv (GroupInvitation (fromMemId, fromRole) (memId, role) cReq groupProfile) ->
|
||||
let params =
|
||||
[ B64.encode fromMemId,
|
||||
serializeMemberRole fromRole,
|
||||
B64.encode memId,
|
||||
serializeMemberRole role,
|
||||
serializeSmpQueueInfo qInfo
|
||||
serializeConnReq' cReq
|
||||
]
|
||||
in rawMsg "x.grp.inv" params [jsonBody groupProfile]
|
||||
XGrpAcpt memId ->
|
||||
@@ -212,15 +243,15 @@ rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
|
||||
in rawMsg "x.grp.mem.new" params [jsonBody profile]
|
||||
XGrpMemIntro (MemberInfo memId role profile) ->
|
||||
rawMsg "x.grp.mem.intro" [B64.encode memId, serializeMemberRole role] [jsonBody profile]
|
||||
XGrpMemInv memId IntroInvitation {groupQInfo, directQInfo} ->
|
||||
let params = [B64.encode memId, serializeSmpQueueInfo groupQInfo, serializeSmpQueueInfo directQInfo]
|
||||
XGrpMemInv memId IntroInvitation {groupConnReq, directConnReq} ->
|
||||
let params = [B64.encode memId, serializeConnReq' groupConnReq, serializeConnReq' directConnReq]
|
||||
in rawMsg "x.grp.mem.inv" params []
|
||||
XGrpMemFwd (MemberInfo memId role profile) IntroInvitation {groupQInfo, directQInfo} ->
|
||||
XGrpMemFwd (MemberInfo memId role profile) IntroInvitation {groupConnReq, directConnReq} ->
|
||||
let params =
|
||||
[ B64.encode memId,
|
||||
serializeMemberRole role,
|
||||
serializeSmpQueueInfo groupQInfo,
|
||||
serializeSmpQueueInfo directQInfo
|
||||
serializeConnReq' groupConnReq,
|
||||
serializeConnReq' directConnReq
|
||||
]
|
||||
in rawMsg "x.grp.mem.fwd" params [jsonBody profile]
|
||||
XGrpMemInfo memId profile ->
|
||||
@@ -257,6 +288,8 @@ rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
|
||||
rawWithDAG body = map rawMsgBodyContent $ case chatDAG of
|
||||
Nothing -> body
|
||||
Just dag -> MsgContentBody {contentType = SimplexDAG, contentData = dag} : body
|
||||
toRawFiles :: [(ContentType, Int)] -> [ByteString]
|
||||
toRawFiles = map $ serializeContentInfo . rawContentInfo
|
||||
|
||||
toMsgBodyContent :: RawMsgBodyContent -> Either String MsgContentBody
|
||||
toMsgBodyContent RawMsgBodyContent {contentType, contentData} = do
|
||||
|
||||
+278
-76
@@ -17,6 +17,7 @@ module Simplex.Chat.Store
|
||||
( SQLiteStore,
|
||||
StoreError (..),
|
||||
createStore,
|
||||
chatStoreFile,
|
||||
createUser,
|
||||
getUsers,
|
||||
setActiveUser,
|
||||
@@ -28,6 +29,14 @@ module Simplex.Chat.Store
|
||||
updateUserProfile,
|
||||
updateContactProfile,
|
||||
getUserContacts,
|
||||
createUserContactLink,
|
||||
getUserContactLinkConnections,
|
||||
deleteUserContactLink,
|
||||
getUserContactLink,
|
||||
createContactRequest,
|
||||
getContactRequest,
|
||||
deleteContactRequest,
|
||||
createAcceptedContact,
|
||||
getLiveSndFileTransfers,
|
||||
getLiveRcvFileTransfers,
|
||||
getPendingSndChunks,
|
||||
@@ -40,6 +49,7 @@ module Simplex.Chat.Store
|
||||
getGroup,
|
||||
deleteGroup,
|
||||
getUserGroups,
|
||||
getUserGroupNames,
|
||||
getGroupInvitation,
|
||||
createContactGroupMember,
|
||||
createMemberConnection,
|
||||
@@ -79,6 +89,7 @@ module Simplex.Chat.Store
|
||||
deleteRcvFileChunks,
|
||||
getFileTransfer,
|
||||
getFileTransferProgress,
|
||||
getOnboarding,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -107,7 +118,7 @@ import qualified Database.SQLite.Simple as DB
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (AParty (..), AgentMsgId, ConnId, SMPQueueInfo)
|
||||
import Simplex.Messaging.Agent.Protocol (AParty (..), AgentMsgId, ConnId, InvitationId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, withTransaction)
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
@@ -127,6 +138,9 @@ migrations =
|
||||
createStore :: FilePath -> Int -> IO SQLiteStore
|
||||
createStore dbFilePath poolSize = createSQLiteStore dbFilePath poolSize migrations
|
||||
|
||||
chatStoreFile :: FilePath -> FilePath
|
||||
chatStoreFile = (<> ".chat.db")
|
||||
|
||||
checkConstraint :: StoreError -> IO (Either StoreError a) -> IO (Either StoreError a)
|
||||
checkConstraint err action = action `E.catch` (pure . Left . handleSQLError err)
|
||||
|
||||
@@ -180,20 +194,45 @@ setActiveUser st userId = do
|
||||
createDirectConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> m ()
|
||||
createDirectConnection st userId agentConnId =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
void $ createConnection_ db userId agentConnId Nothing 0
|
||||
void $ createContactConnection_ db userId agentConnId Nothing 0
|
||||
|
||||
createConnection_ :: DB.Connection -> UserId -> ConnId -> Maybe Int64 -> Int -> IO Connection
|
||||
createConnection_ db userId agentConnId viaContact connLevel = do
|
||||
createContactConnection_ :: DB.Connection -> UserId -> ConnId -> Maybe Int64 -> Int -> IO Connection
|
||||
createContactConnection_ db userId = createConnection_ db userId ConnContact Nothing
|
||||
|
||||
-- field types coincidentally match, but the first element here is user ID and not connection ID as in ConnectionRow
|
||||
type InsertedConnectionRow = ConnectionRow
|
||||
|
||||
createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> Maybe Int64 -> Int -> IO Connection
|
||||
createConnection_ db userId connType entityId agentConnId viaContact connLevel = do
|
||||
createdAt <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO connections
|
||||
(user_id, agent_conn_id, conn_status, conn_type, via_contact, conn_level, created_at) VALUES (?,?,?,?,?,?,?);
|
||||
INSERT INTO connections (
|
||||
user_id, agent_conn_id, conn_level, via_contact, conn_status, conn_type,
|
||||
contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?);
|
||||
|]
|
||||
(userId, agentConnId, ConnNew, ConnContact, viaContact, connLevel, createdAt)
|
||||
(insertConnParams createdAt)
|
||||
connId <- insertedRowId db
|
||||
pure Connection {connId, agentConnId, connType = ConnContact, entityId = Nothing, viaContact, connLevel, connStatus = ConnNew, createdAt}
|
||||
pure Connection {connId, agentConnId, connType, entityId, viaContact, connLevel, connStatus = ConnNew, createdAt}
|
||||
where
|
||||
insertConnParams :: UTCTime -> InsertedConnectionRow
|
||||
insertConnParams createdAt =
|
||||
( userId,
|
||||
agentConnId,
|
||||
connLevel,
|
||||
viaContact,
|
||||
ConnNew,
|
||||
connType,
|
||||
ent ConnContact,
|
||||
ent ConnMember,
|
||||
ent ConnSndFile,
|
||||
ent ConnRcvFile,
|
||||
ent ConnUserContact,
|
||||
createdAt
|
||||
)
|
||||
ent ct = if connType == ct then entityId else Nothing
|
||||
|
||||
createDirectContact :: StoreMonad m => SQLiteStore -> UserId -> Connection -> Profile -> m ()
|
||||
createDirectContact st userId Connection {connId} profile =
|
||||
@@ -337,7 +376,7 @@ getContact_ db userId localDisplayName = do
|
||||
db
|
||||
[sql|
|
||||
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
||||
FROM connections c
|
||||
WHERE c.user_id = :user_id AND c.contact_id == :contact_id
|
||||
ORDER BY c.connection_id DESC
|
||||
@@ -359,6 +398,142 @@ getUserContacts st User {userId} =
|
||||
contactNames <- map fromOnly <$> DB.query db "SELECT local_display_name FROM contacts WHERE user_id = ?" (Only userId)
|
||||
rights <$> mapM (runExceptT . getContact_ db userId) contactNames
|
||||
|
||||
createUserContactLink :: StoreMonad m => SQLiteStore -> UserId -> ConnId -> ConnReqContact -> m ()
|
||||
createUserContactLink st userId agentConnId cReq =
|
||||
liftIOEither . checkConstraint SEDuplicateContactLink . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO user_contact_links (user_id, conn_req_contact) VALUES (?, ?)" (userId, cReq)
|
||||
userContactLinkId <- insertedRowId db
|
||||
Right () <$ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing 0
|
||||
|
||||
getUserContactLinkConnections :: StoreMonad m => SQLiteStore -> UserId -> m [Connection]
|
||||
getUserContactLinkConnections st userId =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
connections
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
||||
FROM connections c
|
||||
JOIN user_contact_links uc ON c.user_contact_link_id == uc.user_contact_link_id
|
||||
WHERE c.user_id = :user_id
|
||||
AND uc.user_id = :user_id
|
||||
AND uc.local_display_name = ''
|
||||
|]
|
||||
[":user_id" := userId]
|
||||
where
|
||||
connections [] = Left SEUserContactLinkNotFound
|
||||
connections rows = Right $ map toConnection rows
|
||||
|
||||
deleteUserContactLink :: MonadUnliftIO m => SQLiteStore -> UserId -> m ()
|
||||
deleteUserContactLink st userId =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM connections WHERE connection_id IN (
|
||||
SELECT connection_id
|
||||
FROM connections c
|
||||
JOIN user_contact_links uc USING (user_contact_link_id)
|
||||
WHERE uc.user_id = ? AND uc.local_display_name = ''
|
||||
)
|
||||
|]
|
||||
(Only userId)
|
||||
DB.executeNamed
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM display_names
|
||||
WHERE user_id = :user_id
|
||||
AND local_display_name in (
|
||||
SELECT cr.local_display_name
|
||||
FROM contact_requests cr
|
||||
JOIN user_contact_links uc USING (user_contact_link_id)
|
||||
WHERE uc.user_id = :user_id
|
||||
AND uc.local_display_name = ''
|
||||
)
|
||||
|]
|
||||
[":user_id" := userId]
|
||||
DB.executeNamed
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM contact_profiles
|
||||
WHERE contact_profile_id in (
|
||||
SELECT cr.contact_profile_id
|
||||
FROM contact_requests cr
|
||||
JOIN user_contact_links uc USING (user_contact_link_id)
|
||||
WHERE uc.user_id = :user_id
|
||||
AND uc.local_display_name = ''
|
||||
)
|
||||
|]
|
||||
[":user_id" := userId]
|
||||
DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = ''" (Only userId)
|
||||
|
||||
getUserContactLink :: StoreMonad m => SQLiteStore -> UserId -> m ConnReqContact
|
||||
getUserContactLink st userId =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
connReq
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_req_contact
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ?
|
||||
AND local_display_name = ''
|
||||
|]
|
||||
(Only userId)
|
||||
where
|
||||
connReq [Only cReq] = Right cReq
|
||||
connReq _ = Left SEUserContactLinkNotFound
|
||||
|
||||
createContactRequest :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> InvitationId -> Profile -> m ContactName
|
||||
createContactRequest st userId userContactId invId Profile {displayName, fullName} =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
withLocalDisplayName db userId displayName $ \ldn -> do
|
||||
DB.execute db "INSERT INTO contact_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName)
|
||||
profileId <- insertedRowId db
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO contact_requests
|
||||
(user_contact_link_id, agent_invitation_id, contact_profile_id, local_display_name, user_id) VALUES (?,?,?,?,?)
|
||||
|]
|
||||
(userContactId, invId, profileId, ldn, userId)
|
||||
pure ldn
|
||||
|
||||
getContactRequest :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m UserContactRequest
|
||||
getContactRequest st userId localDisplayName =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
contactReq
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT cr.contact_request_id, cr.agent_invitation_id, cr.user_contact_link_id,
|
||||
c.agent_conn_id, cr.contact_profile_id
|
||||
FROM contact_requests cr
|
||||
JOIN connections c USING (user_contact_link_id)
|
||||
WHERE cr.user_id = ?
|
||||
AND cr.local_display_name = ?
|
||||
|]
|
||||
(userId, localDisplayName)
|
||||
where
|
||||
contactReq [(contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, profileId)] =
|
||||
Right UserContactRequest {contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, profileId, localDisplayName}
|
||||
contactReq _ = Left $ SEContactRequestNotFound localDisplayName
|
||||
|
||||
deleteContactRequest :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactName -> m ()
|
||||
deleteContactRequest st userId localDisplayName =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
|
||||
DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
|
||||
|
||||
createAcceptedContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> ContactName -> Int64 -> m ()
|
||||
createAcceptedContact st userId agentConnId localDisplayName profileId =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
|
||||
DB.execute db "INSERT INTO contacts (user_id, local_display_name, contact_profile_id) VALUES (?,?,?)" (userId, localDisplayName, profileId)
|
||||
contactId <- insertedRowId db
|
||||
void $ createConnection_ db userId ConnContact (Just contactId) agentConnId Nothing 0
|
||||
|
||||
getLiveSndFileTransfers :: MonadUnliftIO m => SQLiteStore -> User -> m [SndFileTransfer]
|
||||
getLiveSndFileTransfers st User {userId} =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
@@ -416,7 +591,7 @@ getPendingConnections st User {userId} =
|
||||
db
|
||||
[sql|
|
||||
SELECT connection_id, agent_conn_id, conn_level, via_contact,
|
||||
conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, created_at
|
||||
conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at
|
||||
FROM connections
|
||||
WHERE user_id = :user_id
|
||||
AND conn_type = :conn_type
|
||||
@@ -432,7 +607,7 @@ getContactConnections st userId displayName =
|
||||
db
|
||||
[sql|
|
||||
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
||||
FROM connections c
|
||||
JOIN contacts cs ON c.contact_id == cs.contact_id
|
||||
WHERE c.user_id = :user_id
|
||||
@@ -444,12 +619,12 @@ getContactConnections st userId displayName =
|
||||
connections [] = Left $ SEContactNotFound displayName
|
||||
connections rows = Right $ map toConnection rows
|
||||
|
||||
type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, UTCTime)
|
||||
type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, UTCTime)
|
||||
|
||||
type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe UTCTime)
|
||||
type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe UTCTime)
|
||||
|
||||
toConnection :: ConnectionRow -> Connection
|
||||
toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, sndFileId, rcvFileId, createdAt) =
|
||||
toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId, createdAt) =
|
||||
let entityId = entityId_ connType
|
||||
in Connection {connId, agentConnId, connLevel, viaContact, connStatus, connType, entityId, createdAt}
|
||||
where
|
||||
@@ -458,10 +633,11 @@ toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType,
|
||||
entityId_ ConnMember = groupMemberId
|
||||
entityId_ ConnRcvFile = rcvFileId
|
||||
entityId_ ConnSndFile = sndFileId
|
||||
entityId_ ConnUserContact = userContactLinkId
|
||||
|
||||
toMaybeConnection :: MaybeConnectionRow -> Maybe Connection
|
||||
toMaybeConnection (Just connId, Just agentConnId, Just connLevel, viaContact, Just connStatus, Just connType, contactId, groupMemberId, sndFileId, rcvFileId, Just createdAt) =
|
||||
Just $ toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, sndFileId, rcvFileId, createdAt)
|
||||
toMaybeConnection (Just connId, Just agentConnId, Just connLevel, viaContact, Just connStatus, Just connType, contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId, Just createdAt) =
|
||||
Just $ toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId, createdAt)
|
||||
toMaybeConnection _ = Nothing
|
||||
|
||||
getMatchingContacts :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> m [Contact]
|
||||
@@ -599,6 +775,7 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId =
|
||||
ConnContact -> ReceivedDirectMessage c . Just <$> getContactRec_ db entId c
|
||||
ConnSndFile -> SndFileConnection c <$> getConnSndFileTransfer_ db entId c
|
||||
ConnRcvFile -> RcvFileConnection c <$> ExceptT (getRcvFileTransfer_ db userId entId)
|
||||
ConnUserContact -> UserContactConnection c <$> getUserContact_ db entId
|
||||
where
|
||||
getConnection_ :: DB.Connection -> ExceptT StoreError IO Connection
|
||||
getConnection_ db = ExceptT $ do
|
||||
@@ -607,7 +784,7 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId =
|
||||
db
|
||||
[sql|
|
||||
SELECT connection_id, agent_conn_id, conn_level, via_contact,
|
||||
conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, created_at
|
||||
conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at
|
||||
FROM connections
|
||||
WHERE user_id = ? AND agent_conn_id = ?
|
||||
|]
|
||||
@@ -674,6 +851,21 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId =
|
||||
Just recipientDisplayName -> Right SndFileTransfer {..}
|
||||
Nothing -> Left $ SESndFileInvalid fileId
|
||||
sndFileTransfer_ fileId _ _ = Left $ SESndFileNotFound fileId
|
||||
getUserContact_ :: DB.Connection -> Int64 -> ExceptT StoreError IO UserContact
|
||||
getUserContact_ db userContactLinkId = ExceptT $ do
|
||||
userContact_
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_req_contact
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ? AND user_contact_link_id = ?
|
||||
|]
|
||||
(userId, userContactLinkId)
|
||||
where
|
||||
userContact_ :: [Only ConnReqContact] -> Either StoreError UserContact
|
||||
userContact_ [Only cReq] = Right UserContact {userContactLinkId, connReqContact = cReq}
|
||||
userContact_ _ = Left SEUserContactLinkNotFound
|
||||
|
||||
updateConnectionStatus :: MonadUnliftIO m => SQLiteStore -> Connection -> ConnStatus -> m ()
|
||||
updateConnectionStatus st Connection {connId} connStatus =
|
||||
@@ -698,14 +890,14 @@ createNewGroup st gVar user groupProfile =
|
||||
-- | creates a new group record for the group the current user was invited to
|
||||
createGroupInvitation ::
|
||||
StoreMonad m => SQLiteStore -> User -> Contact -> GroupInvitation -> m Group
|
||||
createGroupInvitation st user contact GroupInvitation {fromMember, invitedMember, queueInfo, groupProfile} =
|
||||
createGroupInvitation st user contact GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} =
|
||||
liftIOEither . withTransaction st $ \db -> do
|
||||
let GroupProfile {displayName, fullName} = groupProfile
|
||||
uId = userId user
|
||||
withLocalDisplayName db uId displayName $ \localDisplayName -> do
|
||||
DB.execute db "INSERT INTO group_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName)
|
||||
profileId <- insertedRowId db
|
||||
DB.execute db "INSERT INTO groups (group_profile_id, local_display_name, inv_queue_info, user_id) VALUES (?, ?, ?, ?)" (profileId, localDisplayName, queueInfo, uId)
|
||||
DB.execute db "INSERT INTO groups (group_profile_id, local_display_name, inv_queue_info, user_id) VALUES (?, ?, ?, ?)" (profileId, localDisplayName, connRequest, uId)
|
||||
groupId <- insertedRowId db
|
||||
member <- createContactMember_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown
|
||||
membership <- createContactMember_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact $ contactId contact)
|
||||
@@ -717,14 +909,14 @@ getGroup :: StoreMonad m => SQLiteStore -> User -> GroupName -> m Group
|
||||
getGroup st user localDisplayName =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ fst <$> getGroup_ db user localDisplayName
|
||||
|
||||
getGroup_ :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO (Group, Maybe SMPQueueInfo)
|
||||
getGroup_ :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO (Group, Maybe ConnReqInvitation)
|
||||
getGroup_ db User {userId, userContactId} localDisplayName = do
|
||||
(g@Group {groupId}, qInfo) <- getGroupRec_
|
||||
(g@Group {groupId}, cReq) <- getGroupRec_
|
||||
allMembers <- getMembers_ groupId
|
||||
(members, membership) <- liftEither $ splitUserMember_ allMembers
|
||||
pure (g {members, membership}, qInfo)
|
||||
pure (g {members, membership}, cReq)
|
||||
where
|
||||
getGroupRec_ :: ExceptT StoreError IO (Group, Maybe SMPQueueInfo)
|
||||
getGroupRec_ :: ExceptT StoreError IO (Group, Maybe ConnReqInvitation)
|
||||
getGroupRec_ = ExceptT $ do
|
||||
toGroup
|
||||
<$> DB.query
|
||||
@@ -736,10 +928,10 @@ getGroup_ db User {userId, userContactId} localDisplayName = do
|
||||
WHERE g.local_display_name = ? AND g.user_id = ?
|
||||
|]
|
||||
(localDisplayName, userId)
|
||||
toGroup :: [(Int64, GroupName, Text, Maybe SMPQueueInfo)] -> Either StoreError (Group, Maybe SMPQueueInfo)
|
||||
toGroup [(groupId, displayName, fullName, qInfo)] =
|
||||
toGroup :: [(Int64, GroupName, Text, Maybe ConnReqInvitation)] -> Either StoreError (Group, Maybe ConnReqInvitation)
|
||||
toGroup [(groupId, displayName, fullName, cReq)] =
|
||||
let groupProfile = GroupProfile {displayName, fullName}
|
||||
in Right (Group {groupId, localDisplayName, groupProfile, members = undefined, membership = undefined}, qInfo)
|
||||
in Right (Group {groupId, localDisplayName, groupProfile, members = undefined, membership = undefined}, cReq)
|
||||
toGroup _ = Left $ SEGroupNotFound localDisplayName
|
||||
getMembers_ :: Int64 -> ExceptT StoreError IO [GroupMember]
|
||||
getMembers_ groupId = ExceptT $ do
|
||||
@@ -751,7 +943,7 @@ getGroup_ db User {userId, userContactId} localDisplayName = do
|
||||
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
|
||||
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name,
|
||||
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
||||
FROM group_members m
|
||||
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
||||
LEFT JOIN connections c ON c.connection_id = (
|
||||
@@ -781,19 +973,32 @@ deleteGroup st User {userId} Group {groupId, members, localDisplayName} =
|
||||
DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
|
||||
|
||||
getUserGroups :: MonadUnliftIO m => SQLiteStore -> User -> m [Group]
|
||||
getUserGroups st user =
|
||||
getUserGroups st user@User {userId} =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
groupNames <- liftIO $ map fromOnly <$> DB.query db "SELECT local_display_name FROM groups WHERE user_id = ?" (Only $ userId user)
|
||||
groupNames <- map fromOnly <$> DB.query db "SELECT local_display_name FROM groups WHERE user_id = ?" (Only userId)
|
||||
map fst . rights <$> mapM (runExceptT . getGroup_ db user) groupNames
|
||||
|
||||
getUserGroupNames :: MonadUnliftIO m => SQLiteStore -> UserId -> m [(GroupName, Text)]
|
||||
getUserGroupNames st userId =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT g.local_display_name, p.full_name
|
||||
FROM groups g
|
||||
JOIN group_profiles p USING (group_profile_id)
|
||||
WHERE g.user_id = ?
|
||||
|]
|
||||
(Only userId)
|
||||
|
||||
getGroupInvitation :: StoreMonad m => SQLiteStore -> User -> GroupName -> m ReceivedGroupInvitation
|
||||
getGroupInvitation st user localDisplayName =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
(Group {membership, members, groupProfile}, qInfo) <- getGroup_ db user localDisplayName
|
||||
(Group {membership, members, groupProfile}, cReq) <- getGroup_ db user localDisplayName
|
||||
when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
|
||||
case (qInfo, findFromContact (invitedBy membership) members) of
|
||||
(Just queueInfo, Just fromMember) ->
|
||||
pure ReceivedGroupInvitation {fromMember, userMember = membership, queueInfo, groupProfile}
|
||||
case (cReq, findFromContact (invitedBy membership) members) of
|
||||
(Just connRequest, Just fromMember) ->
|
||||
pure ReceivedGroupInvitation {fromMember, userMember = membership, connRequest, groupProfile}
|
||||
_ -> throwError SEGroupInvitationNotFound
|
||||
where
|
||||
findFromContact :: InvitedBy -> [GroupMember] -> Maybe GroupMember
|
||||
@@ -939,14 +1144,14 @@ saveIntroInvitation st reMember toMember introInv = do
|
||||
WHERE group_member_intro_id = :intro_id
|
||||
|]
|
||||
[ ":intro_status" := GMIntroInvReceived,
|
||||
":group_queue_info" := groupQInfo introInv,
|
||||
":direct_queue_info" := directQInfo introInv,
|
||||
":group_queue_info" := groupConnReq introInv,
|
||||
":direct_queue_info" := directConnReq introInv,
|
||||
":intro_id" := introId intro
|
||||
]
|
||||
pure intro {introInvitation = Just introInv, introStatus = GMIntroInvReceived}
|
||||
|
||||
saveMemberInvitation :: StoreMonad m => SQLiteStore -> GroupMember -> IntroInvitation -> m ()
|
||||
saveMemberInvitation st GroupMember {groupMemberId} IntroInvitation {groupQInfo, directQInfo} =
|
||||
saveMemberInvitation st GroupMember {groupMemberId} IntroInvitation {groupConnReq, directConnReq} =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.executeNamed
|
||||
db
|
||||
@@ -958,8 +1163,8 @@ saveMemberInvitation st GroupMember {groupMemberId} IntroInvitation {groupQInfo,
|
||||
WHERE group_member_id = :group_member_id
|
||||
|]
|
||||
[ ":member_status" := GSMemIntroInvited,
|
||||
":group_queue_info" := groupQInfo,
|
||||
":direct_queue_info" := directQInfo,
|
||||
":group_queue_info" := groupConnReq,
|
||||
":direct_queue_info" := directConnReq,
|
||||
":group_member_id" := groupMemberId
|
||||
]
|
||||
|
||||
@@ -975,9 +1180,9 @@ getIntroduction_ db reMember toMember = ExceptT $ do
|
||||
|]
|
||||
(groupMemberId reMember, groupMemberId toMember)
|
||||
where
|
||||
toIntro :: [(Int64, Maybe SMPQueueInfo, Maybe SMPQueueInfo, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro
|
||||
toIntro [(introId, groupQInfo, directQInfo, introStatus)] =
|
||||
let introInvitation = IntroInvitation <$> groupQInfo <*> directQInfo
|
||||
toIntro :: [(Int64, Maybe ConnReqInvitation, Maybe ConnReqInvitation, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro
|
||||
toIntro [(introId, groupConnReq, directConnReq, introStatus)] =
|
||||
let introInvitation = IntroInvitation <$> groupConnReq <*> directConnReq
|
||||
in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation}
|
||||
toIntro _ = Left SEIntroNotFound
|
||||
|
||||
@@ -985,7 +1190,7 @@ createIntroReMember :: StoreMonad m => SQLiteStore -> User -> Group -> GroupMemb
|
||||
createIntroReMember st user@User {userId} group@Group {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) groupAgentConnId directAgentConnId =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
|
||||
Connection {connId = directConnId} <- liftIO $ createConnection_ db userId directAgentConnId memberContactId cLevel
|
||||
Connection {connId = directConnId} <- liftIO $ createContactConnection_ db userId directAgentConnId memberContactId cLevel
|
||||
(localDisplayName, contactId, memProfileId) <- ExceptT $ createContact_ db userId directConnId memberProfile (Just groupId)
|
||||
liftIO $ do
|
||||
let newMember =
|
||||
@@ -1007,7 +1212,7 @@ createIntroToMemberContact st userId GroupMember {memberContactId = viaContactId
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
|
||||
void $ createMemberConnection_ db userId groupMemberId groupAgentConnId viaContactId cLevel
|
||||
Connection {connId = directConnId} <- createConnection_ db userId directAgentConnId viaContactId cLevel
|
||||
Connection {connId = directConnId} <- createContactConnection_ db userId directAgentConnId viaContactId cLevel
|
||||
contactId <- createMemberContact_ db directConnId
|
||||
updateMember_ db contactId
|
||||
where
|
||||
@@ -1040,17 +1245,7 @@ createIntroToMemberContact st userId GroupMember {memberContactId = viaContactId
|
||||
[":contact_id" := contactId, ":group_member_id" := groupMemberId]
|
||||
|
||||
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> IO Connection
|
||||
createMemberConnection_ db userId groupMemberId agentConnId viaContact connLevel = do
|
||||
createdAt <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO connections
|
||||
(user_id, agent_conn_id, conn_status, conn_type, group_member_id, via_contact, conn_level, created_at) VALUES (?,?,?,?,?,?,?,?);
|
||||
|]
|
||||
(userId, agentConnId, ConnNew, ConnMember, groupMemberId, viaContact, connLevel, createdAt)
|
||||
connId <- insertedRowId db
|
||||
pure Connection {connId, agentConnId, connType = ConnMember, entityId = Just groupMemberId, viaContact, connLevel, connStatus = ConnNew, createdAt}
|
||||
createMemberConnection_ db userId groupMemberId = createConnection_ db userId ConnMember (Just groupMemberId)
|
||||
|
||||
createContactMember_ :: IsContact a => DB.Connection -> User -> Int64 -> a -> (MemberId, GroupMemberRole) -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> IO GroupMember
|
||||
createContactMember_ db User {userId, userContactId} groupId userOrContact (memberId, memberRole) memberCategory memberStatus invitedBy = do
|
||||
@@ -1098,7 +1293,7 @@ getViaGroupMember st User {userId, userContactId} Contact {contactId} =
|
||||
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
|
||||
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name,
|
||||
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
||||
FROM group_members m
|
||||
JOIN contacts ct ON ct.contact_id = m.contact_id
|
||||
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
||||
@@ -1128,7 +1323,7 @@ getViaGroupContact st User {userId} GroupMember {groupMemberId} =
|
||||
SELECT
|
||||
ct.contact_id, ct.local_display_name, p.display_name, p.full_name, ct.via_group,
|
||||
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
||||
FROM contacts ct
|
||||
JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id
|
||||
JOIN connections c ON c.connection_id = (
|
||||
@@ -1171,19 +1366,8 @@ createSndGroupFileTransfer st userId Group {groupId} ms filePath fileSize chunkS
|
||||
pure fileId
|
||||
|
||||
createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection
|
||||
createSndFileConnection_ db userId fileId agentConnId = do
|
||||
createdAt <- getCurrentTime
|
||||
let connType = ConnSndFile
|
||||
connStatus = ConnNew
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO connections
|
||||
(user_id, snd_file_id, agent_conn_id, conn_status, conn_type, created_at) VALUES (?,?,?,?,?,?)
|
||||
|]
|
||||
(userId, fileId, agentConnId, connStatus, connType, createdAt)
|
||||
connId <- insertedRowId db
|
||||
pure Connection {connId, agentConnId, connType, entityId = Just fileId, viaContact = Nothing, connLevel = 0, connStatus, createdAt}
|
||||
createSndFileConnection_ db userId fileId agentConnId =
|
||||
createConnection_ db userId ConnSndFile (Just fileId) agentConnId Nothing 0
|
||||
|
||||
updateSndFileStatus :: MonadUnliftIO m => SQLiteStore -> SndFileTransfer -> FileStatus -> m ()
|
||||
updateSndFileStatus st SndFileTransfer {fileId, connId} status =
|
||||
@@ -1236,19 +1420,19 @@ deleteSndFileChunks st SndFileTransfer {fileId, connId} =
|
||||
DB.execute db "DELETE FROM snd_file_chunks WHERE file_id = ? AND connection_id = ?" (fileId, connId)
|
||||
|
||||
createRcvFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> FileInvitation -> Integer -> m RcvFileTransfer
|
||||
createRcvFileTransfer st userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileQInfo} chunkSize =
|
||||
createRcvFileTransfer st userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq} chunkSize =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size) VALUES (?, ?, ?, ?, ?)" (userId, contactId, fileName, fileSize, chunkSize)
|
||||
fileId <- insertedRowId db
|
||||
DB.execute db "INSERT INTO rcv_files (file_id, file_status, file_queue_info) VALUES (?, ?, ?)" (fileId, FSNew, fileQInfo)
|
||||
DB.execute db "INSERT INTO rcv_files (file_id, file_status, file_queue_info) VALUES (?, ?, ?)" (fileId, FSNew, fileConnReq)
|
||||
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize}
|
||||
|
||||
createRcvGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> FileInvitation -> Integer -> m RcvFileTransfer
|
||||
createRcvGroupFileTransfer st userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileQInfo} chunkSize =
|
||||
createRcvGroupFileTransfer st userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq} chunkSize =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size) VALUES (?, ?, ?, ?, ?)" (userId, groupId, fileName, fileSize, chunkSize)
|
||||
fileId <- insertedRowId db
|
||||
DB.execute db "INSERT INTO rcv_files (file_id, file_status, file_queue_info, group_member_id) VALUES (?, ?, ?, ?)" (fileId, FSNew, fileQInfo, groupMemberId)
|
||||
DB.execute db "INSERT INTO rcv_files (file_id, file_status, file_queue_info, group_member_id) VALUES (?, ?, ?, ?)" (fileId, FSNew, fileConnReq, groupMemberId)
|
||||
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize}
|
||||
|
||||
getRcvFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m RcvFileTransfer
|
||||
@@ -1275,10 +1459,10 @@ getRcvFileTransfer_ db userId fileId =
|
||||
(userId, fileId)
|
||||
where
|
||||
rcvFileTransfer ::
|
||||
[(FileStatus, SMPQueueInfo, String, Integer, Integer, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe ConnId)] ->
|
||||
[(FileStatus, ConnReqInvitation, String, Integer, Integer, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe ConnId)] ->
|
||||
Either StoreError RcvFileTransfer
|
||||
rcvFileTransfer [(fileStatus', fileQInfo, fileName, fileSize, chunkSize, contactName_, memberName_, filePath_, connId_, agentConnId_)] =
|
||||
let fileInv = FileInvitation {fileName, fileSize, fileQInfo}
|
||||
rcvFileTransfer [(fileStatus', fileConnReq, fileName, fileSize, chunkSize, contactName_, memberName_, filePath_, connId_, agentConnId_)] =
|
||||
let fileInv = FileInvitation {fileName, fileSize, fileConnReq}
|
||||
fileInfo = (filePath_, connId_, agentConnId_)
|
||||
in case contactName_ <|> memberName_ of
|
||||
Nothing -> Left $ SERcvFileInvalid fileId
|
||||
@@ -1414,6 +1598,21 @@ getSndFileTransfers_ db userId fileId =
|
||||
Just recipientDisplayName -> Right SndFileTransfer {..}
|
||||
Nothing -> Left $ SESndFileInvalid fileId
|
||||
|
||||
getOnboarding :: MonadUnliftIO m => SQLiteStore -> UserId -> m Onboarding
|
||||
getOnboarding st userId =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
contactsCount <- intQuery db "SELECT COUNT(contact_id) FROM contacts WHERE user_id = ? AND is_user = 0"
|
||||
createdGroups <- headOrZero <$> DB.query db "SELECT COUNT(g.group_id) FROM groups g JOIN group_members m WHERE g.user_id = ? AND m.member_status = ?" (userId, GSMemCreator)
|
||||
membersCount <- headOrZero <$> DB.query db "SELECT COUNT(group_member_id) FROM group_members WHERE user_id = ? AND (member_status = ? OR member_status = ?)" (userId, GSMemConnected, GSMemComplete)
|
||||
filesSentCount <- intQuery db "SELECT COUNT(s.file_id) FROM snd_files s JOIN files f USING (file_id) WHERE f.user_id = ?"
|
||||
addressCount <- intQuery db "SELECT COUNT(user_contact_link_id) FROM user_contact_links WHERE user_id = ?"
|
||||
pure $ Onboarding {..}
|
||||
where
|
||||
intQuery :: DB.Connection -> DB.Query -> IO Int
|
||||
intQuery db q = headOrZero <$> DB.query db q (Only userId)
|
||||
headOrZero [] = 0
|
||||
headOrZero (n : _) = fromOnly n
|
||||
|
||||
-- | Saves unique local display name based on passed displayName, suffixed with _N if required.
|
||||
-- This function should be called inside transaction.
|
||||
withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO a) -> IO (Either StoreError a)
|
||||
@@ -1473,6 +1672,9 @@ data StoreError
|
||||
= SEDuplicateName
|
||||
| SEContactNotFound ContactName
|
||||
| SEContactNotReady ContactName
|
||||
| SEDuplicateContactLink
|
||||
| SEUserContactLinkNotFound
|
||||
| SEContactRequestNotFound ContactName
|
||||
| SEGroupNotFound GroupName
|
||||
| SEGroupWithoutUser
|
||||
| SEDuplicateGroupMember
|
||||
|
||||
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@@ -20,7 +21,7 @@ import Database.SQLite.Simple.Internal (Field (..))
|
||||
import Database.SQLite.Simple.Ok (Ok (Ok))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import GHC.Generics
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId, SMPQueueInfo)
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId, ConnectionMode (..), ConnectionRequest, InvitationId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
|
||||
|
||||
class IsContact a where
|
||||
@@ -60,6 +61,22 @@ data Contact = Contact
|
||||
contactConnId :: Contact -> ConnId
|
||||
contactConnId Contact {activeConn = Connection {agentConnId}} = agentConnId
|
||||
|
||||
data UserContact = UserContact
|
||||
{ userContactLinkId :: Int64,
|
||||
connReqContact :: ConnReqContact
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data UserContactRequest = UserContactRequest
|
||||
{ contactRequestId :: Int64,
|
||||
agentInvitationId :: InvitationId,
|
||||
userContactLinkId :: Int64,
|
||||
agentContactConnId :: ConnId,
|
||||
localDisplayName :: ContactName,
|
||||
profileId :: Int64
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type ContactName = Text
|
||||
|
||||
type GroupName = Text
|
||||
@@ -96,14 +113,14 @@ instance FromJSON GroupProfile
|
||||
data GroupInvitation = GroupInvitation
|
||||
{ fromMember :: (MemberId, GroupMemberRole),
|
||||
invitedMember :: (MemberId, GroupMemberRole),
|
||||
queueInfo :: SMPQueueInfo,
|
||||
connRequest :: ConnReqInvitation,
|
||||
groupProfile :: GroupProfile
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data IntroInvitation = IntroInvitation
|
||||
{ groupQInfo :: SMPQueueInfo,
|
||||
directQInfo :: SMPQueueInfo
|
||||
{ groupConnReq :: ConnReqInvitation,
|
||||
directConnReq :: ConnReqInvitation
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -116,7 +133,7 @@ memberInfo m = MemberInfo (memberId m) (memberRole m) (memberProfile m)
|
||||
data ReceivedGroupInvitation = ReceivedGroupInvitation
|
||||
{ fromMember :: GroupMember,
|
||||
userMember :: GroupMember,
|
||||
queueInfo :: SMPQueueInfo,
|
||||
connRequest :: ConnReqInvitation,
|
||||
groupProfile :: GroupProfile
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@@ -316,7 +333,7 @@ data SndFileTransfer = SndFileTransfer
|
||||
data FileInvitation = FileInvitation
|
||||
{ fileName :: String,
|
||||
fileSize :: Integer,
|
||||
fileQInfo :: SMPQueueInfo
|
||||
fileConnReq :: ConnReqInvitation
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -372,6 +389,10 @@ serializeFileStatus = \case
|
||||
data RcvChunkStatus = RcvChunkOk | RcvChunkFinal | RcvChunkDuplicate | RcvChunkError
|
||||
deriving (Eq, Show)
|
||||
|
||||
type ConnReqInvitation = ConnectionRequest 'CMInvitation
|
||||
|
||||
type ConnReqContact = ConnectionRequest 'CMContact
|
||||
|
||||
data Connection = Connection
|
||||
{ connId :: Int64,
|
||||
agentConnId :: ConnId,
|
||||
@@ -379,7 +400,7 @@ data Connection = Connection
|
||||
viaContact :: Maybe Int64,
|
||||
connType :: ConnType,
|
||||
connStatus :: ConnStatus,
|
||||
entityId :: Maybe Int64, -- contact, group member or file ID
|
||||
entityId :: Maybe Int64, -- contact, group member, file ID or user contact ID
|
||||
createdAt :: UTCTime
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@@ -426,7 +447,7 @@ serializeConnStatus = \case
|
||||
ConnReady -> "ready"
|
||||
ConnDeleted -> "deleted"
|
||||
|
||||
data ConnType = ConnContact | ConnMember | ConnSndFile | ConnRcvFile
|
||||
data ConnType = ConnContact | ConnMember | ConnSndFile | ConnRcvFile | ConnUserContact
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromField ConnType where fromField = fromTextField_ connTypeT
|
||||
@@ -439,6 +460,7 @@ connTypeT = \case
|
||||
"member" -> Just ConnMember
|
||||
"snd_file" -> Just ConnSndFile
|
||||
"rcv_file" -> Just ConnRcvFile
|
||||
"user_contact" -> Just ConnUserContact
|
||||
_ -> Nothing
|
||||
|
||||
serializeConnType :: ConnType -> Text
|
||||
@@ -447,6 +469,7 @@ serializeConnType = \case
|
||||
ConnMember -> "member"
|
||||
ConnSndFile -> "snd_file"
|
||||
ConnRcvFile -> "rcv_file"
|
||||
ConnUserContact -> "user_contact"
|
||||
|
||||
data NewConnection = NewConnection
|
||||
{ agentConnId :: ByteString,
|
||||
@@ -495,3 +518,11 @@ serializeIntroStatus = \case
|
||||
GMIntroReConnected -> "re-con"
|
||||
GMIntroToConnected -> "to-con"
|
||||
GMIntroConnected -> "con"
|
||||
|
||||
data Onboarding = Onboarding
|
||||
{ contactsCount :: Int,
|
||||
createdGroups :: Int,
|
||||
membersCount :: Int,
|
||||
filesSentCount :: Int,
|
||||
addressCount :: Int
|
||||
}
|
||||
|
||||
@@ -1,5 +1,6 @@
|
||||
module Simplex.Chat.Util where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8With)
|
||||
@@ -12,5 +13,8 @@ safeDecodeUtf8 = decodeUtf8With onError
|
||||
ifM :: Monad m => m Bool -> m a -> m a -> m a
|
||||
ifM ba t f = ba >>= \b -> if b then t else f
|
||||
|
||||
whenM :: Monad m => m Bool -> m () -> m ()
|
||||
whenM ba a = ba >>= (`when` a)
|
||||
|
||||
unlessM :: Monad m => m Bool -> m () -> m ()
|
||||
unlessM b = ifM b $ pure ()
|
||||
|
||||
+120
-9
@@ -8,14 +8,25 @@
|
||||
module Simplex.Chat.View
|
||||
( printToView,
|
||||
showInvitation,
|
||||
showSentConfirmation,
|
||||
showSentInvitation,
|
||||
showChatError,
|
||||
showContactDeleted,
|
||||
showContactGroups,
|
||||
showContactsList,
|
||||
showContactConnected,
|
||||
showContactDisconnected,
|
||||
showContactAnotherClient,
|
||||
showContactSubscribed,
|
||||
showContactSubError,
|
||||
showUserContactLinkCreated,
|
||||
showUserContactLinkDeleted,
|
||||
showUserContactLink,
|
||||
showReceivedContactRequest,
|
||||
showAcceptingContactRequest,
|
||||
showContactRequestRejected,
|
||||
showUserContactLinkSubscribed,
|
||||
showUserContactLinkSubError,
|
||||
showGroupSubscribed,
|
||||
showGroupEmpty,
|
||||
showGroupRemoved,
|
||||
@@ -55,6 +66,7 @@ module Simplex.Chat.View
|
||||
showLeftMemberUser,
|
||||
showLeftMember,
|
||||
showGroupMembers,
|
||||
showGroupsList,
|
||||
showContactsMerged,
|
||||
showUserProfile,
|
||||
showUserProfileUpdated,
|
||||
@@ -62,6 +74,7 @@ module Simplex.Chat.View
|
||||
showMessageError,
|
||||
safeDecodeUtf8,
|
||||
msgPlain,
|
||||
clientVersionInfo,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -71,7 +84,7 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Composition ((.:), (.:.))
|
||||
import Data.Function (on)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (groupBy, intersperse, sortOn)
|
||||
import Data.List (groupBy, intersperse, sort, sortOn)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (DiffTime, UTCTime)
|
||||
@@ -86,12 +99,19 @@ import Simplex.Chat.Terminal (printToTerminal)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Util (safeDecodeUtf8)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import System.Console.ANSI.Types
|
||||
|
||||
type ChatReader m = (MonadUnliftIO m, MonadReader ChatController m)
|
||||
|
||||
showInvitation :: ChatReader m => SMPQueueInfo -> m ()
|
||||
showInvitation = printToView . invitation
|
||||
showInvitation :: ChatReader m => ConnReqInvitation -> m ()
|
||||
showInvitation = printToView . connReqInvitation_
|
||||
|
||||
showSentConfirmation :: ChatReader m => m ()
|
||||
showSentConfirmation = printToView ["confirmation sent!"]
|
||||
|
||||
showSentInvitation :: ChatReader m => m ()
|
||||
showSentInvitation = printToView ["connection request sent!"]
|
||||
|
||||
showChatError :: ChatReader m => ChatError -> m ()
|
||||
showChatError = printToView . chatError
|
||||
@@ -102,6 +122,9 @@ showContactDeleted = printToView . contactDeleted
|
||||
showContactGroups :: ChatReader m => ContactName -> [GroupName] -> m ()
|
||||
showContactGroups = printToView .: contactGroups
|
||||
|
||||
showContactsList :: ChatReader m => [Contact] -> m ()
|
||||
showContactsList = printToView . contactsList
|
||||
|
||||
showContactConnected :: ChatReader m => Contact -> m ()
|
||||
showContactConnected = printToView . contactConnected
|
||||
|
||||
@@ -117,6 +140,30 @@ showContactSubscribed = printToView . contactSubscribed
|
||||
showContactSubError :: ChatReader m => ContactName -> ChatError -> m ()
|
||||
showContactSubError = printToView .: contactSubError
|
||||
|
||||
showUserContactLinkCreated :: ChatReader m => ConnReqContact -> m ()
|
||||
showUserContactLinkCreated = printToView . userContactLinkCreated
|
||||
|
||||
showUserContactLinkDeleted :: ChatReader m => m ()
|
||||
showUserContactLinkDeleted = printToView userContactLinkDeleted
|
||||
|
||||
showUserContactLink :: ChatReader m => ConnReqContact -> m ()
|
||||
showUserContactLink = printToView . userContactLink
|
||||
|
||||
showReceivedContactRequest :: ChatReader m => ContactName -> Profile -> m ()
|
||||
showReceivedContactRequest = printToView .: receivedContactRequest
|
||||
|
||||
showAcceptingContactRequest :: ChatReader m => ContactName -> m ()
|
||||
showAcceptingContactRequest = printToView . acceptingContactRequest
|
||||
|
||||
showContactRequestRejected :: ChatReader m => ContactName -> m ()
|
||||
showContactRequestRejected = printToView . contactRequestRejected
|
||||
|
||||
showUserContactLinkSubscribed :: ChatReader m => m ()
|
||||
showUserContactLinkSubscribed = printToView ["Your address is active! To show: " <> highlight' "/sa"]
|
||||
|
||||
showUserContactLinkSubError :: ChatReader m => ChatError -> m ()
|
||||
showUserContactLinkSubError = printToView . userContactLinkSubError
|
||||
|
||||
showGroupSubscribed :: ChatReader m => GroupName -> m ()
|
||||
showGroupSubscribed = printToView . groupSubscribed
|
||||
|
||||
@@ -240,6 +287,9 @@ showLeftMember = printToView .: leftMember
|
||||
showGroupMembers :: ChatReader m => Group -> m ()
|
||||
showGroupMembers = printToView . groupMembers
|
||||
|
||||
showGroupsList :: ChatReader m => [(GroupName, Text)] -> m ()
|
||||
showGroupsList = printToView . groupsList
|
||||
|
||||
showContactsMerged :: ChatReader m => Contact -> Contact -> m ()
|
||||
showContactsMerged = printToView .: contactsMerged
|
||||
|
||||
@@ -255,13 +305,13 @@ showContactUpdated = printToView .: contactUpdated
|
||||
showMessageError :: ChatReader m => Text -> Text -> m ()
|
||||
showMessageError = printToView .: messageError
|
||||
|
||||
invitation :: SMPQueueInfo -> [StyledString]
|
||||
invitation qInfo =
|
||||
[ "pass this invitation to your contact (via another channel): ",
|
||||
connReqInvitation_ :: ConnReqInvitation -> [StyledString]
|
||||
connReqInvitation_ cReq =
|
||||
[ "pass this invitation link to your contact (via another channel): ",
|
||||
"",
|
||||
(plain . serializeSmpQueueInfo) qInfo,
|
||||
(plain . serializeConnReq') cReq,
|
||||
"",
|
||||
"and ask them to connect: " <> highlight' "/c <invitation_above>"
|
||||
"and ask them to connect: " <> highlight' "/c <invitation_link_above>"
|
||||
]
|
||||
|
||||
contactDeleted :: ContactName -> [StyledString]
|
||||
@@ -275,6 +325,11 @@ contactGroups c gNames = [ttyContact c <> ": contact cannot be deleted, it is a
|
||||
ttyGroups [g] = ttyGroup g
|
||||
ttyGroups (g : gs) = ttyGroup g <> ", " <> ttyGroups gs
|
||||
|
||||
contactsList :: [Contact] -> [StyledString]
|
||||
contactsList =
|
||||
let ldn = T.toLower . (localDisplayName :: Contact -> ContactName)
|
||||
in map ttyFullContact . sortOn ldn
|
||||
|
||||
contactConnected :: Contact -> [StyledString]
|
||||
contactConnected ct = [ttyFullContact ct <> ": contact is connected"]
|
||||
|
||||
@@ -290,6 +345,48 @@ contactSubscribed c = [ttyContact c <> ": connected to server"]
|
||||
contactSubError :: ContactName -> ChatError -> [StyledString]
|
||||
contactSubError c e = [ttyContact c <> ": contact error " <> sShow e]
|
||||
|
||||
userContactLinkCreated :: ConnReqContact -> [StyledString]
|
||||
userContactLinkCreated = connReqContact_ "Your new chat address is created!"
|
||||
|
||||
userContactLinkDeleted :: [StyledString]
|
||||
userContactLinkDeleted =
|
||||
[ "Your chat address is deleted - accepted contacts will remain connected.",
|
||||
"To create a new chat address use " <> highlight' "/ad"
|
||||
]
|
||||
|
||||
userContactLink :: ConnReqContact -> [StyledString]
|
||||
userContactLink = connReqContact_ "Your chat address:"
|
||||
|
||||
connReqContact_ :: StyledString -> ConnReqContact -> [StyledString]
|
||||
connReqContact_ intro cReq =
|
||||
[ intro,
|
||||
"",
|
||||
(plain . serializeConnReq') cReq,
|
||||
"",
|
||||
"Anybody can send you contact requests with: " <> highlight' "/c <contact_link_above>",
|
||||
"to show it again: " <> highlight' "/sa",
|
||||
"to delete it: " <> highlight' "/da" <> " (accepted contacts will remain connected)"
|
||||
]
|
||||
|
||||
receivedContactRequest :: ContactName -> Profile -> [StyledString]
|
||||
receivedContactRequest c Profile {fullName} =
|
||||
[ ttyFullName c fullName <> " wants to connect to you!",
|
||||
"to accept: " <> highlight ("/ac " <> c),
|
||||
"to reject: " <> highlight ("/rc " <> c) <> " (the sender will NOT be notified)"
|
||||
]
|
||||
|
||||
acceptingContactRequest :: ContactName -> [StyledString]
|
||||
acceptingContactRequest c = [ttyContact c <> ": accepting contact request..."]
|
||||
|
||||
contactRequestRejected :: ContactName -> [StyledString]
|
||||
contactRequestRejected c = [ttyContact c <> ": contact request rejected"]
|
||||
|
||||
userContactLinkSubError :: ChatError -> [StyledString]
|
||||
userContactLinkSubError e =
|
||||
[ "user address error: " <> sShow e,
|
||||
"to delete your address: " <> highlight' "/da"
|
||||
]
|
||||
|
||||
groupSubscribed :: GroupName -> [StyledString]
|
||||
groupSubscribed g = [ttyGroup g <> ": connected to server(s)"]
|
||||
|
||||
@@ -385,6 +482,12 @@ groupMembers Group {membership, members} = map groupMember . filter (not . remov
|
||||
GSMemCreator -> "created group"
|
||||
_ -> ""
|
||||
|
||||
groupsList :: [(GroupName, Text)] -> [StyledString]
|
||||
groupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"]
|
||||
groupsList gs = map groupNames $ sort gs
|
||||
where
|
||||
groupNames (displayName, fullName) = ttyGroup displayName <> optFullName displayName fullName
|
||||
|
||||
contactsMerged :: Contact -> Contact -> [StyledString]
|
||||
contactsMerged _to@Contact {localDisplayName = c1} _from@Contact {localDisplayName = c2} =
|
||||
[ "contact " <> ttyContact c2 <> " is merged into " <> ttyContact c1,
|
||||
@@ -624,8 +727,13 @@ chatError = \case
|
||||
SEFileNotFound fileId -> fileNotFound fileId
|
||||
SESndFileNotFound fileId -> fileNotFound fileId
|
||||
SERcvFileNotFound fileId -> fileNotFound fileId
|
||||
SEDuplicateContactLink -> ["you already have chat address, to show: " <> highlight' "/sa"]
|
||||
SEUserContactLinkNotFound -> ["no chat address, to create: " <> highlight' "/ad"]
|
||||
SEContactRequestNotFound c -> ["no contact request from " <> ttyContact c]
|
||||
e -> ["chat db error: " <> sShow e]
|
||||
ChatErrorAgent e -> ["smp agent error: " <> sShow e]
|
||||
ChatErrorAgent err -> case err of
|
||||
SMP SMP.AUTH -> ["error: this connection is deleted"]
|
||||
e -> ["smp agent error: " <> sShow e]
|
||||
ChatErrorMessage e -> ["chat message error: " <> sShow e]
|
||||
where
|
||||
fileNotFound fileId = ["file " <> sShow fileId <> " not found"]
|
||||
@@ -685,3 +793,6 @@ highlight' = highlight
|
||||
|
||||
styleTime :: String -> StyledString
|
||||
styleTime = Styled [SetColor Foreground Vivid Black]
|
||||
|
||||
clientVersionInfo :: [StyledString]
|
||||
clientVersionInfo = [plain $ "SimpleX Chat v" <> versionNumber]
|
||||
|
||||
+2
-2
@@ -40,10 +40,10 @@ extra-deps:
|
||||
- simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079
|
||||
- sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002
|
||||
- terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977
|
||||
- simplexmq-0.4.1@sha256:3a1bc40d85e4e398458e5b9b79757e0af4fe27b8ef44eb3157f7f1e07412a8e8,7640
|
||||
- simplexmq-0.5.0@sha256:3d9b84d986df7409839c19455a376722837d52a646cb5d136037cadd0b5a4b76,7828
|
||||
# - ../simplexmq
|
||||
# - github: simplex-chat/simplexmq
|
||||
# commit: 35e6593581e68f7b444e0f8f4fb6a2e2cc59a5ea
|
||||
# commit: f15067cf6891bda3216c6cf6d2e3ecdba9b7269e
|
||||
#
|
||||
# extra-deps: []
|
||||
|
||||
|
||||
+110
-2
@@ -46,6 +46,10 @@ chatTests = do
|
||||
it "sender cancelled file transfer" testFileSndCancel
|
||||
it "recipient cancelled file transfer" testFileRcvCancel
|
||||
it "send and receive file to group" testGroupFileTransfer
|
||||
describe "user contact link" $ do
|
||||
it "should create and connect via contact link" testUserContactLink
|
||||
it "should reject contact and delete contact link" testRejectContactAndDeleteUserContact
|
||||
it "should delete connection requests when contact link deleted" testDeleteConnectionRequests
|
||||
|
||||
testAddContact :: IO ()
|
||||
testAddContact =
|
||||
@@ -54,6 +58,7 @@ testAddContact =
|
||||
alice ##> "/c"
|
||||
inv <- getInvitation alice
|
||||
bob ##> ("/c " <> inv)
|
||||
bob <## "confirmation sent!"
|
||||
concurrently_
|
||||
(bob <## "alice (Alice): contact is connected")
|
||||
(alice <## "bob (Bob): contact is connected")
|
||||
@@ -65,6 +70,7 @@ testAddContact =
|
||||
alice ##> "/c"
|
||||
inv' <- getInvitation alice
|
||||
bob ##> ("/c " <> inv')
|
||||
bob <## "confirmation sent!"
|
||||
concurrently_
|
||||
(bob <## "alice_1 (Alice): contact is connected")
|
||||
(alice <## "bob_1 (Bob): contact is connected")
|
||||
@@ -128,6 +134,20 @@ testGroup =
|
||||
(alice <# "#team cath> hey")
|
||||
(bob <# "#team cath> hey")
|
||||
bob <##> cath
|
||||
-- list groups
|
||||
alice ##> "/gs"
|
||||
alice <## "#team"
|
||||
-- list group members
|
||||
alice ##> "/ms team"
|
||||
alice
|
||||
<### [ "alice (Alice): owner, you, created group",
|
||||
"bob (Bob): admin, invited, connected",
|
||||
"cath (Catherine): admin, invited, connected"
|
||||
]
|
||||
-- list contacts
|
||||
alice ##> "/cs"
|
||||
alice <## "bob (Bob)"
|
||||
alice <## "cath (Catherine)"
|
||||
-- remove member
|
||||
bob ##> "/rm team cath"
|
||||
concurrentlyN_
|
||||
@@ -530,6 +550,73 @@ testGroupFileTransfer =
|
||||
cath <## "completed receiving file 1 (test.jpg) from alice"
|
||||
]
|
||||
|
||||
testUserContactLink :: IO ()
|
||||
testUserContactLink = testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
alice ##> "/ad"
|
||||
cLink <- getContactLink alice True
|
||||
bob ##> ("/c " <> cLink)
|
||||
alice <#? bob
|
||||
alice ##> "/ac bob"
|
||||
alice <## "bob: accepting contact request..."
|
||||
concurrently_
|
||||
(bob <## "alice (Alice): contact is connected")
|
||||
(alice <## "bob (Bob): contact is connected")
|
||||
alice <##> bob
|
||||
|
||||
cath ##> ("/c " <> cLink)
|
||||
alice <#? cath
|
||||
alice ##> "/ac cath"
|
||||
alice <## "cath: accepting contact request..."
|
||||
concurrently_
|
||||
(cath <## "alice (Alice): contact is connected")
|
||||
(alice <## "cath (Catherine): contact is connected")
|
||||
alice <##> cath
|
||||
|
||||
testRejectContactAndDeleteUserContact :: IO ()
|
||||
testRejectContactAndDeleteUserContact = testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
alice ##> "/ad"
|
||||
cLink <- getContactLink alice True
|
||||
bob ##> ("/c " <> cLink)
|
||||
alice <#? bob
|
||||
alice ##> "/rc bob"
|
||||
alice <## "bob: contact request rejected"
|
||||
(bob </)
|
||||
|
||||
alice ##> "/sa"
|
||||
cLink' <- getContactLink alice False
|
||||
cLink' `shouldBe` cLink
|
||||
|
||||
alice ##> "/da"
|
||||
alice <## "Your chat address is deleted - accepted contacts will remain connected."
|
||||
alice <## "To create a new chat address use /ad"
|
||||
|
||||
cath ##> ("/c " <> cLink)
|
||||
cath <## "error: this connection is deleted"
|
||||
|
||||
testDeleteConnectionRequests :: IO ()
|
||||
testDeleteConnectionRequests = testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
alice ##> "/ad"
|
||||
cLink <- getContactLink alice True
|
||||
bob ##> ("/c " <> cLink)
|
||||
alice <#? bob
|
||||
cath ##> ("/c " <> cLink)
|
||||
alice <#? cath
|
||||
|
||||
alice ##> "/da"
|
||||
alice <## "Your chat address is deleted - accepted contacts will remain connected."
|
||||
alice <## "To create a new chat address use /ad"
|
||||
|
||||
alice ##> "/ad"
|
||||
cLink' <- getContactLink alice True
|
||||
bob ##> ("/c " <> cLink')
|
||||
-- same names are used here, as they were released at /da
|
||||
alice <#? bob
|
||||
cath ##> ("/c " <> cLink')
|
||||
alice <#? cath
|
||||
|
||||
startFileTransfer :: TestCC -> TestCC -> IO ()
|
||||
startFileTransfer alice bob = do
|
||||
alice #> "/f @bob ./tests/fixtures/test.jpg"
|
||||
@@ -556,6 +643,7 @@ connectUsers cc1 cc2 = do
|
||||
cc1 ##> "/c"
|
||||
inv <- getInvitation cc1
|
||||
cc2 ##> ("/c " <> inv)
|
||||
cc2 <## "confirmation sent!"
|
||||
concurrently_
|
||||
(cc2 <## (name1 <> ": contact is connected"))
|
||||
(cc1 <## (name2 <> ": contact is connected"))
|
||||
@@ -648,6 +736,15 @@ cc <# line = (dropTime <$> getTermLine cc) `shouldReturn` line
|
||||
(</) :: TestCC -> Expectation
|
||||
(</) cc = timeout 500000 (getTermLine cc) `shouldReturn` Nothing
|
||||
|
||||
(<#?) :: TestCC -> TestCC -> Expectation
|
||||
cc1 <#? cc2 = do
|
||||
name <- userName cc2
|
||||
sName <- showName cc2
|
||||
cc2 <## "connection request sent!"
|
||||
cc1 <## (sName <> " wants to connect to you!")
|
||||
cc1 <## ("to accept: /ac " <> name)
|
||||
cc1 <## ("to reject: /rc " <> name <> " (the sender will NOT be notified)")
|
||||
|
||||
dropTime :: String -> String
|
||||
dropTime msg = case splitAt 6 msg of
|
||||
([m, m', ':', s, s', ' '], text) ->
|
||||
@@ -659,9 +756,20 @@ getTermLine = atomically . readTQueue . termQ
|
||||
|
||||
getInvitation :: TestCC -> IO String
|
||||
getInvitation cc = do
|
||||
cc <## "pass this invitation to your contact (via another channel):"
|
||||
cc <## "pass this invitation link to your contact (via another channel):"
|
||||
cc <## ""
|
||||
inv <- getTermLine cc
|
||||
cc <## ""
|
||||
cc <## "and ask them to connect: /c <invitation_above>"
|
||||
cc <## "and ask them to connect: /c <invitation_link_above>"
|
||||
pure inv
|
||||
|
||||
getContactLink :: TestCC -> Bool -> IO String
|
||||
getContactLink cc created = do
|
||||
cc <## if created then "Your new chat address is created!" else "Your chat address:"
|
||||
cc <## ""
|
||||
link <- getTermLine cc
|
||||
cc <## ""
|
||||
cc <## "Anybody can send you contact requests with: /c <contact_link_above>"
|
||||
cc <## "to show it again: /sa"
|
||||
cc <## "to delete it: /da (accepted contacts will remain connected)"
|
||||
pure link
|
||||
|
||||
Reference in New Issue
Block a user