Compare commits

..

12 Commits

Author SHA1 Message Date
Jesse Horne
0e223a3781 added vertical scrollbar for chat list for desktop 2023-11-28 18:01:12 -05:00
Stanislav Dmitrenko
05a64c99a2 ios: moving webrtc commands processing to another mechanism (#3480)
* ios: moving webrtc commands processing to another mechanism

* async

* decide

* handle errors

* error alert

* await

---------

Co-authored-by: Avently <avently@local>
Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
2023-11-28 17:36:05 +00:00
Alexander Bondarenko
6a21d5c7f1 add remote host bindings (#3471)
* add remote host bindings

* group iface/address together

* rename migration

* add implementation

* update view and api

* bump upstream

* add schema

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
2023-11-28 16:32:33 +00:00
Stanislav Dmitrenko
950bbe19da ios: fix calls connecting state (#3475)
* ios: fix calls connecting state

* optimization

* changes

* removed relay protocol

* simplify

* use actor

* fix loop, better onChange, some questions

* remove extra iteration

---------

Co-authored-by: Avently <avently@local>
Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
2023-11-27 22:20:51 +00:00
Evgeny Poberezkin
05278e5a06 core: allow remote host commands without user (#3478) 2023-11-27 18:34:15 +00:00
spaced4ndy
7a54d74517 Revert "ios: update libraries (#3474)"
This reverts commit bfcb2ac230.
2023-11-27 19:16:53 +04:00
spaced4ndy
bfcb2ac230 ios: update libraries (#3474) 2023-11-27 19:02:44 +04:00
spaced4ndy
3073c4a1d5 core: fix chat previews showing not the latest message, fix message ordering in direct chats; mobile: update group previews only on timestamp increase (#3473) 2023-11-27 17:14:12 +04:00
Evgeny Poberezkin
d4ac1c0cf2 core, ui: add remote host/controller stop reasons to events (#3472) 2023-11-26 23:23:37 +00:00
Evgeny Poberezkin
d29f1bb0cf core: use fourmolu styles (#3470) 2023-11-26 18:16:37 +00:00
Jesse Horne
75c2de8a12 desktop: closing console window no longer closes entire application (#3466)
* closing the console now doesn't close all windows

* simplify

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
2023-11-26 13:40:51 +00:00
Alexander Bondarenko
f20ac33e67 cli: remove clashing short option for device-name (#3468) 2023-11-26 13:16:32 +00:00
68 changed files with 1322 additions and 1079 deletions

View File

@@ -262,7 +262,7 @@ jobs:
# rm -rf dist-newstyle/src/direct-sq* is here because of the bug in cabal's dependency which prevents second build from finishing
- name: 'Setup MSYS2'
if: matrix.os == 'windows-latest'
if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'windows-latest'
uses: msys2/setup-msys2@v2
with:
msystem: ucrt64

View File

@@ -83,7 +83,7 @@ final class ChatModel: ObservableObject {
// current WebRTC call
@Published var callInvitations: Dictionary<ChatId, RcvCallInvitation> = [:]
@Published var activeCall: Call?
@Published var callCommand: WCallCommand?
let callCommand: WebRTCCommandProcessor = WebRTCCommandProcessor()
@Published var showCallView = false
// remote desktop
@Published var remoteCtrlSession: RemoteCtrlSession?
@@ -267,7 +267,20 @@ final class ChatModel: ObservableObject {
func addChatItem(_ cInfo: ChatInfo, _ cItem: ChatItem) {
// update previews
if let i = getChatIndex(cInfo.id) {
chats[i].chatItems = [cItem]
chats[i].chatItems = switch cInfo {
case .group:
if let currentPreviewItem = chats[i].chatItems.first {
if cItem.meta.itemTs >= currentPreviewItem.meta.itemTs {
[cItem]
} else {
[currentPreviewItem]
}
} else {
[cItem]
}
default:
[cItem]
}
if case .rcvNew = cItem.meta.itemStatus {
chats[i].chatStats.unreadCount = chats[i].chatStats.unreadCount + 1
increaseUnreadCounter(user: currentUser!)

View File

@@ -1666,36 +1666,40 @@ func processReceivedMsg(_ res: ChatResponse) async {
activateCall(invitation)
case let .callOffer(_, contact, callType, offer, sharedKey, _):
await withCall(contact) { call in
call.callState = .offerReceived
call.peerMedia = callType.media
call.sharedKey = sharedKey
await MainActor.run {
call.callState = .offerReceived
call.peerMedia = callType.media
call.sharedKey = sharedKey
}
let useRelay = UserDefaults.standard.bool(forKey: DEFAULT_WEBRTC_POLICY_RELAY)
let iceServers = getIceServers()
logger.debug(".callOffer useRelay \(useRelay)")
logger.debug(".callOffer iceServers \(String(describing: iceServers))")
m.callCommand = .offer(
await m.callCommand.processCommand(.offer(
offer: offer.rtcSession,
iceCandidates: offer.rtcIceCandidates,
media: callType.media, aesKey: sharedKey,
iceServers: iceServers,
relay: useRelay
)
))
}
case let .callAnswer(_, contact, answer):
await withCall(contact) { call in
call.callState = .answerReceived
m.callCommand = .answer(answer: answer.rtcSession, iceCandidates: answer.rtcIceCandidates)
await MainActor.run {
call.callState = .answerReceived
}
await m.callCommand.processCommand(.answer(answer: answer.rtcSession, iceCandidates: answer.rtcIceCandidates))
}
case let .callExtraInfo(_, contact, extraInfo):
await withCall(contact) { _ in
m.callCommand = .ice(iceCandidates: extraInfo.rtcIceCandidates)
await m.callCommand.processCommand(.ice(iceCandidates: extraInfo.rtcIceCandidates))
}
case let .callEnded(_, contact):
if let invitation = await MainActor.run(body: { m.callInvitations.removeValue(forKey: contact.id) }) {
CallController.shared.reportCallRemoteEnded(invitation: invitation)
}
await withCall(contact) { call in
m.callCommand = .end
await m.callCommand.processCommand(.end)
CallController.shared.reportCallRemoteEnded(call: call)
}
case .chatSuspended:
@@ -1753,9 +1757,9 @@ func processReceivedMsg(_ res: ChatResponse) async {
logger.debug("unsupported event: \(res.responseType)")
}
func withCall(_ contact: Contact, _ perform: (Call) -> Void) async {
func withCall(_ contact: Contact, _ perform: (Call) async -> Void) async {
if let call = m.activeCall, call.contact.apiId == contact.apiId {
await MainActor.run { perform(call) }
await perform(call)
} else {
logger.debug("processReceivedMsg: ignoring \(res.responseType), not in call with the contact \(contact.id)")
}

View File

@@ -49,10 +49,10 @@ struct ActiveCallView: View {
}
.onDisappear {
logger.debug("ActiveCallView: disappear")
Task { await m.callCommand.setClient(nil) }
AppDelegate.keepScreenOn(false)
client?.endCall()
}
.onChange(of: m.callCommand) { _ in sendCommandToClient()}
.background(.black)
.preferredColorScheme(.dark)
}
@@ -60,19 +60,8 @@ struct ActiveCallView: View {
private func createWebRTCClient() {
if client == nil && canConnectCall {
client = WebRTCClient($activeCall, { msg in await MainActor.run { processRtcMessage(msg: msg) } }, $localRendererAspectRatio)
sendCommandToClient()
}
}
private func sendCommandToClient() {
if call == m.activeCall,
m.activeCall != nil,
let client = client,
let cmd = m.callCommand {
m.callCommand = nil
logger.debug("sendCallCommand: \(cmd.cmdType)")
Task {
await client.sendCallCommand(command: cmd)
await m.callCommand.setClient(client)
}
}
}
@@ -168,8 +157,10 @@ struct ActiveCallView: View {
}
case let .error(message):
logger.debug("ActiveCallView: command error: \(message)")
AlertManager.shared.showAlert(Alert(title: Text("Error"), message: Text(message)))
case let .invalid(type):
logger.debug("ActiveCallView: invalid response: \(type)")
AlertManager.shared.showAlert(Alert(title: Text("Invalid response"), message: Text(type)))
}
}
}
@@ -255,7 +246,6 @@ struct ActiveCallOverlay: View {
HStack {
Text(call.encryptionStatus)
if let connInfo = call.connectionInfo {
// Text("(") + Text(connInfo.text) + Text(", \(connInfo.protocolText))")
Text("(") + Text(connInfo.text) + Text(")")
}
}

View File

@@ -22,7 +22,7 @@ class CallManager {
let m = ChatModel.shared
if let call = m.activeCall, call.callkitUUID == callUUID {
m.showCallView = true
m.callCommand = .capabilities(media: call.localMedia)
Task { await m.callCommand.processCommand(.capabilities(media: call.localMedia)) }
return true
}
return false
@@ -57,19 +57,21 @@ class CallManager {
m.activeCall = call
m.showCallView = true
m.callCommand = .start(
Task {
await m.callCommand.processCommand(.start(
media: invitation.callType.media,
aesKey: invitation.sharedKey,
iceServers: iceServers,
relay: useRelay
)
))
}
}
}
func enableMedia(media: CallMediaType, enable: Bool, callUUID: UUID) -> Bool {
if let call = ChatModel.shared.activeCall, call.callkitUUID == callUUID {
let m = ChatModel.shared
m.callCommand = .media(media: media, enable: enable)
Task { await m.callCommand.processCommand(.media(media: media, enable: enable)) }
return true
}
return false
@@ -94,11 +96,13 @@ class CallManager {
completed()
} else {
logger.debug("CallManager.endCall: ending call...")
m.callCommand = .end
m.activeCall = nil
m.showCallView = false
completed()
Task {
await m.callCommand.processCommand(.end)
await MainActor.run {
m.activeCall = nil
m.showCallView = false
completed()
}
do {
try await apiEndCall(call.contact)
} catch {

View File

@@ -335,6 +335,50 @@ extension WCallResponse: Encodable {
}
}
actor WebRTCCommandProcessor {
private var client: WebRTCClient? = nil
private var commands: [WCallCommand] = []
private var running: Bool = false
func setClient(_ client: WebRTCClient?) async {
logger.debug("WebRTC: setClient, commands count \(self.commands.count)")
self.client = client
if client != nil {
await processAllCommands()
} else {
commands.removeAll()
}
}
func processCommand(_ c: WCallCommand) async {
// logger.debug("WebRTC: process command \(c.cmdType)")
commands.append(c)
if !running && client != nil {
await processAllCommands()
}
}
func processAllCommands() async {
logger.debug("WebRTC: process all commands, commands count \(self.commands.count), client == nil \(self.client == nil)")
if let client = client {
running = true
while let c = commands.first, shouldRunCommand(client, c) {
commands.remove(at: 0)
await client.sendCallCommand(command: c)
logger.debug("WebRTC: processed cmd \(c.cmdType)")
}
running = false
}
}
func shouldRunCommand(_ client: WebRTCClient, _ c: WCallCommand) -> Bool {
switch c {
case .capabilities, .start, .offer, .end: true
default: client.activeCall.wrappedValue != nil
}
}
}
struct ConnectionState: Codable, Equatable {
var connectionState: String
var iceConnectionState: String
@@ -358,26 +402,12 @@ struct ConnectionInfo: Codable, Equatable {
return "\(local?.rawValue ?? unknown) / \(remote?.rawValue ?? unknown)"
}
}
var protocolText: String {
let unknown = NSLocalizedString("unknown", comment: "connection info")
let local = localCandidate?.protocol?.uppercased() ?? unknown
let localRelay = localCandidate?.relayProtocol?.uppercased() ?? unknown
let remote = remoteCandidate?.protocol?.uppercased() ?? unknown
let localText = localRelay == local || localCandidate?.relayProtocol == nil
? local
: "\(local) (\(localRelay))"
return local == remote
? localText
: "\(localText) / \(remote)"
}
}
// https://developer.mozilla.org/en-US/docs/Web/API/RTCIceCandidate
struct RTCIceCandidate: Codable, Equatable {
var candidateType: RTCIceCandidateType?
var `protocol`: String?
var relayProtocol: String?
var sdpMid: String?
var sdpMLineIndex: Int?
var candidate: String

View File

@@ -21,7 +21,7 @@ final class WebRTCClient: NSObject, RTCVideoViewDelegate, RTCFrameEncryptorDeleg
struct Call {
var connection: RTCPeerConnection
var iceCandidates: [RTCIceCandidate]
var iceCandidates: IceCandidates
var localMedia: CallMediaType
var localCamera: RTCVideoCapturer?
var localVideoSource: RTCVideoSource?
@@ -33,10 +33,24 @@ final class WebRTCClient: NSObject, RTCVideoViewDelegate, RTCFrameEncryptorDeleg
var frameDecryptor: RTCFrameDecryptor?
}
actor IceCandidates {
private var candidates: [RTCIceCandidate] = []
func getAndClear() async -> [RTCIceCandidate] {
let cs = candidates
candidates = []
return cs
}
func append(_ c: RTCIceCandidate) async {
candidates.append(c)
}
}
private let rtcAudioSession = RTCAudioSession.sharedInstance()
private let audioQueue = DispatchQueue(label: "audio")
private var sendCallResponse: (WVAPIMessage) async -> Void
private var activeCall: Binding<Call?>
var activeCall: Binding<Call?>
private var localRendererAspectRatio: Binding<CGFloat?>
@available(*, unavailable)
@@ -60,7 +74,7 @@ final class WebRTCClient: NSObject, RTCVideoViewDelegate, RTCFrameEncryptorDeleg
WebRTC.RTCIceServer(urlStrings: ["turn:turn.simplex.im:443?transport=tcp"], username: "private", credential: "yleob6AVkiNI87hpR94Z"),
]
func initializeCall(_ iceServers: [WebRTC.RTCIceServer]?, _ remoteIceCandidates: [RTCIceCandidate], _ mediaType: CallMediaType, _ aesKey: String?, _ relay: Bool?) -> Call {
func initializeCall(_ iceServers: [WebRTC.RTCIceServer]?, _ mediaType: CallMediaType, _ aesKey: String?, _ relay: Bool?) -> Call {
let connection = createPeerConnection(iceServers ?? getWebRTCIceServers() ?? defaultIceServers, relay)
connection.delegate = self
createAudioSender(connection)
@@ -87,7 +101,7 @@ final class WebRTCClient: NSObject, RTCVideoViewDelegate, RTCFrameEncryptorDeleg
}
return Call(
connection: connection,
iceCandidates: remoteIceCandidates,
iceCandidates: IceCandidates(),
localMedia: mediaType,
localCamera: localCamera,
localVideoSource: localVideoSource,
@@ -144,26 +158,18 @@ final class WebRTCClient: NSObject, RTCVideoViewDelegate, RTCFrameEncryptorDeleg
logger.debug("starting incoming call - create webrtc session")
if activeCall.wrappedValue != nil { endCall() }
let encryption = WebRTCClient.enableEncryption
let call = initializeCall(iceServers?.toWebRTCIceServers(), [], media, encryption ? aesKey : nil, relay)
let call = initializeCall(iceServers?.toWebRTCIceServers(), media, encryption ? aesKey : nil, relay)
activeCall.wrappedValue = call
call.connection.offer { answer in
Task {
let gotCandidates = await self.waitWithTimeout(10_000, stepMs: 1000, until: { self.activeCall.wrappedValue?.iceCandidates.count ?? 0 > 0 })
if gotCandidates {
await self.sendCallResponse(.init(
corrId: nil,
resp: .offer(
offer: compressToBase64(input: encodeJSON(CustomRTCSessionDescription(type: answer.type.toSdpType(), sdp: answer.sdp))),
iceCandidates: compressToBase64(input: encodeJSON(self.activeCall.wrappedValue?.iceCandidates ?? [])),
capabilities: CallCapabilities(encryption: encryption)
),
command: command)
)
} else {
self.endCall()
}
}
let (offer, error) = await call.connection.offer()
if let offer = offer {
resp = .offer(
offer: compressToBase64(input: encodeJSON(CustomRTCSessionDescription(type: offer.type.toSdpType(), sdp: offer.sdp))),
iceCandidates: compressToBase64(input: encodeJSON(await self.getInitialIceCandidates())),
capabilities: CallCapabilities(encryption: encryption)
)
self.waitForMoreIceCandidates()
} else {
resp = .error(message: "offer error: \(error?.localizedDescription ?? "unknown error")")
}
case let .offer(offer, iceCandidates, media, aesKey, iceServers, relay):
if activeCall.wrappedValue != nil {
@@ -172,26 +178,21 @@ final class WebRTCClient: NSObject, RTCVideoViewDelegate, RTCFrameEncryptorDeleg
resp = .error(message: "accept: encryption is not supported")
} else if let offer: CustomRTCSessionDescription = decodeJSON(decompressFromBase64(input: offer)),
let remoteIceCandidates: [RTCIceCandidate] = decodeJSON(decompressFromBase64(input: iceCandidates)) {
let call = initializeCall(iceServers?.toWebRTCIceServers(), remoteIceCandidates, media, WebRTCClient.enableEncryption ? aesKey : nil, relay)
let call = initializeCall(iceServers?.toWebRTCIceServers(), media, WebRTCClient.enableEncryption ? aesKey : nil, relay)
activeCall.wrappedValue = call
let pc = call.connection
if let type = offer.type, let sdp = offer.sdp {
if (try? await pc.setRemoteDescription(RTCSessionDescription(type: type.toWebRTCSdpType(), sdp: sdp))) != nil {
pc.answer { answer in
let (answer, error) = await pc.answer()
if let answer = answer {
self.addIceCandidates(pc, remoteIceCandidates)
// Task {
// try? await Task.sleep(nanoseconds: 32_000 * 1000000)
Task {
await self.sendCallResponse(.init(
corrId: nil,
resp: .answer(
answer: compressToBase64(input: encodeJSON(CustomRTCSessionDescription(type: answer.type.toSdpType(), sdp: answer.sdp))),
iceCandidates: compressToBase64(input: encodeJSON(call.iceCandidates))
),
command: command)
)
}
// }
resp = .answer(
answer: compressToBase64(input: encodeJSON(CustomRTCSessionDescription(type: answer.type.toSdpType(), sdp: answer.sdp))),
iceCandidates: compressToBase64(input: encodeJSON(await self.getInitialIceCandidates()))
)
self.waitForMoreIceCandidates()
} else {
resp = .error(message: "answer error: \(error?.localizedDescription ?? "unknown error")")
}
} else {
resp = .error(message: "accept: remote description is not set")
@@ -234,6 +235,7 @@ final class WebRTCClient: NSObject, RTCVideoViewDelegate, RTCFrameEncryptorDeleg
resp = .ok
}
case .end:
// TODO possibly, endCall should be called before returning .ok
await sendCallResponse(.init(corrId: nil, resp: .ok, command: command))
endCall()
}
@@ -242,6 +244,33 @@ final class WebRTCClient: NSObject, RTCVideoViewDelegate, RTCFrameEncryptorDeleg
}
}
func getInitialIceCandidates() async -> [RTCIceCandidate] {
await untilIceComplete(timeoutMs: 750, stepMs: 150) {}
let candidates = await activeCall.wrappedValue?.iceCandidates.getAndClear() ?? []
logger.debug("WebRTCClient: sending initial ice candidates: \(candidates.count)")
return candidates
}
func waitForMoreIceCandidates() {
Task {
await untilIceComplete(timeoutMs: 12000, stepMs: 1500) {
let candidates = await self.activeCall.wrappedValue?.iceCandidates.getAndClear() ?? []
if candidates.count > 0 {
logger.debug("WebRTCClient: sending more ice candidates: \(candidates.count)")
await self.sendIceCandidates(candidates)
}
}
}
}
func sendIceCandidates(_ candidates: [RTCIceCandidate]) async {
await self.sendCallResponse(.init(
corrId: nil,
resp: .ice(iceCandidates: compressToBase64(input: encodeJSON(candidates))),
command: nil)
)
}
func enableMedia(_ media: CallMediaType, _ enable: Bool) {
logger.debug("WebRTCClient: enabling media \(media.rawValue) \(enable)")
media == .video ? setVideoEnabled(enable) : setAudioEnabled(enable)
@@ -387,12 +416,13 @@ final class WebRTCClient: NSObject, RTCVideoViewDelegate, RTCFrameEncryptorDeleg
audioSessionToDefaults()
}
func waitWithTimeout(_ timeoutMs: UInt64, stepMs: UInt64, until success: () -> Bool) async -> Bool {
let startedAt = DispatchTime.now()
while !success() && startedAt.uptimeNanoseconds + timeoutMs * 1000000 > DispatchTime.now().uptimeNanoseconds {
guard let _ = try? await Task.sleep(nanoseconds: stepMs * 1000000) else { break }
}
return success()
func untilIceComplete(timeoutMs: UInt64, stepMs: UInt64, action: @escaping () async -> Void) async {
var t: UInt64 = 0
repeat {
_ = try? await Task.sleep(nanoseconds: stepMs * 1000000)
t += stepMs
await action()
} while t < timeoutMs && activeCall.wrappedValue?.connection.iceGatheringState != .complete
}
}
@@ -405,25 +435,33 @@ extension WebRTC.RTCPeerConnection {
optionalConstraints: nil)
}
func offer(_ completion: @escaping (_ sdp: RTCSessionDescription) -> Void) {
offer(for: mediaConstraints()) { (sdp, error) in
guard let sdp = sdp else {
return
func offer() async -> (RTCSessionDescription?, Error?) {
await withCheckedContinuation { cont in
offer(for: mediaConstraints()) { (sdp, error) in
self.processSDP(cont, sdp, error)
}
self.setLocalDescription(sdp, completionHandler: { (error) in
completion(sdp)
})
}
}
func answer(_ completion: @escaping (_ sdp: RTCSessionDescription) -> Void) {
answer(for: mediaConstraints()) { (sdp, error) in
guard let sdp = sdp else {
return
func answer() async -> (RTCSessionDescription?, Error?) {
await withCheckedContinuation { cont in
answer(for: mediaConstraints()) { (sdp, error) in
self.processSDP(cont, sdp, error)
}
}
}
private func processSDP(_ cont: CheckedContinuation<(RTCSessionDescription?, Error?), Never>, _ sdp: RTCSessionDescription?, _ error: Error?) {
if let sdp = sdp {
self.setLocalDescription(sdp, completionHandler: { (error) in
completion(sdp)
if let error = error {
cont.resume(returning: (nil, error))
} else {
cont.resume(returning: (sdp, nil))
}
})
} else {
cont.resume(returning: (nil, error))
}
}
}
@@ -479,6 +517,7 @@ extension WebRTCClient: RTCPeerConnectionDelegate {
default: enableSpeaker = false
}
setSpeakerEnabledAndConfigureSession(enableSpeaker)
case .connected: sendConnectedEvent(connection)
case .disconnected, .failed: endCall()
default: do {}
}
@@ -491,7 +530,9 @@ extension WebRTCClient: RTCPeerConnectionDelegate {
func peerConnection(_ connection: RTCPeerConnection, didGenerate candidate: WebRTC.RTCIceCandidate) {
// logger.debug("Connection generated candidate \(candidate.debugDescription)")
activeCall.wrappedValue?.iceCandidates.append(candidate.toCandidate(nil, nil, nil))
Task {
await self.activeCall.wrappedValue?.iceCandidates.append(candidate.toCandidate(nil, nil))
}
}
func peerConnection(_ connection: RTCPeerConnection, didRemove candidates: [WebRTC.RTCIceCandidate]) {
@@ -506,10 +547,9 @@ extension WebRTCClient: RTCPeerConnectionDelegate {
lastReceivedMs lastDataReceivedMs: Int32,
changeReason reason: String) {
// logger.debug("Connection changed candidate \(reason) \(remote.debugDescription) \(remote.description)")
sendConnectedEvent(connection, local: local, remote: remote)
}
func sendConnectedEvent(_ connection: WebRTC.RTCPeerConnection, local: WebRTC.RTCIceCandidate, remote: WebRTC.RTCIceCandidate) {
func sendConnectedEvent(_ connection: WebRTC.RTCPeerConnection) {
connection.statistics { (stats: RTCStatisticsReport) in
stats.statistics.values.forEach { stat in
// logger.debug("Stat \(stat.debugDescription)")
@@ -517,24 +557,25 @@ extension WebRTCClient: RTCPeerConnectionDelegate {
let localId = stat.values["localCandidateId"] as? String,
let remoteId = stat.values["remoteCandidateId"] as? String,
let localStats = stats.statistics[localId],
let remoteStats = stats.statistics[remoteId],
local.sdp.contains("\((localStats.values["ip"] as? String ?? "--")) \((localStats.values["port"] as? String ?? "--"))") &&
remote.sdp.contains("\((remoteStats.values["ip"] as? String ?? "--")) \((remoteStats.values["port"] as? String ?? "--"))")
let remoteStats = stats.statistics[remoteId]
{
Task {
await self.sendCallResponse(.init(
corrId: nil,
resp: .connected(connectionInfo: ConnectionInfo(
localCandidate: local.toCandidate(
RTCIceCandidateType.init(rawValue: localStats.values["candidateType"] as! String),
localStats.values["protocol"] as? String,
localStats.values["relayProtocol"] as? String
localCandidate: RTCIceCandidate(
candidateType: RTCIceCandidateType.init(rawValue: localStats.values["candidateType"] as! String),
protocol: localStats.values["protocol"] as? String,
sdpMid: nil,
sdpMLineIndex: nil,
candidate: ""
),
remoteCandidate: remote.toCandidate(
RTCIceCandidateType.init(rawValue: remoteStats.values["candidateType"] as! String),
remoteStats.values["protocol"] as? String,
remoteStats.values["relayProtocol"] as? String
))),
remoteCandidate: RTCIceCandidate(
candidateType: RTCIceCandidateType.init(rawValue: remoteStats.values["candidateType"] as! String),
protocol: remoteStats.values["protocol"] as? String,
sdpMid: nil,
sdpMLineIndex: nil,
candidate: ""))),
command: nil)
)
}
@@ -634,11 +675,10 @@ extension RTCIceCandidate {
}
extension WebRTC.RTCIceCandidate {
func toCandidate(_ candidateType: RTCIceCandidateType?, _ protocol: String?, _ relayProtocol: String?) -> RTCIceCandidate {
func toCandidate(_ candidateType: RTCIceCandidateType?, _ protocol: String?) -> RTCIceCandidate {
RTCIceCandidate(
candidateType: candidateType,
protocol: `protocol`,
relayProtocol: relayProtocol,
sdpMid: sdpMid,
sdpMLineIndex: Int(sdpMLineIndex),
candidate: sdp

View File

@@ -613,7 +613,7 @@ public enum ChatResponse: Decodable, Error {
case remoteCtrlConnecting(remoteCtrl_: RemoteCtrlInfo?, ctrlAppInfo: CtrlAppInfo, appVersion: String)
case remoteCtrlSessionCode(remoteCtrl_: RemoteCtrlInfo?, sessionCode: String)
case remoteCtrlConnected(remoteCtrl: RemoteCtrlInfo)
case remoteCtrlStopped
case remoteCtrlStopped(rcsState: RemoteCtrlSessionState, rcStopReason: RemoteCtrlStopReason)
// misc
case versionInfo(versionInfo: CoreVersionInfo, chatMigrations: [UpMigration], agentMigrations: [UpMigration])
case cmdOk(user: UserRef?)
@@ -1552,6 +1552,13 @@ public enum RemoteCtrlSessionState: Decodable {
case connected(sessionCode: String)
}
public enum RemoteCtrlStopReason: Decodable {
case discoveryFailed(chatError: ChatError)
case connectionFailed(chatError: ChatError)
case setupFailed(chatError: ChatError)
case disconnected
}
public struct CtrlAppInfo: Decodable {
public var appVersionRange: AppVersionRange
public var deviceName: String

View File

@@ -370,7 +370,6 @@ fun CallInfoView(call: Call, alignment: Alignment.Horizontal) {
InfoText(call.callState.text)
val connInfo = call.connectionInfo
// val connInfoText = if (connInfo == null) "" else " (${connInfo.text}, ${connInfo.protocolText})"
val connInfoText = if (connInfo == null) "" else " (${connInfo.text})"
InfoText(call.encryptionStatus + connInfoText)
}
@@ -585,8 +584,8 @@ fun PreviewActiveCallOverlayVideo() {
localMedia = CallMediaType.Video,
peerMedia = CallMediaType.Video,
connectionInfo = ConnectionInfo(
RTCIceCandidate(RTCIceCandidateType.Host, "tcp", null),
RTCIceCandidate(RTCIceCandidateType.Host, "tcp", null)
RTCIceCandidate(RTCIceCandidateType.Host, "tcp"),
RTCIceCandidate(RTCIceCandidateType.Host, "tcp")
)
),
speakerCanBeEnabled = true,
@@ -611,8 +610,8 @@ fun PreviewActiveCallOverlayAudio() {
localMedia = CallMediaType.Audio,
peerMedia = CallMediaType.Audio,
connectionInfo = ConnectionInfo(
RTCIceCandidate(RTCIceCandidateType.Host, "udp", null),
RTCIceCandidate(RTCIceCandidateType.Host, "udp", null)
RTCIceCandidate(RTCIceCandidateType.Host, "udp"),
RTCIceCandidate(RTCIceCandidateType.Host, "udp")
)
),
speakerCanBeEnabled = true,

View File

@@ -222,8 +222,23 @@ object ChatModel {
val chat: Chat
if (i >= 0) {
chat = chats[i]
val newPreviewItem = when (cInfo) {
is ChatInfo.Group -> {
val currentPreviewItem = chat.chatItems.firstOrNull()
if (currentPreviewItem != null) {
if (cItem.meta.itemTs >= currentPreviewItem.meta.itemTs) {
cItem
} else {
currentPreviewItem
}
} else {
cItem
}
}
else -> cItem
}
chats[i] = chat.copy(
chatItems = arrayListOf(cItem),
chatItems = arrayListOf(newPreviewItem),
chatStats =
if (cItem.meta.itemStatus is CIStatus.RcvNew) {
val minUnreadId = if(chat.chatStats.minUnreadItemId == 0L) cItem.id else chat.chatStats.minUnreadItemId
@@ -2945,6 +2960,14 @@ sealed class RemoteCtrlSessionState {
@Serializable @SerialName("connected") data class Connected(val sessionCode: String): RemoteCtrlSessionState()
}
@Serializable
sealed class RemoteCtrlStopReason {
@Serializable @SerialName("discoveryFailed") class DiscoveryFailed(val chatError: ChatError): RemoteCtrlStopReason()
@Serializable @SerialName("connectionFailed") class ConnectionFailed(val chatError: ChatError): RemoteCtrlStopReason()
@Serializable @SerialName("setupFailed") class SetupFailed(val chatError: ChatError): RemoteCtrlStopReason()
@Serializable @SerialName("disconnected") object Disconnected: RemoteCtrlStopReason()
}
sealed class UIRemoteCtrlSessionState {
object Starting: UIRemoteCtrlSessionState()
object Searching: UIRemoteCtrlSessionState()

View File

@@ -3581,6 +3581,13 @@ sealed class RemoteHostSessionState {
@Serializable @SerialName("connected") data class Connected(val sessionCode: String): RemoteHostSessionState()
}
@Serializable
sealed class RemoteHostStopReason {
@Serializable @SerialName("connectionFailed") data class ConnectionFailed(val chatError: ChatError): RemoteHostStopReason()
@Serializable @SerialName("crashed") data class Crashed(val chatError: ChatError): RemoteHostStopReason()
@Serializable @SerialName("disconnected") object Disconnected: RemoteHostStopReason()
}
val json = Json {
prettyPrint = true
ignoreUnknownKeys = true
@@ -3804,7 +3811,7 @@ sealed class CR {
@Serializable @SerialName("remoteHostSessionCode") class RemoteHostSessionCode(val remoteHost_: RemoteHostInfo?, val sessionCode: String): CR()
@Serializable @SerialName("newRemoteHost") class NewRemoteHost(val remoteHost: RemoteHostInfo): CR()
@Serializable @SerialName("remoteHostConnected") class RemoteHostConnected(val remoteHost: RemoteHostInfo): CR()
@Serializable @SerialName("remoteHostStopped") class RemoteHostStopped(val remoteHostId_: Long?): CR()
@Serializable @SerialName("remoteHostStopped") class RemoteHostStopped(val remoteHostId_: Long?, val rhsState: RemoteHostSessionState, val rhStopReason: RemoteHostStopReason): CR()
@Serializable @SerialName("remoteFileStored") class RemoteFileStored(val remoteHostId: Long, val remoteFileSource: CryptoFile): CR()
// remote events (mobile)
@Serializable @SerialName("remoteCtrlList") class RemoteCtrlList(val remoteCtrls: List<RemoteCtrlInfo>): CR()
@@ -3812,7 +3819,7 @@ sealed class CR {
@Serializable @SerialName("remoteCtrlConnecting") class RemoteCtrlConnecting(val remoteCtrl_: RemoteCtrlInfo?, val ctrlAppInfo: CtrlAppInfo, val appVersion: String): CR()
@Serializable @SerialName("remoteCtrlSessionCode") class RemoteCtrlSessionCode(val remoteCtrl_: RemoteCtrlInfo?, val sessionCode: String): CR()
@Serializable @SerialName("remoteCtrlConnected") class RemoteCtrlConnected(val remoteCtrl: RemoteCtrlInfo): CR()
@Serializable @SerialName("remoteCtrlStopped") class RemoteCtrlStopped(): CR()
@Serializable @SerialName("remoteCtrlStopped") class RemoteCtrlStopped(val rcsState: RemoteCtrlSessionState, val rcStopReason: RemoteCtrlStopReason): CR()
@Serializable @SerialName("versionInfo") class VersionInfo(val versionInfo: CoreVersionInfo, val chatMigrations: List<UpMigration>, val agentMigrations: List<UpMigration>): CR()
@Serializable @SerialName("cmdOk") class CmdOk(val user: UserRef?): CR()
@Serializable @SerialName("chatCmdError") class ChatCmdError(val user_: UserRef?, val chatError: ChatError): CR()

View File

@@ -127,18 +127,10 @@ sealed class WCallResponse {
"${local?.value ?: "unknown"} / ${remote?.value ?: "unknown"}"
}
}
val protocolText: String get() {
val local = localCandidate?.protocol?.uppercase(Locale.ROOT) ?: "unknown"
val localRelay = localCandidate?.relayProtocol?.uppercase(Locale.ROOT) ?: "unknown"
val remote = remoteCandidate?.protocol?.uppercase(Locale.ROOT) ?: "unknown"
val localText = if (localRelay == local || localCandidate?.relayProtocol == null) local else "$local ($localRelay)"
return if (local == remote) localText else "$localText / $remote"
}
}
// https://developer.mozilla.org/en-US/docs/Web/API/RTCIceCandidate
@Serializable data class RTCIceCandidate(val candidateType: RTCIceCandidateType?, val protocol: String?, val relayProtocol: String?)
@Serializable data class RTCIceCandidate(val candidateType: RTCIceCandidateType?, val protocol: String?)
// https://developer.mozilla.org/en-US/docs/Web/API/RTCIceServer
@Serializable data class RTCIceServer(val urls: List<String>, val username: String? = null, val credential: String? = null)

View File

@@ -1005,6 +1005,14 @@ fun BoxWithConstraintsScope.ChatItemsList(
}
}
}
if (appPlatform.isDesktop) {
VerticalScrollbar(
modifier = Modifier.align(Alignment.CenterEnd)
.fillMaxHeight(),
adapter = rememberScrollbarAdapter(listState),
reverseLayout = true
)
}
FloatingButtons(chatItems, unreadCount, chat.chatStats.minUnreadItemId, searchValue, markRead, setFloatingButton, listState)
}

View File

@@ -124,7 +124,7 @@ fun showApp() = application {
var hiddenUntilRestart by remember { mutableStateOf(false) }
if (!hiddenUntilRestart) {
val cWindowState = rememberWindowState(placement = WindowPlacement.Floating, width = DEFAULT_START_MODAL_WIDTH, height = 768.dp)
Window(state = cWindowState, onCloseRequest = ::exitApplication, title = stringResource(MR.strings.chat_console)) {
Window(state = cWindowState, onCloseRequest = { hiddenUntilRestart = true }, title = stringResource(MR.strings.chat_console)) {
SimpleXTheme {
TerminalView(ChatModel) { hiddenUntilRestart = true }
}

View File

@@ -136,7 +136,6 @@ private fun SendStateUpdates() {
.collect { call ->
val state = call.callState.text
val connInfo = call.connectionInfo
// val connInfoText = if (connInfo == null) "" else " (${connInfo.text}, ${connInfo.protocolText})"
val connInfoText = if (connInfo == null) "" else " (${connInfo.text})"
val description = call.encryptionStatus + connInfoText
chatModel.callCommand.add(WCallCommand.Description(state, description))

View File

@@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package
type: git
location: https://github.com/simplex-chat/simplexmq.git
tag: 757b7eec81341d8560a326deab303bb6fb6a26a3
tag: febf9019e25e3de35f1b005da59e8434e12ae54b
source-repository-package
type: git

30
fourmolu.yaml Normal file
View File

@@ -0,0 +1,30 @@
indentation: 2
column-limit: none
function-arrows: trailing
comma-style: trailing
import-export-style: trailing
indent-wheres: true
record-brace-space: true
newlines-between-decls: 1
haddock-style: single-line
haddock-style-module: null
let-style: inline
in-style: right-align
single-constraint-parens: never
unicode: never
respectful: true
fixities:
- infixr 9 .
- infixr 8 .:, .:., .=
- infixr 6 <>
- infixr 5 ++
- infixl 4 <$>, <$, $>, <$$>, <$?>
- infixl 4 <*>, <*, *>, <**>
- infix 4 ==, /=
- infixr 3 &&
- infixl 3 <|>
- infixr 2 ||
- infixl 1 >>, >>=
- infixr 1 =<<, >=>, <=<
- infixr 0 $, $!
reexports: []

View File

@@ -1,5 +1,5 @@
{
"https://github.com/simplex-chat/simplexmq.git"."757b7eec81341d8560a326deab303bb6fb6a26a3" = "0kqnxpyz8v43802fncqxdg6i2ni70yv7jg7a1nbkny1w937fwf40";
"https://github.com/simplex-chat/simplexmq.git"."febf9019e25e3de35f1b005da59e8434e12ae54b" = "0rd6cf600978l7xp1sajn9lswml72ms0f55h5q7rxbwpbgx9c3if";
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/kazu-yamamoto/http2.git"."f5525b755ff2418e6e6ecc69e877363b0d0bcaeb" = "0fyx0047gvhm99ilp212mmz37j84cwrfnpmssib5dw363fyb88b6";
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";

View File

@@ -124,6 +124,7 @@ library
Simplex.Chat.Migrations.M20231107_indexes
Simplex.Chat.Migrations.M20231113_group_forward
Simplex.Chat.Migrations.M20231114_remote_control
Simplex.Chat.Migrations.M20231126_remote_ctrl_address
Simplex.Chat.Mobile
Simplex.Chat.Mobile.File
Simplex.Chat.Mobile.Shared

File diff suppressed because one or more lines are too long

View File

@@ -22,7 +22,7 @@ import qualified Data.Text as T
import qualified Database.SQLite3 as SQL
import Simplex.Chat.Controller
import Simplex.Messaging.Agent.Client (agentClientStore)
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), sqlString, closeSQLiteStore)
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), closeSQLiteStore, sqlString)
import Simplex.Messaging.Util
import System.FilePath
import UnliftIO.Directory

View File

@@ -6,8 +6,8 @@ module Simplex.Chat.Bot.KnownContacts where
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Int (Int64)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Options.Applicative
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util (safeDecodeUtf8)

View File

@@ -225,4 +225,3 @@ instance FromField CallState where
fromField = fromTextField_ decodeJSON
$(J.deriveJSON defaultJSON ''RcvCallInvitation)

View File

@@ -1,5 +1,5 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
@@ -41,6 +41,7 @@ import Data.String
import Data.Text (Text)
import Data.Time (NominalDiffTime, UTCTime)
import Data.Version (showVersion)
import Data.Word (Word16)
import Language.Haskell.TH (Exp, Q, runIO)
import Numeric.Natural
import qualified Paths_simplex_chat as SC
@@ -426,19 +427,19 @@ data ChatCommand
| SetGroupTimedMessages GroupName (Maybe Int)
| SetLocalDeviceName Text
| ListRemoteHosts
| StartRemoteHost (Maybe (RemoteHostId, Bool)) -- ^ Start new or known remote host with optional multicast for known host
| SwitchRemoteHost (Maybe RemoteHostId) -- ^ Switch current remote host
| StopRemoteHost RHKey -- ^ Shut down a running session
| DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data
| StartRemoteHost (Maybe (RemoteHostId, Bool)) (Maybe RCCtrlAddress) (Maybe Word16) -- Start new or known remote host with optional multicast for known host
| SwitchRemoteHost (Maybe RemoteHostId) -- Switch current remote host
| StopRemoteHost RHKey -- Shut down a running session
| DeleteRemoteHost RemoteHostId -- Unregister remote host and remove its data
| StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
| GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile}
| ConnectRemoteCtrl RCSignedInvitation -- ^ Connect new or existing controller via OOB data
| FindKnownRemoteCtrl -- ^ Start listening for announcements from all existing controllers
| ConfirmRemoteCtrl RemoteCtrlId -- ^ Confirm the connection with found controller
| VerifyRemoteCtrlSession Text -- ^ Verify remote controller session
| ConnectRemoteCtrl RCSignedInvitation -- Connect new or existing controller via OOB data
| FindKnownRemoteCtrl -- Start listening for announcements from all existing controllers
| ConfirmRemoteCtrl RemoteCtrlId -- Confirm the connection with found controller
| VerifyRemoteCtrlSession Text -- Verify remote controller session
| ListRemoteCtrls
| StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session
| DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a remote controller session
| StopRemoteCtrl -- Stop listening for announcements or terminate an active session
| DeleteRemoteCtrl RemoteCtrlId -- Remove all local data associated with a remote controller session
| QuitChat
| ShowVersion
| DebugLocks
@@ -469,7 +470,7 @@ allowRemoteCommand = \case
APIGetNetworkConfig -> False
SetLocalDeviceName _ -> False
ListRemoteHosts -> False
StartRemoteHost _ -> False
StartRemoteHost {} -> False
SwitchRemoteHost {} -> False
StoreRemoteFile {} -> False
GetRemoteFile {} -> False
@@ -658,7 +659,7 @@ data ChatResponse
| CRContactConnectionDeleted {user :: User, connection :: PendingContactConnection}
| CRRemoteHostList {remoteHosts :: [RemoteHostInfo]}
| CRCurrentRemoteHost {remoteHost_ :: Maybe RemoteHostInfo}
| CRRemoteHostStarted {remoteHost_ :: Maybe RemoteHostInfo, invitation :: Text, ctrlPort :: String}
| CRRemoteHostStarted {remoteHost_ :: Maybe RemoteHostInfo, invitation :: Text, ctrlPort :: String, localAddrs :: NonEmpty RCCtrlAddress}
| CRRemoteHostSessionCode {remoteHost_ :: Maybe RemoteHostInfo, sessionCode :: Text}
| CRNewRemoteHost {remoteHost :: RemoteHostInfo}
| CRRemoteHostConnected {remoteHost :: RemoteHostInfo}
@@ -1072,32 +1073,33 @@ throwDBError = throwError . ChatErrorDatabase
-- TODO review errors, some of it can be covered by HTTP2 errors
data RemoteHostError
= RHEMissing -- ^ No remote session matches this identifier
| RHEInactive -- ^ A session exists, but not active
| RHEBusy -- ^ A session is already running
= RHEMissing -- No remote session matches this identifier
| RHEInactive -- A session exists, but not active
| RHEBusy -- A session is already running
| RHETimeout
| RHEBadState -- ^ Illegal state transition
| RHEBadState -- Illegal state transition
| RHEBadVersion {appVersion :: AppVersion}
| RHELocalCommand -- ^ Command not allowed for remote execution
| RHELocalCommand -- Command not allowed for remote execution
| RHEDisconnected {reason :: Text} -- TODO should be sent when disconnected?
| RHEProtocolError RemoteProtocolError
deriving (Show, Exception)
data RemoteHostStopReason
= RHSRConnectionFailed ChatError
| RHSRCrashed ChatError
= RHSRConnectionFailed {chatError :: ChatError}
| RHSRCrashed {chatError :: ChatError}
| RHSRDisconnected
deriving (Show, Exception)
-- TODO review errors, some of it can be covered by HTTP2 errors
data RemoteCtrlError
= RCEInactive -- ^ No session is running
| RCEBadState -- ^ A session is in a wrong state for the current operation
| RCEBusy -- ^ A session is already running
= RCEInactive -- No session is running
| RCEBadState -- A session is in a wrong state for the current operation
| RCEBusy -- A session is already running
| RCETimeout
| RCENoKnownControllers -- ^ No previously-contacted controllers to discover
| RCEBadController -- ^ Attempting to confirm a found controller with another ID
| RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller
| RCENoKnownControllers -- No previously-contacted controllers to discover
| RCEBadController -- Attempting to confirm a found controller with another ID
| -- | A session disconnected by a controller
RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text}
| RCEBadInvitation
| RCEBadVersion {appVersion :: AppVersion}
| RCEHTTP2Error {http2Error :: Text} -- TODO currently not used
@@ -1105,9 +1107,9 @@ data RemoteCtrlError
deriving (Show, Exception)
data RemoteCtrlStopReason
= RCSRDiscoveryFailed ChatError
| RCSRConnectionFailed ChatError
| RCSRSetupFailed ChatError
= RCSRDiscoveryFailed {chatError :: ChatError}
| RCSRConnectionFailed {chatError :: ChatError}
| RCSRSetupFailed {chatError :: ChatError}
| RCSRDisconnected
deriving (Show, Exception)
@@ -1223,8 +1225,8 @@ toView event = do
session <- asks remoteCtrlSession
atomically $
readTVar session >>= \case
Just (_, RCSessionConnected {remoteOutputQ}) | allowRemoteEvent event ->
writeTBQueue remoteOutputQ event
Just (_, RCSessionConnected {remoteOutputQ})
| allowRemoteEvent event -> writeTBQueue remoteOutputQ event
-- TODO potentially, it should hold some events while connecting
_ -> writeTBQueue localQ (Nothing, Nothing, event)

View File

@@ -35,9 +35,9 @@ runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController
runSimplexChat ChatOpts {maintenance} u cc chat
| maintenance = wait =<< async (chat u cc)
| otherwise = do
a1 <- runReaderT (startChatController True True True) cc
a2 <- async $ chat u cc
waitEither_ a1 a2
a1 <- runReaderT (startChatController True True True) cc
a2 <- async $ chat u cc
waitEither_ a1 a2
sendChatCmdStr :: ChatController -> String -> IO ChatResponse
sendChatCmdStr cc s = runReaderT (execChatCommand Nothing . encodeUtf8 $ T.pack s) cc

View File

@@ -6,8 +6,8 @@ module Simplex.Chat.Files where
import Control.Monad.IO.Class
import Simplex.Chat.Controller
import Simplex.Messaging.Util (ifM)
import System.FilePath (splitExtensions, combine)
import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, getHomeDirectory, doesDirectoryExist)
import System.FilePath (combine, splitExtensions)
import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getHomeDirectory, getTemporaryDirectory)
uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
uniqueCombine fPath fName = tryCombine (0 :: Int)

View File

@@ -19,7 +19,7 @@ import qualified Data.Attoparsec.Text as A
import Data.Char (isDigit, isPunctuation)
import Data.Either (fromRight)
import Data.Functor (($>))
import Data.List (intercalate, foldl')
import Data.List (foldl', intercalate)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe, isNothing)
@@ -85,16 +85,18 @@ newtype FormatColor = FormatColor Color
deriving (Eq, Show)
instance FromJSON FormatColor where
parseJSON = J.withText "FormatColor" $ fmap FormatColor . \case
"red" -> pure Red
"green" -> pure Green
"blue" -> pure Blue
"yellow" -> pure Yellow
"cyan" -> pure Cyan
"magenta" -> pure Magenta
"black" -> pure Black
"white" -> pure White
unexpected -> fail $ "unexpected FormatColor: " <> show unexpected
parseJSON =
J.withText "FormatColor" $
fmap FormatColor . \case
"red" -> pure Red
"green" -> pure Green
"blue" -> pure Blue
"yellow" -> pure Yellow
"cyan" -> pure Cyan
"magenta" -> pure Magenta
"black" -> pure Black
"white" -> pure White
unexpected -> fail $ "unexpected FormatColor: " <> show unexpected
instance ToJSON FormatColor where
toJSON (FormatColor c) = case c of
@@ -167,14 +169,14 @@ markdownP = mconcat <$> A.many' fragmentP
md :: Char -> Format -> Text -> Markdown
md c f s
| T.null s || T.head s == ' ' || T.last s == ' ' =
unmarked $ c `T.cons` s `T.snoc` c
unmarked $ c `T.cons` s `T.snoc` c
| otherwise = markdown f s
secretP :: Parser Markdown
secretP = secret <$> A.takeWhile (== '#') <*> A.takeTill (== '#') <*> A.takeWhile (== '#')
secret :: Text -> Text -> Text -> Markdown
secret b s a
| T.null a || T.null s || T.head s == ' ' || T.last s == ' ' =
unmarked $ '#' `T.cons` ss
unmarked $ '#' `T.cons` ss
| otherwise = markdown Secret $ T.init ss
where
ss = b <> s <> a
@@ -215,9 +217,9 @@ markdownP = mconcat <$> A.many' fragmentP
wordMD s
| T.null s = unmarked s
| isUri s =
let t = T.takeWhileEnd isPunctuation s
uri = uriMarkdown $ T.dropWhileEnd isPunctuation s
in if T.null t then uri else uri :|: unmarked t
let t = T.takeWhileEnd isPunctuation s
uri = uriMarkdown $ T.dropWhileEnd isPunctuation s
in if T.null t then uri else uri :|: unmarked t
| isEmail s = markdown Email s
| otherwise = unmarked s
uriMarkdown s = case strDecode $ encodeUtf8 s of

View File

@@ -11,7 +11,6 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Messages where
@@ -44,7 +43,7 @@ import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptSta
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, parseAll, enumJSON, sumTypeJSON)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON)
import Simplex.Messaging.Protocol (MsgBody)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
@@ -345,7 +344,7 @@ contactTimedTTL Contact {mergedPreferences = ContactUserPreferences {timedMessag
| forUser enabled && forContact enabled = Just ttl
| otherwise = Nothing
where
TimedMessagesPreference {ttl} = userPreference.preference
TimedMessagesPreference {ttl} = userPreference.preference
groupTimedTTL :: GroupInfo -> Maybe (Maybe Int)
groupTimedTTL GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}}

View File

@@ -311,7 +311,7 @@ profileToText Profile {displayName, fullName} = displayName <> optionalFullName
msgIntegrityError :: MsgErrorType -> Text
msgIntegrityError = \case
MsgSkipped fromId toId ->
"skipped message ID " <> tshow fromId
("skipped message ID " <> tshow fromId)
<> if fromId == toId then "" else ".." <> tshow toId
MsgBadId msgId -> "unexpected message ID " <> tshow msgId
MsgBadHash -> "incorrect message hash"

View File

@@ -46,9 +46,9 @@ data SndConnEvent
| SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef}
deriving (Show)
data RcvDirectEvent =
-- RDEProfileChanged {...}
RDEContactDeleted
data RcvDirectEvent
= -- RDEProfileChanged {...}
RDEContactDeleted
deriving (Show)
-- platform-specific JSON encoding (used in API)

View File

@@ -0,0 +1,22 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20231126_remote_ctrl_address where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20231126_remote_ctrl_address :: Query
m20231126_remote_ctrl_address =
[sql|
ALTER TABLE remote_hosts ADD COLUMN bind_addr TEXT;
ALTER TABLE remote_hosts ADD COLUMN bind_iface TEXT;
ALTER TABLE remote_hosts ADD COLUMN bind_port INTEGER;
|]
down_m20231126_remote_ctrl_address :: Query
down_m20231126_remote_ctrl_address =
[sql|
ALTER TABLE remote_hosts DROP COLUMN bind_addr;
ALTER TABLE remote_hosts DROP COLUMN bind_iface;
ALTER TABLE remote_hosts DROP COLUMN bind_port;
|]

View File

@@ -537,6 +537,10 @@ CREATE TABLE remote_hosts(
id_key BLOB NOT NULL, -- long-term/identity signing key
host_fingerprint BLOB NOT NULL, -- remote host CA cert fingerprint, set when connected
host_dh_pub BLOB NOT NULL -- last session DH key
,
bind_addr TEXT,
bind_iface TEXT,
bind_port INTEGER
);
CREATE TABLE remote_controllers(
-- e.g., desktops known to a mobile app

View File

@@ -4,13 +4,12 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fobject-code #-}
module Simplex.Chat.Mobile where
import Control.Concurrent.STM
import Control.Exception (catch, SomeException)
import Control.Exception (SomeException, catch)
import Control.Monad.Except
import Control.Monad.Reader
import qualified Data.Aeson as J
@@ -31,7 +30,7 @@ import Foreign.C.Types (CInt (..))
import Foreign.Ptr
import Foreign.StablePtr
import Foreign.Storable (poke)
import GHC.IO.Encoding (setLocaleEncoding, setFileSystemEncoding, setForeignEncoding)
import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding)
import Simplex.Chat
import Simplex.Chat.Controller
import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
@@ -219,7 +218,7 @@ chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do
ExceptT $
(first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey confirmMigrations)
`catch` (pure . checkDBError)
`catchAll` (pure . dbError)
`catchAll` (pure . dbError)
where
checkDBError e = case sqlError e of
DB.ErrorNotADatabase -> Left $ DBMErrorNotADatabase dbFile
@@ -233,7 +232,7 @@ chatCloseStore ChatController {chatStore, smpAgent} = handleErr $ do
handleErr :: IO () -> IO String
handleErr a = (a $> "") `catch` (pure . show @SomeException)
chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString
chatSendCmd cc = chatSendRemoteCmd cc Nothing

View File

@@ -6,8 +6,8 @@ import qualified Data.ByteString as B
import Data.ByteString.Internal (ByteString (..), memcpy)
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Internal as LB
import Foreign.C (CInt, CString)
import Foreign
import Foreign.C (CInt, CString)
type CJSONString = CString

View File

@@ -1,12 +1,12 @@
{-# LANGUAGE FlexibleContexts #-}
module Simplex.Chat.Mobile.WebRTC (
cChatEncryptMedia,
cChatDecryptMedia,
chatEncryptMedia,
chatDecryptMedia,
reservedSize,
) where
module Simplex.Chat.Mobile.WebRTC
( cChatEncryptMedia,
cChatDecryptMedia,
chatEncryptMedia,
chatDecryptMedia,
reservedSize,
) where
import Control.Monad
import Control.Monad.Except
@@ -21,8 +21,8 @@ import Data.Either (fromLeft)
import Data.Word (Word8)
import Foreign.C (CInt, CString, newCAString)
import Foreign.Ptr (Ptr)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Chat.Mobile.Shared
import qualified Simplex.Messaging.Crypto as C
cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
cChatEncryptMedia = cTransformMedia chatEncryptMedia

View File

@@ -206,7 +206,6 @@ chatOptsP appDir defaultDbFileName = do
optional $
strOption
( long "device-name"
<> short 'e'
<> metavar "DEVICE"
<> help "Device name to use in connections with remote hosts and controller"
)

View File

@@ -18,10 +18,10 @@ generateRandomProfile = do
pickNoun adjective n
| n == 0 = pick nouns
| otherwise = do
noun <- pick nouns
if noun == adjective
then pickNoun adjective (n - 1)
else pure noun
noun <- pick nouns
if noun == adjective
then pickNoun adjective (n - 1)
else pure noun
adjectives :: [Text]
adjectives =

View File

@@ -13,7 +13,6 @@
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Protocol where

View File

@@ -26,13 +26,14 @@ import qualified Data.ByteString.Base64.URL as B64U
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.List.NonEmpty (nonEmpty)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Word (Word32)
import Data.Word (Word16, Word32)
import qualified Network.HTTP.Types as N
import Network.HTTP2.Server (responseStreaming)
import qualified Paths_simplex_chat as SC
@@ -97,24 +98,26 @@ discoveryTimeout = 60000000
getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient
getRemoteHostClient rhId = do
sessions <- asks remoteHostSessions
liftIOEither . atomically $ TM.lookup rhKey sessions >>= \case
Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient
Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
liftIOEither . atomically $
TM.lookup rhKey sessions >>= \case
Just (_, RHSessionConnected {rhClient}) -> pure $ Right rhClient
Just _ -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
where
rhKey = RHId rhId
withRemoteHostSession :: ChatMonad m => RHKey -> SessionSeq -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a
withRemoteHostSession rhKey sseq f = do
sessions <- asks remoteHostSessions
r <- atomically $
TM.lookup rhKey sessions >>= \case
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
Just (stateSeq, state)
| stateSeq /= sseq -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
| otherwise -> case f state of
Right (r, newState) -> Right r <$ TM.insert rhKey (sseq, newState) sessions
Left ce -> pure $ Left ce
r <-
atomically $
TM.lookup rhKey sessions >>= \case
Nothing -> pure . Left $ ChatErrorRemoteHost rhKey RHEMissing
Just (stateSeq, state)
| stateSeq /= sseq -> pure . Left $ ChatErrorRemoteHost rhKey RHEBadState
| otherwise -> case f state of
Right (r, newState) -> Right r <$ TM.insert rhKey (sseq, newState) sessions
Left ce -> pure $ Left ce
liftEither r
-- | Transition session state with a 'RHNew' ID to an assigned 'RemoteHostId'
@@ -133,8 +136,8 @@ setNewRemoteHostId sseq rhId = do
where
err = pure . Left . ChatErrorRemoteHost RHNew
startRemoteHost :: ChatMonad m => Maybe (RemoteHostId, Bool) -> m (Maybe RemoteHostInfo, RCSignedInvitation)
startRemoteHost rh_ = do
startRemoteHost :: ChatMonad m => Maybe (RemoteHostId, Bool) -> Maybe RCCtrlAddress -> Maybe Word16 -> m (NonEmpty RCCtrlAddress, Maybe RemoteHostInfo, RCSignedInvitation)
startRemoteHost rh_ rcAddrPrefs_ port_ = do
(rhKey, multicast, remoteHost_, pairing) <- case rh_ of
Just (rhId, multicast) -> do
rh@RemoteHost {hostPairing} <- withStore $ \db -> getRemoteHost db rhId
@@ -142,19 +145,20 @@ startRemoteHost rh_ = do
Nothing -> (RHNew,False,Nothing,) <$> rcNewHostPairing
sseq <- startRemoteHostSession rhKey
ctrlAppInfo <- mkCtrlAppInfo
(invitation, rchClient, vars) <- handleConnectError rhKey sseq . withAgent $ \a -> rcConnectHost a pairing (J.toJSON ctrlAppInfo) multicast
(localAddrs, invitation, rchClient, vars) <- handleConnectError rhKey sseq . withAgent $ \a -> rcConnectHost a pairing (J.toJSON ctrlAppInfo) multicast rcAddrPrefs_ port_
let rcAddr_ = L.head localAddrs <$ rcAddrPrefs_
cmdOk <- newEmptyTMVarIO
rhsWaitSession <- async $ do
rhKeyVar <- newTVarIO rhKey
atomically $ takeTMVar cmdOk
handleHostError sseq rhKeyVar $ waitForHostSession remoteHost_ rhKey sseq rhKeyVar vars
handleHostError sseq rhKeyVar $ waitForHostSession remoteHost_ rhKey sseq rcAddr_ rhKeyVar vars
let rhs = RHPendingSession {rhKey, rchClient, rhsWaitSession, remoteHost_}
withRemoteHostSession rhKey sseq $ \case
RHSessionStarting ->
let inv = decodeLatin1 $ strEncode invitation
in Right ((), RHSessionConnecting inv rhs)
_ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
(remoteHost_, invitation) <$ atomically (putTMVar cmdOk ())
(localAddrs, remoteHost_, invitation) <$ atomically (putTMVar cmdOk ())
where
mkCtrlAppInfo = do
deviceName <- chatReadVar localDeviceName
@@ -167,16 +171,18 @@ startRemoteHost rh_ = do
when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding
pure hostInfo
handleConnectError :: ChatMonad m => RHKey -> SessionSeq -> m a -> m a
handleConnectError rhKey sessSeq action = action `catchChatError` \err -> do
logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err
cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey
throwError err
handleConnectError rhKey sessSeq action =
action `catchChatError` \err -> do
logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err
cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey
throwError err
handleHostError :: ChatMonad m => SessionSeq -> TVar RHKey -> m () -> m ()
handleHostError sessSeq rhKeyVar action = action `catchChatError` \err -> do
logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err
readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err))
waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
waitForHostSession remoteHost_ rhKey sseq rhKeyVar vars = do
handleHostError sessSeq rhKeyVar action =
action `catchChatError` \err -> do
logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err
readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err))
waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> Maybe RCCtrlAddress -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
waitForHostSession remoteHost_ rhKey sseq rcAddr_ rhKeyVar vars = do
(sessId, tls, vars') <- timeoutThrow (ChatErrorRemoteHost rhKey RHETimeout) 60000000 $ takeRCStep vars
let sessionCode = verificationCode sessId
withRemoteHostSession rhKey sseq $ \case
@@ -190,7 +196,7 @@ startRemoteHost rh_ = do
withRemoteHostSession rhKey sseq $ \case
RHSessionPendingConfirmation _ tls' rhs' -> Right ((), RHSessionConfirmed tls' rhs')
_ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
rhi@RemoteHostInfo {remoteHostId, storePath} <- upsertRemoteHost pairing' rh_' hostDeviceName sseq RHSConfirmed {sessionCode}
rhi@RemoteHostInfo {remoteHostId, storePath} <- upsertRemoteHost pairing' rh_' rcAddr_ hostDeviceName sseq RHSConfirmed {sessionCode}
let rhKey' = RHId remoteHostId -- rhKey may be invalid after upserting on RHNew
when (rhKey' /= rhKey) $ do
atomically $ writeTVar rhKeyVar rhKey'
@@ -205,17 +211,17 @@ startRemoteHost rh_ = do
_ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
chatWriteVar currentRemoteHost $ Just remoteHostId -- this is required for commands to be passed to remote host
toView $ CRRemoteHostConnected rhi {sessionState = Just RHSConnected {sessionCode}}
upsertRemoteHost :: ChatMonad m => RCHostPairing -> Maybe RemoteHostInfo -> Text -> SessionSeq -> RemoteHostSessionState -> m RemoteHostInfo
upsertRemoteHost pairing'@RCHostPairing {knownHost = kh_} rhi_ hostDeviceName sseq state = do
upsertRemoteHost :: ChatMonad m => RCHostPairing -> Maybe RemoteHostInfo -> Maybe RCCtrlAddress -> Text -> SessionSeq -> RemoteHostSessionState -> m RemoteHostInfo
upsertRemoteHost pairing'@RCHostPairing {knownHost = kh_} rhi_ rcAddr_ hostDeviceName sseq state = do
KnownHostPairing {hostDhPubKey = hostDhPubKey'} <- maybe (throwError . ChatError $ CEInternalError "KnownHost is known after verification") pure kh_
case rhi_ of
Nothing -> do
storePath <- liftIO randomStorePath
rh@RemoteHost {remoteHostId} <- withStore $ \db -> insertRemoteHost db hostDeviceName storePath pairing' >>= getRemoteHost db
rh@RemoteHost {remoteHostId} <- withStore $ \db -> insertRemoteHost db hostDeviceName storePath rcAddr_ port_ pairing' >>= getRemoteHost db
setNewRemoteHostId sseq remoteHostId
pure $ remoteHostInfo rh $ Just state
Just rhi@RemoteHostInfo {remoteHostId} -> do
withStore' $ \db -> updateHostPairing db remoteHostId hostDeviceName hostDhPubKey'
withStore' $ \db -> updateHostPairing db remoteHostId hostDeviceName hostDhPubKey' rcAddr_ port_
pure (rhi :: RemoteHostInfo) {sessionState = Just state}
onDisconnected :: ChatMonad m => RHKey -> SessionSeq -> m ()
onDisconnected rhKey sseq = do
@@ -250,14 +256,15 @@ cancelRemoteHostSession :: ChatMonad m => Maybe (SessionSeq, RemoteHostStopReaso
cancelRemoteHostSession handlerInfo_ rhKey = do
sessions <- asks remoteHostSessions
crh <- asks currentRemoteHost
deregistered <- atomically $
TM.lookup rhKey sessions >>= \case
Nothing -> pure Nothing
Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler
Just (_, rhs) -> do
TM.delete rhKey sessions
modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH
pure $ Just rhs
deregistered <-
atomically $
TM.lookup rhKey sessions >>= \case
Nothing -> pure Nothing
Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler
Just (_, rhs) -> do
TM.delete rhKey sessions
modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH
pure $ Just rhs
forM_ deregistered $ \session -> do
liftIO $ cancelRemoteHost handlingError session `catchAny` (logError . tshow)
forM_ (snd <$> handlerInfo_) $ \rhStopReason ->
@@ -312,8 +319,8 @@ switchRemoteHost rhId_ = do
rhi_ <$ chatWriteVar currentRemoteHost rhId_
remoteHostInfo :: RemoteHost -> Maybe RemoteHostSessionState -> RemoteHostInfo
remoteHostInfo RemoteHost {remoteHostId, storePath, hostDeviceName} sessionState =
RemoteHostInfo {remoteHostId, storePath, hostDeviceName, sessionState}
remoteHostInfo RemoteHost {remoteHostId, storePath, hostDeviceName, bindAddress_, bindPort_} sessionState =
RemoteHostInfo {remoteHostId, storePath, hostDeviceName, bindAddress_, bindPort_, sessionState}
deleteRemoteHost :: ChatMonad m => RemoteHostId -> m ()
deleteRemoteHost rhId = do
@@ -401,9 +408,10 @@ findKnownRemoteCtrl = do
(RCCtrlPairing {ctrlFingerprint}, inv@(RCVerifiedInvitation RCInvitation {app})) <-
timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings
ctrlAppInfo_ <- (Just <$> parseCtrlAppInfo app) `catchChatError` const (pure Nothing)
rc <- withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case
Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl"
Just rc -> pure rc
rc <-
withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case
Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl"
Just rc -> pure rc
atomically $ putTMVar foundCtrl (rc, inv)
let compatible = isJust $ compatibleAppVersion hostAppVersionRange . appVersionRange =<< ctrlAppInfo_
toView CRRemoteCtrlFound {remoteCtrl = remoteCtrlInfo rc (Just RCSSearching), ctrlAppInfo_, appVersion = currentAppVersion, compatible}
@@ -422,7 +430,7 @@ confirmRemoteCtrl rcId = do
pure $ Right (sseq, action, foundCtrl)
_ -> pure . Left $ ChatErrorRemoteCtrl RCEBadState
uninterruptibleCancel listener
(RemoteCtrl{remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found
(RemoteCtrl {remoteCtrlId = foundRcId}, verifiedInv) <- atomically $ takeTMVar found
unless (rcId == foundRcId) $ throwError $ ChatErrorRemoteCtrl RCEBadController
connectRemoteCtrl verifiedInv sseq >>= \case
(Nothing, _) -> throwChatError $ CEInternalError "connecting with a stored ctrl"
@@ -647,10 +655,12 @@ handleCtrlError sseq mkReason name action =
cancelActiveRemoteCtrl :: ChatMonad m => Maybe (SessionSeq, RemoteCtrlStopReason) -> m ()
cancelActiveRemoteCtrl handlerInfo_ = handleAny (logError . tshow) $ do
var <- asks remoteCtrlSession
session_ <- atomically $ readTVar var >>= \case
Nothing -> pure Nothing
Just (oldSeq, _) | maybe False (/= oldSeq) (fst <$> handlerInfo_) -> pure Nothing
Just (_, s) -> Just s <$ writeTVar var Nothing
session_ <-
atomically $
readTVar var >>= \case
Nothing -> pure Nothing
Just (oldSeq, _) | (maybe False ((oldSeq /=) . fst) handlerInfo_) -> pure Nothing
Just (_, s) -> Just s <$ writeTVar var Nothing
forM_ session_ $ \session -> do
liftIO $ cancelRemoteCtrl handlingError session
forM_ (snd <$> handlerInfo_) $ \rcStopReason ->

View File

@@ -11,7 +11,7 @@ module Simplex.Chat.Remote.AppVersion
compatibleAppVersion,
isAppCompatible,
)
where
where
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J

View File

@@ -6,10 +6,8 @@ import Network.Socket
#include <HsNet.h>
{- | Toggle multicast group membership.
NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
-}
-- | Toggle multicast group membership.
-- NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups.
setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ())
setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do
#{poke struct ip_mreq, imr_multiaddr} mReqPtr group

View File

@@ -6,8 +6,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Chat.Remote.Protocol where
@@ -41,16 +41,16 @@ import Simplex.FileTransfer.Description (FileDigest (..))
import Simplex.Messaging.Agent.Client (agentDRG)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Crypto.Lazy (LazyByteString)
import Simplex.Messaging.Crypto.Lazy (LazyByteString)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON, pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag)
import Simplex.Messaging.Transport.Buffer (getBuffered)
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect)
import Simplex.Messaging.Util (liftEitherError, liftEitherWith, liftError, tshow)
import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode)
import Simplex.RemoteControl.Client (xrcpBlockSize)
import qualified Simplex.RemoteControl.Client as RC
import Simplex.RemoteControl.Types (CtrlSessKeys (..), HostSessKeys (..), RCErrorType (..), SessionCode)
import System.FilePath (takeFileName, (</>))
import UnliftIO
@@ -64,10 +64,10 @@ data RemoteCommand
data RemoteResponse
= RRChatResponse {chatResponse :: ChatResponse}
| RRChatEvent {chatEvent :: Maybe ChatResponse} -- ^ 'Nothing' on poll timeout
| RRChatEvent {chatEvent :: Maybe ChatResponse} -- 'Nothing' on poll timeout
| RRFileStored {filePath :: String}
| RRFile {fileSize :: Word32, fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest
| RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- ^ The protocol error happened on the server side
| RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- The protocol error happened on the server side
deriving (Show)
-- Force platform-independent encoding as the types aren't UI-visible
@@ -126,7 +126,7 @@ remoteStoreFile c localPath fileName = do
r -> badResponse r
remoteGetFile :: RemoteHostClient -> FilePath -> RemoteFile -> ExceptT RemoteProtocolError IO ()
remoteGetFile c@RemoteHostClient{encryption} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} =
remoteGetFile c@RemoteHostClient {encryption} destDir rf@RemoteFile {fileSource = CryptoFile {filePath}} =
sendRemoteCommand c Nothing RCGetFile {file = rf} >>= \case
(getChunk, RRFile {fileSize, fileDigest}) -> do
-- TODO we could optimize by checking size and hash before receiving the file
@@ -140,7 +140,7 @@ sendRemoteCommand' c attachment_ rc = snd <$> sendRemoteCommand c attachment_ rc
sendRemoteCommand :: RemoteHostClient -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO (Int -> IO ByteString, RemoteResponse)
sendRemoteCommand RemoteHostClient {httpClient, hostEncoding, encryption} file_ cmd = do
encFile_ <- mapM (prepareEncryptedFile encryption) file_
encFile_ <- mapM (prepareEncryptedFile encryption) file_
req <- httpRequest encFile_ <$> encryptEncodeHTTP2Body encryption (J.encode cmd)
HTTP2Response {response, respBody} <- liftEitherError (RPEHTTP2 . tshow) $ sendRequestDirect httpClient req Nothing
(header, getNext) <- parseDecryptHTTP2Body encryption response respBody

View File

@@ -5,15 +5,15 @@ module Simplex.Chat.Remote.Transport where
import Control.Monad
import Control.Monad.Except
import Data.ByteString.Builder (Builder, byteString)
import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder, byteString)
import qualified Data.ByteString.Lazy as LB
import Data.Word (Word32)
import Simplex.FileTransfer.Description (FileDigest (..))
import Simplex.Chat.Remote.Types
import Simplex.FileTransfer.Description (FileDigest (..))
import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile)
import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.FileTransfer.Transport (ReceiveFileError (..), receiveSbFile, sendEncFile)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Util (liftEitherError, liftEitherWith)
import Simplex.RemoteControl.Types (RCErrorType (..))

View File

@@ -18,16 +18,17 @@ import qualified Data.Aeson.TH as J
import Data.ByteString (ByteString)
import Data.Int (Int64)
import Data.Text (Text)
import Data.Word (Word16)
import Simplex.Chat.Remote.AppVersion
import Simplex.Chat.Types (verificationCode)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile)
import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
import Simplex.Messaging.Transport (TLS (..))
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
import Simplex.RemoteControl.Client
import Simplex.RemoteControl.Types
import Simplex.Messaging.Crypto.File (CryptoFile)
import Simplex.Messaging.Transport (TLS (..))
data RemoteHostClient = RemoteHostClient
{ hostEncoding :: PlatformEncoding,
@@ -48,13 +49,13 @@ data RemoteCrypto = RemoteCrypto
data RemoteSignatures
= RSSign
{ idPrivKey :: C.PrivateKeyEd25519,
sessPrivKey :: C.PrivateKeyEd25519
}
{ idPrivKey :: C.PrivateKeyEd25519,
sessPrivKey :: C.PrivateKeyEd25519
}
| RSVerify
{ idPubKey :: C.PublicKeyEd25519,
sessPubKey :: C.PublicKeyEd25519
}
{ idPubKey :: C.PublicKeyEd25519,
sessPubKey :: C.PublicKeyEd25519
}
type SessionSeq = Int
@@ -71,12 +72,12 @@ data RemoteHostSession
| RHSessionPendingConfirmation {sessionCode :: Text, tls :: TLS, rhPendingSession :: RHPendingSession}
| RHSessionConfirmed {tls :: TLS, rhPendingSession :: RHPendingSession}
| RHSessionConnected
{ rchClient :: RCHostClient,
tls :: TLS,
rhClient :: RemoteHostClient,
pollAction :: Async (),
storePath :: FilePath
}
{ rchClient :: RCHostClient,
tls :: TLS,
rhClient :: RemoteHostClient,
pollAction :: Async (),
storePath :: FilePath
}
data RemoteHostSessionState
= RHSStarting
@@ -128,6 +129,8 @@ data RemoteHost = RemoteHost
{ remoteHostId :: RemoteHostId,
hostDeviceName :: Text,
storePath :: FilePath,
bindAddress_ :: Maybe RCCtrlAddress,
bindPort_ :: Maybe Word16,
hostPairing :: RCHostPairing
}
@@ -136,6 +139,8 @@ data RemoteHostInfo = RemoteHostInfo
{ remoteHostId :: RemoteHostId,
hostDeviceName :: Text,
storePath :: FilePath,
bindAddress_ :: Maybe RCCtrlAddress,
bindPort_ :: Maybe Word16,
sessionState :: Maybe RemoteHostSessionState
}
deriving (Show)
@@ -158,6 +163,7 @@ data PlatformEncoding
deriving (Show, Eq)
localEncoding :: PlatformEncoding
#if defined(darwin_HOST_OS) && defined(swiftJSON)
localEncoding = PESwift
#else

View File

@@ -4,7 +4,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Connections
@@ -25,11 +24,11 @@ import Data.Text (Text)
import Data.Time.Clock (UTCTime (..))
import Database.SQLite.Simple (Only (..), (:.) (..))
import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Protocol
import Simplex.Chat.Store.Files
import Simplex.Chat.Store.Groups
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Store.Shared
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent.Protocol (ConnId)
@@ -157,8 +156,9 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
connId_ <- maybeFirstRow fromOnly $
DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2)
connId_ <-
maybeFirstRow fromOnly $
DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
-- search connection for connection plan:
@@ -167,21 +167,22 @@ getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) =
-- deleted connections are filtered out to allow re-connecting via same contact address
getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do
connId_ <- maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT agent_conn_id FROM (
SELECT
agent_conn_id,
(CASE WHEN contact_id IS NOT NULL THEN 1 ELSE 0 END) AS conn_ord
FROM connections
WHERE user_id = ? AND via_contact_uri_hash IN (?,?) AND conn_status != ?
ORDER BY conn_ord DESC, created_at DESC
LIMIT 1
)
|]
(userId, cReqHash1, cReqHash2, ConnDeleted)
connId_ <-
maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT agent_conn_id FROM (
SELECT
agent_conn_id,
(CASE WHEN contact_id IS NOT NULL THEN 1 ELSE 0 END) AS conn_ord
FROM connections
WHERE user_id = ? AND via_contact_uri_hash IN (?,?) AND conn_status != ?
ORDER BY conn_ord DESC, created_at DESC
LIMIT 1
)
|]
(userId, cReqHash1, cReqHash2, ConnDeleted)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity])

View File

@@ -1,13 +1,12 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Direct
@@ -310,14 +309,14 @@ deleteUnusedProfile_ db userId profileId =
updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact
updateContactProfile db user@User {userId} c p'
| displayName == newName = do
liftIO $ updateContactProfile_ db userId profileId p'
pure c {profile, mergedPreferences}
liftIO $ updateContactProfile_ db userId profileId p'
pure c {profile, mergedPreferences}
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
updateContactProfile_' db userId profileId p' currentTs
updateContact_ db userId contactId localDisplayName ldn currentTs
pure $ Right c {localDisplayName = ldn, profile, mergedPreferences}
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
updateContactProfile_' db userId profileId p' currentTs
updateContact_ db userId contactId localDisplayName ldn currentTs
pure $ Right c {localDisplayName = ldn, profile, mergedPreferences}
where
Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, userPreferences} = c
Profile {displayName = newName, preferences} = p'
@@ -784,10 +783,8 @@ updateConnectionStatus :: DB.Connection -> Connection -> ConnStatus -> IO ()
updateConnectionStatus db Connection {connId} connStatus = do
currentTs <- getCurrentTime
if connStatus == ConnReady
then
DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ?, conn_req_inv = NULL WHERE connection_id = ?" (connStatus, currentTs, connId)
else
DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId)
then DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ?, conn_req_inv = NULL WHERE connection_id = ?" (connStatus, currentTs, connId)
else DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId)
updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO ()
updateContactSettings db User {userId} contactId ChatSettings {enableNtfs, sendRcpts, favorite} =
@@ -816,4 +813,3 @@ resetContactConnInitiated db User {userId} Connection {connId} = do
WHERE user_id = ? AND connection_id = ?
|]
(updatedAt, userId, connId)

View File

@@ -109,7 +109,7 @@ import Simplex.Messaging.Protocol (SubscriptionMode (..))
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
getLiveSndFileTransfers db User {userId} = do
cutoffTs <- addUTCTime (- week) <$> getCurrentTime
cutoffTs <- addUTCTime (-week) <$> getCurrentTime
fileIds :: [Int64] <-
map fromOnly
<$> DB.query
@@ -132,7 +132,7 @@ getLiveSndFileTransfers db User {userId} = do
getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer]
getLiveRcvFileTransfers db user@User {userId} = do
cutoffTs <- addUTCTime (- week) <$> getCurrentTime
cutoffTs <- addUTCTime (-week) <$> getCurrentTime
fileIds :: [Int64] <-
map fromOnly
<$> DB.query
@@ -234,11 +234,12 @@ createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Conn
updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> ExceptT StoreError IO ()
updateSndDirectFTDelivery _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = liftIO $
DB.execute
db
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
(msgDeliveryId, connId, fileId)
updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId =
liftIO $
DB.execute
db
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
(msgDeliveryId, connId, fileId)
updateSndGroupFTDelivery :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> Int64 -> IO ()
updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} FileTransferMeta {fileId} msgDeliveryId =
@@ -724,7 +725,7 @@ removeFileCryptoArgs db fileId = do
getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer]
getRcvFilesToReceive db user@User {userId} = do
cutoffTs <- addUTCTime (- (2 * nominalDay)) <$> getCurrentTime
cutoffTs <- addUTCTime (-(2 * nominalDay)) <$> getCurrentTime
fileIds :: [Int64] <-
map fromOnly
<$> DB.query
@@ -768,20 +769,20 @@ createRcvFileChunk db RcvFileTransfer {fileId, fileInvitation = FileInvitation {
pure $ case map fromOnly ns of
[]
| chunkNo == 1 ->
if chunkSize >= fileSize
then RcvChunkFinal
else RcvChunkOk
if chunkSize >= fileSize
then RcvChunkFinal
else RcvChunkOk
| otherwise -> RcvChunkError
n : _
| chunkNo == n -> RcvChunkDuplicate
| chunkNo == n + 1 ->
let prevSize = n * chunkSize
in if prevSize >= fileSize
then RcvChunkError
else
if prevSize + chunkSize >= fileSize
then RcvChunkFinal
else RcvChunkOk
let prevSize = n * chunkSize
in if prevSize >= fileSize
then RcvChunkError
else
if prevSize + chunkSize >= fileSize
then RcvChunkFinal
else RcvChunkOk
| otherwise -> RcvChunkError
updatedRcvFileChunkStored :: DB.Connection -> RcvFileTransfer -> Integer -> IO ()

View File

@@ -2,14 +2,13 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Groups
@@ -122,7 +121,7 @@ import Crypto.Random (ChaChaDRG)
import Data.Either (rights)
import Data.Int (Int64)
import Data.List (partition, sortOn)
import Data.Maybe (fromMaybe, isNothing, catMaybes, isJust)
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
import Data.Ord (Down (..))
import Data.Text (Text)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
@@ -446,39 +445,39 @@ createGroupInvitedViaLink
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs supportedChatVRange
liftIO $ setViaGroupLinkHash db groupId connId
(,) <$> getGroupInfo db user groupId <*> getGroupMemberById db user hostMemberId
where
insertGroup_ currentTs = ExceptT $ do
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile
withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do
liftIO $ do
DB.execute
db
"INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs)
profileId <- insertedRowId db
DB.execute
db
"INSERT INTO groups (group_profile_id, local_display_name, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?)"
(profileId, localDisplayName, customUserProfileId, userId, True, currentTs, currentTs, currentTs)
insertedRowId db
insertHost_ currentTs groupId = ExceptT $ do
let fromMemberProfile = profileFromName fromMemberName
withLocalDisplayName db userId fromMemberName $ \localDisplayName -> runExceptT $ do
(_, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs
let MemberIdRole {memberId, memberRole} = fromMember
liftIO $ do
DB.execute
db
[sql|
INSERT INTO group_members
( group_id, member_id, member_role, member_category, member_status, invited_by,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|]
( (groupId, memberId, memberRole, GCHostMember, GSMemAccepted, fromInvitedBy userContactId IBUnknown)
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs)
)
insertedRowId db
where
insertGroup_ currentTs = ExceptT $ do
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile
withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do
liftIO $ do
DB.execute
db
"INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs)
profileId <- insertedRowId db
DB.execute
db
"INSERT INTO groups (group_profile_id, local_display_name, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?)"
(profileId, localDisplayName, customUserProfileId, userId, True, currentTs, currentTs, currentTs)
insertedRowId db
insertHost_ currentTs groupId = ExceptT $ do
let fromMemberProfile = profileFromName fromMemberName
withLocalDisplayName db userId fromMemberName $ \localDisplayName -> runExceptT $ do
(_, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs
let MemberIdRole {memberId, memberRole} = fromMember
liftIO $ do
DB.execute
db
[sql|
INSERT INTO group_members
( group_id, member_id, member_role, member_category, member_status, invited_by,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|]
( (groupId, memberId, memberRole, GCHostMember, GSMemAccepted, fromInvitedBy userContactId IBUnknown)
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs)
)
insertedRowId db
setViaGroupLinkHash :: DB.Connection -> GroupId -> Int64 -> IO ()
setViaGroupLinkHash db groupId connId =
@@ -814,22 +813,22 @@ createAcceptedMember
insertMember_ (MemberId memId) createdAt
groupMemberId <- liftIO $ insertedRowId db
pure (groupMemberId, MemberId memId)
where
JVersionRange (VersionRange minV maxV) = cReqChatVRange
insertMember_ memberId createdAt =
DB.execute
db
[sql|
INSERT INTO group_members
( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at,
peer_chat_min_version, peer_chat_max_version)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
( (groupId, memberId, memberRole, GCInviteeMember, GSMemAccepted, fromInvitedBy userContactId IBUser, groupMemberId' membership)
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, createdAt, createdAt)
:. (minV, maxV)
)
where
JVersionRange (VersionRange minV maxV) = cReqChatVRange
insertMember_ memberId createdAt =
DB.execute
db
[sql|
INSERT INTO group_members
( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at,
peer_chat_min_version, peer_chat_max_version)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
( (groupId, memberId, memberRole, GCInviteeMember, GSMemAccepted, fromInvitedBy userContactId IBUser, groupMemberId' membership)
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, createdAt, createdAt)
:. (minV, maxV)
)
createAcceptedMemberConnection :: DB.Connection -> User -> (CommandId, ConnId) -> UserContactRequest -> GroupMemberId -> SubscriptionMode -> IO ()
createAcceptedMemberConnection
@@ -957,23 +956,24 @@ createNewMember_
:. (minV, maxV)
)
groupMemberId <- insertedRowId db
pure GroupMember {
groupMemberId,
groupId,
memberId,
memberRole,
memberCategory,
memberStatus,
memberSettings = defaultMemberSettings,
invitedBy,
invitedByGroupMemberId = memInvitedByGroupMemberId,
localDisplayName,
memberProfile = toLocalProfile memberContactProfileId memberProfile "",
memberContactId,
memberContactProfileId,
activeConn,
memberChatVRange = JVersionRange mcvr
}
pure
GroupMember
{ groupMemberId,
groupId,
memberId,
memberRole,
memberCategory,
memberStatus,
memberSettings = defaultMemberSettings,
invitedBy,
invitedByGroupMemberId = memInvitedByGroupMemberId,
localDisplayName,
memberProfile = toLocalProfile memberContactProfileId memberProfile "",
memberContactId,
memberContactProfileId,
activeConn,
memberChatVRange = JVersionRange mcvr
}
checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId)
checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} =
@@ -1104,41 +1104,41 @@ getForwardIntroducedMembers :: DB.Connection -> User -> GroupMember -> Bool -> I
getForwardIntroducedMembers db user invitee highlyAvailable = do
memberIds <- map fromOnly <$> query
filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds
where
mId = groupMemberId' invitee
query
| highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected)
| otherwise =
DB.query
db
(q <> " AND intro_chat_protocol_version >= ?")
(mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange)
q =
[sql|
SELECT re_group_member_id
FROM group_member_intros
WHERE to_group_member_id = ? AND intro_status NOT IN (?,?,?)
|]
where
mId = groupMemberId' invitee
query
| highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected)
| otherwise =
DB.query
db
(q <> " AND intro_chat_protocol_version >= ?")
(mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange)
q =
[sql|
SELECT re_group_member_id
FROM group_member_intros
WHERE to_group_member_id = ? AND intro_status NOT IN (?,?,?)
|]
getForwardInvitedMembers :: DB.Connection -> User -> GroupMember -> Bool -> IO [GroupMember]
getForwardInvitedMembers db user forwardMember highlyAvailable = do
memberIds <- map fromOnly <$> query
filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db user) memberIds
where
mId = groupMemberId' forwardMember
query
| highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected)
| otherwise =
DB.query
db
(q <> " AND intro_chat_protocol_version >= ?")
(mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange)
q =
[sql|
SELECT to_group_member_id
FROM group_member_intros
WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?)
|]
where
mId = groupMemberId' forwardMember
query
| highlyAvailable = DB.query db q (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected)
| otherwise =
DB.query
db
(q <> " AND intro_chat_protocol_version >= ?")
(mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, minVersion groupForwardVRange)
q =
[sql|
SELECT to_group_member_id
FROM group_member_intros
WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?)
|]
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do
@@ -1263,15 +1263,15 @@ getViaGroupContact db user@User {userId} GroupMember {groupMemberId} = do
updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo
updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, description, image, groupPreferences}
| displayName == newName = liftIO $ do
currentTs <- getCurrentTime
updateGroupProfile_ currentTs
pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences}
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
updateGroupProfile_ currentTs
updateGroup_ ldn currentTs
pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences}
pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences}
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
updateGroupProfile_ currentTs
updateGroup_ ldn currentTs
pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences}
where
fullGroupPreferences = mergeGroupPreferences groupPreferences
updateGroupProfile_ currentTs =
@@ -1317,31 +1317,33 @@ getGroupInfo db User {userId, userContactId} groupId =
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
groupId_ <- maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT group_id
FROM user_contact_links
WHERE user_id = ? AND conn_req_contact IN (?,?)
|]
(userId, cReqSchema1, cReqSchema2)
groupId_ <-
maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT group_id
FROM user_contact_links
WHERE user_id = ? AND conn_req_contact IN (?,?)
|]
(userId, cReqSchema1, cReqSchema2)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
groupId_ <- maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT g.group_id
FROM groups g
JOIN group_members mu ON mu.group_id = g.group_id
WHERE g.user_id = ? AND g.via_group_link_uri_hash IN (?,?)
AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?)
LIMIT 1
|]
(userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
groupId_ <-
maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT g.group_id
FROM groups g
JOIN group_members mu ON mu.group_id = g.group_id
WHERE g.user_id = ? AND g.via_group_link_uri_hash IN (?,?)
AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?)
LIMIT 1
|]
(userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
@@ -1935,18 +1937,18 @@ createMemberContactConn_
updateMemberProfile :: DB.Connection -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember
updateMemberProfile db User {userId} m p'
| displayName == newName = do
liftIO $ updateContactProfile_ db userId profileId p'
pure m {memberProfile = profile}
liftIO $ updateContactProfile_ db userId profileId p'
pure m {memberProfile = profile}
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
updateContactProfile_' db userId profileId p' currentTs
DB.execute
db
"UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?"
(ldn, currentTs, userId, groupMemberId)
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId)
pure $ Right m {localDisplayName = ldn, memberProfile = profile}
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
updateContactProfile_' db userId profileId p' currentTs
DB.execute
db
"UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?"
(ldn, currentTs, userId, groupMemberId)
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId)
pure $ Right m {localDisplayName = ldn, memberProfile = profile}
where
GroupMember {groupMemberId, localDisplayName, memberProfile = LocalProfile {profileId, displayName, localAlias}} = m
Profile {displayName = newName} = p'

View File

@@ -10,7 +10,6 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Messages
@@ -199,40 +198,41 @@ createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMs
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs
pure msg
createNewRcvMessage :: forall e. (MsgEncodingI e) => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewRcvMessage db connOrGroupId NewMessage{chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember =
createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember =
case connOrGroupId of
ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing
GroupId groupId -> case sharedMsgId_ of
Just sharedMsgId -> liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case
Just (duplAuthorId, duplFwdMemberId) ->
throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
Just sharedMsgId ->
liftIO (duplicateGroupMsgMemberIds groupId sharedMsgId) >>= \case
Just (duplAuthorId, duplFwdMemberId) ->
throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
where
duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId))
duplicateGroupMsgMemberIds groupId sharedMsgId =
maybeFirstRow id
$ DB.query
where
duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO (Maybe (Maybe GroupMemberId, Maybe GroupMemberId))
duplicateGroupMsgMemberIds groupId sharedMsgId =
maybeFirstRow id $
DB.query
db
[sql|
SELECT author_group_member_id, forwarded_by_group_member_id
FROM messages
WHERE group_id = ? AND shared_msg_id = ? LIMIT 1
|]
(groupId, sharedMsgId)
insertRcvMsg connId_ groupId_ = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
SELECT author_group_member_id, forwarded_by_group_member_id
FROM messages
WHERE group_id = ? AND shared_msg_id = ? LIMIT 1
INSERT INTO messages
(msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id)
VALUES (?,?,?,?,?,?,?,?,?,?)
|]
(groupId, sharedMsgId)
insertRcvMsg connId_ groupId_ = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO messages
(msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id)
VALUES (?,?,?,?,?,?,?,?,?,?)
|]
(MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember)
msgId <- insertedRowId db
pure RcvMessage{msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
(MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember)
msgId <- insertedRowId db
pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO ()
createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do
@@ -528,12 +528,12 @@ getDirectChatPreviews_ db user@User {userId} = do
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
LEFT JOIN connections c ON c.contact_id = ct.contact_id
LEFT JOIN (
SELECT contact_id, MAX(chat_item_id) AS MaxId
SELECT contact_id, chat_item_id, MAX(created_at)
FROM chat_items
GROUP BY contact_id
) MaxIds ON MaxIds.contact_id = ct.contact_id
LEFT JOIN chat_items i ON i.contact_id = MaxIds.contact_id
AND i.chat_item_id = MaxIds.MaxId
) LastItems ON LastItems.contact_id = ct.contact_id
LEFT JOIN chat_items i ON i.contact_id = LastItems.contact_id
AND i.chat_item_id = LastItems.chat_item_id
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
LEFT JOIN (
SELECT contact_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread
@@ -615,12 +615,12 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
JOIN group_members mu ON mu.group_id = g.group_id
JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id)
LEFT JOIN (
SELECT group_id, MAX(chat_item_id) AS MaxId
SELECT group_id, chat_item_id, MAX(item_ts)
FROM chat_items
GROUP BY group_id
) MaxIds ON MaxIds.group_id = g.group_id
LEFT JOIN chat_items i ON i.group_id = MaxIds.group_id
AND i.chat_item_id = MaxIds.MaxId
) LastItems ON LastItems.group_id = g.group_id
LEFT JOIN chat_items i ON i.group_id = LastItems.group_id
AND i.chat_item_id = LastItems.chat_item_id
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
LEFT JOIN (
SELECT group_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread
@@ -724,7 +724,7 @@ getDirectChatItemsLast db User {userId} contactId count search = ExceptT $ do
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id
WHERE i.user_id = ? AND i.contact_id = ? AND i.item_text LIKE '%' || ? || '%'
ORDER BY i.chat_item_id DESC
ORDER BY i.created_at DESC, i.chat_item_id DESC
LIMIT ?
|]
(userId, contactId, search, count)
@@ -754,7 +754,7 @@ getDirectChatAfter_ db User {userId} ct@Contact {contactId} afterChatItemId coun
LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id
WHERE i.user_id = ? AND i.contact_id = ? AND i.item_text LIKE '%' || ? || '%'
AND i.chat_item_id > ?
ORDER BY i.chat_item_id ASC
ORDER BY i.created_at ASC, i.chat_item_id ASC
LIMIT ?
|]
(userId, contactId, search, afterChatItemId, count)
@@ -784,7 +784,7 @@ getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId co
LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id
WHERE i.user_id = ? AND i.contact_id = ? AND i.item_text LIKE '%' || ? || '%'
AND i.chat_item_id < ?
ORDER BY i.chat_item_id DESC
ORDER BY i.created_at DESC, i.chat_item_id DESC
LIMIT ?
|]
(userId, contactId, search, beforeChatItemId, count)
@@ -1802,22 +1802,22 @@ getDirectReactions db ct itemSharedMId sent =
setDirectReaction :: DB.Connection -> Contact -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO ()
setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs
| add =
DB.execute
db
[sql|
INSERT INTO chat_item_reactions
(contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts)
VALUES (?,?,?,?,?,?)
|]
(contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs)
DB.execute
db
[sql|
INSERT INTO chat_item_reactions
(contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts)
VALUES (?,?,?,?,?,?)
|]
(contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs)
| otherwise =
DB.execute
db
[sql|
DELETE FROM chat_item_reactions
WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ?
|]
(contactId' ct, itemSharedMId, sent, reaction)
DB.execute
db
[sql|
DELETE FROM chat_item_reactions
WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ?
|]
(contactId' ct, itemSharedMId, sent, reaction)
getGroupReactions :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> IO [MsgReaction]
getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent =
@@ -1834,22 +1834,22 @@ getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent =
setGroupReaction :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO ()
setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reaction add msgId reactionTs
| add =
DB.execute
db
[sql|
INSERT INTO chat_item_reactions
(group_id, group_member_id, item_member_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts)
VALUES (?,?,?,?,?,?,?,?)
|]
(groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs)
DB.execute
db
[sql|
INSERT INTO chat_item_reactions
(group_id, group_member_id, item_member_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts)
VALUES (?,?,?,?,?,?,?,?)
|]
(groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs)
| otherwise =
DB.execute
db
[sql|
DELETE FROM chat_item_reactions
WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ?
|]
(groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction)
DB.execute
db
[sql|
DELETE FROM chat_item_reactions
WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ?
|]
(groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction)
getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)]
getTimedItems db User {userId} startTimedThreadCutoff =

View File

@@ -90,6 +90,7 @@ import Simplex.Chat.Migrations.M20231030_xgrplinkmem_received
import Simplex.Chat.Migrations.M20231107_indexes
import Simplex.Chat.Migrations.M20231113_group_forward
import Simplex.Chat.Migrations.M20231114_remote_control
import Simplex.Chat.Migrations.M20231126_remote_ctrl_address
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@@ -179,7 +180,8 @@ schemaMigrations =
("20231030_xgrplinkmem_received", m20231030_xgrplinkmem_received, Just down_m20231030_xgrplinkmem_received),
("20231107_indexes", m20231107_indexes, Just down_m20231107_indexes),
("20231113_group_forward", m20231113_group_forward, Just down_m20231113_group_forward),
("20231114_remote_control", m20231114_remote_control, Just down_m20231114_remote_control)
("20231114_remote_control", m20231114_remote_control, Just down_m20231114_remote_control),
("20231126_remote_ctrl_address", m20231126_remote_ctrl_address, Just down_m20231126_remote_ctrl_address)
]
-- | The list of migrations in ascending order by date

View File

@@ -8,7 +8,6 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Store.Profiles
@@ -66,9 +65,9 @@ import Control.Monad.IO.Class
import qualified Data.Aeson.TH as J
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe)
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
@@ -89,7 +88,7 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON)
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (safeDecodeUtf8, eitherToMaybe)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User
createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime
@@ -248,19 +247,19 @@ updateUserGroupReceipts db User {userId} UserMsgReceiptSettings {enable, clearOv
updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User
updateUserProfile db user p'
| displayName == newName = do
liftIO $ updateContactProfile_ db userId profileId p'
pure user {profile, fullPreferences}
liftIO $ updateContactProfile_ db userId profileId p'
pure user {profile, fullPreferences}
| otherwise =
checkConstraint SEDuplicateName . liftIO $ do
currentTs <- getCurrentTime
DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId)
DB.execute
db
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(newName, newName, userId, currentTs, currentTs)
updateContactProfile_' db userId profileId p' currentTs
updateContact_ db userId userContactId localDisplayName newName currentTs
pure user {localDisplayName = newName, profile, fullPreferences}
checkConstraint SEDuplicateName . liftIO $ do
currentTs <- getCurrentTime
DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId)
DB.execute
db
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(newName, newName, userId, currentTs, currentTs)
updateContactProfile_' db userId profileId p' currentTs
updateContact_ db userId userContactId localDisplayName newName currentTs
pure user {localDisplayName = newName, profile, fullPreferences}
where
User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} = user
Profile {displayName = newName, preferences} = p'
@@ -457,17 +456,18 @@ getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) =
getContactWithoutConnViaAddress :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact)
getContactWithoutConnViaAddress db user@User {userId} (cReqSchema1, cReqSchema2) = do
ctId_ <- maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT ct.contact_id
FROM contacts ct
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
LEFT JOIN connections c ON c.contact_id = ct.contact_id
WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL
|]
(userId, cReqSchema1, cReqSchema2)
ctId_ <-
maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT ct.contact_id
FROM contacts ct
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
LEFT JOIN connections c ON c.contact_id = ct.contact_id
WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL
|]
(userId, cReqSchema1, cReqSchema2)
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db user) ctId_
updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink

View File

@@ -8,6 +8,8 @@ module Simplex.Chat.Store.Remote where
import Control.Monad.Except
import Data.Int (Int64)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeASCII)
import Data.Word (Word16)
import Database.SQLite.Simple (Only (..))
import qualified Database.SQLite.Simple as SQL
import Database.SQLite.Simple.QQ (sql)
@@ -16,11 +18,12 @@ import Simplex.Chat.Store.Shared
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.RemoteControl.Types
import UnliftIO
insertRemoteHost :: DB.Connection -> Text -> FilePath -> RCHostPairing -> ExceptT StoreError IO RemoteHostId
insertRemoteHost db hostDeviceName storePath RCHostPairing {caKey, caCert, idPrivKey, knownHost = kh_} = do
insertRemoteHost :: DB.Connection -> Text -> FilePath -> Maybe RCCtrlAddress -> Maybe Word16 -> RCHostPairing -> ExceptT StoreError IO RemoteHostId
insertRemoteHost db hostDeviceName storePath rcAddr_ bindPort_ RCHostPairing {caKey, caCert, idPrivKey, knownHost = kh_} = do
KnownHostPairing {hostFingerprint, hostDhPubKey} <-
maybe (throwError SERemoteHostUnknown) pure kh_
checkConstraint SERemoteHostDuplicateCA . liftIO $
@@ -28,12 +31,14 @@ insertRemoteHost db hostDeviceName storePath RCHostPairing {caKey, caCert, idPri
db
[sql|
INSERT INTO remote_hosts
(host_device_name, store_path, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub)
(host_device_name, store_path, bind_addr, bind_iface, bind_port, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub)
VALUES
(?, ?, ?, ?, ?, ?, ?)
(?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
|]
(hostDeviceName, storePath, caKey, C.SignedObject caCert, idPrivKey, hostFingerprint, hostDhPubKey)
(hostDeviceName, storePath, bindAddr_, bindIface_, bindPort_, caKey, C.SignedObject caCert, idPrivKey, hostFingerprint, hostDhPubKey)
liftIO $ insertedRowId db
where
(bindAddr_, bindIface_) = rcCtrlAddressFields_ rcAddr_
getRemoteHosts :: DB.Connection -> IO [RemoteHost]
getRemoteHosts db =
@@ -52,27 +57,34 @@ getRemoteHostByFingerprint db fingerprint =
remoteHostQuery :: SQL.Query
remoteHostQuery =
[sql|
SELECT remote_host_id, host_device_name, store_path, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub
SELECT remote_host_id, host_device_name, store_path, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub, bind_iface, bind_addr, bind_port
FROM remote_hosts
|]
toRemoteHost :: (Int64, Text, FilePath, C.APrivateSignKey, C.SignedObject C.Certificate, C.PrivateKeyEd25519, C.KeyHash, C.PublicKeyX25519) -> RemoteHost
toRemoteHost (remoteHostId, hostDeviceName, storePath, caKey, C.SignedObject caCert, idPrivKey, hostFingerprint, hostDhPubKey) =
RemoteHost {remoteHostId, hostDeviceName, storePath, hostPairing}
toRemoteHost :: (Int64, Text, FilePath, C.APrivateSignKey, C.SignedObject C.Certificate, C.PrivateKeyEd25519, C.KeyHash, C.PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16) -> RemoteHost
toRemoteHost (remoteHostId, hostDeviceName, storePath, caKey, C.SignedObject caCert, idPrivKey, hostFingerprint, hostDhPubKey, ifaceName_, ifaceAddr_, bindPort_) =
RemoteHost {remoteHostId, hostDeviceName, storePath, hostPairing, bindAddress_, bindPort_}
where
hostPairing = RCHostPairing {caKey, caCert, idPrivKey, knownHost = Just knownHost}
knownHost = KnownHostPairing {hostFingerprint, hostDhPubKey}
bindAddress_ = RCCtrlAddress <$> (decodeAddr <$> ifaceAddr_) <*> ifaceName_
decodeAddr = either (error "Error parsing TransportHost") id . strDecode . encodeUtf8
updateHostPairing :: DB.Connection -> RemoteHostId -> Text -> C.PublicKeyX25519 -> IO ()
updateHostPairing db rhId hostDeviceName hostDhPubKey =
updateHostPairing :: DB.Connection -> RemoteHostId -> Text -> C.PublicKeyX25519 -> Maybe RCCtrlAddress -> Maybe Word16 -> IO ()
updateHostPairing db rhId hostDeviceName hostDhPubKey rcAddr_ bindPort_ =
DB.execute
db
[sql|
UPDATE remote_hosts
SET host_device_name = ?, host_dh_pub = ?
SET host_device_name = ?, host_dh_pub = ?, bind_addr = ?, bind_iface = ?, bind_port = ?
WHERE remote_host_id = ?
|]
(hostDeviceName, hostDhPubKey, rhId)
(hostDeviceName, hostDhPubKey, bindAddr_, bindIface_, bindPort_, rhId)
where
(bindAddr_, bindIface_) = rcCtrlAddressFields_ rcAddr_
rcCtrlAddressFields_ :: Maybe RCCtrlAddress -> (Maybe Text, Maybe Text)
rcCtrlAddressFields_ = maybe (Nothing, Nothing) $ \RCCtrlAddress {address, interface} -> (Just . decodeASCII $ strEncode address, Just interface)
deleteRemoteHostRecord :: DB.Connection -> RemoteHostId -> IO ()
deleteRemoteHostRecord db remoteHostId = DB.execute db "DELETE FROM remote_hosts WHERE remote_host_id = ?" (Only remoteHostId)

View File

@@ -101,7 +101,7 @@ data StoreError
| SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId}
| SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, authorGroupMemberId :: Maybe GroupMemberId, forwardedByGroupMemberId :: Maybe GroupMemberId}
| SERemoteHostNotFound {remoteHostId :: RemoteHostId}
| SERemoteHostUnknown -- ^ attempting to store KnownHost without a known fingerprint
| SERemoteHostUnknown -- attempting to store KnownHost without a known fingerprint
| SERemoteHostDuplicateCA
| SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
| SERemoteCtrlDuplicateCA

View File

@@ -194,19 +194,19 @@ receiveFromTTY cc@ChatController {inputQ, currentUser, currentRemoteHost, chatSt
case lm_ of
Just LiveMessage {chatName}
| live -> do
writeTVar termState ts' {previousInput}
writeTBQueue inputQ $ "/live " <> chatNameStr chatName
writeTVar termState ts' {previousInput}
writeTBQueue inputQ $ "/live " <> chatNameStr chatName
| otherwise ->
writeTVar termState ts' {inputPrompt = "> ", previousInput}
writeTVar termState ts' {inputPrompt = "> ", previousInput}
where
previousInput = chatNameStr chatName <> " " <> s
_
| live -> when (isSend s) $ do
writeTVar termState ts' {previousInput = s}
writeTBQueue inputQ $ "/live " <> s
writeTVar termState ts' {previousInput = s}
writeTBQueue inputQ $ "/live " <> s
| otherwise -> do
writeTVar termState ts' {inputPrompt = "> ", previousInput = s}
writeTBQueue inputQ s
writeTVar termState ts' {inputPrompt = "> ", previousInput = s}
writeTBQueue inputQ s
pure $ (s,) <$> lm_
where
isSend s = length s > 1 && (head s == '@' || head s == '#')
@@ -343,9 +343,9 @@ updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputStr
charsWithContact cs
| live = cs
| null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" && cs /= "+" && cs /= "-" =
chatPrefix <> cs
chatPrefix <> cs
| (s == ">" || s == "\\" || s == "!") && cs == " " =
cs <> chatPrefix
cs <> chatPrefix
| otherwise = cs
insertChars = ts' . if p >= length s then append else insert
append cs = let s' = s <> cs in (s', length s')
@@ -381,13 +381,13 @@ updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputStr
prevWordPos
| p == 0 || null s = p
| otherwise =
let before = take p s
beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before
in max 0 $ p - length before + length beforeWord
let before = take p s
beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before
in max 0 $ p - length before + length beforeWord
nextWordPos
| p >= length s || null s = p
| otherwise =
let after = drop p s
afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after
in min (length s) $ p + length after - length afterWord
let after = drop p s
afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after
in min (length s) $ p + length after - length afterWord
ts' (s', p') = ts {inputString = s', inputPosition = p', autoComplete = acp {acTabPressed = False}}

View File

@@ -24,7 +24,7 @@ import Simplex.Chat (execChatCommand, processChatCommand)
import Simplex.Chat.Controller
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent (CIContent(..), SMsgDirection (..))
import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..))
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..), msgContentText)
import Simplex.Chat.Remote.Types (RHKey (..), RemoteHostId, RemoteHostInfo (..), RemoteHostSession (..))
@@ -167,9 +167,10 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc
_ -> pure ()
logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s
getRemoteUser rhId = runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case
CRActiveUser {user} -> updateRemoteUser ct user rhId
cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr
getRemoteUser rhId =
runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case
CRActiveUser {user} -> updateRemoteUser ct user rhId
cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr
removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct)
responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO ()
@@ -326,9 +327,9 @@ updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessag
clearLines from till
| from >= till = return ()
| otherwise = do
setCursorPosition $ Position {row = from, col = 0}
eraseInLine EraseForward
clearLines (from + 1) till
setCursorPosition $ Position {row = from, col = 0}
eraseInLine EraseForward
clearLines (from + 1) till
inputHeight :: TerminalState -> Int
inputHeight ts = length (autoCompletePrefix ts <> inputPrompt ts <> inputString ts) `div` width + 1
autoCompletePrefix :: TerminalState -> String

View File

@@ -17,7 +17,6 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use newtype instead of data" #-}
@@ -40,7 +39,7 @@ import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Data.Typeable (Typeable)
import Database.SQLite.Simple (ResultError (..), SQLData (..))
import Database.SQLite.Simple.FromField (returnError, FromField(..))
import Database.SQLite.Simple.FromField (FromField (..), returnError)
import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok
import Database.SQLite.Simple.ToField (ToField (..))
@@ -50,7 +49,7 @@ import Simplex.FileTransfer.Description (FileDigest)
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON, enumJSON)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON)
import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
import Simplex.Messaging.Util ((<$?>))
import Simplex.Messaging.Version
@@ -498,7 +497,7 @@ data LocalProfile = LocalProfile
deriving (Eq, Show)
localProfileId :: LocalProfile -> ProfileId
localProfileId LocalProfile{profileId} = profileId
localProfileId LocalProfile {profileId} = profileId
toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile
toLocalProfile profileId Profile {displayName, fullName, image, contactLink, preferences} localAlias =

View File

@@ -14,7 +14,6 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

View File

@@ -2,7 +2,7 @@
module Simplex.Chat.Types.Util where
import Data.Aeson (ToJSON, FromJSON)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as J
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LB

View File

@@ -14,8 +14,8 @@ module Simplex.Chat.View where
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isSpace, toUpper)
import Data.Function (on)
@@ -44,8 +44,8 @@ import Simplex.Chat.Markdown
import Simplex.Chat.Messages hiding (NewChatItem (..))
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol
import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange)
import Simplex.Chat.Remote.Types
import Simplex.Chat.Remote.AppVersion (pattern AppVersionRange, AppVersion (..))
import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..))
import Simplex.Chat.Styled
import Simplex.Chat.Types
@@ -65,6 +65,7 @@ import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Util (bshow, tshow)
import Simplex.Messaging.Version hiding (version)
import Simplex.RemoteControl.Types (RCCtrlAddress (..))
import System.Console.ANSI.Types
type CurrentTime = UTCTime
@@ -286,13 +287,13 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
rhi_
]
CRRemoteHostList hs -> viewRemoteHosts hs
CRRemoteHostStarted {remoteHost_, invitation, ctrlPort} ->
CRRemoteHostStarted {remoteHost_, invitation, localAddrs = RCCtrlAddress {address} :| _, ctrlPort} ->
[ plain $ maybe ("new remote host" <> started) (\RemoteHostInfo {remoteHostId = rhId} -> "remote host " <> show rhId <> started) remoteHost_,
"Remote session invitation:",
plain invitation
]
where
started = " started on port " <> ctrlPort
started = " started on " <> B.unpack (strEncode address) <> ":" <> ctrlPort
CRRemoteHostSessionCode {remoteHost_, sessionCode} ->
[ maybe "new remote host connecting" (\RemoteHostInfo {remoteHostId = rhId} -> "remote host " <> sShow rhId <> " connecting") remoteHost_,
"Compare session code with host:",
@@ -308,10 +309,10 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
<> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_
CRRemoteCtrlList cs -> viewRemoteCtrls cs
CRRemoteCtrlFound {remoteCtrl = RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName}, ctrlAppInfo_, appVersion, compatible} ->
[ "remote controller " <> sShow remoteCtrlId <> " found: "
[ ("remote controller " <> sShow remoteCtrlId <> " found: ")
<> maybe (deviceName <> "not compatible") (\info -> viewRemoteCtrl info appVersion compatible) ctrlAppInfo_
]
<> [ "use " <> highlight ("/confirm remote ctrl " <> show remoteCtrlId) <> " to connect" | isJust ctrlAppInfo_ && compatible]
<> ["use " <> highlight ("/confirm remote ctrl " <> show remoteCtrlId) <> " to connect" | isJust ctrlAppInfo_ && compatible]
where
deviceName = if T.null ctrlDeviceName then "" else plain ctrlDeviceName <> ", "
CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion} ->
@@ -511,42 +512,43 @@ viewChats ts tz = concatMap chatPreview . reverse
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember}, content, quotedItem, file} doShow ts tz =
withGroupMsgForwarded . withItemDeleted <$> (case chat of
DirectChat c -> case chatDir of
CIDirectSnd -> case content of
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
CISndGroupEvent {} -> showSndItemProhibited to
_ -> showSndItem to
where
to = ttyToContact' c
CIDirectRcv -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
CIRcvGroupEvent {} -> showRcvItemProhibited from
_ -> showRcvItem from
where
from = ttyFromContact c
where
quote = maybe [] (directQuote chatDir) quotedItem
GroupChat g -> case chatDir of
CIGroupSnd -> case content of
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
CISndGroupInvitation {} -> showSndItemProhibited to
_ -> showSndItem to
where
to = ttyToGroup g
CIGroupRcv m -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
CIRcvGroupInvitation {} -> showRcvItemProhibited from
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False
_ -> showRcvItem from
where
from = ttyFromGroup g m
where
quote = maybe [] (groupQuote g) quotedItem
_ -> [])
withGroupMsgForwarded . withItemDeleted <$> viewCI
where
viewCI = case chat of
DirectChat c -> case chatDir of
CIDirectSnd -> case content of
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
CISndGroupEvent {} -> showSndItemProhibited to
_ -> showSndItem to
where
to = ttyToContact' c
CIDirectRcv -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
CIRcvGroupEvent {} -> showRcvItemProhibited from
_ -> showRcvItem from
where
from = ttyFromContact c
where
quote = maybe [] (directQuote chatDir) quotedItem
GroupChat g -> case chatDir of
CIGroupSnd -> case content of
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
CISndGroupInvitation {} -> showSndItemProhibited to
_ -> showSndItem to
where
to = ttyToGroup g
CIGroupRcv m -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
CIRcvGroupInvitation {} -> showRcvItemProhibited from
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False
_ -> showRcvItem from
where
from = ttyFromGroup g m
where
quote = maybe [] (groupQuote g) quotedItem
_ -> []
withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of
Nothing -> item
Just t -> item <> styled (colored Red) (" [" <> t <> "]")
@@ -667,15 +669,15 @@ viewItemDelete chat ci@ChatItem {chatDir, meta, content = deletedContent} toItem
| timed = [plain ("timed message deleted: " <> T.unpack (ciContentToText deletedContent)) | testView]
| byUser = [plain $ "message " <> T.unpack (fromMaybe "deleted" deletedText_)] -- deletedText_ Nothing should be impossible here
| otherwise = case chat of
DirectChat c -> case (chatDir, deletedContent) of
(CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c deletedText_) [] mc ts tz meta
DirectChat c -> case (chatDir, deletedContent) of
(CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c deletedText_) [] mc ts tz meta
_ -> prohibited
GroupChat g -> case ciMsgContent deletedContent of
Just mc ->
let m = chatItemMember g ci
in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta
_ -> prohibited
_ -> prohibited
GroupChat g -> case ciMsgContent deletedContent of
Just mc ->
let m = chatItemMember g ci
in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta
_ -> prohibited
_ -> prohibited
where
deletedText_ :: Maybe Text
deletedText_ = case toItem of
@@ -788,7 +790,7 @@ viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of
viewContactsList :: [Contact] -> [StyledString]
viewContactsList =
let getLDN :: Contact -> ContactName
getLDN Contact{localDisplayName} = localDisplayName
getLDN Contact {localDisplayName} = localDisplayName
ldn = T.toLower . getLDN
in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn
where
@@ -823,8 +825,8 @@ simplexChatContact (CRContactUri crData) = CRContactUri crData {crScheme = simpl
autoAcceptStatus_ :: Maybe AutoAccept -> [StyledString]
autoAcceptStatus_ = \case
Just AutoAccept {acceptIncognito, autoReply} ->
("auto_accept on" <> if acceptIncognito then ", incognito" else "") :
maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply
("auto_accept on" <> if acceptIncognito then ", incognito" else "")
: maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply
_ -> ["auto_accept off"]
groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> GroupMemberRole -> [StyledString]
@@ -907,10 +909,10 @@ viewJoinedGroupMember g m =
viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString]
viewReceivedGroupInvitation g c role =
ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role) :
case incognitoMembershipProfile g of
Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)]
Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"]
ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role)
: case incognitoMembershipProfile g of
Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)]
Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"]
groupPreserved :: GroupInfo -> [StyledString]
groupPreserved g = ["use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the group"]
@@ -996,13 +998,13 @@ viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs
GSMemRemoved -> delete "you are removed"
GSMemLeft -> delete "you left"
GSMemGroupDeleted -> delete "group deleted"
_ -> " (" <> memberCount <>
case enableNtfs of
MFAll -> ")"
MFNone -> ", muted, " <> unmute
MFMentions -> ", mentions only, " <> unmute
_ -> " (" <> memberCount <> viewNtf <> ")"
where
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")"
viewNtf = case enableNtfs of
MFAll -> ""
MFNone -> ", muted, " <> unmute
MFMentions -> ", mentions only, " <> unmute
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g)
delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")"
memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s"
@@ -1028,9 +1030,9 @@ viewContactsMerged c1 c2 ct' =
viewContactAndMemberAssociated :: Contact -> GroupInfo -> GroupMember -> Contact -> [StyledString]
viewContactAndMemberAssociated ct g m ct' =
[ "contact and member are merged: " <> ttyContact' ct <> ", " <> ttyGroup' g <> " " <> ttyMember m,
"use " <> ttyToContact' ct' <> highlight' "<message>" <> " to send messages"
]
[ "contact and member are merged: " <> ttyContact' ct <> ", " <> ttyGroup' g <> " " <> ttyMember m,
"use " <> ttyToContact' ct' <> highlight' "<message>" <> " to send messages"
]
viewUserProfile :: Profile -> [StyledString]
viewUserProfile Profile {displayName, fullName} =
@@ -1396,14 +1398,14 @@ viewContactUpdated
Contact {localDisplayName = n', profile = LocalProfile {fullName = fullName', contactLink = contactLink'}}
| n == n' && fullName == fullName' && contactLink == contactLink' = []
| n == n' && fullName == fullName' =
if isNothing contactLink'
then [ttyContact n <> " removed contact address"]
else [ttyContact n <> " set new contact address, use " <> highlight ("/info " <> n) <> " to view"]
if isNothing contactLink'
then [ttyContact n <> " removed contact address"]
else [ttyContact n <> " set new contact address, use " <> highlight ("/info " <> n) <> " to view"]
| n == n' = ["contact " <> ttyContact n <> fullNameUpdate]
| otherwise =
[ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName',
"use " <> ttyToContact n' <> highlight' "<message>" <> " to send messages"
]
[ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName',
"use " <> ttyToContact n' <> highlight' "<message>" <> " to send messages"
]
where
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
@@ -1428,11 +1430,11 @@ receivedWithTime_ ts tz from quote CIMeta {itemId, itemTs, itemEdited, itemDelet
live
| itemEdited || isJust itemDeleted = ""
| otherwise = case itemLive of
Just True
| updated -> ttyFrom "[LIVE] "
| otherwise -> ttyFrom "[LIVE started]" <> " use " <> highlight' ("/show [on/off/" <> show itemId <> "] ")
Just False -> ttyFrom "[LIVE ended] "
_ -> ""
Just True
| updated -> ttyFrom "[LIVE] "
| otherwise -> ttyFrom "[LIVE started]" <> " use " <> highlight' ("/show [on/off/" <> show itemId <> "] ")
Just False -> ttyFrom "[LIVE ended] "
_ -> ""
ttyMsgTime :: CurrentTime -> TimeZone -> UTCTime -> StyledString
ttyMsgTime now tz time =
@@ -1458,9 +1460,9 @@ viewSentMessage to quote mc ts tz meta@CIMeta {itemEdited, itemDeleted, itemLive
live
| itemEdited || isJust itemDeleted = ""
| otherwise = case itemLive of
Just True -> ttyTo "[LIVE started] "
Just False -> ttyTo "[LIVE] "
_ -> ""
Just True -> ttyTo "[LIVE started] "
Just False -> ttyTo "[LIVE] "
_ -> ""
viewSentBroadcast :: MsgContent -> Int -> Int -> CurrentTime -> TimeZone -> UTCTime -> [StyledString]
viewSentBroadcast mc s f ts tz time = prependFirst (highlight' "/feed" <> " (" <> sShow s <> failures <> ") " <> ttyMsgTime ts tz time <> " ") (ttyMsgContent mc)
@@ -1551,11 +1553,12 @@ receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIF
cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"]
cfArgsStr _ = []
getRemoteFileStr = case hu of
(Just rhId, Just User {userId}) | status == "completed" ->
[ "File received to connected remote host " <> sShow rhId,
"To download to this device use:",
highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f}))
]
(Just rhId, Just User {userId})
| status == "completed" ->
[ "File received to connected remote host " <> sShow rhId,
"To download to this device use:",
highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f}))
]
_ -> []
receivingFile_' _ _ status _ = [plain status <> " receiving file"] -- shouldn't happen
@@ -1591,7 +1594,7 @@ viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksN
[recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus]
recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses
fs :: SndFileTransfer -> FileStatus
fs SndFileTransfer{fileStatus} = fileStatus
fs SndFileTransfer {fileStatus} = fileStatus
recipientsTransferStatus [] = []
recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts]
where
@@ -1711,8 +1714,13 @@ viewRemoteHosts = \case
[] -> ["No remote hosts"]
hs -> "Remote hosts: " : map viewRemoteHostInfo hs
where
viewRemoteHostInfo RemoteHostInfo {remoteHostId, hostDeviceName, sessionState} =
plain $ tshow remoteHostId <> ". " <> hostDeviceName <> maybe "" viewSessionState sessionState
viewRemoteHostInfo RemoteHostInfo {remoteHostId, hostDeviceName, sessionState, bindAddress_, bindPort_} =
plain $ tshow remoteHostId <> ". " <> hostDeviceName <> maybe "" viewSessionState sessionState <> ctrlBinds bindAddress_ bindPort_
ctrlBinds Nothing Nothing = ""
ctrlBinds rca_ port_ = mconcat [" [", maybe "" rca rca_, maybe "" port port_, "]"]
where
rca RCCtrlAddress {interface, address} = interface <> " " <> decodeLatin1 (strEncode address)
port p = ":" <> tshow p
viewSessionState = \case
RHSStarting -> " (starting)"
RHSConnecting _ -> " (connecting)"
@@ -1763,9 +1771,10 @@ viewChatError logLevel testView = \case
CEEmptyUserPassword _ -> ["user password is required"]
CEUserAlreadyHidden _ -> ["user is already hidden"]
CEUserNotHidden _ -> ["user is not hidden"]
CEInvalidDisplayName {displayName, validName} -> map plain $
["invalid display name: " <> viewName displayName]
<> ["you could use this one: " <> viewName validName | not (T.null validName)]
CEInvalidDisplayName {displayName, validName} ->
map plain $
["invalid display name: " <> viewName displayName]
<> ["you could use this one: " <> viewName validName | not (T.null validName)]
CEChatNotStarted -> ["error: chat not started"]
CEChatNotStopped -> ["error: chat not stopped"]
CEChatStoreChanged -> ["error: chat store changed, please restart chat"]

View File

@@ -49,7 +49,7 @@ extra-deps:
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
# - ../simplexmq
- github: simplex-chat/simplexmq
commit: 757b7eec81341d8560a326deab303bb6fb6a26a3
commit: febf9019e25e3de35f1b005da59e8434e12ae54b
- github: kazu-yamamoto/http2
commit: f5525b755ff2418e6e6ecc69e877363b0d0bcaeb
# - ../direct-sqlcipher

View File

@@ -5,7 +5,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module ChatClient where
@@ -276,7 +275,7 @@ getTermLine cc =
Just s -> do
-- remove condition to always echo virtual terminal
when (printOutput cc) $ do
-- when True $ do
-- when True $ do
name <- userName cc
putStrLn $ name <> ": " <> s
pure s

View File

@@ -259,7 +259,6 @@ testPlanInvitationLinkOk =
bob ##> ("/_connect plan 1 " <> inv)
bob <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
alice <##> bob
testPlanInvitationLinkOwn :: HasCallStack => FilePath -> IO ()
@@ -283,7 +282,6 @@ testPlanInvitationLinkOwn tmp =
alice ##> ("/_connect plan 1 " <> inv)
alice <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
alice @@@ [("@alice_1", lastChatFeature), ("@alice_2", lastChatFeature)]
alice `send` "@alice_2 hi"
alice
@@ -1213,31 +1211,34 @@ testMuteGroup =
cath `send` "> #team (hello) hello too!"
cath <# "#team > bob hello"
cath <## " hello too!"
concurrently_
(bob </)
( do alice <# "#team cath> > bob hello"
alice <## " hello too!"
)
concurrentlyN_
[ (bob </),
do
alice <# "#team cath> > bob hello"
alice <## " hello too!"
]
bob ##> "/unmute mentions #team"
bob <## "ok"
alice `send` "> #team @bob (hello) hey bob!"
alice <# "#team > bob hello"
alice <## " hey bob!"
concurrently_
( do bob <# "#team alice> > bob hello"
bob <## " hey bob!"
)
( do cath <# "#team alice> > bob hello"
cath <## " hey bob!"
)
concurrentlyN_
[ do
bob <# "#team alice> > bob hello"
bob <## " hey bob!",
do
cath <# "#team alice> > bob hello"
cath <## " hey bob!"
]
alice `send` "> #team @cath (hello) hey cath!"
alice <# "#team > cath hello too!"
alice <## " hey cath!"
concurrently_
(bob </)
( do cath <# "#team alice> > cath hello too!"
cath <## " hey cath!"
)
concurrentlyN_
[ (bob </),
do
cath <# "#team alice> > cath hello too!"
cath <## " hey cath!"
]
bob ##> "/gs"
bob <## "#team (3 members, mentions only, you can /unmute #team)"
bob ##> "/unmute #team"

View File

@@ -1,7 +1,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module ChatTests.Files where

View File

@@ -7,7 +7,7 @@ import ChatClient
import ChatTests.Utils
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_)
import Control.Monad (when, void)
import Control.Monad (void, when)
import qualified Data.ByteString as B
import Data.List (isInfixOf)
import qualified Data.Text as T
@@ -122,7 +122,8 @@ chatGroupTests = do
-- because host uses current code and sends version in MemberInfo
testNoDirect vrMem2 vrMem3 noConns =
it
( "host " <> vRangeStr supportedChatVRange
( "host "
<> vRangeStr supportedChatVRange
<> (", 2nd mem " <> vRangeStr vrMem2)
<> (", 3rd mem " <> vRangeStr vrMem3)
<> (if noConns then " : 2 <!!> 3" else " : 2 <##> 3")
@@ -3859,11 +3860,9 @@ testMemberContactProfileUpdate =
bob #> "#team hello too"
alice <# "#team rob> hello too"
cath <# "#team bob> hello too" -- not updated profile
cath #> "#team hello there"
alice <# "#team kate> hello there"
bob <# "#team cath> hello there" -- not updated profile
bob `send` "@cath hi"
bob
<### [ "member #team cath does not have direct connection, creating",
@@ -3903,7 +3902,6 @@ testMemberContactProfileUpdate =
bob #> "#team hello too"
alice <# "#team rob> hello too"
cath <# "#team rob> hello too" -- updated profile
cath #> "#team hello there"
alice <# "#team kate> hello there"
bob <# "#team kate> hello there" -- updated profile
@@ -3911,7 +3909,7 @@ testMemberContactProfileUpdate =
testGroupMsgForward :: HasCallStack => FilePath -> IO ()
testGroupMsgForward =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
\alice bob cath -> do
setupGroupForwarding3 "team" alice bob cath
bob #> "#team hi there"
@@ -3941,7 +3939,6 @@ setupGroupForwarding3 gName alice bob cath = do
createGroup3 gName alice bob cath
threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected
void $ withCCTransaction bob $ \db ->
DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3"
void $ withCCTransaction cath $ \db ->
@@ -3956,7 +3953,6 @@ testGroupMsgForwardDeduplicate =
createGroup3 "team" alice bob cath
threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected
void $ withCCTransaction alice $ \db ->
DB.execute_ db "UPDATE group_member_intros SET intro_status='fwd'"
@@ -3990,7 +3986,7 @@ testGroupMsgForwardDeduplicate =
testGroupMsgForwardEdit :: HasCallStack => FilePath -> IO ()
testGroupMsgForwardEdit =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
\alice bob cath -> do
setupGroupForwarding3 "team" alice bob cath
bob #> "#team hi there"
@@ -4001,7 +3997,6 @@ testGroupMsgForwardEdit =
bob <# "#team [edited] hello there"
alice <# "#team bob> [edited] hello there"
cath <# "#team bob> [edited] hello there" -- TODO show as forwarded
alice ##> "/tail #team 1"
alice <# "#team bob> hello there"
@@ -4014,7 +4009,7 @@ testGroupMsgForwardEdit =
testGroupMsgForwardReaction :: HasCallStack => FilePath -> IO ()
testGroupMsgForwardReaction =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
\alice bob cath -> do
setupGroupForwarding3 "team" alice bob cath
bob #> "#team hi there"
@@ -4031,7 +4026,7 @@ testGroupMsgForwardReaction =
testGroupMsgForwardDeletion :: HasCallStack => FilePath -> IO ()
testGroupMsgForwardDeletion =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
\alice bob cath -> do
setupGroupForwarding3 "team" alice bob cath
bob #> "#team hi there"
@@ -4073,7 +4068,7 @@ testGroupMsgForwardFile =
testGroupMsgForwardChangeRole :: HasCallStack => FilePath -> IO ()
testGroupMsgForwardChangeRole =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
\alice bob cath -> do
setupGroupForwarding3 "team" alice bob cath
cath ##> "/mr #team bob member"
@@ -4084,7 +4079,7 @@ testGroupMsgForwardChangeRole =
testGroupMsgForwardNewMember :: HasCallStack => FilePath -> IO ()
testGroupMsgForwardNewMember =
testChat4 aliceProfile bobProfile cathProfile danProfile $
\alice bob cath dan -> do
\alice bob cath dan -> do
setupGroupForwarding3 "team" alice bob cath
connectUsers cath dan

View File

@@ -7,16 +7,16 @@ import ChatClient
import ChatTests.Utils
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_)
import Control.Monad
import Control.Monad.Except
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import Simplex.Chat.Store.Shared (createContact)
import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), Profile (..))
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import System.Directory (copyFile, createDirectoryIfMissing)
import Test.Hspec
import Simplex.Chat.Store.Shared (createContact)
import Control.Monad
import Simplex.Messaging.Encoding.String (StrEncoding(..))
chatProfileTests :: SpecWith FilePath
chatProfileTests = do
@@ -633,7 +633,7 @@ testPlanAddressOwn tmp =
alice <## "alice_1 (Alice) wants to connect to you!"
alice <## "to accept: /ac alice_1"
alice <## "to reject: /rc alice_1 (the sender will NOT be notified)"
alice @@@ [("<@alice_1", ""), (":2","")]
alice @@@ [("<@alice_1", ""), (":2", "")]
alice ##> "/ac alice_1"
alice <## "alice_1 (Alice): accepting contact request..."
alice

View File

@@ -310,7 +310,7 @@ getInAnyOrder f cc ls = do
Predicate p -> p l
filterFirst :: (a -> Bool) -> [a] -> [a]
filterFirst _ [] = []
filterFirst p (x:xs)
filterFirst p (x : xs)
| p x = xs
| otherwise = x : filterFirst p xs
@@ -593,7 +593,7 @@ vRangeStr (VersionRange minVer maxVer) = "(" <> show minVer <> ", " <> show maxV
linkAnotherSchema :: String -> String
linkAnotherSchema link
| "https://simplex.chat/" `isPrefixOf` link =
T.unpack $ T.replace "https://simplex.chat/" "simplex:/" $ T.pack link
T.unpack $ T.replace "https://simplex.chat/" "simplex:/" $ T.pack link
| "simplex:/" `isPrefixOf` link =
T.unpack $ T.replace "simplex:/" "https://simplex.chat/" $ T.pack link
T.unpack $ T.replace "simplex:/" "https://simplex.chat/" $ T.pack link
| otherwise = error "link starts with neither https://simplex.chat/ nor simplex:/"

View File

@@ -38,6 +38,7 @@ remoteTests = describe "Remote" $ do
it "connects with stored pairing" remoteHandshakeStoredTest
it "connects with multicast discovery" remoteHandshakeDiscoverTest
it "refuses invalid client cert" remoteHandshakeRejectTest
it "connects with stored server bindings" storedBindingsTest
it "sends messages" remoteMessageTest
describe "remote files" $ do
it "store/get/send/receive files" remoteStoreFileTest
@@ -117,7 +118,7 @@ remoteHandshakeRejectTest = testChat3 aliceProfile aliceDesktopProfile bobProfil
mobileBob ##> "/set device name MobileBob"
mobileBob <## "ok"
desktop ##> "/start remote host 1"
desktop <##. "remote host 1 started on port "
desktop <##. "remote host 1 started on "
desktop <## "Remote session invitation:"
inv <- getTermLine desktop
mobileBob ##> ("/connect remote ctrl " <> inv)
@@ -138,6 +139,37 @@ remoteHandshakeRejectTest = testChat3 aliceProfile aliceDesktopProfile bobProfil
desktop <## "remote host 1 connected"
stopMobile mobile desktop
storedBindingsTest :: HasCallStack => FilePath -> IO ()
storedBindingsTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile desktop -> do
desktop ##> "/set device name My desktop"
desktop <## "ok"
mobile ##> "/set device name Mobile"
mobile <## "ok"
desktop ##> "/start remote host new addr=127.0.0.1 iface=lo port=52230"
desktop <##. "new remote host started on 127.0.0.1:52230" -- TODO: show ip?
desktop <## "Remote session invitation:"
inv <- getTermLine desktop
mobile ##> ("/connect remote ctrl " <> inv)
mobile <## ("connecting new remote controller: My desktop, v" <> versionNumber)
desktop <## "new remote host connecting"
mobile <## "new remote controller connected"
verifyRemoteCtrl mobile desktop
mobile <## "remote controller 1 session started with My desktop"
desktop <## "new remote host 1 added: Mobile"
desktop <## "remote host 1 connected"
desktop ##> "/list remote hosts"
desktop <## "Remote hosts:"
desktop <## "1. Mobile (connected) [lo 127.0.0.1:52230]"
stopDesktop mobile desktop
desktop ##> "/list remote hosts"
desktop <## "Remote hosts:"
desktop <## "1. Mobile [lo 127.0.0.1:52230]"
-- TODO: more parser tests
remoteMessageTest :: HasCallStack => FilePath -> IO ()
remoteMessageTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do
startRemote mobile desktop
@@ -475,7 +507,7 @@ startRemote mobile desktop = do
mobile ##> "/set device name Mobile"
mobile <## "ok"
desktop ##> "/start remote host new"
desktop <##. "new remote host started on port "
desktop <##. "new remote host started on "
desktop <## "Remote session invitation:"
inv <- getTermLine desktop
mobile ##> ("/connect remote ctrl " <> inv)
@@ -490,7 +522,7 @@ startRemote mobile desktop = do
startRemoteStored :: TestCC -> TestCC -> IO ()
startRemoteStored mobile desktop = do
desktop ##> "/start remote host 1"
desktop <##. "remote host 1 started on port "
desktop <##. "remote host 1 started on "
desktop <## "Remote session invitation:"
inv <- getTermLine desktop
mobile ##> ("/connect remote ctrl " <> inv)
@@ -504,7 +536,7 @@ startRemoteStored mobile desktop = do
startRemoteDiscover :: TestCC -> TestCC -> IO ()
startRemoteDiscover mobile desktop = do
desktop ##> "/start remote host 1 multicast=on"
desktop <##. "remote host 1 started on port "
desktop <##. "remote host 1 started on "
desktop <## "Remote session invitation:"
_inv <- getTermLine desktop -- will use multicast instead
mobile ##> "/find remote ctrl"

View File

@@ -13,8 +13,8 @@ import RemoteTests
import SchemaDump
import Test.Hspec
import UnliftIO.Temporary (withTempDirectory)
import ViewTests
import ValidNames
import ViewTests
import WebRTCTests
main :: IO ()