android-apps-mirrors/SimpleX-Chat
0
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-06-28 20:29:53 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

export C interface, started mobile app (#210)

Browse source 
* initial mobile app design draft

* add proposals

* xcode project

* refactor function to send to view as parameter

* export C interface

* remove unused files

* run chat from chatInit

* split chatStart to a separate function

* replace file-embed with QQ

* add mobile views

* server using IP address

* pass dbFilePrefix as parameter to chatInit

* comment on enabling logging

* fix mobile db config

* update C API, make user non-optional in ChatController

* restore SMP server addresses

* revert the change in the tests

* flip dependency - now Controller depends on Terminal

* make ChatController independent of terminal package

* fix Main.hs

* add iOS .gitignore

* refactor Simplex.Chat.Terminal

Co-authored-by: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin 2022-01-21 11:09:33 +00:00 • committed by GitHub
parent f47494e5c8
commit 64381be91d
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
36 changed files with 2211 additions and 777 deletions
Download patch file Download diff file Expand all files Collapse all files

65
apps/ios/.gitignore vendored Normal file
View file

@ -0,0 +1,65 @@
## User settings
xcuserdata/
## Obj-C/Swift specific
*.hmap
## App packaging
*.ipa
*.dSYM.zip
*.dSYM
# Swift Package Manager
#
# Add this line if you want to avoid checking in source code from Swift Package Manager dependencies.
# Packages/
# Package.pins
# Package.resolved
# *.xcodeproj
#
# Xcode automatically generates this directory with a .xcworkspacedata file and xcuserdata
# hence it is not needed unless you have added a package configuration file to your project
# .swiftpm
.build/
# CocoaPods
#
# We recommend against adding the Pods directory to your .gitignore. However
# you should judge for yourself, the pros and cons are mentioned at:
# https://guides.cocoapods.org/using/using-cocoapods.html#should-i-check-the-pods-directory-into-source-control
#
# Pods/
#
# Add this line if you want to avoid checking in source code from the Xcode workspace
# *.xcworkspace
# Carthage
#
# Add this line if you want to avoid checking in source code from Carthage dependencies.
# Carthage/Checkouts
Carthage/Build/
# Accio dependency management
Dependencies/
.accio/
# fastlane
#
# It is recommended to not store the screenshots in the git repo.
# Instead, use fastlane to re-generate the screenshots whenever they are needed.
# For more information about the recommended setup visit:
# https://docs.fastlane.tools/best-practices/source-control/#source-control
fastlane/report.xml
fastlane/Preview.html
fastlane/screenshots/**/*.png
fastlane/test_output
# Code Injection
#
# After new code Injection tools there's a generated folder /iOSInjectionProject
# https://github.com/johnno1962/injectionforxcode
iOSInjectionProject/

11
apps/ios/Shared/Assets.xcassets/AccentColor.colorset/Contents.json Normal file
View file

@ -0,0 +1,11 @@
{
"colors" : [
{
"idiom" : "universal"
}
],
"info" : {
"author" : "xcode",
"version" : 1
}
}

148
apps/ios/Shared/Assets.xcassets/AppIcon.appiconset/Contents.json Normal file
View file

@ -0,0 +1,148 @@
{
"images" : [
{
"idiom" : "iphone",
"scale" : "2x",
"size" : "20x20"
},
{
"idiom" : "iphone",
"scale" : "3x",
"size" : "20x20"
},
{
"idiom" : "iphone",
"scale" : "2x",
"size" : "29x29"
},
{
"idiom" : "iphone",
"scale" : "3x",
"size" : "29x29"
},
{
"idiom" : "iphone",
"scale" : "2x",
"size" : "40x40"
},
{
"idiom" : "iphone",
"scale" : "3x",
"size" : "40x40"
},
{
"idiom" : "iphone",
"scale" : "2x",
"size" : "60x60"
},
{
"idiom" : "iphone",
"scale" : "3x",
"size" : "60x60"
},
{
"idiom" : "ipad",
"scale" : "1x",
"size" : "20x20"
},
{
"idiom" : "ipad",
"scale" : "2x",
"size" : "20x20"
},
{
"idiom" : "ipad",
"scale" : "1x",
"size" : "29x29"
},
{
"idiom" : "ipad",
"scale" : "2x",
"size" : "29x29"
},
{
"idiom" : "ipad",
"scale" : "1x",
"size" : "40x40"
},
{
"idiom" : "ipad",
"scale" : "2x",
"size" : "40x40"
},
{
"idiom" : "ipad",
"scale" : "1x",
"size" : "76x76"
},
{
"idiom" : "ipad",
"scale" : "2x",
"size" : "76x76"
},
{
"idiom" : "ipad",
"scale" : "2x",
"size" : "83.5x83.5"
},
{
"idiom" : "ios-marketing",
"scale" : "1x",
"size" : "1024x1024"
},
{
"idiom" : "mac",
"scale" : "1x",
"size" : "16x16"
},
{
"idiom" : "mac",
"scale" : "2x",
"size" : "16x16"
},
{
"idiom" : "mac",
"scale" : "1x",
"size" : "32x32"
},
{
"idiom" : "mac",
"scale" : "2x",
"size" : "32x32"
},
{
"idiom" : "mac",
"scale" : "1x",
"size" : "128x128"
},
{
"idiom" : "mac",
"scale" : "2x",
"size" : "128x128"
},
{
"idiom" : "mac",
"scale" : "1x",
"size" : "256x256"
},
{
"idiom" : "mac",
"scale" : "2x",
"size" : "256x256"
},
{
"idiom" : "mac",
"scale" : "1x",
"size" : "512x512"
},
{
"idiom" : "mac",
"scale" : "2x",
"size" : "512x512"
}
],
"info" : {
"author" : "xcode",
"version" : 1
}
}

6
apps/ios/Shared/Assets.xcassets/Contents.json Normal file
View file

@ -0,0 +1,6 @@
{
"info" : {
"author" : "xcode",
"version" : 1
}
}

50
apps/ios/Shared/ContentView.swift Normal file
View file

@ -0,0 +1,50 @@
//
// ContentView.swift
// Shared
//
// Created by Evgeny Poberezkin on 17/01/2022.
//
import SwiftUI
struct ContentView: View {
@State var messages: [String] = ["Start session:"]
@State var text: String = ""
func sendMessage() {
}
var body: some View {
VStack {
ScrollView {
LazyVStack {
ForEach(messages, id: \.self) { msg in
MessageView(message: msg, sent: false)
}
}
.padding(10)
}
.frame(minWidth: 0,
maxWidth: .infinity,
minHeight: 0,
maxHeight: .infinity,
alignment: .topLeading)
HStack {
TextField("Message...", text: $text)
.textFieldStyle(RoundedBorderTextFieldStyle())
.frame(minHeight: CGFloat(30))
Button(action: sendMessage) {
Text("Send")
}.disabled(text.isEmpty)
}
.frame(minHeight: CGFloat(30))
.padding()
}
}
}
struct ContentView_Previews: PreviewProvider {
static var previews: some View {
ContentView(text: "Hello!")
}
}

34
apps/ios/Shared/MessageView.swift Normal file
View file

@ -0,0 +1,34 @@
//
// MessageView.swift
// SimpleX
//
// Created by Evgeny Poberezkin on 18/01/2022.
//
import SwiftUI
struct MessageView: View {
var message: String
var sent: Bool
let receivedColor: Color = Color(UIColor(red: 240/255, green: 240/255, blue: 240/255, alpha: 1.0))
var body: some View {
Text(message)
.padding(10)
.foregroundColor(sent ? Color.white : Color.black)
.background(sent ? Color.blue : receivedColor)
.cornerRadius(10)
.frame(minWidth: 100,
maxWidth: .infinity,
minHeight: 0,
maxHeight: .infinity,
alignment: .leading)
}
}
struct MessageView_Previews: PreviewProvider {
static var previews: some View {
MessageView(message: "> Send message: \"Hello world!\"\nSuccessful", sent: false)
}
}

32
apps/ios/Shared/ProfileView.swift Normal file
View file

@ -0,0 +1,32 @@
//
// ProfileView.swift
// SimpleX
//
// Created by Evgeny Poberezkin on 18/01/2022.
//
import SwiftUI
struct ProfileView: View {
@State var displayName: String = ""
@State var fullName: String = ""
var body: some View {
VStack(alignment: .leading) {
Text("Create profile")
.font(.largeTitle)
.padding(.bottom)
Text("Your profile is stored on your device and shared only with your contacts.\nSimpleX servers cannot see your profile.")
.padding(.bottom)
TextField("Display name", text: $displayName)
.padding(.bottom)
TextField("Full name (optional)", text: $fullName)
}
.padding()
}
}
struct ProfileView_Previews: PreviewProvider {
static var previews: some View {
ProfileView()
}
}

17
apps/ios/Shared/SimpleXApp.swift Normal file
View file

@ -0,0 +1,17 @@
//
// SimpleXApp.swift
// Shared
//
// Created by Evgeny Poberezkin on 17/01/2022.
//
import SwiftUI
@main
struct SimpleXApp: App {
var body: some Scene {
WindowGroup {
ContentView()
}
}
}

720
apps/ios/SimpleX.xcodeproj/project.pbxproj Normal file
View file

@ -0,0 +1,720 @@
// !$*UTF8*$!
{
archiveVersion = 1;
classes = {
};
objectVersion = 55;
objects = {
/* Begin PBXBuildFile section */
5CA059DC279559F40002BEB4 /* Tests_iOS.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059DB279559F40002BEB4 /* Tests_iOS.swift */; };
5CA059DE279559F40002BEB4 /* Tests_iOSLaunchTests.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059DD279559F40002BEB4 /* Tests_iOSLaunchTests.swift */; };
5CA059E8279559F40002BEB4 /* Tests_macOS.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059E7279559F40002BEB4 /* Tests_macOS.swift */; };
5CA059EA279559F40002BEB4 /* Tests_macOSLaunchTests.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059E9279559F40002BEB4 /* Tests_macOSLaunchTests.swift */; };
5CA059EB279559F40002BEB4 /* SimpleXApp.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059C3279559F40002BEB4 /* SimpleXApp.swift */; };
5CA059EC279559F40002BEB4 /* SimpleXApp.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059C3279559F40002BEB4 /* SimpleXApp.swift */; };
5CA059ED279559F40002BEB4 /* ContentView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059C4279559F40002BEB4 /* ContentView.swift */; };
5CA059EE279559F40002BEB4 /* ContentView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059C4279559F40002BEB4 /* ContentView.swift */; };
5CA059EF279559F40002BEB4 /* Assets.xcassets in Resources */ = {isa = PBXBuildFile; fileRef = 5CA059C5279559F40002BEB4 /* Assets.xcassets */; };
5CA059F0279559F40002BEB4 /* Assets.xcassets in Resources */ = {isa = PBXBuildFile; fileRef = 5CA059C5279559F40002BEB4 /* Assets.xcassets */; };
5CA05A4C27974EB60002BEB4 /* ProfileView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA05A4B27974EB60002BEB4 /* ProfileView.swift */; };
5CA05A4D27974EB60002BEB4 /* ProfileView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA05A4B27974EB60002BEB4 /* ProfileView.swift */; };
5CA05A4F279752D00002BEB4 /* MessageView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA05A4E279752D00002BEB4 /* MessageView.swift */; };
5CA05A50279752D00002BEB4 /* MessageView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA05A4E279752D00002BEB4 /* MessageView.swift */; };
/* End PBXBuildFile section */
/* Begin PBXContainerItemProxy section */
5CA059D8279559F40002BEB4 /* PBXContainerItemProxy */ = {
isa = PBXContainerItemProxy;
containerPortal = 5CA059BE279559F40002BEB4 /* Project object */;
proxyType = 1;
remoteGlobalIDString = 5CA059C9279559F40002BEB4;
remoteInfo = "SimpleX (iOS)";
};
5CA059E4279559F40002BEB4 /* PBXContainerItemProxy */ = {
isa = PBXContainerItemProxy;
containerPortal = 5CA059BE279559F40002BEB4 /* Project object */;
proxyType = 1;
remoteGlobalIDString = 5CA059CF279559F40002BEB4;
remoteInfo = "SimpleX (macOS)";
};
/* End PBXContainerItemProxy section */
/* Begin PBXFileReference section */
5CA059C3279559F40002BEB4 /* SimpleXApp.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = SimpleXApp.swift; sourceTree = "<group>"; };
5CA059C4279559F40002BEB4 /* ContentView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = ContentView.swift; sourceTree = "<group>"; };
5CA059C5279559F40002BEB4 /* Assets.xcassets */ = {isa = PBXFileReference; lastKnownFileType = folder.assetcatalog; path = Assets.xcassets; sourceTree = "<group>"; };
5CA059CA279559F40002BEB4 /* SimpleX.app */ = {isa = PBXFileReference; explicitFileType = wrapper.application; includeInIndex = 0; path = SimpleX.app; sourceTree = BUILT_PRODUCTS_DIR; };
5CA059D0279559F40002BEB4 /* SimpleX.app */ = {isa = PBXFileReference; explicitFileType = wrapper.application; includeInIndex = 0; path = SimpleX.app; sourceTree = BUILT_PRODUCTS_DIR; };
5CA059D2279559F40002BEB4 /* macOS.entitlements */ = {isa = PBXFileReference; lastKnownFileType = text.plist.entitlements; path = macOS.entitlements; sourceTree = "<group>"; };
5CA059D7279559F40002BEB4 /* Tests iOS.xctest */ = {isa = PBXFileReference; explicitFileType = wrapper.cfbundle; includeInIndex = 0; path = "Tests iOS.xctest"; sourceTree = BUILT_PRODUCTS_DIR; };
5CA059DB279559F40002BEB4 /* Tests_iOS.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = Tests_iOS.swift; sourceTree = "<group>"; };
5CA059DD279559F40002BEB4 /* Tests_iOSLaunchTests.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = Tests_iOSLaunchTests.swift; sourceTree = "<group>"; };
5CA059E3279559F40002BEB4 /* Tests macOS.xctest */ = {isa = PBXFileReference; explicitFileType = wrapper.cfbundle; includeInIndex = 0; path = "Tests macOS.xctest"; sourceTree = BUILT_PRODUCTS_DIR; };
5CA059E7279559F40002BEB4 /* Tests_macOS.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = Tests_macOS.swift; sourceTree = "<group>"; };
5CA059E9279559F40002BEB4 /* Tests_macOSLaunchTests.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = Tests_macOSLaunchTests.swift; sourceTree = "<group>"; };
5CA05A4B27974EB60002BEB4 /* ProfileView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = ProfileView.swift; sourceTree = "<group>"; };
5CA05A4E279752D00002BEB4 /* MessageView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = MessageView.swift; sourceTree = "<group>"; };
/* End PBXFileReference section */
/* Begin PBXFrameworksBuildPhase section */
5CA059C7279559F40002BEB4 /* Frameworks */ = {
isa = PBXFrameworksBuildPhase;
buildActionMask = 2147483647;
files = (
);
runOnlyForDeploymentPostprocessing = 0;
};
5CA059CD279559F40002BEB4 /* Frameworks */ = {
isa = PBXFrameworksBuildPhase;
buildActionMask = 2147483647;
files = (
);
runOnlyForDeploymentPostprocessing = 0;
};
5CA059D4279559F40002BEB4 /* Frameworks */ = {
isa = PBXFrameworksBuildPhase;
buildActionMask = 2147483647;
files = (
);
runOnlyForDeploymentPostprocessing = 0;
};
5CA059E0279559F40002BEB4 /* Frameworks */ = {
isa = PBXFrameworksBuildPhase;
buildActionMask = 2147483647;
files = (
);
runOnlyForDeploymentPostprocessing = 0;
};
/* End PBXFrameworksBuildPhase section */
/* Begin PBXGroup section */
5CA059BD279559F40002BEB4 = {
isa = PBXGroup;
children = (
5CA059C2279559F40002BEB4 /* Shared */,
5CA059D1279559F40002BEB4 /* macOS */,
5CA059DA279559F40002BEB4 /* Tests iOS */,
5CA059E6279559F40002BEB4 /* Tests macOS */,
5CA059CB279559F40002BEB4 /* Products */,
);
sourceTree = "<group>";
};
5CA059C2279559F40002BEB4 /* Shared */ = {
isa = PBXGroup;
children = (
5CA059C3279559F40002BEB4 /* SimpleXApp.swift */,
5CA059C4279559F40002BEB4 /* ContentView.swift */,
5CA05A4B27974EB60002BEB4 /* ProfileView.swift */,
5CA05A4E279752D00002BEB4 /* MessageView.swift */,
5CA059C5279559F40002BEB4 /* Assets.xcassets */,
);
path = Shared;
sourceTree = "<group>";
};
5CA059CB279559F40002BEB4 /* Products */ = {
isa = PBXGroup;
children = (
5CA059CA279559F40002BEB4 /* SimpleX.app */,
5CA059D0279559F40002BEB4 /* SimpleX.app */,
5CA059D7279559F40002BEB4 /* Tests iOS.xctest */,
5CA059E3279559F40002BEB4 /* Tests macOS.xctest */,
);
name = Products;
sourceTree = "<group>";
};
5CA059D1279559F40002BEB4 /* macOS */ = {
isa = PBXGroup;
children = (
5CA059D2279559F40002BEB4 /* macOS.entitlements */,
);
path = macOS;
sourceTree = "<group>";
};
5CA059DA279559F40002BEB4 /* Tests iOS */ = {
isa = PBXGroup;
children = (
5CA059DB279559F40002BEB4 /* Tests_iOS.swift */,
5CA059DD279559F40002BEB4 /* Tests_iOSLaunchTests.swift */,
);
path = "Tests iOS";
sourceTree = "<group>";
};
5CA059E6279559F40002BEB4 /* Tests macOS */ = {
isa = PBXGroup;
children = (
5CA059E7279559F40002BEB4 /* Tests_macOS.swift */,
5CA059E9279559F40002BEB4 /* Tests_macOSLaunchTests.swift */,
);
path = "Tests macOS";
sourceTree = "<group>";
};
/* End PBXGroup section */
/* Begin PBXNativeTarget section */
5CA059C9279559F40002BEB4 /* SimpleX (iOS) */ = {
isa = PBXNativeTarget;
buildConfigurationList = 5CA059F3279559F40002BEB4 /* Build configuration list for PBXNativeTarget "SimpleX (iOS)" */;
buildPhases = (
5CA059C6279559F40002BEB4 /* Sources */,
5CA059C7279559F40002BEB4 /* Frameworks */,
5CA059C8279559F40002BEB4 /* Resources */,
);
buildRules = (
);
dependencies = (
);
name = "SimpleX (iOS)";
productName = "SimpleX (iOS)";
productReference = 5CA059CA279559F40002BEB4 /* SimpleX.app */;
productType = "com.apple.product-type.application";
};
5CA059CF279559F40002BEB4 /* SimpleX (macOS) */ = {
isa = PBXNativeTarget;
buildConfigurationList = 5CA059F6279559F40002BEB4 /* Build configuration list for PBXNativeTarget "SimpleX (macOS)" */;
buildPhases = (
5CA059CC279559F40002BEB4 /* Sources */,
5CA059CD279559F40002BEB4 /* Frameworks */,
5CA059CE279559F40002BEB4 /* Resources */,
);
buildRules = (
);
dependencies = (
);
name = "SimpleX (macOS)";
productName = "SimpleX (macOS)";
productReference = 5CA059D0279559F40002BEB4 /* SimpleX.app */;
productType = "com.apple.product-type.application";
};
5CA059D6279559F40002BEB4 /* Tests iOS */ = {
isa = PBXNativeTarget;
buildConfigurationList = 5CA059F9279559F40002BEB4 /* Build configuration list for PBXNativeTarget "Tests iOS" */;
buildPhases = (
5CA059D3279559F40002BEB4 /* Sources */,
5CA059D4279559F40002BEB4 /* Frameworks */,
5CA059D5279559F40002BEB4 /* Resources */,
);
buildRules = (
);
dependencies = (
5CA059D9279559F40002BEB4 /* PBXTargetDependency */,
);
name = "Tests iOS";
productName = "Tests iOS";
productReference = 5CA059D7279559F40002BEB4 /* Tests iOS.xctest */;
productType = "com.apple.product-type.bundle.ui-testing";
};
5CA059E2279559F40002BEB4 /* Tests macOS */ = {
isa = PBXNativeTarget;
buildConfigurationList = 5CA059FC279559F40002BEB4 /* Build configuration list for PBXNativeTarget "Tests macOS" */;
buildPhases = (
5CA059DF279559F40002BEB4 /* Sources */,
5CA059E0279559F40002BEB4 /* Frameworks */,
5CA059E1279559F40002BEB4 /* Resources */,
);
buildRules = (
);
dependencies = (
5CA059E5279559F40002BEB4 /* PBXTargetDependency */,
);
name = "Tests macOS";
productName = "Tests macOS";
productReference = 5CA059E3279559F40002BEB4 /* Tests macOS.xctest */;
productType = "com.apple.product-type.bundle.ui-testing";
};
/* End PBXNativeTarget section */
/* Begin PBXProject section */
5CA059BE279559F40002BEB4 /* Project object */ = {
isa = PBXProject;
attributes = {
BuildIndependentTargetsInParallel = 1;
LastSwiftUpdateCheck = 1320;
LastUpgradeCheck = 1320;
TargetAttributes = {
5CA059C9279559F40002BEB4 = {
CreatedOnToolsVersion = 13.2.1;
};
5CA059CF279559F40002BEB4 = {
CreatedOnToolsVersion = 13.2.1;
};
5CA059D6279559F40002BEB4 = {
CreatedOnToolsVersion = 13.2.1;
TestTargetID = 5CA059C9279559F40002BEB4;
};
5CA059E2279559F40002BEB4 = {
CreatedOnToolsVersion = 13.2.1;
TestTargetID = 5CA059CF279559F40002BEB4;
};
};
};
buildConfigurationList = 5CA059C1279559F40002BEB4 /* Build configuration list for PBXProject "SimpleX" */;
compatibilityVersion = "Xcode 13.0";
developmentRegion = en;
hasScannedForEncodings = 0;
knownRegions = (
en,
Base,
);
mainGroup = 5CA059BD279559F40002BEB4;
productRefGroup = 5CA059CB279559F40002BEB4 /* Products */;
projectDirPath = "";
projectRoot = "";
targets = (
5CA059C9279559F40002BEB4 /* SimpleX (iOS) */,
5CA059CF279559F40002BEB4 /* SimpleX (macOS) */,
5CA059D6279559F40002BEB4 /* Tests iOS */,
5CA059E2279559F40002BEB4 /* Tests macOS */,
);
};
/* End PBXProject section */
/* Begin PBXResourcesBuildPhase section */
5CA059C8279559F40002BEB4 /* Resources */ = {
isa = PBXResourcesBuildPhase;
buildActionMask = 2147483647;
files = (
5CA059EF279559F40002BEB4 /* Assets.xcassets in Resources */,
);
runOnlyForDeploymentPostprocessing = 0;
};
5CA059CE279559F40002BEB4 /* Resources */ = {
isa = PBXResourcesBuildPhase;
buildActionMask = 2147483647;
files = (
5CA059F0279559F40002BEB4 /* Assets.xcassets in Resources */,
);
runOnlyForDeploymentPostprocessing = 0;
};
5CA059D5279559F40002BEB4 /* Resources */ = {
isa = PBXResourcesBuildPhase;
buildActionMask = 2147483647;
files = (
);
runOnlyForDeploymentPostprocessing = 0;
};
5CA059E1279559F40002BEB4 /* Resources */ = {
isa = PBXResourcesBuildPhase;
buildActionMask = 2147483647;
files = (
);
runOnlyForDeploymentPostprocessing = 0;
};
/* End PBXResourcesBuildPhase section */
/* Begin PBXSourcesBuildPhase section */
5CA059C6279559F40002BEB4 /* Sources */ = {
isa = PBXSourcesBuildPhase;
buildActionMask = 2147483647;
files = (
5CA05A4F279752D00002BEB4 /* MessageView.swift in Sources */,
5CA059ED279559F40002BEB4 /* ContentView.swift in Sources */,
5CA05A4C27974EB60002BEB4 /* ProfileView.swift in Sources */,
5CA059EB279559F40002BEB4 /* SimpleXApp.swift in Sources */,
);
runOnlyForDeploymentPostprocessing = 0;
};
5CA059CC279559F40002BEB4 /* Sources */ = {
isa = PBXSourcesBuildPhase;
buildActionMask = 2147483647;
files = (
5CA05A50279752D00002BEB4 /* MessageView.swift in Sources */,
5CA059EE279559F40002BEB4 /* ContentView.swift in Sources */,
5CA05A4D27974EB60002BEB4 /* ProfileView.swift in Sources */,
5CA059EC279559F40002BEB4 /* SimpleXApp.swift in Sources */,
);
runOnlyForDeploymentPostprocessing = 0;
};
5CA059D3279559F40002BEB4 /* Sources */ = {
isa = PBXSourcesBuildPhase;
buildActionMask = 2147483647;
files = (
5CA059DE279559F40002BEB4 /* Tests_iOSLaunchTests.swift in Sources */,
5CA059DC279559F40002BEB4 /* Tests_iOS.swift in Sources */,
);
runOnlyForDeploymentPostprocessing = 0;
};
5CA059DF279559F40002BEB4 /* Sources */ = {
isa = PBXSourcesBuildPhase;
buildActionMask = 2147483647;
files = (
5CA059EA279559F40002BEB4 /* Tests_macOSLaunchTests.swift in Sources */,
5CA059E8279559F40002BEB4 /* Tests_macOS.swift in Sources */,
);
runOnlyForDeploymentPostprocessing = 0;
};
/* End PBXSourcesBuildPhase section */
/* Begin PBXTargetDependency section */
5CA059D9279559F40002BEB4 /* PBXTargetDependency */ = {
isa = PBXTargetDependency;
target = 5CA059C9279559F40002BEB4 /* SimpleX (iOS) */;
targetProxy = 5CA059D8279559F40002BEB4 /* PBXContainerItemProxy */;
};
5CA059E5279559F40002BEB4 /* PBXTargetDependency */ = {
isa = PBXTargetDependency;
target = 5CA059CF279559F40002BEB4 /* SimpleX (macOS) */;
targetProxy = 5CA059E4279559F40002BEB4 /* PBXContainerItemProxy */;
};
/* End PBXTargetDependency section */
/* Begin XCBuildConfiguration section */
5CA059F1279559F40002BEB4 /* Debug */ = {
isa = XCBuildConfiguration;
buildSettings = {
ALWAYS_SEARCH_USER_PATHS = NO;
CLANG_ANALYZER_NONNULL = YES;
CLANG_ANALYZER_NUMBER_OBJECT_CONVERSION = YES_AGGRESSIVE;
CLANG_CXX_LANGUAGE_STANDARD = "gnu++17";
CLANG_CXX_LIBRARY = "libc++";
CLANG_ENABLE_MODULES = YES;
CLANG_ENABLE_OBJC_ARC = YES;
CLANG_ENABLE_OBJC_WEAK = YES;
CLANG_WARN_BLOCK_CAPTURE_AUTORELEASING = YES;
CLANG_WARN_BOOL_CONVERSION = YES;
CLANG_WARN_COMMA = YES;
CLANG_WARN_CONSTANT_CONVERSION = YES;
CLANG_WARN_DEPRECATED_OBJC_IMPLEMENTATIONS = YES;
CLANG_WARN_DIRECT_OBJC_ISA_USAGE = YES_ERROR;
CLANG_WARN_DOCUMENTATION_COMMENTS = YES;
CLANG_WARN_EMPTY_BODY = YES;
CLANG_WARN_ENUM_CONVERSION = YES;
CLANG_WARN_INFINITE_RECURSION = YES;
CLANG_WARN_INT_CONVERSION = YES;
CLANG_WARN_NON_LITERAL_NULL_CONVERSION = YES;
CLANG_WARN_OBJC_IMPLICIT_RETAIN_SELF = YES;
CLANG_WARN_OBJC_LITERAL_CONVERSION = YES;
CLANG_WARN_OBJC_ROOT_CLASS = YES_ERROR;
CLANG_WARN_QUOTED_INCLUDE_IN_FRAMEWORK_HEADER = YES;
CLANG_WARN_RANGE_LOOP_ANALYSIS = YES;
CLANG_WARN_STRICT_PROTOTYPES = YES;
CLANG_WARN_SUSPICIOUS_MOVE = YES;
CLANG_WARN_UNGUARDED_AVAILABILITY = YES_AGGRESSIVE;
CLANG_WARN_UNREACHABLE_CODE = YES;
CLANG_WARN__DUPLICATE_METHOD_MATCH = YES;
COPY_PHASE_STRIP = NO;
DEBUG_INFORMATION_FORMAT = dwarf;
ENABLE_STRICT_OBJC_MSGSEND = YES;
ENABLE_TESTABILITY = YES;
GCC_C_LANGUAGE_STANDARD = gnu11;
GCC_DYNAMIC_NO_PIC = NO;
GCC_NO_COMMON_BLOCKS = YES;
GCC_OPTIMIZATION_LEVEL = 0;
GCC_PREPROCESSOR_DEFINITIONS = (
"DEBUG=1",
"$(inherited)",
);
GCC_WARN_64_TO_32_BIT_CONVERSION = YES;
GCC_WARN_ABOUT_RETURN_TYPE = YES_ERROR;
GCC_WARN_UNDECLARED_SELECTOR = YES;
GCC_WARN_UNINITIALIZED_AUTOS = YES_AGGRESSIVE;
GCC_WARN_UNUSED_FUNCTION = YES;
GCC_WARN_UNUSED_VARIABLE = YES;
MTL_ENABLE_DEBUG_INFO = INCLUDE_SOURCE;
MTL_FAST_MATH = YES;
ONLY_ACTIVE_ARCH = YES;
SWIFT_ACTIVE_COMPILATION_CONDITIONS = DEBUG;
SWIFT_OPTIMIZATION_LEVEL = "-Onone";
};
name = Debug;
};
5CA059F2279559F40002BEB4 /* Release */ = {
isa = XCBuildConfiguration;
buildSettings = {
ALWAYS_SEARCH_USER_PATHS = NO;
CLANG_ANALYZER_NONNULL = YES;
CLANG_ANALYZER_NUMBER_OBJECT_CONVERSION = YES_AGGRESSIVE;
CLANG_CXX_LANGUAGE_STANDARD = "gnu++17";
CLANG_CXX_LIBRARY = "libc++";
CLANG_ENABLE_MODULES = YES;
CLANG_ENABLE_OBJC_ARC = YES;
CLANG_ENABLE_OBJC_WEAK = YES;
CLANG_WARN_BLOCK_CAPTURE_AUTORELEASING = YES;
CLANG_WARN_BOOL_CONVERSION = YES;
CLANG_WARN_COMMA = YES;
CLANG_WARN_CONSTANT_CONVERSION = YES;
CLANG_WARN_DEPRECATED_OBJC_IMPLEMENTATIONS = YES;
CLANG_WARN_DIRECT_OBJC_ISA_USAGE = YES_ERROR;
CLANG_WARN_DOCUMENTATION_COMMENTS = YES;
CLANG_WARN_EMPTY_BODY = YES;
CLANG_WARN_ENUM_CONVERSION = YES;
CLANG_WARN_INFINITE_RECURSION = YES;
CLANG_WARN_INT_CONVERSION = YES;
CLANG_WARN_NON_LITERAL_NULL_CONVERSION = YES;
CLANG_WARN_OBJC_IMPLICIT_RETAIN_SELF = YES;
CLANG_WARN_OBJC_LITERAL_CONVERSION = YES;
CLANG_WARN_OBJC_ROOT_CLASS = YES_ERROR;
CLANG_WARN_QUOTED_INCLUDE_IN_FRAMEWORK_HEADER = YES;
CLANG_WARN_RANGE_LOOP_ANALYSIS = YES;
CLANG_WARN_STRICT_PROTOTYPES = YES;
CLANG_WARN_SUSPICIOUS_MOVE = YES;
CLANG_WARN_UNGUARDED_AVAILABILITY = YES_AGGRESSIVE;
CLANG_WARN_UNREACHABLE_CODE = YES;
CLANG_WARN__DUPLICATE_METHOD_MATCH = YES;
COPY_PHASE_STRIP = NO;
DEBUG_INFORMATION_FORMAT = "dwarf-with-dsym";
ENABLE_NS_ASSERTIONS = NO;
ENABLE_STRICT_OBJC_MSGSEND = YES;
GCC_C_LANGUAGE_STANDARD = gnu11;
GCC_NO_COMMON_BLOCKS = YES;
GCC_WARN_64_TO_32_BIT_CONVERSION = YES;
GCC_WARN_ABOUT_RETURN_TYPE = YES_ERROR;
GCC_WARN_UNDECLARED_SELECTOR = YES;
GCC_WARN_UNINITIALIZED_AUTOS = YES_AGGRESSIVE;
GCC_WARN_UNUSED_FUNCTION = YES;
GCC_WARN_UNUSED_VARIABLE = YES;
MTL_ENABLE_DEBUG_INFO = NO;
MTL_FAST_MATH = YES;
SWIFT_COMPILATION_MODE = wholemodule;
SWIFT_OPTIMIZATION_LEVEL = "-O";
};
name = Release;
};
5CA059F4279559F40002BEB4 /* Debug */ = {
isa = XCBuildConfiguration;
buildSettings = {
ASSETCATALOG_COMPILER_APPICON_NAME = AppIcon;
ASSETCATALOG_COMPILER_GLOBAL_ACCENT_COLOR_NAME = AccentColor;
CODE_SIGN_STYLE = Automatic;
CURRENT_PROJECT_VERSION = 1;
DEVELOPMENT_TEAM = 9767FTRA3G;
ENABLE_PREVIEWS = YES;
GENERATE_INFOPLIST_FILE = YES;
INFOPLIST_KEY_UIApplicationSceneManifest_Generation = YES;
INFOPLIST_KEY_UIApplicationSupportsIndirectInputEvents = YES;
INFOPLIST_KEY_UILaunchScreen_Generation = YES;
INFOPLIST_KEY_UISupportedInterfaceOrientations_iPad = "UIInterfaceOrientationPortrait UIInterfaceOrientationPortraitUpsideDown UIInterfaceOrientationLandscapeLeft UIInterfaceOrientationLandscapeRight";
INFOPLIST_KEY_UISupportedInterfaceOrientations_iPhone = "UIInterfaceOrientationPortrait UIInterfaceOrientationLandscapeLeft UIInterfaceOrientationLandscapeRight";
IPHONEOS_DEPLOYMENT_TARGET = 15.2;
LD_RUNPATH_SEARCH_PATHS = (
"$(inherited)",
"@executable_path/Frameworks",
);
MARKETING_VERSION = 1.0;
PRODUCT_BUNDLE_IDENTIFIER = chat.simplex.SimpleX;
PRODUCT_NAME = SimpleX;
SDKROOT = iphoneos;
SWIFT_EMIT_LOC_STRINGS = YES;
SWIFT_VERSION = 5.0;
TARGETED_DEVICE_FAMILY = "1,2";
};
name = Debug;
};
5CA059F5279559F40002BEB4 /* Release */ = {
isa = XCBuildConfiguration;
buildSettings = {
ASSETCATALOG_COMPILER_APPICON_NAME = AppIcon;
ASSETCATALOG_COMPILER_GLOBAL_ACCENT_COLOR_NAME = AccentColor;
CODE_SIGN_STYLE = Automatic;
CURRENT_PROJECT_VERSION = 1;
DEVELOPMENT_TEAM = 9767FTRA3G;
ENABLE_PREVIEWS = YES;
GENERATE_INFOPLIST_FILE = YES;
INFOPLIST_KEY_UIApplicationSceneManifest_Generation = YES;
INFOPLIST_KEY_UIApplicationSupportsIndirectInputEvents = YES;
INFOPLIST_KEY_UILaunchScreen_Generation = YES;
INFOPLIST_KEY_UISupportedInterfaceOrientations_iPad = "UIInterfaceOrientationPortrait UIInterfaceOrientationPortraitUpsideDown UIInterfaceOrientationLandscapeLeft UIInterfaceOrientationLandscapeRight";
INFOPLIST_KEY_UISupportedInterfaceOrientations_iPhone = "UIInterfaceOrientationPortrait UIInterfaceOrientationLandscapeLeft UIInterfaceOrientationLandscapeRight";
IPHONEOS_DEPLOYMENT_TARGET = 15.2;
LD_RUNPATH_SEARCH_PATHS = (
"$(inherited)",
"@executable_path/Frameworks",
);
MARKETING_VERSION = 1.0;
PRODUCT_BUNDLE_IDENTIFIER = chat.simplex.SimpleX;
PRODUCT_NAME = SimpleX;
SDKROOT = iphoneos;
SWIFT_EMIT_LOC_STRINGS = YES;
SWIFT_VERSION = 5.0;
TARGETED_DEVICE_FAMILY = "1,2";
VALIDATE_PRODUCT = YES;
};
name = Release;
};
5CA059F7279559F40002BEB4 /* Debug */ = {
isa = XCBuildConfiguration;
buildSettings = {
ASSETCATALOG_COMPILER_APPICON_NAME = AppIcon;
ASSETCATALOG_COMPILER_GLOBAL_ACCENT_COLOR_NAME = AccentColor;
CODE_SIGN_ENTITLEMENTS = macOS/macOS.entitlements;
CODE_SIGN_STYLE = Automatic;
COMBINE_HIDPI_IMAGES = YES;
CURRENT_PROJECT_VERSION = 1;
DEVELOPMENT_TEAM = 9767FTRA3G;
ENABLE_HARDENED_RUNTIME = YES;
ENABLE_PREVIEWS = YES;
GENERATE_INFOPLIST_FILE = YES;
INFOPLIST_KEY_NSHumanReadableCopyright = "";
LD_RUNPATH_SEARCH_PATHS = (
"$(inherited)",
"@executable_path/../Frameworks",
);
MACOSX_DEPLOYMENT_TARGET = 12.1;
MARKETING_VERSION = 1.0;
PRODUCT_BUNDLE_IDENTIFIER = chat.simplex.SimpleX;
PRODUCT_NAME = SimpleX;
SDKROOT = macosx;
SWIFT_EMIT_LOC_STRINGS = YES;
SWIFT_VERSION = 5.0;
};
name = Debug;
};
5CA059F8279559F40002BEB4 /* Release */ = {
isa = XCBuildConfiguration;
buildSettings = {
ASSETCATALOG_COMPILER_APPICON_NAME = AppIcon;
ASSETCATALOG_COMPILER_GLOBAL_ACCENT_COLOR_NAME = AccentColor;
CODE_SIGN_ENTITLEMENTS = macOS/macOS.entitlements;
CODE_SIGN_STYLE = Automatic;
COMBINE_HIDPI_IMAGES = YES;
CURRENT_PROJECT_VERSION = 1;
DEVELOPMENT_TEAM = 9767FTRA3G;
ENABLE_HARDENED_RUNTIME = YES;
ENABLE_PREVIEWS = YES;
GENERATE_INFOPLIST_FILE = YES;
INFOPLIST_KEY_NSHumanReadableCopyright = "";
LD_RUNPATH_SEARCH_PATHS = (
"$(inherited)",
"@executable_path/../Frameworks",
);
MACOSX_DEPLOYMENT_TARGET = 12.1;
MARKETING_VERSION = 1.0;
PRODUCT_BUNDLE_IDENTIFIER = chat.simplex.SimpleX;
PRODUCT_NAME = SimpleX;
SDKROOT = macosx;
SWIFT_EMIT_LOC_STRINGS = YES;
SWIFT_VERSION = 5.0;
};
name = Release;
};
5CA059FA279559F40002BEB4 /* Debug */ = {
isa = XCBuildConfiguration;
buildSettings = {
ALWAYS_EMBED_SWIFT_STANDARD_LIBRARIES = YES;
CODE_SIGN_STYLE = Automatic;
CURRENT_PROJECT_VERSION = 1;
DEVELOPMENT_TEAM = 9767FTRA3G;
GENERATE_INFOPLIST_FILE = YES;
IPHONEOS_DEPLOYMENT_TARGET = 15.2;
MARKETING_VERSION = 1.0;
PRODUCT_BUNDLE_IDENTIFIER = "chat.simplex.Tests-iOS";
PRODUCT_NAME = "$(TARGET_NAME)";
SDKROOT = iphoneos;
SWIFT_EMIT_LOC_STRINGS = NO;
SWIFT_VERSION = 5.0;
TARGETED_DEVICE_FAMILY = "1,2";
TEST_TARGET_NAME = "SimpleX (iOS)";
};
name = Debug;
};
5CA059FB279559F40002BEB4 /* Release */ = {
isa = XCBuildConfiguration;
buildSettings = {
ALWAYS_EMBED_SWIFT_STANDARD_LIBRARIES = YES;
CODE_SIGN_STYLE = Automatic;
CURRENT_PROJECT_VERSION = 1;
DEVELOPMENT_TEAM = 9767FTRA3G;
GENERATE_INFOPLIST_FILE = YES;
IPHONEOS_DEPLOYMENT_TARGET = 15.2;
MARKETING_VERSION = 1.0;
PRODUCT_BUNDLE_IDENTIFIER = "chat.simplex.Tests-iOS";
PRODUCT_NAME = "$(TARGET_NAME)";
SDKROOT = iphoneos;
SWIFT_EMIT_LOC_STRINGS = NO;
SWIFT_VERSION = 5.0;
TARGETED_DEVICE_FAMILY = "1,2";
TEST_TARGET_NAME = "SimpleX (iOS)";
VALIDATE_PRODUCT = YES;
};
name = Release;
};
5CA059FD279559F40002BEB4 /* Debug */ = {
isa = XCBuildConfiguration;
buildSettings = {
ALWAYS_EMBED_SWIFT_STANDARD_LIBRARIES = YES;
CODE_SIGN_STYLE = Automatic;
CURRENT_PROJECT_VERSION = 1;
DEVELOPMENT_TEAM = 9767FTRA3G;
GENERATE_INFOPLIST_FILE = YES;
MACOSX_DEPLOYMENT_TARGET = 12.1;
MARKETING_VERSION = 1.0;
PRODUCT_BUNDLE_IDENTIFIER = "chat.simplex.Tests-macOS";
PRODUCT_NAME = "$(TARGET_NAME)";
SDKROOT = macosx;
SWIFT_EMIT_LOC_STRINGS = NO;
SWIFT_VERSION = 5.0;
TEST_TARGET_NAME = "SimpleX (macOS)";
};
name = Debug;
};
5CA059FE279559F40002BEB4 /* Release */ = {
isa = XCBuildConfiguration;
buildSettings = {
ALWAYS_EMBED_SWIFT_STANDARD_LIBRARIES = YES;
CODE_SIGN_STYLE = Automatic;
CURRENT_PROJECT_VERSION = 1;
DEVELOPMENT_TEAM = 9767FTRA3G;
GENERATE_INFOPLIST_FILE = YES;
MACOSX_DEPLOYMENT_TARGET = 12.1;
MARKETING_VERSION = 1.0;
PRODUCT_BUNDLE_IDENTIFIER = "chat.simplex.Tests-macOS";
PRODUCT_NAME = "$(TARGET_NAME)";
SDKROOT = macosx;
SWIFT_EMIT_LOC_STRINGS = NO;
SWIFT_VERSION = 5.0;
TEST_TARGET_NAME = "SimpleX (macOS)";
};
name = Release;
};
/* End XCBuildConfiguration section */
/* Begin XCConfigurationList section */
5CA059C1279559F40002BEB4 /* Build configuration list for PBXProject "SimpleX" */ = {
isa = XCConfigurationList;
buildConfigurations = (
5CA059F1279559F40002BEB4 /* Debug */,
5CA059F2279559F40002BEB4 /* Release */,
);
defaultConfigurationIsVisible = 0;
defaultConfigurationName = Release;
};
5CA059F3279559F40002BEB4 /* Build configuration list for PBXNativeTarget "SimpleX (iOS)" */ = {
isa = XCConfigurationList;
buildConfigurations = (
5CA059F4279559F40002BEB4 /* Debug */,
5CA059F5279559F40002BEB4 /* Release */,
);
defaultConfigurationIsVisible = 0;
defaultConfigurationName = Release;
};
5CA059F6279559F40002BEB4 /* Build configuration list for PBXNativeTarget "SimpleX (macOS)" */ = {
isa = XCConfigurationList;
buildConfigurations = (
5CA059F7279559F40002BEB4 /* Debug */,
5CA059F8279559F40002BEB4 /* Release */,
);
defaultConfigurationIsVisible = 0;
defaultConfigurationName = Release;
};
5CA059F9279559F40002BEB4 /* Build configuration list for PBXNativeTarget "Tests iOS" */ = {
isa = XCConfigurationList;
buildConfigurations = (
5CA059FA279559F40002BEB4 /* Debug */,
5CA059FB279559F40002BEB4 /* Release */,
);
defaultConfigurationIsVisible = 0;
defaultConfigurationName = Release;
};
5CA059FC279559F40002BEB4 /* Build configuration list for PBXNativeTarget "Tests macOS" */ = {
isa = XCConfigurationList;
buildConfigurations = (
5CA059FD279559F40002BEB4 /* Debug */,
5CA059FE279559F40002BEB4 /* Release */,
);
defaultConfigurationIsVisible = 0;
defaultConfigurationName = Release;
};
/* End XCConfigurationList section */
};
rootObject = 5CA059BE279559F40002BEB4 /* Project object */;
}

7
apps/ios/SimpleX.xcodeproj/project.xcworkspace/contents.xcworkspacedata generated Normal file
View file

@ -0,0 +1,7 @@
<?xml version="1.0" encoding="UTF-8"?>
<Workspace
version = "1.0">
<FileRef
location = "self:">
</FileRef>
</Workspace>

8
apps/ios/SimpleX.xcodeproj/project.xcworkspace/xcshareddata/IDEWorkspaceChecks.plist Normal file
View file

@ -0,0 +1,8 @@
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
<key>IDEDidComputeMac32BitWarning</key>
<true/>
</dict>
</plist>

42
apps/ios/Tests iOS/Tests_iOS.swift Normal file
View file

@ -0,0 +1,42 @@
//
// Tests_iOS.swift
// Tests iOS
//
// Created by Evgeny Poberezkin on 17/01/2022.
//
import XCTest
class Tests_iOS: XCTestCase {
override func setUpWithError() throws {
// Put setup code here. This method is called before the invocation of each test method in the class.
// In UI tests it is usually best to stop immediately when a failure occurs.
continueAfterFailure = false
// In UI tests it’s important to set the initial state - such as interface orientation - required for your tests before they run. The setUp method is a good place to do this.
}
override func tearDownWithError() throws {
// Put teardown code here. This method is called after the invocation of each test method in the class.
}
func testExample() throws {
// UI tests must launch the application that they test.
let app = XCUIApplication()
app.launch()
// Use recording to get started writing UI tests.
// Use XCTAssert and related functions to verify your tests produce the correct results.
}
func testLaunchPerformance() throws {
if #available(macOS 10.15, iOS 13.0, tvOS 13.0, watchOS 7.0, *) {
// This measures how long it takes to launch your application.
measure(metrics: [XCTApplicationLaunchMetric()]) {
XCUIApplication().launch()
}
}
}
}

32
apps/ios/Tests iOS/Tests_iOSLaunchTests.swift Normal file
View file

@ -0,0 +1,32 @@
//
// Tests_iOSLaunchTests.swift
// Tests iOS
//
// Created by Evgeny Poberezkin on 17/01/2022.
//
import XCTest
class Tests_iOSLaunchTests: XCTestCase {
override class var runsForEachTargetApplicationUIConfiguration: Bool {
true
}
override func setUpWithError() throws {
continueAfterFailure = false
}
func testLaunch() throws {
let app = XCUIApplication()
app.launch()
// Insert steps here to perform after app launch but before taking a screenshot,
// such as logging into a test account or navigating somewhere in the app
let attachment = XCTAttachment(screenshot: app.screenshot())
attachment.name = "Launch Screen"
attachment.lifetime = .keepAlways
add(attachment)
}
}

42
apps/ios/Tests macOS/Tests_macOS.swift Normal file
View file

@ -0,0 +1,42 @@
//
// Tests_macOS.swift
// Tests macOS
//
// Created by Evgeny Poberezkin on 17/01/2022.
//
import XCTest
class Tests_macOS: XCTestCase {
override func setUpWithError() throws {
// Put setup code here. This method is called before the invocation of each test method in the class.
// In UI tests it is usually best to stop immediately when a failure occurs.
continueAfterFailure = false
// In UI tests it’s important to set the initial state - such as interface orientation - required for your tests before they run. The setUp method is a good place to do this.
}
override func tearDownWithError() throws {
// Put teardown code here. This method is called after the invocation of each test method in the class.
}
func testExample() throws {
// UI tests must launch the application that they test.
let app = XCUIApplication()
app.launch()
// Use recording to get started writing UI tests.
// Use XCTAssert and related functions to verify your tests produce the correct results.
}
func testLaunchPerformance() throws {
if #available(macOS 10.15, iOS 13.0, tvOS 13.0, watchOS 7.0, *) {
// This measures how long it takes to launch your application.
measure(metrics: [XCTApplicationLaunchMetric()]) {
XCUIApplication().launch()
}
}
}
}

32
apps/ios/Tests macOS/Tests_macOSLaunchTests.swift Normal file
View file

@ -0,0 +1,32 @@
//
// Tests_macOSLaunchTests.swift
// Tests macOS
//
// Created by Evgeny Poberezkin on 17/01/2022.
//
import XCTest
class Tests_macOSLaunchTests: XCTestCase {
override class var runsForEachTargetApplicationUIConfiguration: Bool {
true
}
override func setUpWithError() throws {
continueAfterFailure = false
}
func testLaunch() throws {
let app = XCUIApplication()
app.launch()
// Insert steps here to perform after app launch but before taking a screenshot,
// such as logging into a test account or navigating somewhere in the app
let attachment = XCTAttachment(screenshot: app.screenshot())
attachment.name = "Launch Screen"
attachment.lifetime = .keepAlways
add(attachment)
}
}

10
apps/ios/macOS/macOS.entitlements Normal file
View file

@ -0,0 +1,10 @@
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
<key>com.apple.security.app-sandbox</key>
<true/>
<key>com.apple.security.files.user-selected.read-only</key>
<true/>
</dict>
</plist>

5
apps/simplex-chat/Main.hs
View file

@ -8,6 +8,7 @@ module Main where
import Simplex.Chat import Simplex.Chat
import Simplex.Chat.Controller (versionNumber) import Simplex.Chat.Controller (versionNumber)
import Simplex.Chat.Options import Simplex.Chat.Options
import Simplex.Chat.Terminal
import System.Directory (getAppUserDataDirectory) import System.Directory (getAppUserDataDirectory)
import System.Terminal (withTerminal) import System.Terminal (withTerminal)
@ -20,8 +21,8 @@ main = do
welcomeGetOpts :: IO ChatOpts welcomeGetOpts :: IO ChatOpts
welcomeGetOpts = do welcomeGetOpts = do
appDir <- getAppUserDataDirectory "simplex" appDir <- getAppUserDataDirectory "simplex"
opts@ChatOpts {dbFile} <- getChatOpts appDir opts@ChatOpts {dbFilePrefix} <- getChatOpts appDir
putStrLn $ "SimpleX Chat v" ++ versionNumber putStrLn $ "SimpleX Chat v" ++ versionNumber
putStrLn $ "db: " <> dbFile <> "_chat.db, " <> dbFile <> "_agent.db" putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
putStrLn "type \"/help\" or \"/h\" for usage info" putStrLn "type \"/help\" or \"/h\" for usage info"
pure opts pure opts

7
cabal.project
View file

@ -1,9 +1,14 @@
packages: . packages: .
source-repository-package
type: git
location: git://github.com/simplex-chat/simplexmq.git
tag: 670b3b79749bfb48a04ee40b8c441e9ca68ad41a
source-repository-package source-repository-package
type: git type: git
location: git://github.com/simplex-chat/hs-tls.git location: git://github.com/simplex-chat/hs-tls.git
tag: cea6d52c512716ff09adcac86ebc95bb0b3bb797 tag: f6cc753611f80af300401cfae63846e9d7c40d9e
subdir: core subdir: core
source-repository-package source-repository-package

2
package.yaml
View file

@ -10,7 +10,6 @@ copyright: 2020-22 simplex.chat
category: Web, System, Services, Cryptography category: Web, System, Services, Cryptography
extra-source-files: extra-source-files:
- README.md - README.md
- migrations/*.*
dependencies: dependencies:
- aeson == 1.5.* - aeson == 1.5.*
@ -24,7 +23,6 @@ dependencies:
- cryptonite >= 0.27 && < 0.30 - cryptonite >= 0.27 && < 0.30
- directory == 1.3.* - directory == 1.3.*
- exceptions == 0.10.* - exceptions == 0.10.*
- file-embed >= 0.0.14 && < 0.0.16
- filepath == 1.4.* - filepath == 1.4.*
- mtl == 2.2.* - mtl == 2.2.*
- optparse-applicative >= 0.15 && < 0.17 - optparse-applicative >= 0.15 && < 0.17

167
rfcs/2022-01-26-mobile-app.md Normal file
View file

@ -0,0 +1,167 @@
# Porting SimpleX Chat to mobile
## Background and motivation
We have code that "works", the aim is to keep platform differences in the core minimal and get the apps to market faster.
### SimpleX platform design
See [overview](https://github.com/simplex-chat/simplexmq/blob/master/protocol/overview-tjr.md) for overall platform design and objectives, it is worth reading the introduction. The diagram copied from this doc:
```
User's Computer Internet Third-Party Server
------------------ | ---------------------- | -------------------------
| |
SimpleX Chat | |
| |
+----------------+ | |
| Chat App | | |
+----------------+ | |
| SimpleX Agent | | |
+----------------+ -------------- TLS ---------------- +----------------+
| SimpleX Client | ------ SimpleX Messaging Protocol ------> | SimpleX Server |
+----------------+ ----------------------------------- +----------------+
| |
```
- SimpleX Servers only pass messages, we don't need to touch that for the app
- SimpleX clients talk to the servers, we won't use them directly
- SimpleX agent is used from chat, we won't use it directly from the app
- Chat app will expose API to the app to communicate with everything, including DB and network.
### Important application modules
Modules of simplexmq package used from simplex-chat:
- a [functional API in Agent.hs]([Agent.hs](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent.hs#L38)) to send messages and commands
- TBQueue to receive messages and notifications (specifically, [subQ field of AgentClient record in Agent/Client.hs](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent/Client.hs#L72))
- [types from Agent/Protocol.hs](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent/Protocol.hs)).
This package has its [own sqlite database file](https://github.com/simplex-chat/simplexmq/tree/master/migrations) - as v1 was not backwards compatible migrations are restarted - where it stores all encryption and signing keys, shared secrets, servers and queue addresses - effectively it completely abstracts the network away from chat application, providing an API to manage logical duplex connections.
Simplex-chat library is what we will use from the app:
- command type [ChatCommand in Chat.hs](https://github.com/simplex-chat/simplex-chat/blob/master/src/Simplex/Chat.hs#L72) that UI can send to it
- UI sends these commands via TBQueue that `inputSubscriber` reads in forever loop and sends to `processChatCommand`. There is a hack that `inputSubscriber` not only reads commands but also shows them in the view, depending on the commands.
- collection of [view functions in Chat/View.hs](https://github.com/simplex-chat/simplex-chat/blob/master/src/Simplex/Chat/View.hs) to reflect all events in view.
This package also creates its own [database file](https://github.com/simplex-chat/simplex-chat/tree/master/migrations) where it stores references to agent connections managed by the agent, and how they map to contacts, groups, and file transmissions.
## App design options and questions
### Sending chat commands from UI and receiving them in Haskell
Possible options:
- function (exported via FFI) that receives strings from UI and decodes them into ChatCommand type, then sending this command to `processChatCommand`. This option requires a single function in C header file, but also requires encoding in UI and decoding in Haskell.
- multiple functions exported via FFI each sending different command to `processChatCommand`. This option requires multiple functions in header file and multiple exports from Haskell.
Overall, the second option seems a bit simpler and cleaner, if we agree to go this route we will refactor `processChatCommand` to expose its parts that process different commands as independent functions.
On another hand, it might be easier to grow chat API if this is passed via a single function and serialized as strings (e.g. as JSON, to have it more universal) - it would also might give us an API for a possible future chat server that works with thin, UI-only clients.
In both cases, we should split `processChatCommand` (or the functions it calls) into a separate module, so it does not have code that is not used from the app.
**Proposal**
Use option 2 to send commands from UI to chat, encoding/decoding commands as strings with a tag in the beginning (TBC binary, text or JSON based - encoding will have to be replicated in UI land; both encoding and decoding is needed in Haskell land to refactor terminal chat to use this layer as well, so we have a standard API for all implementations).
This function would have this type:
```haskell
sendRequest :: CString -> IO CString
```
to allow instant responses.
One more idea. This function could be made to match REST semantics that would simplify making chat into a REST chat server api:
```haskell
sendRequest :: CString -> CString -> CString -> CString -> IO CString
sendRequest verb path qs body = pure ""
```
### Sending messages and notifications from Haskell to UI
Firstly, we have to refactor the existing code so that all functions in [View.hs](https://github.com/simplex-chat/simplex-chat/blob/master/src/Simplex/Chat/View.hs) are passed to `processChatCommand` (or the functions for each command, if we go with this approach) as a single record containing all view functions.
The current code from View.hs will not be used in the mobile app, it is terminal specific; we will create a separate connector to the UI that has the same functions in a record - these functions communicate to the UI.
Again, there are two similar options how this communication can happen:
- UIs would export multiple functions however each platform allows it, as C exports, and they would be all imported in Haskell. This option feels definitely worse, as it would have to be maintained in both iOS and Android separately for exports, and in Haskell for imports, resulting in lots of boilerplate.
- UIs would export one function that receives strings (e.g. JSON encoded) with the messages and notifications, there will be one function in Haskell to send these JSON. All required view functions in Haskell land would simply send different strings into the same function.
In this case the second option seems definitely easier, as even with simple terminal UI there are more view events than chat commands (although, given different mobile UI paradigms some of these events may not be needed, but some additional events are likely to be addedd, that would be doing nothing for terminal app).
**Proposal**
Encode messages and notifications as JSON, but instead of exporting the function from UI (which would have to be done differently from different platforms), have Haskell export function `receiveMessage` that would be blocking until the next notification or message is available. UI would handle it in a simple loop, on a separate thread:
```haskell
-- CString is serialized JSON (ToJSON serialized datatype from haskell)
receiveMessage :: IO CString ()
```
To convert between Haskell and C interface:
```haskell
type CJSON = CString
toCJSON ToJSON a => a -> CJSON
toCJSON = ...
-- Haskell interface
send :: ToJSON a => String -> IO a
recv :: ToJSON a => IO a
-- C interface
c_send :: CString -> IO CJSON
c_recv :: IO CJSON
```
### Accessing chat database from the UI
Unlike terminal UI that does not provide any capabilities to access chat history, mobile UI needs to have access to it.
Two options how it can be done:
- UI accesses database directly via its own database library. The upside of this approach is that it keeps Haskel core smaller. The downside is that sqlite is relatively bad with concurrent access. In Haskell code we allowed some concurrency initially, having the pool limited to few concurrent connection, but later we removed concurrency (by limiting pool size to 1), as otherwise it required retrying to get transaction locks with difficult to set retry time limits, and leading to deadlocks in some cases. Also mobile sqlite seems to be compiled with concurrency disabled, so we would have to ship app with our own sqlite (which we might have to do anyway, for the sake of full text search support). We could use some shared semaphore in Haskell to obtain database lock, but it adds extra complexity...
- UI accesses database via Haskell functions. The upside of this is that there would be no issues with concurrency, and chat schema would be "owned" by Haskell core, but it requires either a separate serializable protocol for database access or multiple exported functions (same two options as before).
However bad the second option is, it seems slightly better as at least we would not have to duplicate sql quiries in iOS and Android. But this is the trade-off I am least certain of...
**Proposal**
Use the same `sendRequest` function to access database.
Additional idea: as these calls should never mutate chat database, they should only query the state, and as these functions will not be needed for terminal UI, I think we could export it as a separate function and have all necessary queries/functions in a separate module, e.g.:
```haskell
-- params and result are JSON encoded
chatQuery :: CString -> IO CString
chatQuery params = pure ""
```
On another hand, if we go with REST-like `sendRequest` then it definitely should be the only function to access chat and database state.
### UI database
UI needs to have its own storage to store information about user settings in the app and, possibly, which chat profiles the user has (each would have its own chat/agent databases).
### Chat database initialization
Currently it is done in an ad hoc way, during the application start ([`getCreateActiveUser` function](https://github.com/simplex-chat/simplex-chat/blob/master/src/Simplex/Chat.hs#L1178)), we could either expose this function to accept database name or just check on the start and initialize database with the default name in case it is not present.
### Multiple profiles in the app
All user profiles are stored in the same database. The current schema allows multiple profiles, but the current UI does not. We do not need to do it in the app MVP.
## Notifications
We don't need it in the first version - it is out of scope of releasable MVP - but we need to think a bit ahead how it will be done so it doesn't invalidate the design we settle on.
There is no reliable background execution, so the only way to receive messages when the app is off is via notifications. We have added notification subscriptions to the low protocol layer so that Haskell core would receive function call when notification arrives to the native part and receive and process messages and communicate back to the local part that would show a local notification on the device:
```
Push notification -> Native -> Haskell ... process ... -> Native -> Local notification
```
Notifications are the main reason why we will need to store multiple profiles in the same database file - when notification arrives we do not know which profile it is for, it only has server address and queue ID, and if different profiles were in different databases we would either had to have a single table mapping queues to profiles or lookup multiple databases - both options seem worse than a single database with multiple profiles.
For the rest we would just use the same approaches we would use for UI/Haskell communications - probably a separate functions to receive notifications to Haskell, and the same events to be sent back.

11
simplex-chat.cabal
View file

@ -16,21 +16,23 @@ license-file: LICENSE
build-type: Simple build-type: Simple
extra-source-files: extra-source-files:
README.md README.md
migrations/20220101_initial.sql
library library
exposed-modules: exposed-modules:
Simplex.Chat Simplex.Chat
Simplex.Chat.Controller Simplex.Chat.Controller
Simplex.Chat.Help Simplex.Chat.Help
Simplex.Chat.Input
Simplex.Chat.Markdown Simplex.Chat.Markdown
Simplex.Chat.Notification Simplex.Chat.Migrations.M20220101_initial
Simplex.Chat.Mobile
Simplex.Chat.Options Simplex.Chat.Options
Simplex.Chat.Protocol Simplex.Chat.Protocol
Simplex.Chat.Store Simplex.Chat.Store
Simplex.Chat.Styled Simplex.Chat.Styled
Simplex.Chat.Terminal Simplex.Chat.Terminal
Simplex.Chat.Terminal.Input
Simplex.Chat.Terminal.Output
Simplex.Chat.Terminal.Notification
Simplex.Chat.Types Simplex.Chat.Types
Simplex.Chat.Util Simplex.Chat.Util
Simplex.Chat.View Simplex.Chat.View
@ -51,7 +53,6 @@ library
, cryptonite >=0.27 && <0.30 , cryptonite >=0.27 && <0.30
, directory ==1.3.* , directory ==1.3.*
, exceptions ==0.10.* , exceptions ==0.10.*
, file-embed >=0.0.14 && <0.0.16
, filepath ==1.4.* , filepath ==1.4.*
, mtl ==2.2.* , mtl ==2.2.*
, optparse-applicative >=0.15 && <0.17 , optparse-applicative >=0.15 && <0.17
@ -87,7 +88,6 @@ executable simplex-chat
, cryptonite >=0.27 && <0.30 , cryptonite >=0.27 && <0.30
, directory ==1.3.* , directory ==1.3.*
, exceptions ==0.10.* , exceptions ==0.10.*
, file-embed >=0.0.14 && <0.0.16
, filepath ==1.4.* , filepath ==1.4.*
, mtl ==2.2.* , mtl ==2.2.*
, optparse-applicative >=0.15 && <0.17 , optparse-applicative >=0.15 && <0.17
@ -130,7 +130,6 @@ test-suite simplex-chat-test
, cryptonite >=0.27 && <0.30 , cryptonite >=0.27 && <0.30
, directory ==1.3.* , directory ==1.3.*
, exceptions ==0.10.* , exceptions ==0.10.*
, file-embed >=0.0.14 && <0.0.16
, filepath ==1.4.* , filepath ==1.4.*
, hspec ==2.7.* , hspec ==2.7.*
, mtl ==2.2.* , mtl ==2.2.*

255
src/Simplex/Chat.hs
View file

@ -38,15 +38,12 @@ import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word32) import Data.Word (Word32)
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Chat.Help import Simplex.Chat.Help
import Simplex.Chat.Input
import Simplex.Chat.Notification
import Simplex.Chat.Options (ChatOpts (..)) import Simplex.Chat.Options (ChatOpts (..))
import Simplex.Chat.Protocol import Simplex.Chat.Protocol
import Simplex.Chat.Store import Simplex.Chat.Store
import Simplex.Chat.Styled (plain) import Simplex.Chat.Styled
import Simplex.Chat.Terminal
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Chat.Util (ifM, unlessM, whenM) import Simplex.Chat.Util (ifM, unlessM)
import Simplex.Chat.View import Simplex.Chat.View
import Simplex.Messaging.Agent import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), defaultAgentConfig) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), defaultAgentConfig)
@ -62,7 +59,6 @@ import System.Exit (exitFailure, exitSuccess)
import System.FilePath (combine, splitExtensions, takeFileName) import System.FilePath (combine, splitExtensions, takeFileName)
import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout) import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout)
import Text.Read (readMaybe) import Text.Read (readMaybe)
import UnliftIO.Async (race_)
import UnliftIO.Concurrent (forkIO, threadDelay) import UnliftIO.Concurrent (forkIO, threadDelay)
import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getFileSize, getHomeDirectory, getTemporaryDirectory) import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getFileSize, getHomeDirectory, getTemporaryDirectory)
import qualified UnliftIO.Exception as E import qualified UnliftIO.Exception as E
@ -126,45 +122,29 @@ defaultChatConfig =
logCfg :: LogConfig logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
simplexChat :: WithTerminal t => ChatConfig -> ChatOpts -> t -> IO () newChatController :: SQLiteStore -> User -> ChatConfig -> ChatOpts -> (Notification -> IO ()) -> IO ChatController
simplexChat cfg opts@ChatOpts {logging} t newChatController chatStore user config@ChatConfig {agentConfig = cfg, tbqSize} ChatOpts {dbFilePrefix, smpServers} sendNotification = do
| logging = do let f = chatStoreFile dbFilePrefix
setLogLevel LogInfo -- LogError activeTo <- newTVarIO ActiveNone
withGlobalLogging logCfg initRun
| otherwise = initRun
where
initRun =
initializeNotifications
>>= newChatController cfg opts t
>>= runSimplexChat
newChatController :: WithTerminal t => ChatConfig -> ChatOpts -> t -> (Notification -> IO ()) -> IO ChatController
newChatController config@ChatConfig {agentConfig = cfg, dbPoolSize, tbqSize} ChatOpts {dbFile, smpServers} t sendNotification = do
let f = chatStoreFile dbFile
firstTime <- not <$> doesFileExist f firstTime <- not <$> doesFileExist f
chatStore <- createStore f dbPoolSize currentUser <- newTVarIO user
currentUser <- newTVarIO =<< getCreateActiveUser chatStore smpAgent <- getSMPAgentClient cfg {dbFile = dbFilePrefix <> "_agent.db", smpServers}
chatTerminal <- newChatTerminal t
smpAgent <- getSMPAgentClient cfg {dbFile = dbFile <> "_agent.db", smpServers}
idsDrg <- newTVarIO =<< drgNew idsDrg <- newTVarIO =<< drgNew
inputQ <- newTBQueueIO tbqSize inputQ <- newTBQueueIO tbqSize
outputQ <- newTBQueueIO tbqSize
notifyQ <- newTBQueueIO tbqSize notifyQ <- newTBQueueIO tbqSize
chatLock <- newTMVarIO () chatLock <- newTMVarIO ()
sndFiles <- newTVarIO M.empty sndFiles <- newTVarIO M.empty
rcvFiles <- newTVarIO M.empty rcvFiles <- newTVarIO M.empty
pure ChatController {..} pure ChatController {activeTo, firstTime, currentUser, smpAgent, chatStore, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, config, sendNotification}
runSimplexChat :: ChatController -> IO ()
runSimplexChat = runReaderT $ do
user <- readTVarIO =<< asks currentUser
whenM (asks firstTime) . printToView $ chatWelcome user
race_ runTerminalInput runChatController
runChatController :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m () runChatController :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m ()
runChatController = runChatController = do
q <- asks outputQ
let toView = atomically . writeTBQueue q
raceAny_ raceAny_
[ inputSubscriber, [ inputSubscriber toView,
agentSubscriber, agentSubscriber toView,
notificationSubscriber notificationSubscriber
] ]
@ -174,8 +154,8 @@ withLock lock =
(void . atomically $ takeTMVar lock) (void . atomically $ takeTMVar lock)
(atomically $ putTMVar lock ()) (atomically $ putTMVar lock ())
inputSubscriber :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m () inputSubscriber :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => ([StyledString] -> m ()) -> m ()
inputSubscriber = do inputSubscriber toView = do
q <- asks inputQ q <- asks inputQ
l <- asks chatLock l <- asks chatLock
a <- asks smpAgent a <- asks smpAgent
@ -184,34 +164,36 @@ inputSubscriber = do
InputControl _ -> pure () InputControl _ -> pure ()
InputCommand s -> InputCommand s ->
case parseAll chatCommandP . B.dropWhileEnd isSpace . encodeUtf8 $ T.pack s of case parseAll chatCommandP . B.dropWhileEnd isSpace . encodeUtf8 $ T.pack s of
Left e -> printToView [plain s, "invalid input: " <> plain e] Left e -> toView [plain s, "invalid input: " <> plain e]
Right cmd -> do Right cmd -> do
case cmd of case cmd of
SendMessage c msg -> showSentMessage c msg SendMessage c msg -> toView =<< liftIO (viewSentMessage c msg)
SendGroupMessage g msg -> showSentGroupMessage g msg SendGroupMessage g msg -> toView =<< liftIO (viewSentGroupMessage g msg)
SendFile c f -> showSentFileInvitation c f SendFile c f -> toView =<< liftIO (viewSentFileInvitation c f)
SendGroupFile g f -> showSentGroupFileInvitation g f SendGroupFile g f -> toView =<< liftIO (viewSentGroupFileInvitation g f)
_ -> printToView [plain s] _ -> toView [plain s]
user <- readTVarIO =<< asks currentUser user <- readTVarIO =<< asks currentUser
withAgentLock a . withLock l . void . runExceptT $ withAgentLock a . withLock l . void . runExceptT $
processChatCommand user cmd `catchError` showChatError processChatCommand toView' user cmd `catchError` (toView' . viewChatError)
where
toView' = ExceptT . fmap Right . toView
processChatCommand :: forall m. ChatMonad m => User -> ChatCommand -> m () processChatCommand :: forall m. ChatMonad m => ([StyledString] -> m ()) -> User -> ChatCommand -> m ()
processChatCommand user@User {userId, profile} = \case processChatCommand toView user@User {userId, profile} = \case
ChatHelp -> printToView chatHelpInfo ChatHelp -> toView chatHelpInfo
FilesHelp -> printToView filesHelpInfo FilesHelp -> toView filesHelpInfo
GroupsHelp -> printToView groupsHelpInfo GroupsHelp -> toView groupsHelpInfo
MyAddressHelp -> printToView myAddressHelpInfo MyAddressHelp -> toView myAddressHelpInfo
MarkdownHelp -> printToView markdownInfo MarkdownHelp -> toView markdownInfo
Welcome -> printToView $ chatWelcome user Welcome -> toView $ chatWelcome user
AddContact -> do AddContact -> do
(connId, cReq) <- withAgent (`createConnection` SCMInvitation) (connId, cReq) <- withAgent (`createConnection` SCMInvitation)
withStore $ \st -> createDirectConnection st userId connId withStore $ \st -> createDirectConnection st userId connId
showInvitation cReq toView $ viewConnReqInvitation cReq
Connect (Just (ACR SCMInvitation cReq)) -> connect cReq (XInfo profile) >> showSentConfirmation Connect (Just (ACR SCMInvitation cReq)) -> connect cReq (XInfo profile) >> toView viewSentConfirmation
Connect (Just (ACR SCMContact cReq)) -> connect cReq (XContact profile Nothing) >> showSentInvitation Connect (Just (ACR SCMContact cReq)) -> connect cReq (XContact profile Nothing) >> toView viewSentInvitation
Connect Nothing -> showInvalidConnReq Connect Nothing -> toView viewInvalidConnReq
ConnectAdmin -> connect adminContactReq (XContact profile Nothing) >> showSentInvitation ConnectAdmin -> connect adminContactReq (XContact profile Nothing) >> toView viewSentInvitation
DeleteContact cName -> DeleteContact cName ->
withStore (\st -> getContactGroupNames st userId cName) >>= \case withStore (\st -> getContactGroupNames st userId cName) >>= \case
[] -> do [] -> do
@ -220,39 +202,39 @@ processChatCommand user@User {userId, profile} = \case
deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure () deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
withStore $ \st -> deleteContact st userId cName withStore $ \st -> deleteContact st userId cName
unsetActive $ ActiveC cName unsetActive $ ActiveC cName
showContactDeleted cName toView $ viewContactDeleted cName
gs -> showContactGroups cName gs gs -> toView $ viewContactGroups cName gs
ListContacts -> withStore (`getUserContacts` user) >>= showContactsList ListContacts -> withStore (`getUserContacts` user) >>= toView . viewContactsList
CreateMyAddress -> do CreateMyAddress -> do
(connId, cReq) <- withAgent (`createConnection` SCMContact) (connId, cReq) <- withAgent (`createConnection` SCMContact)
withStore $ \st -> createUserContactLink st userId connId cReq withStore $ \st -> createUserContactLink st userId connId cReq
showUserContactLinkCreated cReq toView $ viewUserContactLinkCreated cReq
DeleteMyAddress -> do DeleteMyAddress -> do
conns <- withStore $ \st -> getUserContactLinkConnections st userId conns <- withStore $ \st -> getUserContactLinkConnections st userId
withAgent $ \a -> forM_ conns $ \Connection {agentConnId} -> withAgent $ \a -> forM_ conns $ \Connection {agentConnId} ->
deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure () deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
withStore $ \st -> deleteUserContactLink st userId withStore $ \st -> deleteUserContactLink st userId
showUserContactLinkDeleted toView viewUserContactLinkDeleted
ShowMyAddress -> do ShowMyAddress -> do
cReq <- withStore $ \st -> getUserContactLink st userId cReq <- withStore $ \st -> getUserContactLink st userId
showUserContactLink cReq toView $ viewUserContactLink cReq
AcceptContact cName -> do AcceptContact cName -> do
UserContactRequest {agentInvitationId, profileId} <- withStore $ \st -> UserContactRequest {agentInvitationId, profileId} <- withStore $ \st ->
getContactRequest st userId cName getContactRequest st userId cName
connId <- withAgent $ \a -> acceptContact a agentInvitationId . directMessage $ XInfo profile connId <- withAgent $ \a -> acceptContact a agentInvitationId . directMessage $ XInfo profile
withStore $ \st -> createAcceptedContact st userId connId cName profileId withStore $ \st -> createAcceptedContact st userId connId cName profileId
showAcceptingContactRequest cName toView $ viewAcceptingContactRequest cName
RejectContact cName -> do RejectContact cName -> do
UserContactRequest {agentContactConnId, agentInvitationId} <- withStore $ \st -> UserContactRequest {agentContactConnId, agentInvitationId} <- withStore $ \st ->
getContactRequest st userId cName getContactRequest st userId cName
`E.finally` deleteContactRequest st userId cName `E.finally` deleteContactRequest st userId cName
withAgent $ \a -> rejectContact a agentContactConnId agentInvitationId withAgent $ \a -> rejectContact a agentContactConnId agentInvitationId
showContactRequestRejected cName toView $ viewContactRequestRejected cName
SendMessage cName msg -> sendMessageCmd cName msg SendMessage cName msg -> sendMessageCmd cName msg
NewGroup gProfile -> do NewGroup gProfile -> do
gVar <- asks idsDrg gVar <- asks idsDrg
group <- withStore $ \st -> createNewGroup st gVar user gProfile group <- withStore $ \st -> createNewGroup st gVar user gProfile
showGroupCreated group toView $ viewGroupCreated group
AddMember gName cName memRole -> do AddMember gName cName memRole -> do
(group, contact) <- withStore $ \st -> (,) <$> getGroup st user gName <*> getContact st userId cName (group, contact) <- withStore $ \st -> (,) <$> getGroup st user gName <*> getContact st userId cName
let Group {groupId, groupProfile, membership, members} = group let Group {groupId, groupProfile, membership, members} = group
@ -263,7 +245,7 @@ processChatCommand user@User {userId, profile} = \case
let sendInvitation memberId cReq = do let sendInvitation memberId cReq = do
sendDirectMessage (contactConn contact) $ sendDirectMessage (contactConn contact) $
XGrpInv $ GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile XGrpInv $ GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile
showSentGroupInvitation gName cName toView $ viewSentGroupInvitation gName cName
setActive $ ActiveG gName setActive $ ActiveG gName
case contactMember contact members of case contactMember contact members of
Nothing -> do Nothing -> do
@ -275,7 +257,7 @@ processChatCommand user@User {userId, profile} = \case
| memberStatus == GSMemInvited -> | memberStatus == GSMemInvited ->
withStore (\st -> getMemberInvitation st user groupMemberId) >>= \case withStore (\st -> getMemberInvitation st user groupMemberId) >>= \case
Just cReq -> sendInvitation memberId cReq Just cReq -> sendInvitation memberId cReq
Nothing -> showCannotResendInvitation gName cName Nothing -> toView $ viewCannotResendInvitation gName cName
| otherwise -> chatError (CEGroupDuplicateMember cName) | otherwise -> chatError (CEGroupDuplicateMember cName)
JoinGroup gName -> do JoinGroup gName -> do
ReceivedGroupInvitation {fromMember, userMember, connRequest} <- withStore $ \st -> getGroupInvitation st user gName ReceivedGroupInvitation {fromMember, userMember, connRequest} <- withStore $ \st -> getGroupInvitation st user gName
@ -295,13 +277,13 @@ processChatCommand user@User {userId, profile} = \case
when (mStatus /= GSMemInvited) . sendGroupMessage members $ XGrpMemDel mId when (mStatus /= GSMemInvited) . sendGroupMessage members $ XGrpMemDel mId
deleteMemberConnection m deleteMemberConnection m
withStore $ \st -> updateGroupMemberStatus st userId m GSMemRemoved withStore $ \st -> updateGroupMemberStatus st userId m GSMemRemoved
showDeletedMember gName Nothing (Just m) toView $ viewDeletedMember gName Nothing (Just m)
LeaveGroup gName -> do LeaveGroup gName -> do
Group {membership, members} <- withStore $ \st -> getGroup st user gName Group {membership, members} <- withStore $ \st -> getGroup st user gName
sendGroupMessage members XGrpLeave sendGroupMessage members XGrpLeave
mapM_ deleteMemberConnection members mapM_ deleteMemberConnection members
withStore $ \st -> updateGroupMemberStatus st userId membership GSMemLeft withStore $ \st -> updateGroupMemberStatus st userId membership GSMemLeft
showLeftMemberUser gName toView $ viewLeftMemberUser gName
DeleteGroup gName -> do DeleteGroup gName -> do
g@Group {membership, members} <- withStore $ \st -> getGroup st user gName g@Group {membership, members} <- withStore $ \st -> getGroup st user gName
let s = memberStatus membership let s = memberStatus membership
@ -312,11 +294,11 @@ processChatCommand user@User {userId, profile} = \case
when (memberActive membership) $ sendGroupMessage members XGrpDel when (memberActive membership) $ sendGroupMessage members XGrpDel
mapM_ deleteMemberConnection members mapM_ deleteMemberConnection members
withStore $ \st -> deleteGroup st user g withStore $ \st -> deleteGroup st user g
showGroupDeletedUser gName toView $ viewGroupDeletedUser gName
ListMembers gName -> do ListMembers gName -> do
group <- withStore $ \st -> getGroup st user gName group <- withStore $ \st -> getGroup st user gName
showGroupMembers group toView $ viewGroupMembers group
ListGroups -> withStore (`getUserGroupDetails` userId) >>= showGroupsList ListGroups -> withStore (`getUserGroupDetails` userId) >>= toView . viewGroupsList
SendGroupMessage gName msg -> do SendGroupMessage gName msg -> do
-- TODO save pending message delivery for members without connections -- TODO save pending message delivery for members without connections
Group {members, membership} <- withStore $ \st -> getGroup st user gName Group {members, membership} <- withStore $ \st -> getGroup st user gName
@ -332,7 +314,7 @@ processChatCommand user@User {userId, profile} = \case
SndFileTransfer {fileId} <- withStore $ \st -> SndFileTransfer {fileId} <- withStore $ \st ->
createSndFileTransfer st userId contact f fileInv agentConnId chSize createSndFileTransfer st userId contact f fileInv agentConnId chSize
sendDirectMessage (contactConn contact) $ XFile fileInv sendDirectMessage (contactConn contact) $ XFile fileInv
showSentFileInfo fileId toView $ viewSentFileInfo fileId
setActive $ ActiveC cName setActive $ ActiveC cName
SendGroupFile gName f -> do SendGroupFile gName f -> do
(fileSize, chSize) <- checkSndFile f (fileSize, chSize) <- checkSndFile f
@ -346,7 +328,7 @@ processChatCommand user@User {userId, profile} = \case
-- TODO sendGroupMessage - same file invitation to all -- TODO sendGroupMessage - same file invitation to all
forM_ ms $ \(m, _, fileInv) -> forM_ ms $ \(m, _, fileInv) ->
traverse (`sendDirectMessage` XFile fileInv) $ memberConn m traverse (`sendDirectMessage` XFile fileInv) $ memberConn m
showSentFileInfo fileId toView $ viewSentFileInfo fileId
setActive $ ActiveG gName setActive $ ActiveG gName
ReceiveFile fileId filePath_ -> do ReceiveFile fileId filePath_ -> do
ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileConnReq}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileConnReq}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId
@ -355,29 +337,29 @@ processChatCommand user@User {userId, profile} = \case
Right agentConnId -> do Right agentConnId -> do
filePath <- getRcvFilePath fileId filePath_ fileName filePath <- getRcvFilePath fileId filePath_ fileName
withStore $ \st -> acceptRcvFileTransfer st userId fileId agentConnId filePath withStore $ \st -> acceptRcvFileTransfer st userId fileId agentConnId filePath
showRcvFileAccepted ft filePath toView $ viewRcvFileAccepted ft filePath
Left (ChatErrorAgent (SMP SMP.AUTH)) -> showRcvFileSndCancelled ft Left (ChatErrorAgent (SMP SMP.AUTH)) -> toView $ viewRcvFileSndCancelled ft
Left (ChatErrorAgent (CONN DUPLICATE)) -> showRcvFileSndCancelled ft Left (ChatErrorAgent (CONN DUPLICATE)) -> toView $ viewRcvFileSndCancelled ft
Left e -> throwError e Left e -> throwError e
CancelFile fileId -> CancelFile fileId ->
withStore (\st -> getFileTransfer st userId fileId) >>= \case withStore (\st -> getFileTransfer st userId fileId) >>= \case
FTSnd fts -> do FTSnd fts -> do
forM_ fts $ \ft -> cancelSndFileTransfer ft forM_ fts $ \ft -> cancelSndFileTransfer ft
showSndGroupFileCancelled fts toView $ viewSndGroupFileCancelled fts
FTRcv ft -> do FTRcv ft -> do
cancelRcvFileTransfer ft cancelRcvFileTransfer ft
showRcvFileCancelled ft toView $ viewRcvFileCancelled ft
FileStatus fileId -> FileStatus fileId ->
withStore (\st -> getFileTransferProgress st userId fileId) >>= showFileTransferStatus withStore (\st -> getFileTransferProgress st userId fileId) >>= toView . viewFileTransferStatus
UpdateProfile p -> unless (p == profile) $ do UpdateProfile p -> unless (p == profile) $ do
user' <- withStore $ \st -> updateUserProfile st user p user' <- withStore $ \st -> updateUserProfile st user p
asks currentUser >>= atomically . (`writeTVar` user') asks currentUser >>= atomically . (`writeTVar` user')
contacts <- withStore (`getUserContacts` user) contacts <- withStore (`getUserContacts` user)
forM_ contacts $ \ct -> sendDirectMessage (contactConn ct) $ XInfo p forM_ contacts $ \ct -> sendDirectMessage (contactConn ct) $ XInfo p
showUserProfileUpdated user user' toView $ viewUserProfileUpdated user user'
ShowProfile -> showUserProfile profile ShowProfile -> toView $ viewUserProfile profile
QuitChat -> liftIO exitSuccess QuitChat -> liftIO exitSuccess
ShowVersion -> printToView clientVersionInfo ShowVersion -> toView clientVersionInfo
where where
connect :: ConnectionRequestUri c -> ChatMsgEvent -> m () connect :: ConnectionRequestUri c -> ChatMsgEvent -> m ()
connect cReq msg = do connect cReq msg = do
@ -429,19 +411,21 @@ processChatCommand user@User {userId, profile} = \case
f = filePath `combine` (name <> suffix <> ext) f = filePath `combine` (name <> suffix <> ext)
in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f) in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f)
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m () agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => ([StyledString] -> m ()) -> m ()
agentSubscriber = do agentSubscriber toView = do
q <- asks $ subQ . smpAgent q <- asks $ subQ . smpAgent
l <- asks chatLock l <- asks chatLock
subscribeUserConnections subscribeUserConnections toView
forever $ do forever $ do
(_, connId, msg) <- atomically $ readTBQueue q (_, connId, msg) <- atomically $ readTBQueue q
user <- readTVarIO =<< asks currentUser user <- readTVarIO =<< asks currentUser
withLock l . void . runExceptT $ withLock l . void . runExceptT $
processAgentMessage user connId msg `catchError` showChatError processAgentMessage toView' user connId msg `catchError` (toView' . viewChatError)
where
toView' = ExceptT . fmap Right . toView
subscribeUserConnections :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m () subscribeUserConnections :: forall m. (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => ([StyledString] -> m ()) -> m ()
subscribeUserConnections = void . runExceptT $ do subscribeUserConnections toView = void . runExceptT $ do
user <- readTVarIO =<< asks currentUser user <- readTVarIO =<< asks currentUser
subscribeContacts user subscribeContacts user
subscribeGroups user subscribeGroups user
@ -449,39 +433,40 @@ subscribeUserConnections = void . runExceptT $ do
subscribePendingConnections user subscribePendingConnections user
subscribeUserContactLink user subscribeUserContactLink user
where where
toView' = ExceptT . fmap Right . toView
subscribeContacts user = do subscribeContacts user = do
contacts <- withStore (`getUserContacts` user) contacts <- withStore (`getUserContacts` user)
forM_ contacts $ \ct@Contact {localDisplayName = c} -> forM_ contacts $ \ct@Contact {localDisplayName = c} ->
(subscribe (contactConnId ct) >> showContactSubscribed c) `catchError` showContactSubError c (subscribe (contactConnId ct) >> toView' (viewContactSubscribed c)) `catchError` (toView' . viewContactSubError c)
subscribeGroups user = do subscribeGroups user = do
groups <- withStore (`getUserGroups` user) groups <- withStore (`getUserGroups` user)
forM_ groups $ \g@Group {members, membership, localDisplayName = gn} -> do forM_ groups $ \g@Group {members, membership, localDisplayName = gn} -> do
let connectedMembers = mapMaybe (\m -> (m,) <$> memberConnId m) members let connectedMembers = mapMaybe (\m -> (m,) <$> memberConnId m) members
if memberStatus membership == GSMemInvited if memberStatus membership == GSMemInvited
then showGroupInvitation g then toView' $ viewGroupInvitation g
else else
if null connectedMembers if null connectedMembers
then then
if memberActive membership if memberActive membership
then showGroupEmpty g then toView' $ viewGroupEmpty g
else showGroupRemoved g else toView' $ viewGroupRemoved g
else do else do
forM_ connectedMembers $ \(GroupMember {localDisplayName = c}, cId) -> forM_ connectedMembers $ \(GroupMember {localDisplayName = c}, cId) ->
subscribe cId `catchError` showMemberSubError gn c subscribe cId `catchError` (toView' . viewMemberSubError gn c)
showGroupSubscribed g toView' $ viewGroupSubscribed g
subscribeFiles user = do subscribeFiles user = do
withStore (`getLiveSndFileTransfers` user) >>= mapM_ subscribeSndFile withStore (`getLiveSndFileTransfers` user) >>= mapM_ subscribeSndFile
withStore (`getLiveRcvFileTransfers` user) >>= mapM_ subscribeRcvFile withStore (`getLiveRcvFileTransfers` user) >>= mapM_ subscribeRcvFile
where where
subscribeSndFile ft@SndFileTransfer {fileId, fileStatus, agentConnId} = do subscribeSndFile ft@SndFileTransfer {fileId, fileStatus, agentConnId} = do
subscribe agentConnId `catchError` showSndFileSubError ft subscribe agentConnId `catchError` (toView' . viewSndFileSubError ft)
void . forkIO $ do void . forkIO $ do
threadDelay 1000000 threadDelay 1000000
l <- asks chatLock l <- asks chatLock
a <- asks smpAgent a <- asks smpAgent
unless (fileStatus == FSNew) . unlessM (isFileActive fileId sndFiles) $ unless (fileStatus == FSNew) . unlessM (isFileActive fileId sndFiles) $
withAgentLock a . withLock l $ withAgentLock a . withLock l $
sendFileChunk ft sendFileChunk toView' ft
subscribeRcvFile ft@RcvFileTransfer {fileStatus} = subscribeRcvFile ft@RcvFileTransfer {fileStatus} =
case fileStatus of case fileStatus of
RFSAccepted fInfo -> resume fInfo RFSAccepted fInfo -> resume fInfo
@ -489,22 +474,22 @@ subscribeUserConnections = void . runExceptT $ do
_ -> pure () _ -> pure ()
where where
resume RcvFileInfo {agentConnId} = resume RcvFileInfo {agentConnId} =
subscribe agentConnId `catchError` showRcvFileSubError ft subscribe agentConnId `catchError` (toView' . viewRcvFileSubError ft)
subscribePendingConnections user = do subscribePendingConnections user = do
cs <- withStore (`getPendingConnections` user) cs <- withStore (`getPendingConnections` user)
subscribeConns cs `catchError` \_ -> pure () subscribeConns cs `catchError` \_ -> pure ()
subscribeUserContactLink User {userId} = do subscribeUserContactLink User {userId} = do
cs <- withStore (`getUserContactLinkConnections` userId) cs <- withStore (`getUserContactLinkConnections` userId)
(subscribeConns cs >> showUserContactLinkSubscribed) (subscribeConns cs >> toView' viewUserContactLinkSubscribed)
`catchError` showUserContactLinkSubError `catchError` (toView' . viewUserContactLinkSubError)
subscribe cId = withAgent (`subscribeConnection` cId) subscribe cId = withAgent (`subscribeConnection` cId)
subscribeConns conns = subscribeConns conns =
withAgent $ \a -> withAgent $ \a ->
forM_ conns $ \Connection {agentConnId} -> forM_ conns $ \Connection {agentConnId} ->
subscribeConnection a agentConnId subscribeConnection a agentConnId
processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agent -> m () processAgentMessage :: forall m. ChatMonad m => ([StyledString] -> m ()) -> User -> ConnId -> ACommand 'Agent -> m ()
processAgentMessage user@User {userId, profile} agentConnId agentMessage = do processAgentMessage toView user@User {userId, profile} agentConnId agentMessage = do
chatDirection <- withStore $ \st -> getConnectionChatDirection st user agentConnId chatDirection <- withStore $ \st -> getConnectionChatDirection st user agentConnId
forM_ (agentMsgConnStatus agentMessage) $ \status -> forM_ (agentMsgConnStatus agentMessage) $ \status ->
withStore $ \st -> updateConnectionStatus st (fromConnection chatDirection) status withStore $ \st -> updateConnectionStatus st (fromConnection chatDirection) status
@ -594,7 +579,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
CON -> CON ->
withStore (\st -> getViaGroupMember st user ct) >>= \case withStore (\st -> getViaGroupMember st user ct) >>= \case
Nothing -> do Nothing -> do
showContactConnected ct toView $ viewContactConnected ct
setActive $ ActiveC c setActive $ ActiveC c
showToast (c <> "> ") "connected" showToast (c <> "> ") "connected"
Just (gName, m) -> Just (gName, m) ->
@ -604,14 +589,14 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
SENT msgId -> SENT msgId ->
sentMsgDeliveryEvent conn msgId sentMsgDeliveryEvent conn msgId
END -> do END -> do
showContactAnotherClient c toView $ viewContactAnotherClient c
showToast (c <> "> ") "connected to another client" showToast (c <> "> ") "connected to another client"
unsetActive $ ActiveC c unsetActive $ ActiveC c
DOWN -> do DOWN -> do
showContactDisconnected c toView $ viewContactDisconnected c
showToast (c <> "> ") "disconnected" showToast (c <> "> ") "disconnected"
UP -> do UP -> do
showContactSubscribed c toView $ viewContactSubscribed c
showToast (c <> "> ") "is active" showToast (c <> "> ") "is active"
setActive $ ActiveC c setActive $ ActiveC c
-- TODO print errors -- TODO print errors
@ -662,11 +647,11 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
-- TODO forward any pending (GMIntroInvReceived) introductions -- TODO forward any pending (GMIntroInvReceived) introductions
case memberCategory m of case memberCategory m of
GCHostMember -> do GCHostMember -> do
showUserJoinedGroup gName toView $ viewUserJoinedGroup gName
setActive $ ActiveG gName setActive $ ActiveG gName
showToast ("#" <> gName) "you are connected to group" showToast ("#" <> gName) "you are connected to group"
GCInviteeMember -> do GCInviteeMember -> do
showJoinedGroupMember gName m toView $ viewJoinedGroupMember gName m
setActive $ ActiveG gName setActive $ ActiveG gName
showToast ("#" <> gName) $ "member " <> localDisplayName (m :: GroupMember) <> " is connected" showToast ("#" <> gName) $ "member " <> localDisplayName (m :: GroupMember) <> " is connected"
intros <- withStore $ \st -> createIntroductions st group m intros <- withStore $ \st -> createIntroductions st group m
@ -723,15 +708,15 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
_ -> messageError "CONF from file connection must have x.file.acpt" _ -> messageError "CONF from file connection must have x.file.acpt"
CON -> do CON -> do
withStore $ \st -> updateSndFileStatus st ft FSConnected withStore $ \st -> updateSndFileStatus st ft FSConnected
showSndFileStart ft toView $ viewSndFileStart ft
sendFileChunk ft sendFileChunk toView ft
SENT msgId -> do SENT msgId -> do
withStore $ \st -> updateSndFileChunkSent st ft msgId withStore $ \st -> updateSndFileChunkSent st ft msgId
unless (fileStatus == FSCancelled) $ sendFileChunk ft unless (fileStatus == FSCancelled) $ sendFileChunk toView ft
MERR _ err -> do MERR _ err -> do
cancelSndFileTransfer ft cancelSndFileTransfer ft
case err of case err of
SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ showSndFileRcvCancelled ft SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ toView $ viewSndFileRcvCancelled ft
_ -> chatError $ CEFileSend fileId err _ -> chatError $ CEFileSend fileId err
MSG meta _ -> MSG meta _ ->
withAckMessage agentConnId meta $ pure () withAckMessage agentConnId meta $ pure ()
@ -745,12 +730,12 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
case agentMsg of case agentMsg of
CON -> do CON -> do
withStore $ \st -> updateRcvFileStatus st ft FSConnected withStore $ \st -> updateRcvFileStatus st ft FSConnected
showRcvFileStart ft toView $ viewRcvFileStart ft
MSG meta@MsgMeta {recipient = (msgId, _), integrity} msgBody -> withAckMessage agentConnId meta $ do MSG meta@MsgMeta {recipient = (msgId, _), integrity} msgBody -> withAckMessage agentConnId meta $ do
parseFileChunk msgBody >>= \case parseFileChunk msgBody >>= \case
FileChunkCancel -> do FileChunkCancel -> do
cancelRcvFileTransfer ft cancelRcvFileTransfer ft
showRcvFileSndCancelled ft toView $ viewRcvFileSndCancelled ft
FileChunk {chunkNo, chunkBytes = chunk} -> do FileChunk {chunkNo, chunkBytes = chunk} -> do
case integrity of case integrity of
MsgOk -> pure () MsgOk -> pure ()
@ -770,7 +755,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
withStore $ \st -> do withStore $ \st -> do
updateRcvFileStatus st ft FSComplete updateRcvFileStatus st ft FSComplete
deleteRcvFileChunks st ft deleteRcvFileChunks st ft
showRcvFileComplete ft toView $ viewRcvFileComplete ft
closeFileHandle fileId rcvFiles closeFileHandle fileId rcvFiles
withAgent (`deleteConnection` agentConnId) withAgent (`deleteConnection` agentConnId)
RcvChunkDuplicate -> pure () RcvChunkDuplicate -> pure ()
@ -799,7 +784,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
profileContactRequest :: InvitationId -> Profile -> m () profileContactRequest :: InvitationId -> Profile -> m ()
profileContactRequest invId p = do profileContactRequest invId p = do
cName <- withStore $ \st -> createContactRequest st userId userContactLinkId invId p cName <- withStore $ \st -> createContactRequest st userId userContactLinkId invId p
showReceivedContactRequest cName p toView $ viewReceivedContactRequest cName p
showToast (cName <> "> ") "wants to connect to you" showToast (cName <> "> ") "wants to connect to you"
withAckMessage :: ConnId -> MsgMeta -> m () -> m () withAckMessage :: ConnId -> MsgMeta -> m () -> m ()
@ -824,7 +809,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
notifyMemberConnected :: GroupName -> GroupMember -> m () notifyMemberConnected :: GroupName -> GroupMember -> m ()
notifyMemberConnected gName m@GroupMember {localDisplayName} = do notifyMemberConnected gName m@GroupMember {localDisplayName} = do
showConnectedToGroupMember gName m toView $ viewConnectedToGroupMember gName m
setActive $ ActiveG gName setActive $ ActiveG gName
showToast ("#" <> gName) $ "member " <> localDisplayName <> " is connected" showToast ("#" <> gName) $ "member " <> localDisplayName <> " is connected"
@ -842,20 +827,20 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
withStore $ \st -> createSentProbeHash st userId probeId c withStore $ \st -> createSentProbeHash st userId probeId c
messageWarning :: Text -> m () messageWarning :: Text -> m ()
messageWarning = showMessageError "warning" messageWarning = toView . viewMessageError "warning"
messageError :: Text -> m () messageError :: Text -> m ()
messageError = showMessageError "error" messageError = toView . viewMessageError "error"
newTextMessage :: ContactName -> MsgMeta -> Text -> m () newTextMessage :: ContactName -> MsgMeta -> Text -> m ()
newTextMessage c meta text = do newTextMessage c meta text = do
showReceivedMessage c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta)) toView =<< liftIO (viewReceivedMessage c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta)))
showToast (c <> "> ") text showToast (c <> "> ") text
setActive $ ActiveC c setActive $ ActiveC c
newGroupTextMessage :: GroupName -> GroupMember -> MsgMeta -> Text -> m () newGroupTextMessage :: GroupName -> GroupMember -> MsgMeta -> Text -> m ()
newGroupTextMessage gName GroupMember {localDisplayName = c} meta text = do newGroupTextMessage gName GroupMember {localDisplayName = c} meta text = do
showReceivedGroupMessage gName c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta)) toView =<< liftIO (viewReceivedGroupMessage gName c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta)))
showToast ("#" <> gName <> " " <> c <> "> ") text showToast ("#" <> gName <> " " <> c <> "> ") text
setActive $ ActiveG gName setActive $ ActiveG gName
@ -864,7 +849,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
-- TODO chunk size has to be sent as part of invitation -- TODO chunk size has to be sent as part of invitation
chSize <- asks $ fileChunkSize . config chSize <- asks $ fileChunkSize . config
ft <- withStore $ \st -> createRcvFileTransfer st userId contact fInv chSize ft <- withStore $ \st -> createRcvFileTransfer st userId contact fInv chSize
showReceivedMessage c (snd $ broker meta) (receivedFileInvitation ft) (integrity (meta :: MsgMeta)) toView =<< liftIO (viewReceivedFileInvitation c (snd $ broker meta) ft (integrity (meta :: MsgMeta)))
showToast (c <> "> ") "wants to send a file" showToast (c <> "> ") "wants to send a file"
setActive $ ActiveC c setActive $ ActiveC c
@ -872,7 +857,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
processGroupFileInvitation gName m@GroupMember {localDisplayName = c} meta fInv = do processGroupFileInvitation gName m@GroupMember {localDisplayName = c} meta fInv = do
chSize <- asks $ fileChunkSize . config chSize <- asks $ fileChunkSize . config
ft <- withStore $ \st -> createRcvGroupFileTransfer st userId m fInv chSize ft <- withStore $ \st -> createRcvGroupFileTransfer st userId m fInv chSize
showReceivedGroupMessage gName c (snd $ broker meta) (receivedFileInvitation ft) (integrity (meta :: MsgMeta)) toView =<< liftIO (viewReceivedGroupFileInvitation gName c (snd $ broker meta) ft (integrity (meta :: MsgMeta)))
showToast ("#" <> gName <> " " <> c <> "> ") "wants to send a file" showToast ("#" <> gName <> " " <> c <> "> ") "wants to send a file"
setActive $ ActiveG gName setActive $ ActiveG gName
@ -881,13 +866,13 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
when (fromRole < GRAdmin || fromRole < memRole) $ chatError (CEGroupContactRole c) when (fromRole < GRAdmin || fromRole < memRole) $ chatError (CEGroupContactRole c)
when (fromMemId == memId) $ chatError CEGroupDuplicateMemberId when (fromMemId == memId) $ chatError CEGroupDuplicateMemberId
group@Group {localDisplayName = gName} <- withStore $ \st -> createGroupInvitation st user ct inv group@Group {localDisplayName = gName} <- withStore $ \st -> createGroupInvitation st user ct inv
showReceivedGroupInvitation group c memRole toView $ viewReceivedGroupInvitation group c memRole
showToast ("#" <> gName <> " " <> c <> "> ") $ "invited you to join the group" showToast ("#" <> gName <> " " <> c <> "> ") $ "invited you to join the group"
xInfo :: Contact -> Profile -> m () xInfo :: Contact -> Profile -> m ()
xInfo c@Contact {profile = p} p' = unless (p == p') $ do xInfo c@Contact {profile = p} p' = unless (p == p') $ do
c' <- withStore $ \st -> updateContactProfile st userId c p' c' <- withStore $ \st -> updateContactProfile st userId c p'
showContactUpdated c c' toView $ viewContactUpdated c c'
xInfoProbe :: Contact -> Probe -> m () xInfoProbe :: Contact -> Probe -> m ()
xInfoProbe c2 probe = do xInfoProbe c2 probe = do
@ -913,7 +898,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
mergeContacts :: Contact -> Contact -> m () mergeContacts :: Contact -> Contact -> m ()
mergeContacts to from = do mergeContacts to from = do
withStore $ \st -> mergeContactRecords st userId to from withStore $ \st -> mergeContactRecords st userId to from
showContactsMerged to from toView $ viewContactsMerged to from
saveConnInfo :: Connection -> ConnInfo -> m () saveConnInfo :: Connection -> ConnInfo -> m ()
saveConnInfo activeConn connInfo = do saveConnInfo activeConn connInfo = do
@ -932,7 +917,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
then messageError "x.grp.mem.new error: member already exists" then messageError "x.grp.mem.new error: member already exists"
else do else do
newMember <- withStore $ \st -> createNewGroupMember st user group memInfo GCPostMember GSMemAnnounced newMember <- withStore $ \st -> createNewGroupMember st user group memInfo GCPostMember GSMemAnnounced
showJoinedGroupMemberConnecting gName m newMember toView $ viewJoinedGroupMemberConnecting gName m newMember
xGrpMemIntro :: Connection -> GroupName -> GroupMember -> MemberInfo -> m () xGrpMemIntro :: Connection -> GroupName -> GroupMember -> MemberInfo -> m ()
xGrpMemIntro conn gName m memInfo@(MemberInfo memId _ _) = xGrpMemIntro conn gName m memInfo@(MemberInfo memId _ _) =
@ -989,7 +974,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
then do then do
mapM_ deleteMemberConnection members mapM_ deleteMemberConnection members
withStore $ \st -> updateGroupMemberStatus st userId membership GSMemRemoved withStore $ \st -> updateGroupMemberStatus st userId membership GSMemRemoved
showDeletedMemberUser gName m toView $ viewDeletedMemberUser gName m
else case find (sameMemberId memId) members of else case find (sameMemberId memId) members of
Nothing -> messageError "x.grp.mem.del with unknown member ID" Nothing -> messageError "x.grp.mem.del with unknown member ID"
Just member -> do Just member -> do
@ -999,7 +984,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
else do else do
deleteMemberConnection member deleteMemberConnection member
withStore $ \st -> updateGroupMemberStatus st userId member GSMemRemoved withStore $ \st -> updateGroupMemberStatus st userId member GSMemRemoved
showDeletedMember gName (Just m) (Just member) toView $ viewDeletedMember gName (Just m) (Just member)
sameMemberId :: MemberId -> GroupMember -> Bool sameMemberId :: MemberId -> GroupMember -> Bool
sameMemberId memId GroupMember {memberId} = memId == memberId sameMemberId memId GroupMember {memberId} = memId == memberId
@ -1008,7 +993,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
xGrpLeave gName m = do xGrpLeave gName m = do
deleteMemberConnection m deleteMemberConnection m
withStore $ \st -> updateGroupMemberStatus st userId m GSMemLeft withStore $ \st -> updateGroupMemberStatus st userId m GSMemLeft
showLeftMember gName m toView $ viewLeftMember gName m
xGrpDel :: GroupName -> GroupMember -> m () xGrpDel :: GroupName -> GroupMember -> m ()
xGrpDel gName m@GroupMember {memberRole} = do xGrpDel gName m@GroupMember {memberRole} = do
@ -1018,13 +1003,13 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
updateGroupMemberStatus st userId membership GSMemGroupDeleted updateGroupMemberStatus st userId membership GSMemGroupDeleted
pure members pure members
mapM_ deleteMemberConnection ms mapM_ deleteMemberConnection ms
showGroupDeleted gName m toView $ viewGroupDeleted gName m
parseChatMessage :: ByteString -> Either ChatError ChatMessage parseChatMessage :: ByteString -> Either ChatError ChatMessage
parseChatMessage = first ChatErrorMessage . strDecode parseChatMessage = first ChatErrorMessage . strDecode
sendFileChunk :: ChatMonad m => SndFileTransfer -> m () sendFileChunk :: ChatMonad m => ([StyledString] -> m ()) -> SndFileTransfer -> m ()
sendFileChunk ft@SndFileTransfer {fileId, fileStatus, agentConnId} = sendFileChunk toView ft@SndFileTransfer {fileId, fileStatus, agentConnId} =
unless (fileStatus == FSComplete || fileStatus == FSCancelled) $ unless (fileStatus == FSComplete || fileStatus == FSCancelled) $
withStore (`createSndFileChunk` ft) >>= \case withStore (`createSndFileChunk` ft) >>= \case
Just chunkNo -> sendFileChunkNo ft chunkNo Just chunkNo -> sendFileChunkNo ft chunkNo
@ -1032,7 +1017,7 @@ sendFileChunk ft@SndFileTransfer {fileId, fileStatus, agentConnId} =
withStore $ \st -> do withStore $ \st -> do
updateSndFileStatus st ft FSComplete updateSndFileStatus st ft FSComplete
deleteSndFileChunks st ft deleteSndFileChunks st ft
showSndFileComplete ft toView $ viewSndFileComplete ft
closeFileHandle fileId sndFiles closeFileHandle fileId sndFiles
withAgent (`deleteConnection` agentConnId) withAgent (`deleteConnection` agentConnId)

14
src/Simplex/Chat/Controller.hs
View file

@ -2,6 +2,7 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.Controller where module Simplex.Chat.Controller where
@ -14,9 +15,8 @@ import Crypto.Random (ChaChaDRG)
import Data.Int (Int64) import Data.Int (Int64)
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import Numeric.Natural import Numeric.Natural
import Simplex.Chat.Notification
import Simplex.Chat.Store (StoreError) import Simplex.Chat.Store (StoreError)
import Simplex.Chat.Terminal import Simplex.Chat.Styled
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Messaging.Agent (AgentClient) import Simplex.Messaging.Agent (AgentClient)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig)
@ -41,14 +41,18 @@ data ChatConfig = ChatConfig
fileChunkSize :: Integer fileChunkSize :: Integer
} }
data ActiveTo = ActiveNone | ActiveC ContactName | ActiveG GroupName
deriving (Eq)
data ChatController = ChatController data ChatController = ChatController
{ currentUser :: TVar User, { currentUser :: TVar User,
activeTo :: TVar ActiveTo,
firstTime :: Bool, firstTime :: Bool,
smpAgent :: AgentClient, smpAgent :: AgentClient,
chatTerminal :: ChatTerminal,
chatStore :: SQLiteStore, chatStore :: SQLiteStore,
idsDrg :: TVar ChaChaDRG, idsDrg :: TVar ChaChaDRG,
inputQ :: TBQueue InputEvent, inputQ :: TBQueue InputEvent,
outputQ :: TBQueue [StyledString],
notifyQ :: TBQueue Notification, notifyQ :: TBQueue Notification,
sendNotification :: Notification -> IO (), sendNotification :: Notification -> IO (),
chatLock :: TMVar (), chatLock :: TMVar (),
@ -90,9 +94,9 @@ data ChatErrorType
type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m, MonadFail m) type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m, MonadFail m)
setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m () setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
setActive to = asks (activeTo . chatTerminal) >>= atomically . (`writeTVar` to) setActive to = asks activeTo >>= atomically . (`writeTVar` to)
unsetActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m () unsetActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
unsetActive a = asks (activeTo . chatTerminal) >>= atomically . (`modifyTVar` unset) unsetActive a = asks activeTo >>= atomically . (`modifyTVar` unset)
where where
unset a' = if a == a' then ActiveNone else a' unset a' = if a == a' then ActiveNone else a'

11
migrations/20220101_initial.sql → src/Simplex/Chat/Migrations/M20220101_initial.hs
View file

@ -1,3 +1,13 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20220101_initial where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220101_initial :: Query
m20220101_initial =
[sql|
CREATE TABLE contact_profiles ( -- remote user profile CREATE TABLE contact_profiles ( -- remote user profile
contact_profile_id INTEGER PRIMARY KEY, contact_profile_id INTEGER PRIMARY KEY,
display_name TEXT NOT NULL, -- contact name set by remote user (not unique), this name must not contain spaces display_name TEXT NOT NULL, -- contact name set by remote user (not unique), this name must not contain spaces
@ -257,3 +267,4 @@ CREATE TABLE msg_delivery_events (
created_at TEXT NOT NULL DEFAULT (datetime('now')), created_at TEXT NOT NULL DEFAULT (datetime('now')),
UNIQUE (msg_delivery_id, delivery_status) UNIQUE (msg_delivery_id, delivery_status)
); );
|]

126
src/Simplex/Chat/Mobile.hs Normal file
View file

@ -0,0 +1,126 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.Mobile where
import Control.Concurrent (forkIO)
import Control.Concurrent.STM
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson ((.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.List (find)
import Foreign.C.String
import Foreign.StablePtr
import Simplex.Chat
import Simplex.Chat.Controller
import Simplex.Chat.Options
import Simplex.Chat.Store
import Simplex.Chat.Styled
import Simplex.Chat.Types
foreign export ccall "chat_init_store" cChatInitStore :: CString -> IO (StablePtr ChatStore)
foreign export ccall "chat_get_user" cChatGetUser :: StablePtr ChatStore -> IO CJSONString
foreign export ccall "chat_create_user" cChatCreateUser :: StablePtr ChatStore -> CJSONString -> IO CJSONString
foreign export ccall "chat_start" cChatStart :: StablePtr ChatStore -> IO (StablePtr ChatController)
foreign export ccall "chat_send_cmd" cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString
foreign export ccall "chat_recv_msg" cChatRecvMsg :: StablePtr ChatController -> IO CString
-- | creates or connects to chat store
cChatInitStore :: CString -> IO (StablePtr ChatStore)
cChatInitStore fp = peekCString fp >>= chatInitStore >>= newStablePtr
-- | returns JSON in the form `{"user": <user object>}` or `{}` in case there is no active user (to show dialog to enter displayName/fullName)
cChatGetUser :: StablePtr ChatStore -> IO CJSONString
cChatGetUser cc = deRefStablePtr cc >>= chatGetUser >>= newCString
-- | accepts Profile JSON, returns JSON `{"user": <user object>}` or `{"error": "<error>"}`
cChatCreateUser :: StablePtr ChatStore -> CJSONString -> IO CJSONString
cChatCreateUser cPtr profileCJson = do
c <- deRefStablePtr cPtr
p <- peekCString profileCJson
newCString =<< chatCreateUser c p
-- | this function starts chat - it cannot be started during initialization right now, as it cannot work without user (to be fixed later)
cChatStart :: StablePtr ChatStore -> IO (StablePtr ChatController)
cChatStart st = deRefStablePtr st >>= chatStart >>= newStablePtr
-- | send command to chat (same syntax as in terminal for now)
cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString
cChatSendCmd cPtr cCmd = do
c <- deRefStablePtr cPtr
cmd <- peekCString cCmd
newCString =<< chatSendCmd c cmd
-- | receive message from chat (blocking)
cChatRecvMsg :: StablePtr ChatController -> IO CString
cChatRecvMsg cc = deRefStablePtr cc >>= chatRecvMsg >>= newCString
mobileChatOpts :: ChatOpts
mobileChatOpts =
ChatOpts
{ dbFilePrefix = "simplex_v1", -- two database files will be created: simplex_v1_chat.db and simplex_v1_agent.db
smpServers = defaultSMPServers,
logging = False
}
type CJSONString = CString
type JSONString = String
data ChatStore = ChatStore
{ dbFilePrefix :: FilePath,
chatStore :: SQLiteStore
}
chatInitStore :: String -> IO ChatStore
chatInitStore dbFilePrefix = do
let f = chatStoreFile dbFilePrefix
chatStore <- createStore f $ dbPoolSize defaultChatConfig
pure ChatStore {dbFilePrefix, chatStore}
getActiveUser_ :: SQLiteStore -> IO (Maybe User)
getActiveUser_ st = find activeUser <$> getUsers st
-- | returns JSON in the form `{"user": <user object>}` or `{}`
chatGetUser :: ChatStore -> IO JSONString
chatGetUser ChatStore {chatStore} =
maybe "{}" (jsonObject . ("user" .=)) <$> getActiveUser_ chatStore
-- | returns JSON in the form `{"user": <user object>}` or `{"error": "<error>"}`
chatCreateUser :: ChatStore -> JSONString -> IO JSONString
chatCreateUser ChatStore {chatStore} profileJson =
case J.eitherDecodeStrict' $ B.pack profileJson of
Left e -> err e
Right p ->
runExceptT (createUser chatStore p True) >>= \case
Right user -> pure . jsonObject $ "user" .= user
Left e -> err e
where
err e = pure . jsonObject $ "error" .= show e
chatStart :: ChatStore -> IO ChatController
chatStart ChatStore {dbFilePrefix, chatStore} = do
Just user <- getActiveUser_ chatStore
cc <- newChatController chatStore user defaultChatConfig mobileChatOpts {dbFilePrefix} . const $ pure ()
void . forkIO $ runReaderT runChatController cc
pure cc
chatSendCmd :: ChatController -> String -> IO JSONString
chatSendCmd ChatController {inputQ} s = atomically (writeTBQueue inputQ $ InputCommand s) >> pure "{}"
chatRecvMsg :: ChatController -> IO String
chatRecvMsg ChatController {outputQ} = unlines . map unStyle <$> atomically (readTBQueue outputQ)
jsonObject :: J.Series -> JSONString
jsonObject = LB.unpack . JE.encodingToLazyByteString . J.pairs

26
src/Simplex/Chat/Options.hs
View file

@ -1,6 +1,11 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.Options (getChatOpts, ChatOpts (..)) where module Simplex.Chat.Options
( ChatOpts (..),
getChatOpts,
defaultSMPServers,
)
where
import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
@ -14,11 +19,20 @@ import Simplex.Messaging.Parsers (parseAll)
import System.FilePath (combine) import System.FilePath (combine)
data ChatOpts = ChatOpts data ChatOpts = ChatOpts
{ dbFile :: String, { dbFilePrefix :: String,
smpServers :: NonEmpty SMPServer, smpServers :: NonEmpty SMPServer,
logging :: Bool logging :: Bool
} }
defaultSMPServers :: NonEmpty SMPServer
defaultSMPServers =
L.fromList
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im",
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im",
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im"
-- "smp://Tn1b3Rr7_gErbVt2v50Y_T-PvUAi1BYAMS-62w-k9CI=@139.162.240.237"
]
chatOpts :: FilePath -> Parser ChatOpts chatOpts :: FilePath -> Parser ChatOpts
chatOpts appDir = chatOpts appDir =
ChatOpts ChatOpts
@ -38,13 +52,7 @@ chatOpts appDir =
<> help <> help
"Comma separated list of SMP server(s) to use \ "Comma separated list of SMP server(s) to use \
\(default: smp4.simplex.im,smp5.simplex.im,smp6.simplex.im)" \(default: smp4.simplex.im,smp5.simplex.im,smp6.simplex.im)"
<> value <> value defaultSMPServers
( L.fromList
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im",
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im",
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im"
]
)
) )
<*> switch <*> switch
( long "log" ( long "log"

19
src/Simplex/Chat/Store.hs
View file

@ -108,7 +108,6 @@ import Crypto.Random (ChaChaDRG, randomBytesGenerate)
import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import Data.Either (rights) import Data.Either (rights)
import Data.FileEmbed (embedDir, makeRelativeToProject)
import Data.Function (on) import Data.Function (on)
import Data.Functor (($>)) import Data.Functor (($>))
import Data.Int (Int64) import Data.Int (Int64)
@ -116,11 +115,11 @@ import Data.List (find, sortBy)
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Clock (UTCTime, getCurrentTime)
import Database.SQLite.Simple (NamedParam (..), Only (..), SQLError, (:.) (..)) import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), SQLError, (:.) (..))
import qualified Database.SQLite.Simple as DB import qualified Database.SQLite.Simple as DB
import Database.SQLite.Simple.QQ (sql) import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Migrations.M20220101_initial
import Simplex.Chat.Protocol import Simplex.Chat.Protocol
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (AParty (..), AgentMsgId, ConnId, InvitationId, MsgMeta (..)) import Simplex.Messaging.Agent.Protocol (AParty (..), AgentMsgId, ConnId, InvitationId, MsgMeta (..))
@ -128,17 +127,19 @@ import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Util (bshow, liftIOEither, (<$$>)) import Simplex.Messaging.Util (bshow, liftIOEither, (<$$>))
import System.FilePath (takeBaseName, takeExtension, takeFileName) import System.FilePath (takeFileName)
import UnliftIO.STM import UnliftIO.STM
schemaMigrations :: [(String, Query)]
schemaMigrations =
[ ("20220101_initial", m20220101_initial)
]
-- | The list of migrations in ascending order by date -- | The list of migrations in ascending order by date
migrations :: [Migration] migrations :: [Migration]
migrations = migrations = sortBy (compare `on` name) $ map migration schemaMigrations
sortBy (compare `on` name) . map migration . filter sqlFile $
$(makeRelativeToProject "migrations" >>= embedDir)
where where
sqlFile (file, _) = takeExtension file == ".sql" migration (name, query) = Migration {name = name, up = fromQuery query}
migration (file, qStr) = Migration {name = takeBaseName file, up = decodeUtf8 qStr}
createStore :: FilePath -> Int -> IO SQLiteStore createStore :: FilePath -> Int -> IO SQLiteStore
createStore dbFilePath poolSize = createSQLiteStore dbFilePath poolSize migrations createStore dbFilePath poolSize = createSQLiteStore dbFilePath poolSize migrations

5
src/Simplex/Chat/Styled.hs
View file

@ -6,6 +6,7 @@ module Simplex.Chat.Styled
StyledFormat (..), StyledFormat (..),
styleMarkdown, styleMarkdown,
styleMarkdownText, styleMarkdownText,
unStyle,
sLength, sLength,
sShow, sShow,
) )
@ -69,6 +70,10 @@ sgr = \case
Snippet -> [] Snippet -> []
NoFormat -> [] NoFormat -> []
unStyle :: StyledString -> String
unStyle (Styled _ s) = s
unStyle (s1 :<>: s2) = unStyle s1 <> unStyle s2
sLength :: StyledString -> Int sLength :: StyledString -> Int
sLength (Styled _ s) = length s sLength (Styled _ s) = length s
sLength (s1 :<>: s2) = sLength s1 + sLength s2 sLength (s1 :<>: s2) = sLength s1 + sLength s2

200
src/Simplex/Chat/Terminal.hs
View file

@ -1,176 +1,38 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Chat.Terminal where module Simplex.Chat.Terminal where
import Control.Monad.Catch (MonadMask) import Control.Logger.Simple
import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader
import Simplex.Chat.Styled import Simplex.Chat
import Simplex.Chat.Types import Simplex.Chat.Controller
import System.Console.ANSI.Types import Simplex.Chat.Help (chatWelcome)
import System.Terminal import Simplex.Chat.Options
import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal) import Simplex.Chat.Store
import UnliftIO.STM import Simplex.Chat.Terminal.Input
import Simplex.Chat.Terminal.Notification
import Simplex.Chat.Terminal.Output
import Simplex.Chat.Types (User)
import Simplex.Chat.Util (whenM)
import Simplex.Messaging.Util (raceAny_)
data ActiveTo = ActiveNone | ActiveC ContactName | ActiveG GroupName simplexChat :: WithTerminal t => ChatConfig -> ChatOpts -> t -> IO ()
deriving (Eq) simplexChat cfg opts t
| logging opts = do
data ChatTerminal = ChatTerminal setLogLevel LogInfo -- LogError
{ activeTo :: TVar ActiveTo, withGlobalLogging logCfg initRun
termDevice :: TerminalDevice, | otherwise = initRun
termState :: TVar TerminalState,
termSize :: Size,
nextMessageRow :: TVar Int,
termLock :: TMVar ()
}
data TerminalState = TerminalState
{ inputPrompt :: String,
inputString :: String,
inputPosition :: Int,
previousInput :: String
}
class Terminal t => WithTerminal t where
withTerm :: (MonadIO m, MonadMask m) => t -> (t -> m a) -> m a
data TerminalDevice = forall t. WithTerminal t => TerminalDevice t
instance WithTerminal LocalTerminal where
withTerm _ = withTerminal
instance WithTerminal VirtualTerminal where
withTerm t = ($ t)
withChatTerm :: (MonadIO m, MonadMask m) => ChatTerminal -> (forall t. WithTerminal t => TerminalT t m a) -> m a
withChatTerm ChatTerminal {termDevice = TerminalDevice t} action = withTerm t $ runTerminalT action
newChatTerminal :: WithTerminal t => t -> IO ChatTerminal
newChatTerminal t = do
activeTo <- newTVarIO ActiveNone
termSize <- withTerm t . runTerminalT $ getWindowSize
let lastRow = height termSize - 1
termState <- newTVarIO newTermState
termLock <- newTMVarIO ()
nextMessageRow <- newTVarIO lastRow
-- threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
return ChatTerminal {activeTo, termDevice = TerminalDevice t, termState, termSize, nextMessageRow, termLock}
newTermState :: TerminalState
newTermState =
TerminalState
{ inputString = "",
inputPosition = 0,
inputPrompt = "> ",
previousInput = ""
}
withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m ()
withTermLock ChatTerminal {termLock} action = do
_ <- atomically $ takeTMVar termLock
action
atomically $ putTMVar termLock ()
printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
printToTerminal ct s =
withChatTerm ct $
withTermLock ct $ do
printMessage ct s
updateInput ct
updateInput :: forall m. MonadTerminal m => ChatTerminal -> m ()
updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessageRow} = do
hideCursor
ts <- readTVarIO termState
nmr <- readTVarIO nextMessageRow
let ih = inputHeight ts
iStart = height - ih
prompt = inputPrompt ts
Position {row, col} = positionRowColumn width $ length prompt + inputPosition ts
if nmr >= iStart
then atomically $ writeTVar nextMessageRow iStart
else clearLines nmr iStart
setCursorPosition $ Position {row = max nmr iStart, col = 0}
putString $ prompt <> inputString ts <> " "
eraseInLine EraseForward
setCursorPosition $ Position {row = iStart + row, col}
showCursor
flush
where where
clearLines :: Int -> Int -> m () initRun = do
clearLines from till sendNotification <- initializeNotifications
| from >= till = return () let f = chatStoreFile $ dbFilePrefix opts
| otherwise = do st <- createStore f $ dbPoolSize cfg
setCursorPosition $ Position {row = from, col = 0} user <- getCreateActiveUser st
eraseInLine EraseForward ct <- newChatTerminal t
clearLines (from + 1) till cc <- newChatController st user cfg opts sendNotification
inputHeight :: TerminalState -> Int runSimplexChat user ct cc
inputHeight ts = length (inputPrompt ts <> inputString ts) `div` width + 1
positionRowColumn :: Int -> Int -> Position
positionRowColumn wid pos =
let row = pos `div` wid
col = pos - row * wid
in Position {row, col}
printMessage :: forall m. MonadTerminal m => ChatTerminal -> [StyledString] -> m () runSimplexChat :: User -> ChatTerminal -> ChatController -> IO ()
printMessage ChatTerminal {termSize = Size {height, width}, nextMessageRow} msg = do runSimplexChat user ct = runReaderT $ do
nmr <- readTVarIO nextMessageRow whenM (asks firstTime) . liftIO . printToTerminal ct $ chatWelcome user
setCursorPosition $ Position {row = nmr, col = 0} raceAny_ [runTerminalInput ct, runTerminalOutput ct, runChatController]
mapM_ printStyled msg
flush
let lc = sum $ map lineCount msg
atomically . writeTVar nextMessageRow $ min (height - 1) (nmr + lc)
where
lineCount :: StyledString -> Int
lineCount s = sLength s `div` width + 1
printStyled :: StyledString -> m ()
printStyled s = do
putStyled s
eraseInLine EraseForward
putLn
-- Currently it is assumed that the message does not have internal line breaks.
-- Previous implementation "kind of" supported them,
-- but it was not determining the number of printed lines correctly
-- because of accounting for control sequences in length
putStyled :: MonadTerminal m => StyledString -> m ()
putStyled (s1 :<>: s2) = putStyled s1 >> putStyled s2
putStyled (Styled [] s) = putString s
putStyled (Styled sgr s) = setSGR sgr >> putString s >> resetAttributes
setSGR :: MonadTerminal m => [SGR] -> m ()
setSGR = mapM_ $ \case
Reset -> resetAttributes
SetConsoleIntensity BoldIntensity -> setAttribute bold
SetConsoleIntensity _ -> resetAttribute bold
SetItalicized True -> setAttribute italic
SetItalicized _ -> resetAttribute italic
SetUnderlining NoUnderline -> resetAttribute underlined
SetUnderlining _ -> setAttribute underlined
SetSwapForegroundBackground True -> setAttribute inverted
SetSwapForegroundBackground _ -> resetAttribute inverted
SetColor l i c -> setAttribute . layer l . intensity i $ color c
SetBlinkSpeed _ -> pure ()
SetVisible _ -> pure ()
SetRGBColor _ _ -> pure ()
SetPaletteColor _ _ -> pure ()
SetDefaultColor _ -> pure ()
where
layer = \case
Foreground -> foreground
Background -> background
intensity = \case
Dull -> id
Vivid -> bright
color = \case
Black -> black
Red -> red
Green -> green
Yellow -> yellow
Blue -> blue
Magenta -> magenta
Cyan -> cyan
White -> white

16
src/Simplex/Chat/Input.hs → src/Simplex/Chat/Terminal/Input.hs
View file

@ -2,14 +2,14 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
module Simplex.Chat.Input where module Simplex.Chat.Terminal.Input where
import Control.Monad.IO.Unlift import Control.Monad.IO.Unlift
import Control.Monad.Reader import Control.Monad.Reader
import Data.List (dropWhileEnd) import Data.List (dropWhileEnd)
import qualified Data.Text as T import qualified Data.Text as T
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Chat.Terminal import Simplex.Chat.Terminal.Output
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import System.Terminal hiding (insertChars) import System.Terminal hiding (insertChars)
import UnliftIO.STM import UnliftIO.STM
@ -21,16 +21,16 @@ getKey =
Right (KeyEvent key ms) -> pure (key, ms) Right (KeyEvent key ms) -> pure (key, ms)
_ -> getKey _ -> getKey
runTerminalInput :: (MonadUnliftIO m, MonadReader ChatController m) => m () runTerminalInput :: (MonadUnliftIO m, MonadReader ChatController m) => ChatTerminal -> m ()
runTerminalInput = do runTerminalInput ct = do
ChatController {inputQ, chatTerminal = ct} <- ask cc <- ask
liftIO $ liftIO $
withChatTerm ct $ do withChatTerm ct $ do
updateInput ct updateInput ct
receiveFromTTY inputQ ct receiveFromTTY cc ct
receiveFromTTY :: MonadTerminal m => TBQueue InputEvent -> ChatTerminal -> m () receiveFromTTY :: MonadTerminal m => ChatController -> ChatTerminal -> m ()
receiveFromTTY inputQ ct@ChatTerminal {activeTo, termSize, termState} = receiveFromTTY ChatController {inputQ, activeTo} ct@ChatTerminal {termSize, termState} =
forever $ getKey >>= processKey >> withTermLock ct (updateInput ct) forever $ getKey >>= processKey >> withTermLock ct (updateInput ct)
where where
processKey :: MonadTerminal m => (Key, Modifiers) -> m () processKey :: MonadTerminal m => (Key, Modifiers) -> m ()

5
src/Simplex/Chat/Notification.hs → src/Simplex/Chat/Terminal/Notification.hs
View file

@ -3,7 +3,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Chat.Notification (Notification (..), initializeNotifications) where module Simplex.Chat.Terminal.Notification (Notification (..), initializeNotifications) where
import Control.Exception import Control.Exception
import Control.Monad (void) import Control.Monad (void)
@ -13,13 +13,12 @@ import qualified Data.Map as M
import Data.Maybe (fromMaybe, isJust) import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Simplex.Chat.Types
import System.Directory (createDirectoryIfMissing, doesFileExist, findExecutable, getAppUserDataDirectory) import System.Directory (createDirectoryIfMissing, doesFileExist, findExecutable, getAppUserDataDirectory)
import System.FilePath (combine) import System.FilePath (combine)
import System.Info (os) import System.Info (os)
import System.Process (readCreateProcess, shell) import System.Process (readCreateProcess, shell)
data Notification = Notification {title :: Text, text :: Text}
initializeNotifications :: IO (Notification -> IO ()) initializeNotifications :: IO (Notification -> IO ())
initializeNotifications = initializeNotifications =
hideException <$> case os of hideException <$> case os of

179
src/Simplex/Chat/Terminal/Output.hs Normal file
View file

@ -0,0 +1,179 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Chat.Terminal.Output where
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Simplex.Chat.Controller
import Simplex.Chat.Styled
import System.Console.ANSI.Types
import System.Terminal
import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal)
import UnliftIO.STM
data ChatTerminal = ChatTerminal
{ termDevice :: TerminalDevice,
termState :: TVar TerminalState,
termSize :: Size,
nextMessageRow :: TVar Int,
termLock :: TMVar ()
}
data TerminalState = TerminalState
{ inputPrompt :: String,
inputString :: String,
inputPosition :: Int,
previousInput :: String
}
class Terminal t => WithTerminal t where
withTerm :: (MonadIO m, MonadMask m) => t -> (t -> m a) -> m a
data TerminalDevice = forall t. WithTerminal t => TerminalDevice t
instance WithTerminal LocalTerminal where
withTerm _ = withTerminal
instance WithTerminal VirtualTerminal where
withTerm t = ($ t)
withChatTerm :: (MonadIO m, MonadMask m) => ChatTerminal -> (forall t. WithTerminal t => TerminalT t m a) -> m a
withChatTerm ChatTerminal {termDevice = TerminalDevice t} action = withTerm t $ runTerminalT action
newChatTerminal :: WithTerminal t => t -> IO ChatTerminal
newChatTerminal t = do
termSize <- withTerm t . runTerminalT $ getWindowSize
let lastRow = height termSize - 1
termState <- newTVarIO mkTermState
termLock <- newTMVarIO ()
nextMessageRow <- newTVarIO lastRow
-- threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
return ChatTerminal {termDevice = TerminalDevice t, termState, termSize, nextMessageRow, termLock}
mkTermState :: TerminalState
mkTermState =
TerminalState
{ inputString = "",
inputPosition = 0,
inputPrompt = "> ",
previousInput = ""
}
withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m ()
withTermLock ChatTerminal {termLock} action = do
_ <- atomically $ takeTMVar termLock
action
atomically $ putTMVar termLock ()
runTerminalOutput :: (MonadUnliftIO m, MonadReader ChatController m) => ChatTerminal -> m ()
runTerminalOutput ct = do
ChatController {outputQ} <- ask
forever $
atomically (readTBQueue outputQ) >>= liftIO . printToTerminal ct
printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
printToTerminal ct s =
withChatTerm ct $
withTermLock ct $ do
printMessage ct s
updateInput ct
updateInput :: forall m. MonadTerminal m => ChatTerminal -> m ()
updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessageRow} = do
hideCursor
ts <- readTVarIO termState
nmr <- readTVarIO nextMessageRow
let ih = inputHeight ts
iStart = height - ih
prompt = inputPrompt ts
Position {row, col} = positionRowColumn width $ length prompt + inputPosition ts
if nmr >= iStart
then atomically $ writeTVar nextMessageRow iStart
else clearLines nmr iStart
setCursorPosition $ Position {row = max nmr iStart, col = 0}
putString $ prompt <> inputString ts <> " "
eraseInLine EraseForward
setCursorPosition $ Position {row = iStart + row, col}
showCursor
flush
where
clearLines :: Int -> Int -> m ()
clearLines from till
| from >= till = return ()
| otherwise = do
setCursorPosition $ Position {row = from, col = 0}
eraseInLine EraseForward
clearLines (from + 1) till
inputHeight :: TerminalState -> Int
inputHeight ts = length (inputPrompt ts <> inputString ts) `div` width + 1
positionRowColumn :: Int -> Int -> Position
positionRowColumn wid pos =
let row = pos `div` wid
col = pos - row * wid
in Position {row, col}
printMessage :: forall m. MonadTerminal m => ChatTerminal -> [StyledString] -> m ()
printMessage ChatTerminal {termSize = Size {height, width}, nextMessageRow} msg = do
nmr <- readTVarIO nextMessageRow
setCursorPosition $ Position {row = nmr, col = 0}
mapM_ printStyled msg
flush
let lc = sum $ map lineCount msg
atomically . writeTVar nextMessageRow $ min (height - 1) (nmr + lc)
where
lineCount :: StyledString -> Int
lineCount s = sLength s `div` width + 1
printStyled :: StyledString -> m ()
printStyled s = do
putStyled s
eraseInLine EraseForward
putLn
-- Currently it is assumed that the message does not have internal line breaks.
-- Previous implementation "kind of" supported them,
-- but it was not determining the number of printed lines correctly
-- because of accounting for control sequences in length
putStyled :: MonadTerminal m => StyledString -> m ()
putStyled (s1 :<>: s2) = putStyled s1 >> putStyled s2
putStyled (Styled [] s) = putString s
putStyled (Styled sgr s) = setSGR sgr >> putString s >> resetAttributes
setSGR :: MonadTerminal m => [SGR] -> m ()
setSGR = mapM_ $ \case
Reset -> resetAttributes
SetConsoleIntensity BoldIntensity -> setAttribute bold
SetConsoleIntensity _ -> resetAttribute bold
SetItalicized True -> setAttribute italic
SetItalicized _ -> resetAttribute italic
SetUnderlining NoUnderline -> resetAttribute underlined
SetUnderlining _ -> setAttribute underlined
SetSwapForegroundBackground True -> setAttribute inverted
SetSwapForegroundBackground _ -> resetAttribute inverted
SetColor l i c -> setAttribute . layer l . intensity i $ color c
SetBlinkSpeed _ -> pure ()
SetVisible _ -> pure ()
SetRGBColor _ _ -> pure ()
SetPaletteColor _ _ -> pure ()
SetDefaultColor _ -> pure ()
where
layer = \case
Foreground -> foreground
Background -> background
intensity = \case
Dull -> id
Vivid -> bright
color = \case
Black -> black
Red -> red
Green -> green
Yellow -> yellow
Blue -> blue
Magenta -> magenta
Cyan -> cyan
White -> white

5
src/Simplex/Chat/Types.hs
View file

@ -60,6 +60,9 @@ data User = User
profile :: Profile, profile :: Profile,
activeUser :: Bool activeUser :: Bool
} }
deriving (Generic, FromJSON)
instance ToJSON User where toEncoding = J.genericToEncoding J.defaultOptions
type UserId = Int64 type UserId = Int64
@ -743,3 +746,5 @@ msgDeliveryStatusT' s =
case testEquality d (msgDirection @d) of case testEquality d (msgDirection @d) of
Just Refl -> Just st Just Refl -> Just st
_ -> Nothing _ -> Nothing
data Notification = Notification {title :: Text, text :: Text}

656
src/Simplex/Chat/View.hs
View file

@ -7,85 +7,83 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.View module Simplex.Chat.View
( printToView, ( safeDecodeUtf8,
showInvitation,
showSentConfirmation,
showSentInvitation,
showInvalidConnReq,
showChatError,
showContactDeleted,
showContactGroups,
showContactsList,
showContactConnected,
showContactDisconnected,
showContactAnotherClient,
showContactSubscribed,
showContactSubError,
showUserContactLinkCreated,
showUserContactLinkDeleted,
showUserContactLink,
showReceivedContactRequest,
showAcceptingContactRequest,
showContactRequestRejected,
showUserContactLinkSubscribed,
showUserContactLinkSubError,
showGroupSubscribed,
showGroupEmpty,
showGroupRemoved,
showGroupInvitation,
showMemberSubError,
showReceivedMessage,
showReceivedGroupMessage,
showSentMessage,
showSentGroupMessage,
showSentFileInvitation,
showSentGroupFileInvitation,
showSentFileInfo,
showSndFileStart,
showSndFileComplete,
showSndFileCancelled,
showSndGroupFileCancelled,
showSndFileRcvCancelled,
receivedFileInvitation,
showRcvFileAccepted,
showRcvFileStart,
showRcvFileComplete,
showRcvFileCancelled,
showRcvFileSndCancelled,
showFileTransferStatus,
showSndFileSubError,
showRcvFileSubError,
showGroupCreated,
showGroupDeletedUser,
showGroupDeleted,
showSentGroupInvitation,
showCannotResendInvitation,
showReceivedGroupInvitation,
showJoinedGroupMember,
showUserJoinedGroup,
showJoinedGroupMemberConnecting,
showConnectedToGroupMember,
showDeletedMember,
showDeletedMemberUser,
showLeftMemberUser,
showLeftMember,
showGroupMembers,
showGroupsList,
showContactsMerged,
showUserProfile,
showUserProfileUpdated,
showContactUpdated,
showMessageError,
safeDecodeUtf8,
msgPlain, msgPlain,
clientVersionInfo, clientVersionInfo,
viewConnReqInvitation,
viewSentConfirmation,
viewSentInvitation,
viewInvalidConnReq,
viewContactDeleted,
viewContactGroups,
viewContactsList,
viewUserContactLinkCreated,
viewUserContactLinkDeleted,
viewUserContactLink,
viewAcceptingContactRequest,
viewContactRequestRejected,
viewGroupCreated,
viewSentGroupInvitation,
viewCannotResendInvitation,
viewDeletedMember,
viewLeftMemberUser,
viewGroupDeletedUser,
viewGroupMembers,
viewSentFileInfo,
viewRcvFileAccepted,
viewRcvFileSndCancelled,
viewSndGroupFileCancelled,
viewRcvFileCancelled,
viewFileTransferStatus,
viewUserProfileUpdated,
viewUserProfile,
viewChatError,
viewSentMessage,
viewSentGroupMessage,
viewSentGroupFileInvitation,
viewSentFileInvitation,
viewGroupsList,
viewContactSubscribed,
viewContactSubError,
viewGroupInvitation,
viewGroupEmpty,
viewGroupRemoved,
viewMemberSubError,
viewGroupSubscribed,
viewSndFileSubError,
viewRcvFileSubError,
viewUserContactLinkSubscribed,
viewUserContactLinkSubError,
viewContactConnected,
viewContactDisconnected,
viewContactAnotherClient,
viewJoinedGroupMember,
viewUserJoinedGroup,
viewJoinedGroupMemberConnecting,
viewConnectedToGroupMember,
viewReceivedGroupInvitation,
viewDeletedMemberUser,
viewLeftMember,
viewSndFileStart,
viewSndFileComplete,
viewSndFileCancelled,
viewSndFileRcvCancelled,
viewRcvFileStart,
viewRcvFileComplete,
viewReceivedContactRequest,
viewMessageError,
viewReceivedMessage,
viewReceivedGroupMessage,
viewReceivedFileInvitation,
viewReceivedGroupFileInvitation,
viewContactUpdated,
viewContactsMerged,
viewGroupDeleted,
) )
where where
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import Data.Composition ((.:), (.:.)) import Data.Composition ((.:))
import Data.Function (on) import Data.Function (on)
import Data.Int (Int64) import Data.Int (Int64)
import Data.List (groupBy, intersperse, sort, sortOn) import Data.List (groupBy, intersperse, sort, sortOn)
@ -99,7 +97,6 @@ import Simplex.Chat.Controller
import Simplex.Chat.Markdown import Simplex.Chat.Markdown
import Simplex.Chat.Store (StoreError (..)) import Simplex.Chat.Store (StoreError (..))
import Simplex.Chat.Styled import Simplex.Chat.Styled
import Simplex.Chat.Terminal (printToTerminal)
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Chat.Util (safeDecodeUtf8) import Simplex.Chat.Util (safeDecodeUtf8)
import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Protocol
@ -107,227 +104,25 @@ import Simplex.Messaging.Encoding.String
import qualified Simplex.Messaging.Protocol as SMP import qualified Simplex.Messaging.Protocol as SMP
import System.Console.ANSI.Types import System.Console.ANSI.Types
type ChatReader m = (MonadUnliftIO m, MonadReader ChatController m) viewSentConfirmation :: [StyledString]
viewSentConfirmation = ["confirmation sent!"]
showInvitation :: ChatReader m => ConnReqInvitation -> m () viewSentInvitation :: [StyledString]
showInvitation = printToView . connReqInvitation_ viewSentInvitation = ["connection request sent!"]
showSentConfirmation :: ChatReader m => m () viewInvalidConnReq :: [StyledString]
showSentConfirmation = printToView ["confirmation sent!"] viewInvalidConnReq =
[ "",
"Connection link is invalid, possibly it was created in a previous version.",
"Please ask your contact to check " <> highlight' "/version" <> " and update if needed.",
plain updateStr
]
showSentInvitation :: ChatReader m => m () viewUserContactLinkSubscribed :: [StyledString]
showSentInvitation = printToView ["connection request sent!"] viewUserContactLinkSubscribed = ["Your address is active! To show: " <> highlight' "/sa"]
showInvalidConnReq :: ChatReader m => m () viewConnReqInvitation :: ConnReqInvitation -> [StyledString]
showInvalidConnReq = viewConnReqInvitation cReq =
printToView
[ "",
"Connection link is invalid, possibly it was created in a previous version.",
"Please ask your contact to check " <> highlight' "/version" <> " and update if needed.",
plain updateStr
]
showChatError :: ChatReader m => ChatError -> m ()
showChatError = printToView . chatError
showContactDeleted :: ChatReader m => ContactName -> m ()
showContactDeleted = printToView . contactDeleted
showContactGroups :: ChatReader m => ContactName -> [GroupName] -> m ()
showContactGroups = printToView .: contactGroups
showContactsList :: ChatReader m => [Contact] -> m ()
showContactsList = printToView . contactsList
showContactConnected :: ChatReader m => Contact -> m ()
showContactConnected = printToView . contactConnected
showContactDisconnected :: ChatReader m => ContactName -> m ()
showContactDisconnected = printToView . contactDisconnected
showContactAnotherClient :: ChatReader m => ContactName -> m ()
showContactAnotherClient = printToView . contactAnotherClient
showContactSubscribed :: ChatReader m => ContactName -> m ()
showContactSubscribed = printToView . contactSubscribed
showContactSubError :: ChatReader m => ContactName -> ChatError -> m ()
showContactSubError = printToView .: contactSubError
showUserContactLinkCreated :: ChatReader m => ConnReqContact -> m ()
showUserContactLinkCreated = printToView . userContactLinkCreated
showUserContactLinkDeleted :: ChatReader m => m ()
showUserContactLinkDeleted = printToView userContactLinkDeleted
showUserContactLink :: ChatReader m => ConnReqContact -> m ()
showUserContactLink = printToView . userContactLink
showReceivedContactRequest :: ChatReader m => ContactName -> Profile -> m ()
showReceivedContactRequest = printToView .: receivedContactRequest
showAcceptingContactRequest :: ChatReader m => ContactName -> m ()
showAcceptingContactRequest = printToView . acceptingContactRequest
showContactRequestRejected :: ChatReader m => ContactName -> m ()
showContactRequestRejected = printToView . contactRequestRejected
showUserContactLinkSubscribed :: ChatReader m => m ()
showUserContactLinkSubscribed = printToView ["Your address is active! To show: " <> highlight' "/sa"]
showUserContactLinkSubError :: ChatReader m => ChatError -> m ()
showUserContactLinkSubError = printToView . userContactLinkSubError
showGroupSubscribed :: ChatReader m => Group -> m ()
showGroupSubscribed = printToView . groupSubscribed
showGroupEmpty :: ChatReader m => Group -> m ()
showGroupEmpty = printToView . groupEmpty
showGroupRemoved :: ChatReader m => Group -> m ()
showGroupRemoved = printToView . groupRemoved
showGroupInvitation :: ChatReader m => Group -> m ()
showGroupInvitation Group {localDisplayName = ldn, groupProfile = GroupProfile {fullName}} =
printToView [groupInvitation ldn fullName]
showMemberSubError :: ChatReader m => GroupName -> ContactName -> ChatError -> m ()
showMemberSubError = printToView .:. memberSubError
showReceivedMessage :: ChatReader m => ContactName -> UTCTime -> [StyledString] -> MsgIntegrity -> m ()
showReceivedMessage = showReceivedMessage_ . ttyFromContact
showReceivedGroupMessage :: ChatReader m => GroupName -> ContactName -> UTCTime -> [StyledString] -> MsgIntegrity -> m ()
showReceivedGroupMessage = showReceivedMessage_ .: ttyFromGroup
showReceivedMessage_ :: ChatReader m => StyledString -> UTCTime -> [StyledString] -> MsgIntegrity -> m ()
showReceivedMessage_ from utcTime msg mOk = printToView =<< liftIO (receivedMessage from utcTime msg mOk)
showSentMessage :: ChatReader m => ContactName -> ByteString -> m ()
showSentMessage = showSentMessage_ . ttyToContact
showSentGroupMessage :: ChatReader m => GroupName -> ByteString -> m ()
showSentGroupMessage = showSentMessage_ . ttyToGroup
showSentMessage_ :: ChatReader m => StyledString -> ByteString -> m ()
showSentMessage_ to msg = printToView =<< liftIO (sentMessage to msg)
showSentFileInvitation :: ChatReader m => ContactName -> FilePath -> m ()
showSentFileInvitation = showSentFileInvitation_ . ttyToContact
showSentGroupFileInvitation :: ChatReader m => GroupName -> FilePath -> m ()
showSentGroupFileInvitation = showSentFileInvitation_ . ttyToGroup
showSentFileInvitation_ :: ChatReader m => StyledString -> FilePath -> m ()
showSentFileInvitation_ to filePath = printToView =<< liftIO (sentFileInvitation to filePath)
showSentFileInfo :: ChatReader m => Int64 -> m ()
showSentFileInfo = printToView . sentFileInfo
showSndFileStart :: ChatReader m => SndFileTransfer -> m ()
showSndFileStart = printToView . sndFileStart
showSndFileComplete :: ChatReader m => SndFileTransfer -> m ()
showSndFileComplete = printToView . sndFileComplete
showSndFileCancelled :: ChatReader m => SndFileTransfer -> m ()
showSndFileCancelled = printToView . sndFileCancelled
showSndGroupFileCancelled :: ChatReader m => [SndFileTransfer] -> m ()
showSndGroupFileCancelled = printToView . sndGroupFileCancelled
showSndFileRcvCancelled :: ChatReader m => SndFileTransfer -> m ()
showSndFileRcvCancelled = printToView . sndFileRcvCancelled
showRcvFileAccepted :: ChatReader m => RcvFileTransfer -> FilePath -> m ()
showRcvFileAccepted = printToView .: rcvFileAccepted
showRcvFileStart :: ChatReader m => RcvFileTransfer -> m ()
showRcvFileStart = printToView . rcvFileStart
showRcvFileComplete :: ChatReader m => RcvFileTransfer -> m ()
showRcvFileComplete = printToView . rcvFileComplete
showRcvFileCancelled :: ChatReader m => RcvFileTransfer -> m ()
showRcvFileCancelled = printToView . rcvFileCancelled
showRcvFileSndCancelled :: ChatReader m => RcvFileTransfer -> m ()
showRcvFileSndCancelled = printToView . rcvFileSndCancelled
showFileTransferStatus :: ChatReader m => (FileTransfer, [Integer]) -> m ()
showFileTransferStatus = printToView . fileTransferStatus
showSndFileSubError :: ChatReader m => SndFileTransfer -> ChatError -> m ()
showSndFileSubError = printToView .: sndFileSubError
showRcvFileSubError :: ChatReader m => RcvFileTransfer -> ChatError -> m ()
showRcvFileSubError = printToView .: rcvFileSubError
showGroupCreated :: ChatReader m => Group -> m ()
showGroupCreated = printToView . groupCreated
showGroupDeletedUser :: ChatReader m => GroupName -> m ()
showGroupDeletedUser = printToView . groupDeletedUser
showGroupDeleted :: ChatReader m => GroupName -> GroupMember -> m ()
showGroupDeleted = printToView .: groupDeleted
showSentGroupInvitation :: ChatReader m => GroupName -> ContactName -> m ()
showSentGroupInvitation = printToView .: sentGroupInvitation
showCannotResendInvitation :: ChatReader m => GroupName -> ContactName -> m ()
showCannotResendInvitation = printToView .: cannotResendInvitation
showReceivedGroupInvitation :: ChatReader m => Group -> ContactName -> GroupMemberRole -> m ()
showReceivedGroupInvitation = printToView .:. receivedGroupInvitation
showJoinedGroupMember :: ChatReader m => GroupName -> GroupMember -> m ()
showJoinedGroupMember = printToView .: joinedGroupMember
showUserJoinedGroup :: ChatReader m => GroupName -> m ()
showUserJoinedGroup = printToView . userJoinedGroup
showJoinedGroupMemberConnecting :: ChatReader m => GroupName -> GroupMember -> GroupMember -> m ()
showJoinedGroupMemberConnecting = printToView .:. joinedGroupMemberConnecting
showConnectedToGroupMember :: ChatReader m => GroupName -> GroupMember -> m ()
showConnectedToGroupMember = printToView .: connectedToGroupMember
showDeletedMember :: ChatReader m => GroupName -> Maybe GroupMember -> Maybe GroupMember -> m ()
showDeletedMember = printToView .:. deletedMember
showDeletedMemberUser :: ChatReader m => GroupName -> GroupMember -> m ()
showDeletedMemberUser = printToView .: deletedMemberUser
showLeftMemberUser :: ChatReader m => GroupName -> m ()
showLeftMemberUser = printToView . leftMemberUser
showLeftMember :: ChatReader m => GroupName -> GroupMember -> m ()
showLeftMember = printToView .: leftMember
showGroupMembers :: ChatReader m => Group -> m ()
showGroupMembers = printToView . groupMembers
showGroupsList :: ChatReader m => [(GroupName, Text, GroupMemberStatus)] -> m ()
showGroupsList = printToView . groupsList
showContactsMerged :: ChatReader m => Contact -> Contact -> m ()
showContactsMerged = printToView .: contactsMerged
showUserProfile :: ChatReader m => Profile -> m ()
showUserProfile = printToView . userProfile
showUserProfileUpdated :: ChatReader m => User -> User -> m ()
showUserProfileUpdated = printToView .: userProfileUpdated
showContactUpdated :: ChatReader m => Contact -> Contact -> m ()
showContactUpdated = printToView .: contactUpdated
showMessageError :: ChatReader m => Text -> Text -> m ()
showMessageError = printToView .: messageError
connReqInvitation_ :: ConnReqInvitation -> [StyledString]
connReqInvitation_ cReq =
[ "pass this invitation link to your contact (via another channel): ", [ "pass this invitation link to your contact (via another channel): ",
"", "",
(plain . strEncode) cReq, (plain . strEncode) cReq,
@ -335,48 +130,48 @@ connReqInvitation_ cReq =
"and ask them to connect: " <> highlight' "/c <invitation_link_above>" "and ask them to connect: " <> highlight' "/c <invitation_link_above>"
] ]
contactDeleted :: ContactName -> [StyledString] viewContactDeleted :: ContactName -> [StyledString]
contactDeleted c = [ttyContact c <> ": contact is deleted"] viewContactDeleted c = [ttyContact c <> ": contact is deleted"]
contactGroups :: ContactName -> [GroupName] -> [StyledString] viewContactGroups :: ContactName -> [GroupName] -> [StyledString]
contactGroups c gNames = [ttyContact c <> ": contact cannot be deleted, it is a member of the group(s) " <> ttyGroups gNames] viewContactGroups c gNames = [ttyContact c <> ": contact cannot be deleted, it is a member of the group(s) " <> ttyGroups gNames]
where where
ttyGroups :: [GroupName] -> StyledString ttyGroups :: [GroupName] -> StyledString
ttyGroups [] = "" ttyGroups [] = ""
ttyGroups [g] = ttyGroup g ttyGroups [g] = ttyGroup g
ttyGroups (g : gs) = ttyGroup g <> ", " <> ttyGroups gs ttyGroups (g : gs) = ttyGroup g <> ", " <> ttyGroups gs
contactsList :: [Contact] -> [StyledString] viewContactsList :: [Contact] -> [StyledString]
contactsList = viewContactsList =
let ldn = T.toLower . (localDisplayName :: Contact -> ContactName) let ldn = T.toLower . (localDisplayName :: Contact -> ContactName)
in map ttyFullContact . sortOn ldn in map ttyFullContact . sortOn ldn
contactConnected :: Contact -> [StyledString] viewContactConnected :: Contact -> [StyledString]
contactConnected ct = [ttyFullContact ct <> ": contact is connected"] viewContactConnected ct = [ttyFullContact ct <> ": contact is connected"]
contactDisconnected :: ContactName -> [StyledString] viewContactDisconnected :: ContactName -> [StyledString]
contactDisconnected c = [ttyContact c <> ": disconnected from server (messages will be queued)"] viewContactDisconnected c = [ttyContact c <> ": disconnected from server (messages will be queued)"]
contactAnotherClient :: ContactName -> [StyledString] viewContactAnotherClient :: ContactName -> [StyledString]
contactAnotherClient c = [ttyContact c <> ": contact is connected to another client"] viewContactAnotherClient c = [ttyContact c <> ": contact is connected to another client"]
contactSubscribed :: ContactName -> [StyledString] viewContactSubscribed :: ContactName -> [StyledString]
contactSubscribed c = [ttyContact c <> ": connected to server"] viewContactSubscribed c = [ttyContact c <> ": connected to server"]
contactSubError :: ContactName -> ChatError -> [StyledString] viewContactSubError :: ContactName -> ChatError -> [StyledString]
contactSubError c e = [ttyContact c <> ": contact error " <> sShow e] viewContactSubError c e = [ttyContact c <> ": contact error " <> sShow e]
userContactLinkCreated :: ConnReqContact -> [StyledString] viewUserContactLinkCreated :: ConnReqContact -> [StyledString]
userContactLinkCreated = connReqContact_ "Your new chat address is created!" viewUserContactLinkCreated = connReqContact_ "Your new chat address is created!"
userContactLinkDeleted :: [StyledString] viewUserContactLinkDeleted :: [StyledString]
userContactLinkDeleted = viewUserContactLinkDeleted =
[ "Your chat address is deleted - accepted contacts will remain connected.", [ "Your chat address is deleted - accepted contacts will remain connected.",
"To create a new chat address use " <> highlight' "/ad" "To create a new chat address use " <> highlight' "/ad"
] ]
userContactLink :: ConnReqContact -> [StyledString] viewUserContactLink :: ConnReqContact -> [StyledString]
userContactLink = connReqContact_ "Your chat address:" viewUserContactLink = connReqContact_ "Your chat address:"
connReqContact_ :: StyledString -> ConnReqContact -> [StyledString] connReqContact_ :: StyledString -> ConnReqContact -> [StyledString]
connReqContact_ intro cReq = connReqContact_ intro cReq =
@ -389,90 +184,90 @@ connReqContact_ intro cReq =
"to delete it: " <> highlight' "/da" <> " (accepted contacts will remain connected)" "to delete it: " <> highlight' "/da" <> " (accepted contacts will remain connected)"
] ]
receivedContactRequest :: ContactName -> Profile -> [StyledString] viewReceivedContactRequest :: ContactName -> Profile -> [StyledString]
receivedContactRequest c Profile {fullName} = viewReceivedContactRequest c Profile {fullName} =
[ ttyFullName c fullName <> " wants to connect to you!", [ ttyFullName c fullName <> " wants to connect to you!",
"to accept: " <> highlight ("/ac " <> c), "to accept: " <> highlight ("/ac " <> c),
"to reject: " <> highlight ("/rc " <> c) <> " (the sender will NOT be notified)" "to reject: " <> highlight ("/rc " <> c) <> " (the sender will NOT be notified)"
] ]
acceptingContactRequest :: ContactName -> [StyledString] viewAcceptingContactRequest :: ContactName -> [StyledString]
acceptingContactRequest c = [ttyContact c <> ": accepting contact request..."] viewAcceptingContactRequest c = [ttyContact c <> ": accepting contact request..."]
contactRequestRejected :: ContactName -> [StyledString] viewContactRequestRejected :: ContactName -> [StyledString]
contactRequestRejected c = [ttyContact c <> ": contact request rejected"] viewContactRequestRejected c = [ttyContact c <> ": contact request rejected"]
userContactLinkSubError :: ChatError -> [StyledString] viewUserContactLinkSubError :: ChatError -> [StyledString]
userContactLinkSubError e = viewUserContactLinkSubError e =
[ "user address error: " <> sShow e, [ "user address error: " <> sShow e,
"to delete your address: " <> highlight' "/da" "to delete your address: " <> highlight' "/da"
] ]
groupSubscribed :: Group -> [StyledString] viewGroupSubscribed :: Group -> [StyledString]
groupSubscribed g = [ttyFullGroup g <> ": connected to server(s)"] viewGroupSubscribed g = [ttyFullGroup g <> ": connected to server(s)"]
groupEmpty :: Group -> [StyledString] viewGroupEmpty :: Group -> [StyledString]
groupEmpty g = [ttyFullGroup g <> ": group is empty"] viewGroupEmpty g = [ttyFullGroup g <> ": group is empty"]
groupRemoved :: Group -> [StyledString] viewGroupRemoved :: Group -> [StyledString]
groupRemoved g = [ttyFullGroup g <> ": you are no longer a member or group deleted"] viewGroupRemoved g = [ttyFullGroup g <> ": you are no longer a member or group deleted"]
memberSubError :: GroupName -> ContactName -> ChatError -> [StyledString] viewMemberSubError :: GroupName -> ContactName -> ChatError -> [StyledString]
memberSubError g c e = [ttyGroup g <> " member " <> ttyContact c <> " error: " <> sShow e] viewMemberSubError g c e = [ttyGroup g <> " member " <> ttyContact c <> " error: " <> sShow e]
groupCreated :: Group -> [StyledString] viewGroupCreated :: Group -> [StyledString]
groupCreated g@Group {localDisplayName} = viewGroupCreated g@Group {localDisplayName} =
[ "group " <> ttyFullGroup g <> " is created", [ "group " <> ttyFullGroup g <> " is created",
"use " <> highlight ("/a " <> localDisplayName <> " <name>") <> " to add members" "use " <> highlight ("/a " <> localDisplayName <> " <name>") <> " to add members"
] ]
groupDeletedUser :: GroupName -> [StyledString] viewGroupDeletedUser :: GroupName -> [StyledString]
groupDeletedUser g = groupDeleted_ g Nothing viewGroupDeletedUser g = groupDeleted_ g Nothing
groupDeleted :: GroupName -> GroupMember -> [StyledString] viewGroupDeleted :: GroupName -> GroupMember -> [StyledString]
groupDeleted g m = groupDeleted_ g (Just m) <> ["use " <> highlight ("/d #" <> g) <> " to delete the local copy of the group"] viewGroupDeleted g m = groupDeleted_ g (Just m) <> ["use " <> highlight ("/d #" <> g) <> " to delete the local copy of the group"]
groupDeleted_ :: GroupName -> Maybe GroupMember -> [StyledString] groupDeleted_ :: GroupName -> Maybe GroupMember -> [StyledString]
groupDeleted_ g m = [ttyGroup g <> ": " <> memberOrUser m <> " deleted the group"] groupDeleted_ g m = [ttyGroup g <> ": " <> memberOrUser m <> " deleted the group"]
sentGroupInvitation :: GroupName -> ContactName -> [StyledString] viewSentGroupInvitation :: GroupName -> ContactName -> [StyledString]
sentGroupInvitation g c = ["invitation to join the group " <> ttyGroup g <> " sent to " <> ttyContact c] viewSentGroupInvitation g c = ["invitation to join the group " <> ttyGroup g <> " sent to " <> ttyContact c]
cannotResendInvitation :: GroupName -> ContactName -> [StyledString] viewCannotResendInvitation :: GroupName -> ContactName -> [StyledString]
cannotResendInvitation g c = viewCannotResendInvitation g c =
[ ttyContact c <> " is already invited to group " <> ttyGroup g, [ ttyContact c <> " is already invited to group " <> ttyGroup g,
"to re-send invitation: " <> highlight ("/rm " <> g <> " " <> c) <> ", " <> highlight ("/a " <> g <> " " <> c) "to re-send invitation: " <> highlight ("/rm " <> g <> " " <> c) <> ", " <> highlight ("/a " <> g <> " " <> c)
] ]
receivedGroupInvitation :: Group -> ContactName -> GroupMemberRole -> [StyledString] viewReceivedGroupInvitation :: Group -> ContactName -> GroupMemberRole -> [StyledString]
receivedGroupInvitation g@Group {localDisplayName} c role = viewReceivedGroupInvitation g@Group {localDisplayName} c role =
[ ttyFullGroup g <> ": " <> ttyContact c <> " invites you to join the group as " <> plain (strEncode role), [ ttyFullGroup g <> ": " <> ttyContact c <> " invites you to join the group as " <> plain (strEncode role),
"use " <> highlight ("/j " <> localDisplayName) <> " to accept" "use " <> highlight ("/j " <> localDisplayName) <> " to accept"
] ]
joinedGroupMember :: GroupName -> GroupMember -> [StyledString] viewJoinedGroupMember :: GroupName -> GroupMember -> [StyledString]
joinedGroupMember g m = [ttyGroup g <> ": " <> ttyMember m <> " joined the group "] viewJoinedGroupMember g m = [ttyGroup g <> ": " <> ttyMember m <> " joined the group "]
userJoinedGroup :: GroupName -> [StyledString] viewUserJoinedGroup :: GroupName -> [StyledString]
userJoinedGroup g = [ttyGroup g <> ": you joined the group"] viewUserJoinedGroup g = [ttyGroup g <> ": you joined the group"]
joinedGroupMemberConnecting :: GroupName -> GroupMember -> GroupMember -> [StyledString] viewJoinedGroupMemberConnecting :: GroupName -> GroupMember -> GroupMember -> [StyledString]
joinedGroupMemberConnecting g host m = [ttyGroup g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"] viewJoinedGroupMemberConnecting g host m = [ttyGroup g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"]
connectedToGroupMember :: GroupName -> GroupMember -> [StyledString] viewConnectedToGroupMember :: GroupName -> GroupMember -> [StyledString]
connectedToGroupMember g m = [ttyGroup g <> ": " <> connectedMember m <> " is connected"] viewConnectedToGroupMember g m = [ttyGroup g <> ": " <> connectedMember m <> " is connected"]
deletedMember :: GroupName -> Maybe GroupMember -> Maybe GroupMember -> [StyledString] viewDeletedMember :: GroupName -> Maybe GroupMember -> Maybe GroupMember -> [StyledString]
deletedMember g by m = [ttyGroup g <> ": " <> memberOrUser by <> " removed " <> memberOrUser m <> " from the group"] viewDeletedMember g by m = [ttyGroup g <> ": " <> memberOrUser by <> " removed " <> memberOrUser m <> " from the group"]
deletedMemberUser :: GroupName -> GroupMember -> [StyledString] viewDeletedMemberUser :: GroupName -> GroupMember -> [StyledString]
deletedMemberUser g by = deletedMember g (Just by) Nothing <> groupPreserved g viewDeletedMemberUser g by = viewDeletedMember g (Just by) Nothing <> groupPreserved g
leftMemberUser :: GroupName -> [StyledString] viewLeftMemberUser :: GroupName -> [StyledString]
leftMemberUser g = leftMember_ g Nothing <> groupPreserved g viewLeftMemberUser g = leftMember_ g Nothing <> groupPreserved g
leftMember :: GroupName -> GroupMember -> [StyledString] viewLeftMember :: GroupName -> GroupMember -> [StyledString]
leftMember g m = leftMember_ g (Just m) viewLeftMember g m = leftMember_ g (Just m)
leftMember_ :: GroupName -> Maybe GroupMember -> [StyledString] leftMember_ :: GroupName -> Maybe GroupMember -> [StyledString]
leftMember_ g m = [ttyGroup g <> ": " <> memberOrUser m <> " left the group"] leftMember_ g m = [ttyGroup g <> ": " <> memberOrUser m <> " left the group"]
@ -489,8 +284,8 @@ connectedMember m = case memberCategory m of
GCPostMember -> "new member " <> ttyMember m -- without fullName as as it was shown in joinedGroupMemberConnecting GCPostMember -> "new member " <> ttyMember m -- without fullName as as it was shown in joinedGroupMemberConnecting
_ -> "member " <> ttyMember m -- these case is not used _ -> "member " <> ttyMember m -- these case is not used
groupMembers :: Group -> [StyledString] viewGroupMembers :: Group -> [StyledString]
groupMembers Group {membership, members} = map groupMember . filter (not . removedOrLeft) $ membership : members viewGroupMembers Group {membership, members} = map groupMember . filter (not . removedOrLeft) $ membership : members
where where
removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft
groupMember m = ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m groupMember m = ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m
@ -509,13 +304,17 @@ groupMembers Group {membership, members} = map groupMember . filter (not . remov
GSMemCreator -> "created group" GSMemCreator -> "created group"
_ -> "" _ -> ""
groupsList :: [(GroupName, Text, GroupMemberStatus)] -> [StyledString] viewGroupsList :: [(GroupName, Text, GroupMemberStatus)] -> [StyledString]
groupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"] viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"]
groupsList gs = map groupSS $ sort gs viewGroupsList gs = map groupSS $ sort gs
where where
groupSS (displayName, fullName, GSMemInvited) = groupInvitation displayName fullName groupSS (displayName, fullName, GSMemInvited) = groupInvitation displayName fullName
groupSS (displayName, fullName, _) = ttyGroup displayName <> optFullName displayName fullName groupSS (displayName, fullName, _) = ttyGroup displayName <> optFullName displayName fullName
viewGroupInvitation :: Group -> [StyledString]
viewGroupInvitation Group {localDisplayName = ldn, groupProfile = GroupProfile {fullName}} =
[groupInvitation ldn fullName]
groupInvitation :: GroupName -> Text -> StyledString groupInvitation :: GroupName -> Text -> StyledString
groupInvitation displayName fullName = groupInvitation displayName fullName =
highlight ("#" <> displayName) highlight ("#" <> displayName)
@ -526,21 +325,21 @@ groupInvitation displayName fullName =
<> highlight ("/d #" <> displayName) <> highlight ("/d #" <> displayName)
<> " to delete invitation)" <> " to delete invitation)"
contactsMerged :: Contact -> Contact -> [StyledString] viewContactsMerged :: Contact -> Contact -> [StyledString]
contactsMerged _to@Contact {localDisplayName = c1} _from@Contact {localDisplayName = c2} = viewContactsMerged _to@Contact {localDisplayName = c1} _from@Contact {localDisplayName = c2} =
[ "contact " <> ttyContact c2 <> " is merged into " <> ttyContact c1, [ "contact " <> ttyContact c2 <> " is merged into " <> ttyContact c1,
"use " <> ttyToContact c1 <> highlight' "<message>" <> " to send messages" "use " <> ttyToContact c1 <> highlight' "<message>" <> " to send messages"
] ]
userProfile :: Profile -> [StyledString] viewUserProfile :: Profile -> [StyledString]
userProfile Profile {displayName, fullName} = viewUserProfile Profile {displayName, fullName} =
[ "user profile: " <> ttyFullName displayName fullName, [ "user profile: " <> ttyFullName displayName fullName,
"use " <> highlight' "/p <display name> [<full name>]" <> " to change it", "use " <> highlight' "/p <display name> [<full name>]" <> " to change it",
"(the updated profile will be sent to all your contacts)" "(the updated profile will be sent to all your contacts)"
] ]
userProfileUpdated :: User -> User -> [StyledString] viewUserProfileUpdated :: User -> User -> [StyledString]
userProfileUpdated viewUserProfileUpdated
User {localDisplayName = n, profile = Profile {fullName}} User {localDisplayName = n, profile = Profile {fullName}}
User {localDisplayName = n', profile = Profile {fullName = fullName'}} User {localDisplayName = n', profile = Profile {fullName = fullName'}}
| n == n' && fullName == fullName' = [] | n == n' && fullName == fullName' = []
@ -549,8 +348,8 @@ userProfileUpdated
where where
notified = " (your contacts are notified)" notified = " (your contacts are notified)"
contactUpdated :: Contact -> Contact -> [StyledString] viewContactUpdated :: Contact -> Contact -> [StyledString]
contactUpdated viewContactUpdated
Contact {localDisplayName = n, profile = Profile {fullName}} Contact {localDisplayName = n, profile = Profile {fullName}}
Contact {localDisplayName = n', profile = Profile {fullName = fullName'}} Contact {localDisplayName = n', profile = Profile {fullName = fullName'}}
| n == n' && fullName == fullName' = [] | n == n' && fullName == fullName' = []
@ -562,11 +361,17 @@ contactUpdated
where where
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName' fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
messageError :: Text -> Text -> [StyledString] viewMessageError :: Text -> Text -> [StyledString]
messageError prefix err = [plain prefix <> ": " <> plain err] viewMessageError prefix err = [plain prefix <> ": " <> plain err]
receivedMessage :: StyledString -> UTCTime -> [StyledString] -> MsgIntegrity -> IO [StyledString] viewReceivedMessage :: ContactName -> UTCTime -> [StyledString] -> MsgIntegrity -> IO [StyledString]
receivedMessage from utcTime msg mOk = do viewReceivedMessage = viewReceivedMessage_ . ttyFromContact
viewReceivedGroupMessage :: GroupName -> ContactName -> UTCTime -> [StyledString] -> MsgIntegrity -> IO [StyledString]
viewReceivedGroupMessage = viewReceivedMessage_ .: ttyFromGroup
viewReceivedMessage_ :: StyledString -> UTCTime -> [StyledString] -> MsgIntegrity -> IO [StyledString]
viewReceivedMessage_ from utcTime msg mOk = do
t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime
pure $ prependFirst (t <> " " <> from) msg ++ showIntegrity mOk pure $ prependFirst (t <> " " <> from) msg ++ showIntegrity mOk
where where
@ -591,14 +396,26 @@ receivedMessage from utcTime msg mOk = do
msgError :: String -> [StyledString] msgError :: String -> [StyledString]
msgError s = [styled (Colored Red) s] msgError s = [styled (Colored Red) s]
sentMessage :: StyledString -> ByteString -> IO [StyledString] viewSentMessage :: ContactName -> ByteString -> IO [StyledString]
sentMessage to msg = sendWithTime_ to . msgPlain $ safeDecodeUtf8 msg viewSentMessage = viewSentMessage_ . ttyToContact
sentFileInvitation :: StyledString -> FilePath -> IO [StyledString] viewSentGroupMessage :: GroupName -> ByteString -> IO [StyledString]
sentFileInvitation to f = sendWithTime_ ("/f " <> to) [ttyFilePath f] viewSentGroupMessage = viewSentMessage_ . ttyToGroup
sendWithTime_ :: StyledString -> [StyledString] -> IO [StyledString] viewSentMessage_ :: StyledString -> ByteString -> IO [StyledString]
sendWithTime_ to styledMsg = do viewSentMessage_ to msg = sentWithTime_ to . msgPlain $ safeDecodeUtf8 msg
viewSentFileInvitation :: ContactName -> FilePath -> IO [StyledString]
viewSentFileInvitation = viewSentFileInvitation_ . ttyToContact
viewSentGroupFileInvitation :: GroupName -> FilePath -> IO [StyledString]
viewSentGroupFileInvitation = viewSentFileInvitation_ . ttyToGroup
viewSentFileInvitation_ :: StyledString -> FilePath -> IO [StyledString]
viewSentFileInvitation_ to f = sentWithTime_ ("/f " <> to) [ttyFilePath f]
sentWithTime_ :: StyledString -> [StyledString] -> IO [StyledString]
sentWithTime_ to styledMsg = do
time <- formatTime defaultTimeLocale "%H:%M" <$> getZonedTime time <- formatTime defaultTimeLocale "%H:%M" <$> getZonedTime
pure $ prependFirst (styleTime time <> " " <> to) styledMsg pure $ prependFirst (styleTime time <> " " <> to) styledMsg
@ -609,21 +426,21 @@ prependFirst s (s' : ss) = (s <> s') : ss
msgPlain :: Text -> [StyledString] msgPlain :: Text -> [StyledString]
msgPlain = map styleMarkdownText . T.lines msgPlain = map styleMarkdownText . T.lines
sentFileInfo :: Int64 -> [StyledString] viewSentFileInfo :: Int64 -> [StyledString]
sentFileInfo fileId = viewSentFileInfo fileId =
["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"] ["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"]
sndFileStart :: SndFileTransfer -> [StyledString] viewSndFileStart :: SndFileTransfer -> [StyledString]
sndFileStart = sendingFile_ "started" viewSndFileStart = sendingFile_ "started"
sndFileComplete :: SndFileTransfer -> [StyledString] viewSndFileComplete :: SndFileTransfer -> [StyledString]
sndFileComplete = sendingFile_ "completed" viewSndFileComplete = sendingFile_ "completed"
sndFileCancelled :: SndFileTransfer -> [StyledString] viewSndFileCancelled :: SndFileTransfer -> [StyledString]
sndFileCancelled = sendingFile_ "cancelled" viewSndFileCancelled = sendingFile_ "cancelled"
sndGroupFileCancelled :: [SndFileTransfer] -> [StyledString] viewSndGroupFileCancelled :: [SndFileTransfer] -> [StyledString]
sndGroupFileCancelled fts = viewSndGroupFileCancelled fts =
case filter (\SndFileTransfer {fileStatus = s} -> s /= FSCancelled && s /= FSComplete) fts of case filter (\SndFileTransfer {fileStatus = s} -> s /= FSCancelled && s /= FSComplete) fts of
[] -> ["sending file can't be cancelled"] [] -> ["sending file can't be cancelled"]
ts@(ft : _) -> ["cancelled sending " <> sndFile ft <> " to " <> listMembers ts] ts@(ft : _) -> ["cancelled sending " <> sndFile ft <> " to " <> listMembers ts]
@ -632,15 +449,21 @@ sendingFile_ :: StyledString -> SndFileTransfer -> [StyledString]
sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} = sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
[status <> " sending " <> sndFile ft <> " to " <> ttyContact c] [status <> " sending " <> sndFile ft <> " to " <> ttyContact c]
sndFileRcvCancelled :: SndFileTransfer -> [StyledString] viewSndFileRcvCancelled :: SndFileTransfer -> [StyledString]
sndFileRcvCancelled ft@SndFileTransfer {recipientDisplayName = c} = viewSndFileRcvCancelled ft@SndFileTransfer {recipientDisplayName = c} =
[ttyContact c <> " cancelled receiving " <> sndFile ft] [ttyContact c <> " cancelled receiving " <> sndFile ft]
sndFile :: SndFileTransfer -> StyledString sndFile :: SndFileTransfer -> StyledString
sndFile SndFileTransfer {fileId, fileName} = fileTransfer fileId fileName sndFile SndFileTransfer {fileId, fileName} = fileTransfer fileId fileName
receivedFileInvitation :: RcvFileTransfer -> [StyledString] viewReceivedFileInvitation :: ContactName -> UTCTime -> RcvFileTransfer -> MsgIntegrity -> IO [StyledString]
receivedFileInvitation RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName, fileSize}} = viewReceivedFileInvitation c ts = viewReceivedMessage c ts . receivedFileInvitation_
viewReceivedGroupFileInvitation :: GroupName -> ContactName -> UTCTime -> RcvFileTransfer -> MsgIntegrity -> IO [StyledString]
viewReceivedGroupFileInvitation g c ts = viewReceivedGroupMessage g c ts . receivedFileInvitation_
receivedFileInvitation_ :: RcvFileTransfer -> [StyledString]
receivedFileInvitation_ RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName, fileSize}} =
[ "sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)", [ "sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)",
"use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it" "use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"
] ]
@ -657,25 +480,25 @@ humanReadableSize size
mB = kB * 1024 mB = kB * 1024
gB = mB * 1024 gB = mB * 1024
rcvFileAccepted :: RcvFileTransfer -> FilePath -> [StyledString] viewRcvFileAccepted :: RcvFileTransfer -> FilePath -> [StyledString]
rcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath = viewRcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath =
["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath] ["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath]
rcvFileStart :: RcvFileTransfer -> [StyledString] viewRcvFileStart :: RcvFileTransfer -> [StyledString]
rcvFileStart = receivingFile_ "started" viewRcvFileStart = receivingFile_ "started"
rcvFileComplete :: RcvFileTransfer -> [StyledString] viewRcvFileComplete :: RcvFileTransfer -> [StyledString]
rcvFileComplete = receivingFile_ "completed" viewRcvFileComplete = receivingFile_ "completed"
rcvFileCancelled :: RcvFileTransfer -> [StyledString] viewRcvFileCancelled :: RcvFileTransfer -> [StyledString]
rcvFileCancelled = receivingFile_ "cancelled" viewRcvFileCancelled = receivingFile_ "cancelled"
receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString] receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString]
receivingFile_ status ft@RcvFileTransfer {senderDisplayName = c} = receivingFile_ status ft@RcvFileTransfer {senderDisplayName = c} =
[status <> " receiving " <> rcvFile ft <> " from " <> ttyContact c] [status <> " receiving " <> rcvFile ft <> " from " <> ttyContact c]
rcvFileSndCancelled :: RcvFileTransfer -> [StyledString] viewRcvFileSndCancelled :: RcvFileTransfer -> [StyledString]
rcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} = viewRcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} =
[ttyContact c <> " cancelled sending " <> rcvFile ft] [ttyContact c <> " cancelled sending " <> rcvFile ft]
rcvFile :: RcvFileTransfer -> StyledString rcvFile :: RcvFileTransfer -> StyledString
@ -684,8 +507,8 @@ rcvFile RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} = f
fileTransfer :: Int64 -> String -> StyledString fileTransfer :: Int64 -> String -> StyledString
fileTransfer fileId fileName = "file " <> sShow fileId <> " (" <> ttyFilePath fileName <> ")" fileTransfer fileId fileName = "file " <> sShow fileId <> " (" <> ttyFilePath fileName <> ")"
fileTransferStatus :: (FileTransfer, [Integer]) -> [StyledString] viewFileTransferStatus :: (FileTransfer, [Integer]) -> [StyledString]
fileTransferStatus (FTSnd [ft@SndFileTransfer {fileStatus, fileSize, chunkSize}], chunksNum) = viewFileTransferStatus (FTSnd [ft@SndFileTransfer {fileStatus, fileSize, chunkSize}], chunksNum) =
["sending " <> sndFile ft <> " " <> sndStatus] ["sending " <> sndFile ft <> " " <> sndStatus]
where where
sndStatus = case fileStatus of sndStatus = case fileStatus of
@ -694,8 +517,8 @@ fileTransferStatus (FTSnd [ft@SndFileTransfer {fileStatus, fileSize, chunkSize}]
FSConnected -> "progress " <> fileProgress chunksNum chunkSize fileSize FSConnected -> "progress " <> fileProgress chunksNum chunkSize fileSize
FSComplete -> "complete" FSComplete -> "complete"
FSCancelled -> "cancelled" FSCancelled -> "cancelled"
fileTransferStatus (FTSnd [], _) = ["no file transfers (empty group)"] viewFileTransferStatus (FTSnd [], _) = ["no file transfers (empty group)"]
fileTransferStatus (FTSnd fts@(ft : _), chunksNum) = viewFileTransferStatus (FTSnd fts@(ft : _), chunksNum) =
case concatMap membersTransferStatus $ groupBy ((==) `on` fs) $ sortOn fs fts of case concatMap membersTransferStatus $ groupBy ((==) `on` fs) $ sortOn fs fts of
[membersStatus] -> ["sending " <> sndFile ft <> " " <> membersStatus] [membersStatus] -> ["sending " <> sndFile ft <> " " <> membersStatus]
membersStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) membersStatuses membersStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) membersStatuses
@ -710,7 +533,7 @@ fileTransferStatus (FTSnd fts@(ft : _), chunksNum) =
FSConnected -> "in progress (" <> sShow (sum chunksNum * chunkSize * 100 `div` (toInteger (length chunksNum) * fileSize)) <> "%)" FSConnected -> "in progress (" <> sShow (sum chunksNum * chunkSize * 100 `div` (toInteger (length chunksNum) * fileSize)) <> "%)"
FSComplete -> "complete" FSComplete -> "complete"
FSCancelled -> "cancelled" FSCancelled -> "cancelled"
fileTransferStatus (FTRcv ft@RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, fileStatus, chunkSize}, chunksNum) = viewFileTransferStatus (FTRcv ft@RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, fileStatus, chunkSize}, chunksNum) =
["receiving " <> rcvFile ft <> " " <> rcvStatus] ["receiving " <> rcvFile ft <> " " <> rcvStatus]
where where
rcvStatus = case fileStatus of rcvStatus = case fileStatus of
@ -727,16 +550,16 @@ fileProgress :: [Integer] -> Integer -> Integer -> StyledString
fileProgress chunksNum chunkSize fileSize = fileProgress chunksNum chunkSize fileSize =
sShow (sum chunksNum * chunkSize * 100 `div` fileSize) <> "% of " <> humanReadableSize fileSize sShow (sum chunksNum * chunkSize * 100 `div` fileSize) <> "% of " <> humanReadableSize fileSize
sndFileSubError :: SndFileTransfer -> ChatError -> [StyledString] viewSndFileSubError :: SndFileTransfer -> ChatError -> [StyledString]
sndFileSubError SndFileTransfer {fileId, fileName} e = viewSndFileSubError SndFileTransfer {fileId, fileName} e =
["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e] ["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
rcvFileSubError :: RcvFileTransfer -> ChatError -> [StyledString] viewRcvFileSubError :: RcvFileTransfer -> ChatError -> [StyledString]
rcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e = viewRcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e =
["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e] ["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
chatError :: ChatError -> [StyledString] viewChatError :: ChatError -> [StyledString]
chatError = \case viewChatError = \case
ChatError err -> case err of ChatError err -> case err of
CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"] CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"]
CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"] CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"]
@ -777,9 +600,6 @@ chatError = \case
where where
fileNotFound fileId = ["file " <> sShow fileId <> " not found"] fileNotFound fileId = ["file " <> sShow fileId <> " not found"]
printToView :: (MonadUnliftIO m, MonadReader ChatController m) => [StyledString] -> m ()
printToView s = asks chatTerminal >>= liftIO . (`printToTerminal` s)
ttyContact :: ContactName -> StyledString ttyContact :: ContactName -> StyledString
ttyContact = styled (Colored Green) ttyContact = styled (Colored Green)

8
stack.yaml
View file

@ -40,12 +40,12 @@ extra-deps:
# - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977 # - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977
- github: simplex-chat/haskell-terminal - github: simplex-chat/haskell-terminal
commit: f708b00009b54890172068f168bf98508ffcd495 commit: f708b00009b54890172068f168bf98508ffcd495
- simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561 # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
# - ../simplexmq # - ../simplexmq
# - github: simplex-chat/simplexmq - github: simplex-chat/simplexmq
# commit: bfa4911217b71527a6fbaf73b242b5684aaf9fce commit: 670b3b79749bfb48a04ee40b8c441e9ca68ad41a
- github: simplex-chat/hs-tls - github: simplex-chat/hs-tls
commit: cea6d52c512716ff09adcac86ebc95bb0b3bb797 commit: f6cc753611f80af300401cfae63846e9d7c40d9e
subdirs: subdirs:
- core - core

15
tests/ChatClient.hs
View file

@ -18,6 +18,8 @@ import Simplex.Chat
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..)) import Simplex.Chat.Controller (ChatConfig (..), ChatController (..))
import Simplex.Chat.Options import Simplex.Chat.Options
import Simplex.Chat.Store import Simplex.Chat.Store
import Simplex.Chat.Terminal
import Simplex.Chat.Terminal.Output (newChatTerminal)
import Simplex.Chat.Types (Profile) import Simplex.Chat.Types (Profile)
import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.RetryInterval
@ -38,7 +40,7 @@ serverPort = "5001"
opts :: ChatOpts opts :: ChatOpts
opts = opts =
ChatOpts ChatOpts
{ dbFile = undefined, { dbFilePrefix = undefined,
smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"], smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"],
logging = False logging = False
} }
@ -71,12 +73,13 @@ cfg =
} }
virtualSimplexChat :: FilePath -> Profile -> IO TestCC virtualSimplexChat :: FilePath -> Profile -> IO TestCC
virtualSimplexChat dbFile profile = do virtualSimplexChat dbFilePrefix profile = do
st <- createStore (dbFile <> "_chat.db") 1 st <- createStore (dbFilePrefix <> "_chat.db") 1
void . runExceptT $ createUser st profile True Right user <- runExceptT $ createUser st profile True
t <- withVirtualTerminal termSettings pure t <- withVirtualTerminal termSettings pure
cc <- newChatController cfg opts {dbFile} t . const $ pure () -- no notifications ct <- newChatTerminal t
chatAsync <- async $ runSimplexChat cc cc <- newChatController st user cfg opts {dbFilePrefix} . const $ pure () -- no notifications
chatAsync <- async $ runSimplexChat user ct cc
termQ <- newTQueueIO termQ <- newTQueueIO
termAsync <- async $ readTerminalOutput t termQ termAsync <- async $ readTerminalOutput t termQ
pure TestCC {chatController = cc, virtualTerminal = t, chatAsync, termAsync, termQ} pure TestCC {chatController = cc, virtualTerminal = t, chatAsync, termAsync, termQ}