mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-08-28 05:24:44 +00:00
export C interface, started mobile app (#210)
* 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
co-authored by
Efim Poberezkin
Efim Poberezkin
parent
f47494e5c8
commit
64381be91d
@@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Controller where
|
||||
@@ -14,9 +15,8 @@ import Crypto.Random (ChaChaDRG)
|
||||
import Data.Int (Int64)
|
||||
import Data.Map.Strict (Map)
|
||||
import Numeric.Natural
|
||||
import Simplex.Chat.Notification
|
||||
import Simplex.Chat.Store (StoreError)
|
||||
import Simplex.Chat.Terminal
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent (AgentClient)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig)
|
||||
@@ -41,14 +41,18 @@ data ChatConfig = ChatConfig
|
||||
fileChunkSize :: Integer
|
||||
}
|
||||
|
||||
data ActiveTo = ActiveNone | ActiveC ContactName | ActiveG GroupName
|
||||
deriving (Eq)
|
||||
|
||||
data ChatController = ChatController
|
||||
{ currentUser :: TVar User,
|
||||
activeTo :: TVar ActiveTo,
|
||||
firstTime :: Bool,
|
||||
smpAgent :: AgentClient,
|
||||
chatTerminal :: ChatTerminal,
|
||||
chatStore :: SQLiteStore,
|
||||
idsDrg :: TVar ChaChaDRG,
|
||||
inputQ :: TBQueue InputEvent,
|
||||
outputQ :: TBQueue [StyledString],
|
||||
notifyQ :: TBQueue Notification,
|
||||
sendNotification :: Notification -> IO (),
|
||||
chatLock :: TMVar (),
|
||||
@@ -90,9 +94,9 @@ data ChatErrorType
|
||||
type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m, MonadFail 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 a = asks (activeTo . chatTerminal) >>= atomically . (`modifyTVar` unset)
|
||||
unsetActive a = asks activeTo >>= atomically . (`modifyTVar` unset)
|
||||
where
|
||||
unset a' = if a == a' then ActiveNone else a'
|
||||
|
||||
@@ -0,0 +1,270 @@
|
||||
{-# 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
|
||||
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
|
||||
full_name TEXT NOT NULL,
|
||||
properties TEXT NOT NULL DEFAULT '{}' -- JSON with contact profile properties
|
||||
);
|
||||
|
||||
CREATE INDEX contact_profiles_index ON contact_profiles (display_name, full_name);
|
||||
|
||||
CREATE TABLE users (
|
||||
user_id INTEGER PRIMARY KEY,
|
||||
contact_id INTEGER NOT NULL UNIQUE REFERENCES contacts ON DELETE CASCADE
|
||||
DEFERRABLE INITIALLY DEFERRED,
|
||||
local_display_name TEXT NOT NULL UNIQUE,
|
||||
active_user INTEGER NOT NULL DEFAULT 0, -- 1 for active user
|
||||
FOREIGN KEY (user_id, local_display_name)
|
||||
REFERENCES display_names (user_id, local_display_name)
|
||||
ON DELETE CASCADE
|
||||
ON UPDATE CASCADE
|
||||
DEFERRABLE INITIALLY DEFERRED
|
||||
);
|
||||
|
||||
CREATE TABLE display_names (
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
local_display_name TEXT NOT NULL,
|
||||
ldn_base TEXT NOT NULL,
|
||||
ldn_suffix INTEGER NOT NULL DEFAULT 0,
|
||||
PRIMARY KEY (user_id, local_display_name) ON CONFLICT FAIL,
|
||||
UNIQUE (user_id, ldn_base, ldn_suffix) ON CONFLICT FAIL
|
||||
) WITHOUT ROWID;
|
||||
|
||||
CREATE TABLE contacts (
|
||||
contact_id INTEGER PRIMARY KEY,
|
||||
contact_profile_id INTEGER REFERENCES contact_profiles ON DELETE SET NULL, -- NULL if it's an incognito profile
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
local_display_name TEXT NOT NULL,
|
||||
is_user INTEGER NOT NULL DEFAULT 0, -- 1 if this contact is a user
|
||||
via_group INTEGER REFERENCES groups (group_id) ON DELETE SET NULL,
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
FOREIGN KEY (user_id, local_display_name)
|
||||
REFERENCES display_names (user_id, local_display_name)
|
||||
ON DELETE CASCADE
|
||||
ON UPDATE CASCADE,
|
||||
UNIQUE (user_id, local_display_name),
|
||||
UNIQUE (user_id, contact_profile_id)
|
||||
);
|
||||
|
||||
CREATE TABLE sent_probes (
|
||||
sent_probe_id INTEGER PRIMARY KEY,
|
||||
contact_id INTEGER NOT NULL UNIQUE REFERENCES contacts ON DELETE CASCADE,
|
||||
probe BLOB NOT NULL,
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
UNIQUE (user_id, probe)
|
||||
);
|
||||
|
||||
CREATE TABLE sent_probe_hashes (
|
||||
sent_probe_hash_id INTEGER PRIMARY KEY,
|
||||
sent_probe_id INTEGER NOT NULL REFERENCES sent_probes ON DELETE CASCADE,
|
||||
contact_id INTEGER NOT NULL REFERENCES contacts ON DELETE CASCADE,
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
UNIQUE (sent_probe_id, contact_id)
|
||||
);
|
||||
|
||||
CREATE TABLE received_probes (
|
||||
received_probe_id INTEGER PRIMARY KEY,
|
||||
contact_id INTEGER NOT NULL REFERENCES contacts ON DELETE CASCADE,
|
||||
probe BLOB,
|
||||
probe_hash BLOB NOT NULL,
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE
|
||||
);
|
||||
|
||||
CREATE TABLE known_servers(
|
||||
server_id INTEGER PRIMARY KEY,
|
||||
host TEXT NOT NULL,
|
||||
port TEXT NOT NULL,
|
||||
key_hash BLOB,
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
UNIQUE (user_id, host, port)
|
||||
) WITHOUT ROWID;
|
||||
|
||||
CREATE TABLE group_profiles ( -- shared group profiles
|
||||
group_profile_id INTEGER PRIMARY KEY,
|
||||
display_name TEXT NOT NULL, -- this name must not contain spaces
|
||||
full_name TEXT NOT NULL,
|
||||
properties TEXT NOT NULL DEFAULT '{}' -- JSON with user or contact profile
|
||||
);
|
||||
|
||||
CREATE TABLE groups (
|
||||
group_id INTEGER PRIMARY KEY, -- local group ID
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
local_display_name TEXT NOT NULL, -- local group name without spaces
|
||||
group_profile_id INTEGER REFERENCES group_profiles ON DELETE SET NULL, -- shared group profile
|
||||
inv_queue_info BLOB, -- received
|
||||
FOREIGN KEY (user_id, local_display_name)
|
||||
REFERENCES display_names (user_id, local_display_name)
|
||||
ON DELETE CASCADE
|
||||
ON UPDATE CASCADE,
|
||||
UNIQUE (user_id, local_display_name),
|
||||
UNIQUE (user_id, group_profile_id)
|
||||
);
|
||||
|
||||
CREATE INDEX idx_groups_inv_queue_info ON groups (inv_queue_info);
|
||||
|
||||
CREATE TABLE group_members ( -- group members, excluding the local user
|
||||
group_member_id INTEGER PRIMARY KEY,
|
||||
group_id INTEGER NOT NULL REFERENCES groups ON DELETE CASCADE,
|
||||
member_id BLOB NOT NULL, -- shared member ID, unique per group
|
||||
member_role TEXT NOT NULL, -- owner, admin, member
|
||||
member_category TEXT NOT NULL, -- see GroupMemberCategory
|
||||
member_status TEXT NOT NULL, -- see GroupMemberStatus
|
||||
invited_by INTEGER REFERENCES contacts (contact_id) ON DELETE SET NULL, -- NULL for the members who joined before the current user and for the group creator
|
||||
sent_inv_queue_info BLOB, -- sent
|
||||
group_queue_info BLOB, -- received
|
||||
direct_queue_info BLOB, -- received
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
local_display_name TEXT NOT NULL, -- should be the same as contact
|
||||
contact_profile_id INTEGER NOT NULL REFERENCES contact_profiles ON DELETE CASCADE,
|
||||
contact_id INTEGER REFERENCES contacts ON DELETE CASCADE,
|
||||
FOREIGN KEY (user_id, local_display_name)
|
||||
REFERENCES display_names (user_id, local_display_name)
|
||||
ON DELETE CASCADE
|
||||
ON UPDATE CASCADE,
|
||||
UNIQUE (group_id, member_id)
|
||||
);
|
||||
|
||||
CREATE TABLE group_member_intros (
|
||||
group_member_intro_id INTEGER PRIMARY KEY,
|
||||
re_group_member_id INTEGER NOT NULL REFERENCES group_members (group_member_id) ON DELETE CASCADE,
|
||||
to_group_member_id INTEGER NOT NULL REFERENCES group_members (group_member_id) ON DELETE CASCADE,
|
||||
group_queue_info BLOB,
|
||||
direct_queue_info BLOB,
|
||||
intro_status TEXT NOT NULL, -- see GroupMemberIntroStatus
|
||||
UNIQUE (re_group_member_id, to_group_member_id)
|
||||
);
|
||||
|
||||
CREATE TABLE files (
|
||||
file_id INTEGER PRIMARY KEY,
|
||||
contact_id INTEGER REFERENCES contacts ON DELETE CASCADE,
|
||||
group_id INTEGER REFERENCES groups ON DELETE CASCADE,
|
||||
file_name TEXT NOT NULL,
|
||||
file_path TEXT,
|
||||
file_size INTEGER NOT NULL,
|
||||
chunk_size INTEGER NOT NULL,
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE
|
||||
);
|
||||
|
||||
CREATE TABLE snd_files (
|
||||
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
|
||||
connection_id INTEGER NOT NULL REFERENCES connections ON DELETE CASCADE,
|
||||
file_status TEXT NOT NULL, -- new, accepted, connected, completed
|
||||
group_member_id INTEGER REFERENCES group_members ON DELETE CASCADE,
|
||||
PRIMARY KEY (file_id, connection_id)
|
||||
) WITHOUT ROWID;
|
||||
|
||||
CREATE TABLE rcv_files (
|
||||
file_id INTEGER PRIMARY KEY REFERENCES files ON DELETE CASCADE,
|
||||
file_status TEXT NOT NULL, -- new, accepted, connected, completed
|
||||
group_member_id INTEGER REFERENCES group_members ON DELETE CASCADE,
|
||||
file_queue_info BLOB
|
||||
);
|
||||
|
||||
CREATE TABLE snd_file_chunks (
|
||||
file_id INTEGER NOT NULL,
|
||||
connection_id INTEGER NOT NULL,
|
||||
chunk_number INTEGER NOT NULL,
|
||||
chunk_agent_msg_id INTEGER,
|
||||
chunk_sent INTEGER NOT NULL DEFAULT 0, -- 0 (sent to agent), 1 (sent to server)
|
||||
FOREIGN KEY (file_id, connection_id) REFERENCES snd_files ON DELETE CASCADE,
|
||||
PRIMARY KEY (file_id, connection_id, chunk_number)
|
||||
) WITHOUT ROWID;
|
||||
|
||||
CREATE TABLE rcv_file_chunks (
|
||||
file_id INTEGER NOT NULL REFERENCES rcv_files ON DELETE CASCADE,
|
||||
chunk_number INTEGER NOT NULL,
|
||||
chunk_agent_msg_id INTEGER NOT NULL,
|
||||
chunk_stored INTEGER NOT NULL DEFAULT 0, -- 0 (received), 1 (appended to file)
|
||||
PRIMARY KEY (file_id, chunk_number)
|
||||
) WITHOUT ROWID;
|
||||
|
||||
CREATE TABLE connections ( -- all SMP agent connections
|
||||
connection_id INTEGER PRIMARY KEY,
|
||||
agent_conn_id BLOB NOT NULL UNIQUE,
|
||||
conn_level INTEGER NOT NULL DEFAULT 0,
|
||||
via_contact INTEGER REFERENCES contacts (contact_id) ON DELETE SET NULL,
|
||||
conn_status TEXT NOT NULL,
|
||||
conn_type TEXT NOT NULL, -- contact, member, rcv_file, snd_file
|
||||
user_contact_link_id INTEGER REFERENCES user_contact_links ON DELETE CASCADE,
|
||||
contact_id INTEGER REFERENCES contacts ON DELETE CASCADE,
|
||||
group_member_id INTEGER REFERENCES group_members ON DELETE CASCADE,
|
||||
snd_file_id INTEGER,
|
||||
rcv_file_id INTEGER REFERENCES rcv_files (file_id) ON DELETE CASCADE,
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
FOREIGN KEY (snd_file_id, connection_id)
|
||||
REFERENCES snd_files (file_id, connection_id)
|
||||
ON DELETE CASCADE
|
||||
DEFERRABLE INITIALLY DEFERRED
|
||||
);
|
||||
|
||||
CREATE TABLE user_contact_links (
|
||||
user_contact_link_id INTEGER PRIMARY KEY,
|
||||
conn_req_contact BLOB NOT NULL,
|
||||
local_display_name TEXT NOT NULL DEFAULT '',
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
UNIQUE (user_id, local_display_name)
|
||||
);
|
||||
|
||||
CREATE TABLE contact_requests (
|
||||
contact_request_id INTEGER PRIMARY KEY,
|
||||
user_contact_link_id INTEGER NOT NULL REFERENCES user_contact_links
|
||||
ON UPDATE CASCADE ON DELETE CASCADE,
|
||||
agent_invitation_id BLOB NOT NULL,
|
||||
contact_profile_id INTEGER REFERENCES contact_profiles
|
||||
ON DELETE SET NULL -- NULL if it's an incognito profile
|
||||
DEFERRABLE INITIALLY DEFERRED,
|
||||
local_display_name TEXT NOT NULL,
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
|
||||
FOREIGN KEY (user_id, local_display_name)
|
||||
REFERENCES display_names (user_id, local_display_name)
|
||||
ON UPDATE CASCADE
|
||||
ON DELETE CASCADE
|
||||
DEFERRABLE INITIALLY DEFERRED,
|
||||
UNIQUE (user_id, local_display_name),
|
||||
UNIQUE (user_id, contact_profile_id)
|
||||
);
|
||||
|
||||
-- all message events as received or sent, append only
|
||||
-- maps to message deliveries as one-to-many for group messages
|
||||
CREATE TABLE messages (
|
||||
message_id INTEGER PRIMARY KEY,
|
||||
msg_sent INTEGER NOT NULL, -- 0 for received, 1 for sent
|
||||
chat_msg_event TEXT NOT NULL, -- message event type (the constructor of ChatMsgEvent)
|
||||
msg_body BLOB, -- agent message body as received or sent
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now'))
|
||||
);
|
||||
|
||||
-- message deliveries communicated with the agent, append only
|
||||
CREATE TABLE msg_deliveries (
|
||||
msg_delivery_id INTEGER PRIMARY KEY,
|
||||
message_id INTEGER NOT NULL REFERENCES messages ON DELETE CASCADE, -- non UNIQUE for group messages
|
||||
connection_id INTEGER NOT NULL REFERENCES connections ON DELETE CASCADE,
|
||||
agent_msg_id INTEGER, -- internal agent message ID (NULL while pending)
|
||||
agent_msg_meta TEXT, -- JSON with timestamps etc. sent in MSG, NULL for sent
|
||||
chat_ts TEXT NOT NULL DEFAULT (datetime('now')), -- broker_ts for received, created_at for sent
|
||||
UNIQUE (connection_id, agent_msg_id)
|
||||
);
|
||||
|
||||
-- TODO recovery for received messages with "rcv_agent" status - acknowledge to agent
|
||||
-- changes of messagy delivery status, append only
|
||||
CREATE TABLE msg_delivery_events (
|
||||
msg_delivery_event_id INTEGER PRIMARY KEY,
|
||||
msg_delivery_id INTEGER NOT NULL REFERENCES msg_deliveries ON DELETE CASCADE, -- non UNIQUE for multiple events per msg delivery
|
||||
delivery_status TEXT NOT NULL, -- see MsgDeliveryStatus for allowed values
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
UNIQUE (msg_delivery_id, delivery_status)
|
||||
);
|
||||
|]
|
||||
@@ -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
|
||||
@@ -1,6 +1,11 @@
|
||||
{-# 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.ByteString.Char8 as B
|
||||
@@ -14,11 +19,20 @@ import Simplex.Messaging.Parsers (parseAll)
|
||||
import System.FilePath (combine)
|
||||
|
||||
data ChatOpts = ChatOpts
|
||||
{ dbFile :: String,
|
||||
{ dbFilePrefix :: String,
|
||||
smpServers :: NonEmpty SMPServer,
|
||||
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 appDir =
|
||||
ChatOpts
|
||||
@@ -38,13 +52,7 @@ chatOpts appDir =
|
||||
<> help
|
||||
"Comma separated list of SMP server(s) to use \
|
||||
\(default: smp4.simplex.im,smp5.simplex.im,smp6.simplex.im)"
|
||||
<> value
|
||||
( L.fromList
|
||||
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im",
|
||||
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im",
|
||||
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im"
|
||||
]
|
||||
)
|
||||
<> value defaultSMPServers
|
||||
)
|
||||
<*> switch
|
||||
( long "log"
|
||||
|
||||
@@ -108,7 +108,6 @@ import Crypto.Random (ChaChaDRG, randomBytesGenerate)
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Either (rights)
|
||||
import Data.FileEmbed (embedDir, makeRelativeToProject)
|
||||
import Data.Function (on)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
@@ -116,11 +115,11 @@ import Data.List (find, sortBy)
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
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 Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Migrations.M20220101_initial
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
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 qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Util (bshow, liftIOEither, (<$$>))
|
||||
import System.FilePath (takeBaseName, takeExtension, takeFileName)
|
||||
import System.FilePath (takeFileName)
|
||||
import UnliftIO.STM
|
||||
|
||||
schemaMigrations :: [(String, Query)]
|
||||
schemaMigrations =
|
||||
[ ("20220101_initial", m20220101_initial)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
migrations :: [Migration]
|
||||
migrations =
|
||||
sortBy (compare `on` name) . map migration . filter sqlFile $
|
||||
$(makeRelativeToProject "migrations" >>= embedDir)
|
||||
migrations = sortBy (compare `on` name) $ map migration schemaMigrations
|
||||
where
|
||||
sqlFile (file, _) = takeExtension file == ".sql"
|
||||
migration (file, qStr) = Migration {name = takeBaseName file, up = decodeUtf8 qStr}
|
||||
migration (name, query) = Migration {name = name, up = fromQuery query}
|
||||
|
||||
createStore :: FilePath -> Int -> IO SQLiteStore
|
||||
createStore dbFilePath poolSize = createSQLiteStore dbFilePath poolSize migrations
|
||||
|
||||
@@ -6,6 +6,7 @@ module Simplex.Chat.Styled
|
||||
StyledFormat (..),
|
||||
styleMarkdown,
|
||||
styleMarkdownText,
|
||||
unStyle,
|
||||
sLength,
|
||||
sShow,
|
||||
)
|
||||
@@ -69,6 +70,10 @@ sgr = \case
|
||||
Snippet -> []
|
||||
NoFormat -> []
|
||||
|
||||
unStyle :: StyledString -> String
|
||||
unStyle (Styled _ s) = s
|
||||
unStyle (s1 :<>: s2) = unStyle s1 <> unStyle s2
|
||||
|
||||
sLength :: StyledString -> Int
|
||||
sLength (Styled _ s) = length s
|
||||
sLength (s1 :<>: s2) = sLength s1 + sLength s2
|
||||
|
||||
+31
-169
@@ -1,176 +1,38 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Chat.Terminal where
|
||||
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Types
|
||||
import System.Console.ANSI.Types
|
||||
import System.Terminal
|
||||
import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal)
|
||||
import UnliftIO.STM
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad.Reader
|
||||
import Simplex.Chat
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Help (chatWelcome)
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Store
|
||||
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
|
||||
deriving (Eq)
|
||||
|
||||
data ChatTerminal = ChatTerminal
|
||||
{ activeTo :: TVar ActiveTo,
|
||||
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
|
||||
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
|
||||
simplexChat :: WithTerminal t => ChatConfig -> ChatOpts -> t -> IO ()
|
||||
simplexChat cfg opts t
|
||||
| logging opts = do
|
||||
setLogLevel LogInfo -- LogError
|
||||
withGlobalLogging logCfg initRun
|
||||
| otherwise = initRun
|
||||
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}
|
||||
initRun = do
|
||||
sendNotification <- initializeNotifications
|
||||
let f = chatStoreFile $ dbFilePrefix opts
|
||||
st <- createStore f $ dbPoolSize cfg
|
||||
user <- getCreateActiveUser st
|
||||
ct <- newChatTerminal t
|
||||
cc <- newChatController st user cfg opts sendNotification
|
||||
runSimplexChat user ct cc
|
||||
|
||||
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
|
||||
runSimplexChat :: User -> ChatTerminal -> ChatController -> IO ()
|
||||
runSimplexChat user ct = runReaderT $ do
|
||||
whenM (asks firstTime) . liftIO . printToTerminal ct $ chatWelcome user
|
||||
raceAny_ [runTerminalInput ct, runTerminalOutput ct, runChatController]
|
||||
|
||||
@@ -2,14 +2,14 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Simplex.Chat.Input where
|
||||
module Simplex.Chat.Terminal.Input where
|
||||
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Data.List (dropWhileEnd)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Terminal
|
||||
import Simplex.Chat.Terminal.Output
|
||||
import System.Exit (exitSuccess)
|
||||
import System.Terminal hiding (insertChars)
|
||||
import UnliftIO.STM
|
||||
@@ -21,16 +21,16 @@ getKey =
|
||||
Right (KeyEvent key ms) -> pure (key, ms)
|
||||
_ -> getKey
|
||||
|
||||
runTerminalInput :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
runTerminalInput = do
|
||||
ChatController {inputQ, chatTerminal = ct} <- ask
|
||||
runTerminalInput :: (MonadUnliftIO m, MonadReader ChatController m) => ChatTerminal -> m ()
|
||||
runTerminalInput ct = do
|
||||
cc <- ask
|
||||
liftIO $
|
||||
withChatTerm ct $ do
|
||||
updateInput ct
|
||||
receiveFromTTY inputQ ct
|
||||
receiveFromTTY cc ct
|
||||
|
||||
receiveFromTTY :: MonadTerminal m => TBQueue InputEvent -> ChatTerminal -> m ()
|
||||
receiveFromTTY inputQ ct@ChatTerminal {activeTo, termSize, termState} =
|
||||
receiveFromTTY :: MonadTerminal m => ChatController -> ChatTerminal -> m ()
|
||||
receiveFromTTY ChatController {inputQ, activeTo} ct@ChatTerminal {termSize, termState} =
|
||||
forever $ getKey >>= processKey >> withTermLock ct (updateInput ct)
|
||||
where
|
||||
processKey :: MonadTerminal m => (Key, Modifiers) -> m ()
|
||||
@@ -3,7 +3,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Chat.Notification (Notification (..), initializeNotifications) where
|
||||
module Simplex.Chat.Terminal.Notification (Notification (..), initializeNotifications) where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad (void)
|
||||
@@ -13,13 +13,12 @@ import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Types
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist, findExecutable, getAppUserDataDirectory)
|
||||
import System.FilePath (combine)
|
||||
import System.Info (os)
|
||||
import System.Process (readCreateProcess, shell)
|
||||
|
||||
data Notification = Notification {title :: Text, text :: Text}
|
||||
|
||||
initializeNotifications :: IO (Notification -> IO ())
|
||||
initializeNotifications =
|
||||
hideException <$> case os of
|
||||
@@ -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
|
||||
@@ -60,6 +60,9 @@ data User = User
|
||||
profile :: Profile,
|
||||
activeUser :: Bool
|
||||
}
|
||||
deriving (Generic, FromJSON)
|
||||
|
||||
instance ToJSON User where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
type UserId = Int64
|
||||
|
||||
@@ -743,3 +746,5 @@ msgDeliveryStatusT' s =
|
||||
case testEquality d (msgDirection @d) of
|
||||
Just Refl -> Just st
|
||||
_ -> Nothing
|
||||
|
||||
data Notification = Notification {title :: Text, text :: Text}
|
||||
|
||||
+238
-418
@@ -7,85 +7,83 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.View
|
||||
( printToView,
|
||||
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,
|
||||
( safeDecodeUtf8,
|
||||
msgPlain,
|
||||
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
|
||||
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Composition ((.:), (.:.))
|
||||
import Data.Composition ((.:))
|
||||
import Data.Function (on)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (groupBy, intersperse, sort, sortOn)
|
||||
@@ -99,7 +97,6 @@ import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Store (StoreError (..))
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Terminal (printToTerminal)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Util (safeDecodeUtf8)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
@@ -107,227 +104,25 @@ import Simplex.Messaging.Encoding.String
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import System.Console.ANSI.Types
|
||||
|
||||
type ChatReader m = (MonadUnliftIO m, MonadReader ChatController m)
|
||||
viewSentConfirmation :: [StyledString]
|
||||
viewSentConfirmation = ["confirmation sent!"]
|
||||
|
||||
showInvitation :: ChatReader m => ConnReqInvitation -> m ()
|
||||
showInvitation = printToView . connReqInvitation_
|
||||
viewSentInvitation :: [StyledString]
|
||||
viewSentInvitation = ["connection request sent!"]
|
||||
|
||||
showSentConfirmation :: ChatReader m => m ()
|
||||
showSentConfirmation = printToView ["confirmation sent!"]
|
||||
viewInvalidConnReq :: [StyledString]
|
||||
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 ()
|
||||
showSentInvitation = printToView ["connection request sent!"]
|
||||
viewUserContactLinkSubscribed :: [StyledString]
|
||||
viewUserContactLinkSubscribed = ["Your address is active! To show: " <> highlight' "/sa"]
|
||||
|
||||
showInvalidConnReq :: ChatReader m => m ()
|
||||
showInvalidConnReq =
|
||||
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 =
|
||||
viewConnReqInvitation :: ConnReqInvitation -> [StyledString]
|
||||
viewConnReqInvitation cReq =
|
||||
[ "pass this invitation link to your contact (via another channel): ",
|
||||
"",
|
||||
(plain . strEncode) cReq,
|
||||
@@ -335,48 +130,48 @@ connReqInvitation_ cReq =
|
||||
"and ask them to connect: " <> highlight' "/c <invitation_link_above>"
|
||||
]
|
||||
|
||||
contactDeleted :: ContactName -> [StyledString]
|
||||
contactDeleted c = [ttyContact c <> ": contact is deleted"]
|
||||
viewContactDeleted :: ContactName -> [StyledString]
|
||||
viewContactDeleted c = [ttyContact c <> ": contact is deleted"]
|
||||
|
||||
contactGroups :: ContactName -> [GroupName] -> [StyledString]
|
||||
contactGroups c gNames = [ttyContact c <> ": contact cannot be deleted, it is a member of the group(s) " <> ttyGroups gNames]
|
||||
viewContactGroups :: ContactName -> [GroupName] -> [StyledString]
|
||||
viewContactGroups c gNames = [ttyContact c <> ": contact cannot be deleted, it is a member of the group(s) " <> ttyGroups gNames]
|
||||
where
|
||||
ttyGroups :: [GroupName] -> StyledString
|
||||
ttyGroups [] = ""
|
||||
ttyGroups [g] = ttyGroup g
|
||||
ttyGroups (g : gs) = ttyGroup g <> ", " <> ttyGroups gs
|
||||
|
||||
contactsList :: [Contact] -> [StyledString]
|
||||
contactsList =
|
||||
viewContactsList :: [Contact] -> [StyledString]
|
||||
viewContactsList =
|
||||
let ldn = T.toLower . (localDisplayName :: Contact -> ContactName)
|
||||
in map ttyFullContact . sortOn ldn
|
||||
|
||||
contactConnected :: Contact -> [StyledString]
|
||||
contactConnected ct = [ttyFullContact ct <> ": contact is connected"]
|
||||
viewContactConnected :: Contact -> [StyledString]
|
||||
viewContactConnected ct = [ttyFullContact ct <> ": contact is connected"]
|
||||
|
||||
contactDisconnected :: ContactName -> [StyledString]
|
||||
contactDisconnected c = [ttyContact c <> ": disconnected from server (messages will be queued)"]
|
||||
viewContactDisconnected :: ContactName -> [StyledString]
|
||||
viewContactDisconnected c = [ttyContact c <> ": disconnected from server (messages will be queued)"]
|
||||
|
||||
contactAnotherClient :: ContactName -> [StyledString]
|
||||
contactAnotherClient c = [ttyContact c <> ": contact is connected to another client"]
|
||||
viewContactAnotherClient :: ContactName -> [StyledString]
|
||||
viewContactAnotherClient c = [ttyContact c <> ": contact is connected to another client"]
|
||||
|
||||
contactSubscribed :: ContactName -> [StyledString]
|
||||
contactSubscribed c = [ttyContact c <> ": connected to server"]
|
||||
viewContactSubscribed :: ContactName -> [StyledString]
|
||||
viewContactSubscribed c = [ttyContact c <> ": connected to server"]
|
||||
|
||||
contactSubError :: ContactName -> ChatError -> [StyledString]
|
||||
contactSubError c e = [ttyContact c <> ": contact error " <> sShow e]
|
||||
viewContactSubError :: ContactName -> ChatError -> [StyledString]
|
||||
viewContactSubError c e = [ttyContact c <> ": contact error " <> sShow e]
|
||||
|
||||
userContactLinkCreated :: ConnReqContact -> [StyledString]
|
||||
userContactLinkCreated = connReqContact_ "Your new chat address is created!"
|
||||
viewUserContactLinkCreated :: ConnReqContact -> [StyledString]
|
||||
viewUserContactLinkCreated = connReqContact_ "Your new chat address is created!"
|
||||
|
||||
userContactLinkDeleted :: [StyledString]
|
||||
userContactLinkDeleted =
|
||||
viewUserContactLinkDeleted :: [StyledString]
|
||||
viewUserContactLinkDeleted =
|
||||
[ "Your chat address is deleted - accepted contacts will remain connected.",
|
||||
"To create a new chat address use " <> highlight' "/ad"
|
||||
]
|
||||
|
||||
userContactLink :: ConnReqContact -> [StyledString]
|
||||
userContactLink = connReqContact_ "Your chat address:"
|
||||
viewUserContactLink :: ConnReqContact -> [StyledString]
|
||||
viewUserContactLink = connReqContact_ "Your chat address:"
|
||||
|
||||
connReqContact_ :: StyledString -> ConnReqContact -> [StyledString]
|
||||
connReqContact_ intro cReq =
|
||||
@@ -389,90 +184,90 @@ connReqContact_ intro cReq =
|
||||
"to delete it: " <> highlight' "/da" <> " (accepted contacts will remain connected)"
|
||||
]
|
||||
|
||||
receivedContactRequest :: ContactName -> Profile -> [StyledString]
|
||||
receivedContactRequest c Profile {fullName} =
|
||||
viewReceivedContactRequest :: ContactName -> Profile -> [StyledString]
|
||||
viewReceivedContactRequest c Profile {fullName} =
|
||||
[ ttyFullName c fullName <> " wants to connect to you!",
|
||||
"to accept: " <> highlight ("/ac " <> c),
|
||||
"to reject: " <> highlight ("/rc " <> c) <> " (the sender will NOT be notified)"
|
||||
]
|
||||
|
||||
acceptingContactRequest :: ContactName -> [StyledString]
|
||||
acceptingContactRequest c = [ttyContact c <> ": accepting contact request..."]
|
||||
viewAcceptingContactRequest :: ContactName -> [StyledString]
|
||||
viewAcceptingContactRequest c = [ttyContact c <> ": accepting contact request..."]
|
||||
|
||||
contactRequestRejected :: ContactName -> [StyledString]
|
||||
contactRequestRejected c = [ttyContact c <> ": contact request rejected"]
|
||||
viewContactRequestRejected :: ContactName -> [StyledString]
|
||||
viewContactRequestRejected c = [ttyContact c <> ": contact request rejected"]
|
||||
|
||||
userContactLinkSubError :: ChatError -> [StyledString]
|
||||
userContactLinkSubError e =
|
||||
viewUserContactLinkSubError :: ChatError -> [StyledString]
|
||||
viewUserContactLinkSubError e =
|
||||
[ "user address error: " <> sShow e,
|
||||
"to delete your address: " <> highlight' "/da"
|
||||
]
|
||||
|
||||
groupSubscribed :: Group -> [StyledString]
|
||||
groupSubscribed g = [ttyFullGroup g <> ": connected to server(s)"]
|
||||
viewGroupSubscribed :: Group -> [StyledString]
|
||||
viewGroupSubscribed g = [ttyFullGroup g <> ": connected to server(s)"]
|
||||
|
||||
groupEmpty :: Group -> [StyledString]
|
||||
groupEmpty g = [ttyFullGroup g <> ": group is empty"]
|
||||
viewGroupEmpty :: Group -> [StyledString]
|
||||
viewGroupEmpty g = [ttyFullGroup g <> ": group is empty"]
|
||||
|
||||
groupRemoved :: Group -> [StyledString]
|
||||
groupRemoved g = [ttyFullGroup g <> ": you are no longer a member or group deleted"]
|
||||
viewGroupRemoved :: Group -> [StyledString]
|
||||
viewGroupRemoved g = [ttyFullGroup g <> ": you are no longer a member or group deleted"]
|
||||
|
||||
memberSubError :: GroupName -> ContactName -> ChatError -> [StyledString]
|
||||
memberSubError g c e = [ttyGroup g <> " member " <> ttyContact c <> " error: " <> sShow e]
|
||||
viewMemberSubError :: GroupName -> ContactName -> ChatError -> [StyledString]
|
||||
viewMemberSubError g c e = [ttyGroup g <> " member " <> ttyContact c <> " error: " <> sShow e]
|
||||
|
||||
groupCreated :: Group -> [StyledString]
|
||||
groupCreated g@Group {localDisplayName} =
|
||||
viewGroupCreated :: Group -> [StyledString]
|
||||
viewGroupCreated g@Group {localDisplayName} =
|
||||
[ "group " <> ttyFullGroup g <> " is created",
|
||||
"use " <> highlight ("/a " <> localDisplayName <> " <name>") <> " to add members"
|
||||
]
|
||||
|
||||
groupDeletedUser :: GroupName -> [StyledString]
|
||||
groupDeletedUser g = groupDeleted_ g Nothing
|
||||
viewGroupDeletedUser :: GroupName -> [StyledString]
|
||||
viewGroupDeletedUser g = groupDeleted_ g Nothing
|
||||
|
||||
groupDeleted :: GroupName -> GroupMember -> [StyledString]
|
||||
groupDeleted g m = groupDeleted_ g (Just m) <> ["use " <> highlight ("/d #" <> g) <> " to delete the local copy of the group"]
|
||||
viewGroupDeleted :: GroupName -> GroupMember -> [StyledString]
|
||||
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_ g m = [ttyGroup g <> ": " <> memberOrUser m <> " deleted the group"]
|
||||
|
||||
sentGroupInvitation :: GroupName -> ContactName -> [StyledString]
|
||||
sentGroupInvitation g c = ["invitation to join the group " <> ttyGroup g <> " sent to " <> ttyContact c]
|
||||
viewSentGroupInvitation :: GroupName -> ContactName -> [StyledString]
|
||||
viewSentGroupInvitation g c = ["invitation to join the group " <> ttyGroup g <> " sent to " <> ttyContact c]
|
||||
|
||||
cannotResendInvitation :: GroupName -> ContactName -> [StyledString]
|
||||
cannotResendInvitation g c =
|
||||
viewCannotResendInvitation :: GroupName -> ContactName -> [StyledString]
|
||||
viewCannotResendInvitation g c =
|
||||
[ ttyContact c <> " is already invited to group " <> ttyGroup g,
|
||||
"to re-send invitation: " <> highlight ("/rm " <> g <> " " <> c) <> ", " <> highlight ("/a " <> g <> " " <> c)
|
||||
]
|
||||
|
||||
receivedGroupInvitation :: Group -> ContactName -> GroupMemberRole -> [StyledString]
|
||||
receivedGroupInvitation g@Group {localDisplayName} c role =
|
||||
viewReceivedGroupInvitation :: Group -> ContactName -> GroupMemberRole -> [StyledString]
|
||||
viewReceivedGroupInvitation g@Group {localDisplayName} c role =
|
||||
[ ttyFullGroup g <> ": " <> ttyContact c <> " invites you to join the group as " <> plain (strEncode role),
|
||||
"use " <> highlight ("/j " <> localDisplayName) <> " to accept"
|
||||
]
|
||||
|
||||
joinedGroupMember :: GroupName -> GroupMember -> [StyledString]
|
||||
joinedGroupMember g m = [ttyGroup g <> ": " <> ttyMember m <> " joined the group "]
|
||||
viewJoinedGroupMember :: GroupName -> GroupMember -> [StyledString]
|
||||
viewJoinedGroupMember g m = [ttyGroup g <> ": " <> ttyMember m <> " joined the group "]
|
||||
|
||||
userJoinedGroup :: GroupName -> [StyledString]
|
||||
userJoinedGroup g = [ttyGroup g <> ": you joined the group"]
|
||||
viewUserJoinedGroup :: GroupName -> [StyledString]
|
||||
viewUserJoinedGroup g = [ttyGroup g <> ": you joined the group"]
|
||||
|
||||
joinedGroupMemberConnecting :: GroupName -> GroupMember -> GroupMember -> [StyledString]
|
||||
joinedGroupMemberConnecting g host m = [ttyGroup g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"]
|
||||
viewJoinedGroupMemberConnecting :: GroupName -> GroupMember -> GroupMember -> [StyledString]
|
||||
viewJoinedGroupMemberConnecting g host m = [ttyGroup g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"]
|
||||
|
||||
connectedToGroupMember :: GroupName -> GroupMember -> [StyledString]
|
||||
connectedToGroupMember g m = [ttyGroup g <> ": " <> connectedMember m <> " is connected"]
|
||||
viewConnectedToGroupMember :: GroupName -> GroupMember -> [StyledString]
|
||||
viewConnectedToGroupMember g m = [ttyGroup g <> ": " <> connectedMember m <> " is connected"]
|
||||
|
||||
deletedMember :: GroupName -> Maybe GroupMember -> Maybe GroupMember -> [StyledString]
|
||||
deletedMember g by m = [ttyGroup g <> ": " <> memberOrUser by <> " removed " <> memberOrUser m <> " from the group"]
|
||||
viewDeletedMember :: GroupName -> Maybe GroupMember -> Maybe GroupMember -> [StyledString]
|
||||
viewDeletedMember g by m = [ttyGroup g <> ": " <> memberOrUser by <> " removed " <> memberOrUser m <> " from the group"]
|
||||
|
||||
deletedMemberUser :: GroupName -> GroupMember -> [StyledString]
|
||||
deletedMemberUser g by = deletedMember g (Just by) Nothing <> groupPreserved g
|
||||
viewDeletedMemberUser :: GroupName -> GroupMember -> [StyledString]
|
||||
viewDeletedMemberUser g by = viewDeletedMember g (Just by) Nothing <> groupPreserved g
|
||||
|
||||
leftMemberUser :: GroupName -> [StyledString]
|
||||
leftMemberUser g = leftMember_ g Nothing <> groupPreserved g
|
||||
viewLeftMemberUser :: GroupName -> [StyledString]
|
||||
viewLeftMemberUser g = leftMember_ g Nothing <> groupPreserved g
|
||||
|
||||
leftMember :: GroupName -> GroupMember -> [StyledString]
|
||||
leftMember g m = leftMember_ g (Just m)
|
||||
viewLeftMember :: GroupName -> GroupMember -> [StyledString]
|
||||
viewLeftMember g m = leftMember_ g (Just m)
|
||||
|
||||
leftMember_ :: GroupName -> Maybe GroupMember -> [StyledString]
|
||||
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
|
||||
_ -> "member " <> ttyMember m -- these case is not used
|
||||
|
||||
groupMembers :: Group -> [StyledString]
|
||||
groupMembers Group {membership, members} = map groupMember . filter (not . removedOrLeft) $ membership : members
|
||||
viewGroupMembers :: Group -> [StyledString]
|
||||
viewGroupMembers Group {membership, members} = map groupMember . filter (not . removedOrLeft) $ membership : members
|
||||
where
|
||||
removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft
|
||||
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"
|
||||
_ -> ""
|
||||
|
||||
groupsList :: [(GroupName, Text, GroupMemberStatus)] -> [StyledString]
|
||||
groupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"]
|
||||
groupsList gs = map groupSS $ sort gs
|
||||
viewGroupsList :: [(GroupName, Text, GroupMemberStatus)] -> [StyledString]
|
||||
viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"]
|
||||
viewGroupsList gs = map groupSS $ sort gs
|
||||
where
|
||||
groupSS (displayName, fullName, GSMemInvited) = groupInvitation 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 displayName fullName =
|
||||
highlight ("#" <> displayName)
|
||||
@@ -526,21 +325,21 @@ groupInvitation displayName fullName =
|
||||
<> highlight ("/d #" <> displayName)
|
||||
<> " to delete invitation)"
|
||||
|
||||
contactsMerged :: Contact -> Contact -> [StyledString]
|
||||
contactsMerged _to@Contact {localDisplayName = c1} _from@Contact {localDisplayName = c2} =
|
||||
viewContactsMerged :: Contact -> Contact -> [StyledString]
|
||||
viewContactsMerged _to@Contact {localDisplayName = c1} _from@Contact {localDisplayName = c2} =
|
||||
[ "contact " <> ttyContact c2 <> " is merged into " <> ttyContact c1,
|
||||
"use " <> ttyToContact c1 <> highlight' "<message>" <> " to send messages"
|
||||
]
|
||||
|
||||
userProfile :: Profile -> [StyledString]
|
||||
userProfile Profile {displayName, fullName} =
|
||||
viewUserProfile :: Profile -> [StyledString]
|
||||
viewUserProfile Profile {displayName, fullName} =
|
||||
[ "user profile: " <> ttyFullName displayName fullName,
|
||||
"use " <> highlight' "/p <display name> [<full name>]" <> " to change it",
|
||||
"(the updated profile will be sent to all your contacts)"
|
||||
]
|
||||
|
||||
userProfileUpdated :: User -> User -> [StyledString]
|
||||
userProfileUpdated
|
||||
viewUserProfileUpdated :: User -> User -> [StyledString]
|
||||
viewUserProfileUpdated
|
||||
User {localDisplayName = n, profile = Profile {fullName}}
|
||||
User {localDisplayName = n', profile = Profile {fullName = fullName'}}
|
||||
| n == n' && fullName == fullName' = []
|
||||
@@ -549,8 +348,8 @@ userProfileUpdated
|
||||
where
|
||||
notified = " (your contacts are notified)"
|
||||
|
||||
contactUpdated :: Contact -> Contact -> [StyledString]
|
||||
contactUpdated
|
||||
viewContactUpdated :: Contact -> Contact -> [StyledString]
|
||||
viewContactUpdated
|
||||
Contact {localDisplayName = n, profile = Profile {fullName}}
|
||||
Contact {localDisplayName = n', profile = Profile {fullName = fullName'}}
|
||||
| n == n' && fullName == fullName' = []
|
||||
@@ -562,11 +361,17 @@ contactUpdated
|
||||
where
|
||||
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
|
||||
|
||||
messageError :: Text -> Text -> [StyledString]
|
||||
messageError prefix err = [plain prefix <> ": " <> plain err]
|
||||
viewMessageError :: Text -> Text -> [StyledString]
|
||||
viewMessageError prefix err = [plain prefix <> ": " <> plain err]
|
||||
|
||||
receivedMessage :: StyledString -> UTCTime -> [StyledString] -> MsgIntegrity -> IO [StyledString]
|
||||
receivedMessage from utcTime msg mOk = do
|
||||
viewReceivedMessage :: ContactName -> UTCTime -> [StyledString] -> MsgIntegrity -> IO [StyledString]
|
||||
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
|
||||
pure $ prependFirst (t <> " " <> from) msg ++ showIntegrity mOk
|
||||
where
|
||||
@@ -591,14 +396,26 @@ receivedMessage from utcTime msg mOk = do
|
||||
msgError :: String -> [StyledString]
|
||||
msgError s = [styled (Colored Red) s]
|
||||
|
||||
sentMessage :: StyledString -> ByteString -> IO [StyledString]
|
||||
sentMessage to msg = sendWithTime_ to . msgPlain $ safeDecodeUtf8 msg
|
||||
viewSentMessage :: ContactName -> ByteString -> IO [StyledString]
|
||||
viewSentMessage = viewSentMessage_ . ttyToContact
|
||||
|
||||
sentFileInvitation :: StyledString -> FilePath -> IO [StyledString]
|
||||
sentFileInvitation to f = sendWithTime_ ("/f " <> to) [ttyFilePath f]
|
||||
viewSentGroupMessage :: GroupName -> ByteString -> IO [StyledString]
|
||||
viewSentGroupMessage = viewSentMessage_ . ttyToGroup
|
||||
|
||||
sendWithTime_ :: StyledString -> [StyledString] -> IO [StyledString]
|
||||
sendWithTime_ to styledMsg = do
|
||||
viewSentMessage_ :: StyledString -> ByteString -> IO [StyledString]
|
||||
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
|
||||
pure $ prependFirst (styleTime time <> " " <> to) styledMsg
|
||||
|
||||
@@ -609,21 +426,21 @@ prependFirst s (s' : ss) = (s <> s') : ss
|
||||
msgPlain :: Text -> [StyledString]
|
||||
msgPlain = map styleMarkdownText . T.lines
|
||||
|
||||
sentFileInfo :: Int64 -> [StyledString]
|
||||
sentFileInfo fileId =
|
||||
viewSentFileInfo :: Int64 -> [StyledString]
|
||||
viewSentFileInfo fileId =
|
||||
["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"]
|
||||
|
||||
sndFileStart :: SndFileTransfer -> [StyledString]
|
||||
sndFileStart = sendingFile_ "started"
|
||||
viewSndFileStart :: SndFileTransfer -> [StyledString]
|
||||
viewSndFileStart = sendingFile_ "started"
|
||||
|
||||
sndFileComplete :: SndFileTransfer -> [StyledString]
|
||||
sndFileComplete = sendingFile_ "completed"
|
||||
viewSndFileComplete :: SndFileTransfer -> [StyledString]
|
||||
viewSndFileComplete = sendingFile_ "completed"
|
||||
|
||||
sndFileCancelled :: SndFileTransfer -> [StyledString]
|
||||
sndFileCancelled = sendingFile_ "cancelled"
|
||||
viewSndFileCancelled :: SndFileTransfer -> [StyledString]
|
||||
viewSndFileCancelled = sendingFile_ "cancelled"
|
||||
|
||||
sndGroupFileCancelled :: [SndFileTransfer] -> [StyledString]
|
||||
sndGroupFileCancelled fts =
|
||||
viewSndGroupFileCancelled :: [SndFileTransfer] -> [StyledString]
|
||||
viewSndGroupFileCancelled fts =
|
||||
case filter (\SndFileTransfer {fileStatus = s} -> s /= FSCancelled && s /= FSComplete) fts of
|
||||
[] -> ["sending file can't be cancelled"]
|
||||
ts@(ft : _) -> ["cancelled sending " <> sndFile ft <> " to " <> listMembers ts]
|
||||
@@ -632,15 +449,21 @@ sendingFile_ :: StyledString -> SndFileTransfer -> [StyledString]
|
||||
sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
|
||||
[status <> " sending " <> sndFile ft <> " to " <> ttyContact c]
|
||||
|
||||
sndFileRcvCancelled :: SndFileTransfer -> [StyledString]
|
||||
sndFileRcvCancelled ft@SndFileTransfer {recipientDisplayName = c} =
|
||||
viewSndFileRcvCancelled :: SndFileTransfer -> [StyledString]
|
||||
viewSndFileRcvCancelled ft@SndFileTransfer {recipientDisplayName = c} =
|
||||
[ttyContact c <> " cancelled receiving " <> sndFile ft]
|
||||
|
||||
sndFile :: SndFileTransfer -> StyledString
|
||||
sndFile SndFileTransfer {fileId, fileName} = fileTransfer fileId fileName
|
||||
|
||||
receivedFileInvitation :: RcvFileTransfer -> [StyledString]
|
||||
receivedFileInvitation RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName, fileSize}} =
|
||||
viewReceivedFileInvitation :: ContactName -> UTCTime -> RcvFileTransfer -> MsgIntegrity -> IO [StyledString]
|
||||
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)",
|
||||
"use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"
|
||||
]
|
||||
@@ -657,25 +480,25 @@ humanReadableSize size
|
||||
mB = kB * 1024
|
||||
gB = mB * 1024
|
||||
|
||||
rcvFileAccepted :: RcvFileTransfer -> FilePath -> [StyledString]
|
||||
rcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath =
|
||||
viewRcvFileAccepted :: RcvFileTransfer -> FilePath -> [StyledString]
|
||||
viewRcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath =
|
||||
["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath]
|
||||
|
||||
rcvFileStart :: RcvFileTransfer -> [StyledString]
|
||||
rcvFileStart = receivingFile_ "started"
|
||||
viewRcvFileStart :: RcvFileTransfer -> [StyledString]
|
||||
viewRcvFileStart = receivingFile_ "started"
|
||||
|
||||
rcvFileComplete :: RcvFileTransfer -> [StyledString]
|
||||
rcvFileComplete = receivingFile_ "completed"
|
||||
viewRcvFileComplete :: RcvFileTransfer -> [StyledString]
|
||||
viewRcvFileComplete = receivingFile_ "completed"
|
||||
|
||||
rcvFileCancelled :: RcvFileTransfer -> [StyledString]
|
||||
rcvFileCancelled = receivingFile_ "cancelled"
|
||||
viewRcvFileCancelled :: RcvFileTransfer -> [StyledString]
|
||||
viewRcvFileCancelled = receivingFile_ "cancelled"
|
||||
|
||||
receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString]
|
||||
receivingFile_ status ft@RcvFileTransfer {senderDisplayName = c} =
|
||||
[status <> " receiving " <> rcvFile ft <> " from " <> ttyContact c]
|
||||
|
||||
rcvFileSndCancelled :: RcvFileTransfer -> [StyledString]
|
||||
rcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} =
|
||||
viewRcvFileSndCancelled :: RcvFileTransfer -> [StyledString]
|
||||
viewRcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} =
|
||||
[ttyContact c <> " cancelled sending " <> rcvFile ft]
|
||||
|
||||
rcvFile :: RcvFileTransfer -> StyledString
|
||||
@@ -684,8 +507,8 @@ rcvFile RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} = f
|
||||
fileTransfer :: Int64 -> String -> StyledString
|
||||
fileTransfer fileId fileName = "file " <> sShow fileId <> " (" <> ttyFilePath fileName <> ")"
|
||||
|
||||
fileTransferStatus :: (FileTransfer, [Integer]) -> [StyledString]
|
||||
fileTransferStatus (FTSnd [ft@SndFileTransfer {fileStatus, fileSize, chunkSize}], chunksNum) =
|
||||
viewFileTransferStatus :: (FileTransfer, [Integer]) -> [StyledString]
|
||||
viewFileTransferStatus (FTSnd [ft@SndFileTransfer {fileStatus, fileSize, chunkSize}], chunksNum) =
|
||||
["sending " <> sndFile ft <> " " <> sndStatus]
|
||||
where
|
||||
sndStatus = case fileStatus of
|
||||
@@ -694,8 +517,8 @@ fileTransferStatus (FTSnd [ft@SndFileTransfer {fileStatus, fileSize, chunkSize}]
|
||||
FSConnected -> "progress " <> fileProgress chunksNum chunkSize fileSize
|
||||
FSComplete -> "complete"
|
||||
FSCancelled -> "cancelled"
|
||||
fileTransferStatus (FTSnd [], _) = ["no file transfers (empty group)"]
|
||||
fileTransferStatus (FTSnd fts@(ft : _), chunksNum) =
|
||||
viewFileTransferStatus (FTSnd [], _) = ["no file transfers (empty group)"]
|
||||
viewFileTransferStatus (FTSnd fts@(ft : _), chunksNum) =
|
||||
case concatMap membersTransferStatus $ groupBy ((==) `on` fs) $ sortOn fs fts of
|
||||
[membersStatus] -> ["sending " <> sndFile ft <> " " <> membersStatus]
|
||||
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)) <> "%)"
|
||||
FSComplete -> "complete"
|
||||
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]
|
||||
where
|
||||
rcvStatus = case fileStatus of
|
||||
@@ -727,16 +550,16 @@ fileProgress :: [Integer] -> Integer -> Integer -> StyledString
|
||||
fileProgress chunksNum chunkSize fileSize =
|
||||
sShow (sum chunksNum * chunkSize * 100 `div` fileSize) <> "% of " <> humanReadableSize fileSize
|
||||
|
||||
sndFileSubError :: SndFileTransfer -> ChatError -> [StyledString]
|
||||
sndFileSubError SndFileTransfer {fileId, fileName} e =
|
||||
viewSndFileSubError :: SndFileTransfer -> ChatError -> [StyledString]
|
||||
viewSndFileSubError SndFileTransfer {fileId, fileName} e =
|
||||
["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
|
||||
|
||||
rcvFileSubError :: RcvFileTransfer -> ChatError -> [StyledString]
|
||||
rcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e =
|
||||
viewRcvFileSubError :: RcvFileTransfer -> ChatError -> [StyledString]
|
||||
viewRcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e =
|
||||
["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
|
||||
|
||||
chatError :: ChatError -> [StyledString]
|
||||
chatError = \case
|
||||
viewChatError :: ChatError -> [StyledString]
|
||||
viewChatError = \case
|
||||
ChatError err -> case err of
|
||||
CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"]
|
||||
CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"]
|
||||
@@ -777,9 +600,6 @@ chatError = \case
|
||||
where
|
||||
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 = styled (Colored Green)
|
||||
|
||||
|
||||
Reference in New Issue
Block a user