mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
started chat model (#221)
* started chat model * refactor processing commands and UI events * message chat event processing * groups: delayed delivery of messages and introductions to announced members (#217) * combine migrations, rename fields * show all view messages vis ChatResponse type * serialize chat response * update C api * remove unused extensions, fix typos Co-authored-by: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
a5ad0b185c
commit
b38d5f3465
@@ -2,7 +2,6 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Controller where
|
||||
@@ -12,16 +11,20 @@ import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Int (Int64)
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.Text (Text)
|
||||
import Numeric.Natural
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Store (StoreError)
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent (AgentClient)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig)
|
||||
import Simplex.Messaging.Agent.Protocol (AgentErrorType)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
|
||||
import Simplex.Messaging.Protocol (CorrId)
|
||||
import System.IO (Handle)
|
||||
import UnliftIO.STM
|
||||
|
||||
@@ -51,8 +54,8 @@ data ChatController = ChatController
|
||||
smpAgent :: AgentClient,
|
||||
chatStore :: SQLiteStore,
|
||||
idsDrg :: TVar ChaChaDRG,
|
||||
inputQ :: TBQueue InputEvent,
|
||||
outputQ :: TBQueue [StyledString],
|
||||
inputQ :: TBQueue String,
|
||||
outputQ :: TBQueue (CorrId, ChatResponse),
|
||||
notifyQ :: TBQueue Notification,
|
||||
sendNotification :: Notification -> IO (),
|
||||
chatLock :: TMVar (),
|
||||
@@ -61,7 +64,120 @@ data ChatController = ChatController
|
||||
config :: ChatConfig
|
||||
}
|
||||
|
||||
data InputEvent = InputCommand String | InputControl Char
|
||||
data HelpSection = HSMain | HSFiles | HSGroups | HSMyAddress | HSMarkdown
|
||||
deriving (Show)
|
||||
|
||||
data ChatCommand
|
||||
= ChatHelp HelpSection
|
||||
| Welcome
|
||||
| AddContact
|
||||
| Connect (Maybe AConnectionRequestUri)
|
||||
| ConnectAdmin
|
||||
| DeleteContact ContactName
|
||||
| ListContacts
|
||||
| CreateMyAddress
|
||||
| DeleteMyAddress
|
||||
| ShowMyAddress
|
||||
| AcceptContact ContactName
|
||||
| RejectContact ContactName
|
||||
| SendMessage ContactName ByteString
|
||||
| NewGroup GroupProfile
|
||||
| AddMember GroupName ContactName GroupMemberRole
|
||||
| JoinGroup GroupName
|
||||
| RemoveMember GroupName ContactName
|
||||
| MemberRole GroupName ContactName GroupMemberRole
|
||||
| LeaveGroup GroupName
|
||||
| DeleteGroup GroupName
|
||||
| ListMembers GroupName
|
||||
| ListGroups
|
||||
| SendGroupMessage GroupName ByteString
|
||||
| SendFile ContactName FilePath
|
||||
| SendGroupFile GroupName FilePath
|
||||
| ReceiveFile Int64 (Maybe FilePath)
|
||||
| CancelFile Int64
|
||||
| FileStatus Int64
|
||||
| ShowProfile
|
||||
| UpdateProfile Profile
|
||||
| QuitChat
|
||||
| ShowVersion
|
||||
deriving (Show)
|
||||
|
||||
data ChatResponse
|
||||
= CRSentMessage ContactName MsgContent ChatMsgMeta
|
||||
| CRSentGroupMessage GroupName MsgContent ChatMsgMeta
|
||||
| CRSentFileInvitation ContactName FileTransferId FilePath ChatMsgMeta
|
||||
| CRSentGroupFileInvitation GroupName FileTransferId FilePath ChatMsgMeta
|
||||
| CRReceivedMessage ContactName ChatMsgMeta MsgContent MsgIntegrity
|
||||
| CRReceivedGroupMessage GroupName ContactName ChatMsgMeta MsgContent MsgIntegrity
|
||||
| CRReceivedFileInvitation ContactName ChatMsgMeta RcvFileTransfer MsgIntegrity
|
||||
| CRReceivedGroupFileInvitation GroupName ContactName ChatMsgMeta RcvFileTransfer MsgIntegrity
|
||||
| CRCommandAccepted CorrId
|
||||
| CRChatHelp HelpSection
|
||||
| CRWelcome User
|
||||
| CRGroupCreated Group
|
||||
| CRGroupMembers Group
|
||||
| CRContactsList [Contact]
|
||||
| CRUserContactLink ConnReqContact
|
||||
| CRContactRequestRejected ContactName
|
||||
| CRUserAcceptedGroupSent GroupName
|
||||
| CRUserDeletedMember GroupName GroupMember
|
||||
| CRGroupsList [GroupInfo]
|
||||
| CRSentGroupInvitation GroupName ContactName
|
||||
| CRFileTransferStatus (FileTransfer, [Integer])
|
||||
| CRUserProfile Profile
|
||||
| CRUserProfileNoChange
|
||||
| CRVersionInfo
|
||||
| CRInvitation ConnReqInvitation
|
||||
| CRSentConfirmation
|
||||
| CRSentInvitation
|
||||
| CRContactUpdated {fromContact :: Contact, toContact :: Contact}
|
||||
| CRContactsMerged {intoContact :: Contact, mergedContact :: Contact}
|
||||
| CRContactDeleted ContactName
|
||||
| CRUserContactLinkCreated ConnReqContact
|
||||
| CRUserContactLinkDeleted
|
||||
| CRReceivedContactRequest ContactName Profile
|
||||
| CRAcceptingContactRequest ContactName
|
||||
| CRLeftMemberUser GroupName
|
||||
| CRGroupDeletedUser GroupName
|
||||
| CRRcvFileAccepted RcvFileTransfer FilePath
|
||||
| CRRcvFileAcceptedSndCancelled RcvFileTransfer
|
||||
| CRRcvFileStart RcvFileTransfer
|
||||
| CRRcvFileComplete RcvFileTransfer
|
||||
| CRRcvFileCancelled RcvFileTransfer
|
||||
| CRRcvFileSndCancelled RcvFileTransfer
|
||||
| CRSndFileStart SndFileTransfer
|
||||
| CRSndFileComplete SndFileTransfer
|
||||
| CRSndFileCancelled SndFileTransfer
|
||||
| CRSndFileRcvCancelled SndFileTransfer
|
||||
| CRSndGroupFileCancelled [SndFileTransfer]
|
||||
| CRUserProfileUpdated {fromProfile :: Profile, toProfile :: Profile}
|
||||
| CRContactConnected Contact
|
||||
| CRContactAnotherClient ContactName
|
||||
| CRContactDisconnected ContactName
|
||||
| CRContactSubscribed ContactName
|
||||
| CRContactSubError ContactName ChatError
|
||||
| CRGroupInvitation Group
|
||||
| CRReceivedGroupInvitation Group ContactName GroupMemberRole
|
||||
| CRUserJoinedGroup GroupName
|
||||
| CRJoinedGroupMember GroupName GroupMember
|
||||
| CRJoinedGroupMemberConnecting {group :: GroupName, hostMember :: GroupMember, member :: GroupMember}
|
||||
| CRConnectedToGroupMember GroupName GroupMember
|
||||
| CRDeletedMember {group :: GroupName, byMember :: GroupMember, deletedMember :: GroupMember}
|
||||
| CRDeletedMemberUser GroupName GroupMember
|
||||
| CRLeftMember GroupName GroupMember
|
||||
| CRGroupEmpty Group
|
||||
| CRGroupRemoved Group
|
||||
| CRGroupDeleted GroupName GroupMember
|
||||
| CRMemberSubError GroupName ContactName ChatError
|
||||
| CRGroupSubscribed Group
|
||||
| CRSndFileSubError SndFileTransfer ChatError
|
||||
| CRRcvFileSubError RcvFileTransfer ChatError
|
||||
| CRUserContactLinkSubscribed
|
||||
| CRUserContactLinkSubError ChatError
|
||||
| CRMessageError Text Text
|
||||
| CRChatCmdError ChatError
|
||||
| CRChatError ChatError
|
||||
deriving (Show)
|
||||
|
||||
data ChatError
|
||||
= ChatError ChatErrorType
|
||||
@@ -72,6 +188,8 @@ data ChatError
|
||||
|
||||
data ChatErrorType
|
||||
= CEGroupUserRole
|
||||
| CEInvalidConnReq
|
||||
| CEContactGroups ContactName [GroupName]
|
||||
| CEGroupContactRole ContactName
|
||||
| CEGroupDuplicateMember ContactName
|
||||
| CEGroupDuplicateMemberId
|
||||
@@ -79,6 +197,8 @@ data ChatErrorType
|
||||
| CEGroupMemberNotActive
|
||||
| CEGroupMemberUserRemoved
|
||||
| CEGroupMemberNotFound ContactName
|
||||
| CEGroupMemberIntroNotFound ContactName
|
||||
| CEGroupCantResendInvitation GroupName ContactName
|
||||
| CEGroupInternal String
|
||||
| CEFileNotFound String
|
||||
| CEFileAlreadyReceiving String
|
||||
@@ -89,9 +209,10 @@ data ChatErrorType
|
||||
| CEFileRcvChunk String
|
||||
| CEFileInternal String
|
||||
| CEAgentVersion
|
||||
| CECommandError String
|
||||
deriving (Show, Exception)
|
||||
|
||||
type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m, MonadFail m)
|
||||
type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m)
|
||||
|
||||
setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
|
||||
setActive to = asks activeTo >>= atomically . (`writeTVar` to)
|
||||
|
||||
@@ -0,0 +1,179 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.Chat.Messages where
|
||||
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Time.LocalTime (ZonedTime)
|
||||
import Data.Type.Equality
|
||||
import Data.Typeable (Typeable)
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import GHC.Generics
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), serializeMsgIntegrity)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
|
||||
import Simplex.Messaging.Protocol (MsgBody)
|
||||
|
||||
data NewMessage = NewMessage
|
||||
{ direction :: MsgDirection,
|
||||
cmEventTag :: CMEventTag,
|
||||
chatTs :: UTCTime,
|
||||
msgBody :: MsgBody
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data Message = Message
|
||||
{ msgId :: MessageId,
|
||||
direction :: MsgDirection,
|
||||
cmEventTag :: CMEventTag,
|
||||
chatTs :: UTCTime,
|
||||
msgBody :: MsgBody,
|
||||
createdAt :: UTCTime
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data PendingGroupMessage = PendingGroupMessage
|
||||
{ msgId :: MessageId,
|
||||
cmEventTag :: CMEventTag,
|
||||
msgBody :: MsgBody,
|
||||
introId_ :: Maybe Int64
|
||||
}
|
||||
|
||||
data ChatMsgMeta = ChatMsgMeta
|
||||
{ msgId :: MessageId,
|
||||
chatTs :: UTCTime,
|
||||
localChatTs :: ZonedTime,
|
||||
createdAt :: UTCTime
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data MsgDirection = MDRcv | MDSnd
|
||||
deriving (Show)
|
||||
|
||||
data SMsgDirection (d :: MsgDirection) where
|
||||
SMDRcv :: SMsgDirection 'MDRcv
|
||||
SMDSnd :: SMsgDirection 'MDSnd
|
||||
|
||||
instance TestEquality SMsgDirection where
|
||||
testEquality SMDRcv SMDRcv = Just Refl
|
||||
testEquality SMDSnd SMDSnd = Just Refl
|
||||
testEquality _ _ = Nothing
|
||||
|
||||
class MsgDirectionI (d :: MsgDirection) where
|
||||
msgDirection :: SMsgDirection d
|
||||
|
||||
instance MsgDirectionI 'MDRcv where msgDirection = SMDRcv
|
||||
|
||||
instance MsgDirectionI 'MDSnd where msgDirection = SMDSnd
|
||||
|
||||
instance ToField MsgDirection where toField = toField . msgDirectionInt
|
||||
|
||||
msgDirectionInt :: MsgDirection -> Int
|
||||
msgDirectionInt = \case
|
||||
MDRcv -> 0
|
||||
MDSnd -> 1
|
||||
|
||||
msgDirectionIntP :: Int -> Maybe MsgDirection
|
||||
msgDirectionIntP = \case
|
||||
0 -> Just MDRcv
|
||||
1 -> Just MDSnd
|
||||
_ -> Nothing
|
||||
|
||||
data SndMsgDelivery = SndMsgDelivery
|
||||
{ connId :: Int64,
|
||||
agentMsgId :: AgentMsgId
|
||||
}
|
||||
|
||||
data RcvMsgDelivery = RcvMsgDelivery
|
||||
{ connId :: Int64,
|
||||
agentMsgId :: AgentMsgId,
|
||||
agentMsgMeta :: MsgMeta
|
||||
}
|
||||
|
||||
data MsgMetaJSON = MsgMetaJSON
|
||||
{ integrity :: Text,
|
||||
rcvId :: Int64,
|
||||
rcvTs :: UTCTime,
|
||||
serverId :: Text,
|
||||
serverTs :: UTCTime,
|
||||
sndId :: Int64
|
||||
}
|
||||
deriving (Eq, Show, FromJSON, Generic)
|
||||
|
||||
instance ToJSON MsgMetaJSON where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
msgMetaToJson :: MsgMeta -> MsgMetaJSON
|
||||
msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId, serverTs), sndMsgId = sndId} =
|
||||
MsgMetaJSON
|
||||
{ integrity = (decodeLatin1 . serializeMsgIntegrity) integrity,
|
||||
rcvId,
|
||||
rcvTs,
|
||||
serverId = (decodeLatin1 . B64.encode) serverId,
|
||||
serverTs,
|
||||
sndId
|
||||
}
|
||||
|
||||
msgMetaJson :: MsgMeta -> Text
|
||||
msgMetaJson = decodeLatin1 . LB.toStrict . J.encode . msgMetaToJson
|
||||
|
||||
data MsgDeliveryStatus (d :: MsgDirection) where
|
||||
MDSRcvAgent :: MsgDeliveryStatus 'MDRcv
|
||||
MDSRcvAcknowledged :: MsgDeliveryStatus 'MDRcv
|
||||
MDSSndPending :: MsgDeliveryStatus 'MDSnd
|
||||
MDSSndAgent :: MsgDeliveryStatus 'MDSnd
|
||||
MDSSndSent :: MsgDeliveryStatus 'MDSnd
|
||||
MDSSndReceived :: MsgDeliveryStatus 'MDSnd
|
||||
MDSSndRead :: MsgDeliveryStatus 'MDSnd
|
||||
|
||||
data AMsgDeliveryStatus = forall d. AMDS (SMsgDirection d) (MsgDeliveryStatus d)
|
||||
|
||||
instance (Typeable d, MsgDirectionI d) => FromField (MsgDeliveryStatus d) where
|
||||
fromField = fromTextField_ msgDeliveryStatusT'
|
||||
|
||||
instance ToField (MsgDeliveryStatus d) where toField = toField . serializeMsgDeliveryStatus
|
||||
|
||||
serializeMsgDeliveryStatus :: MsgDeliveryStatus d -> Text
|
||||
serializeMsgDeliveryStatus = \case
|
||||
MDSRcvAgent -> "rcv_agent"
|
||||
MDSRcvAcknowledged -> "rcv_acknowledged"
|
||||
MDSSndPending -> "snd_pending"
|
||||
MDSSndAgent -> "snd_agent"
|
||||
MDSSndSent -> "snd_sent"
|
||||
MDSSndReceived -> "snd_received"
|
||||
MDSSndRead -> "snd_read"
|
||||
|
||||
msgDeliveryStatusT :: Text -> Maybe AMsgDeliveryStatus
|
||||
msgDeliveryStatusT = \case
|
||||
"rcv_agent" -> Just $ AMDS SMDRcv MDSRcvAgent
|
||||
"rcv_acknowledged" -> Just $ AMDS SMDRcv MDSRcvAcknowledged
|
||||
"snd_pending" -> Just $ AMDS SMDSnd MDSSndPending
|
||||
"snd_agent" -> Just $ AMDS SMDSnd MDSSndAgent
|
||||
"snd_sent" -> Just $ AMDS SMDSnd MDSSndSent
|
||||
"snd_received" -> Just $ AMDS SMDSnd MDSSndReceived
|
||||
"snd_read" -> Just $ AMDS SMDSnd MDSSndRead
|
||||
_ -> Nothing
|
||||
|
||||
msgDeliveryStatusT' :: forall d. MsgDirectionI d => Text -> Maybe (MsgDeliveryStatus d)
|
||||
msgDeliveryStatusT' s =
|
||||
msgDeliveryStatusT s >>= \(AMDS d st) ->
|
||||
case testEquality d (msgDirection @d) of
|
||||
Just Refl -> Just st
|
||||
_ -> Nothing
|
||||
@@ -242,11 +242,12 @@ CREATE TABLE contact_requests (
|
||||
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)
|
||||
chat_msg_event TEXT NOT NULL, -- message event tag (the constructor of CMEventTag)
|
||||
msg_body BLOB, -- agent message body as received or sent
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now'))
|
||||
);
|
||||
|
||||
-- TODO ? agent_msg_id could be NOT NULL now that pending_group_messages are separate
|
||||
-- message deliveries communicated with the agent, append only
|
||||
CREATE TABLE msg_deliveries (
|
||||
msg_delivery_id INTEGER PRIMARY KEY,
|
||||
@@ -259,7 +260,7 @@ CREATE TABLE msg_deliveries (
|
||||
);
|
||||
|
||||
-- TODO recovery for received messages with "rcv_agent" status - acknowledge to agent
|
||||
-- changes of messagy delivery status, append only
|
||||
-- changes of message 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
|
||||
|
||||
@@ -0,0 +1,21 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20220122_pending_group_messages where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20220122_pending_group_messages :: Query
|
||||
m20220122_pending_group_messages =
|
||||
[sql|
|
||||
-- pending messages for announced (memberCurrent) but not yet connected (memberActive) group members
|
||||
CREATE TABLE pending_group_messages (
|
||||
pending_group_message_id INTEGER PRIMARY KEY,
|
||||
group_member_id INTEGER NOT NULL REFERENCES group_members ON DELETE CASCADE,
|
||||
message_id INTEGER NOT NULL REFERENCES messages ON DELETE CASCADE,
|
||||
group_member_intro_id INTEGER REFERENCES group_member_intros ON DELETE CASCADE,
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now'))
|
||||
);
|
||||
|
||||
ALTER TABLE messages ADD chat_ts TEXT;
|
||||
|]
|
||||
@@ -21,8 +21,8 @@ import Simplex.Chat
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.View
|
||||
|
||||
foreign export ccall "chat_init_store" cChatInitStore :: CString -> IO (StablePtr ChatStore)
|
||||
|
||||
@@ -76,8 +76,6 @@ mobileChatOpts =
|
||||
|
||||
type CJSONString = CString
|
||||
|
||||
type JSONString = String
|
||||
|
||||
data ChatStore = ChatStore
|
||||
{ dbFilePrefix :: FilePath,
|
||||
chatStore :: SQLiteStore
|
||||
@@ -117,10 +115,18 @@ chatStart ChatStore {dbFilePrefix, chatStore} = do
|
||||
pure cc
|
||||
|
||||
chatSendCmd :: ChatController -> String -> IO JSONString
|
||||
chatSendCmd ChatController {inputQ} s = atomically (writeTBQueue inputQ $ InputCommand s) >> pure "{}"
|
||||
chatSendCmd cc s = crToJSON <$> runReaderT (execChatCommand s) cc
|
||||
|
||||
chatRecvMsg :: ChatController -> IO String
|
||||
chatRecvMsg ChatController {outputQ} = unlines . map unStyle <$> atomically (readTBQueue outputQ)
|
||||
chatRecvMsg ChatController {outputQ} = serializeChatResponse . snd <$> atomically (readTBQueue outputQ)
|
||||
|
||||
jsonObject :: J.Series -> JSONString
|
||||
jsonObject = LB.unpack . JE.encodingToLazyByteString . J.pairs
|
||||
|
||||
crToJSON :: ChatResponse -> JSONString
|
||||
crToJSON = \case
|
||||
CRUserProfile p -> o "profile" $ J.object ["profile" .= p]
|
||||
r -> o "terminal" $ J.object ["response" .= serializeChatResponse r]
|
||||
where
|
||||
o :: String -> J.Value -> JSONString
|
||||
o tp params = jsonObject ("type" .= tp <> "params" .= params)
|
||||
|
||||
@@ -22,9 +22,12 @@ import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import qualified Data.HashMap.Strict as H
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import GHC.Generics
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
|
||||
@@ -111,6 +114,11 @@ instance ToJSON MsgContentType where
|
||||
data MsgContent = MCText Text | MCUnknown
|
||||
deriving (Eq, Show)
|
||||
|
||||
msgContentText :: MsgContent -> Text
|
||||
msgContentText = \case
|
||||
MCText t -> t
|
||||
MCUnknown -> unknownMsgType
|
||||
|
||||
toMsgContentType :: MsgContent -> MsgContentType
|
||||
toMsgContentType = \case
|
||||
MCText _ -> MCText_
|
||||
@@ -161,6 +169,7 @@ data CMEventTag
|
||||
| XInfoProbeCheck_
|
||||
| XInfoProbeOk_
|
||||
| XOk_
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance StrEncoding CMEventTag where
|
||||
strEncode = \case
|
||||
@@ -234,8 +243,15 @@ toCMEventTag = \case
|
||||
XInfoProbeOk _ -> XInfoProbeOk_
|
||||
XOk -> XOk_
|
||||
|
||||
toChatEventTag :: ChatMsgEvent -> Text
|
||||
toChatEventTag = decodeLatin1 . strEncode . toCMEventTag
|
||||
cmEventTagT :: Text -> Maybe CMEventTag
|
||||
cmEventTagT = either (const Nothing) Just . strDecode . encodeUtf8
|
||||
|
||||
serializeCMEventTag :: CMEventTag -> Text
|
||||
serializeCMEventTag = decodeLatin1 . strEncode
|
||||
|
||||
instance FromField CMEventTag where fromField = fromTextField_ cmEventTagT
|
||||
|
||||
instance ToField CMEventTag where toField = toField . serializeCMEventTag
|
||||
|
||||
appToChatMessage :: AppMessage -> Either String ChatMessage
|
||||
appToChatMessage AppMessage {event, params} = do
|
||||
@@ -271,7 +287,7 @@ appToChatMessage AppMessage {event, params} = do
|
||||
chatToAppMessage :: ChatMessage -> AppMessage
|
||||
chatToAppMessage ChatMessage {chatMsgEvent} = AppMessage {event, params}
|
||||
where
|
||||
event = toChatEventTag chatMsgEvent
|
||||
event = serializeCMEventTag . toCMEventTag $ chatMsgEvent
|
||||
o :: [(Text, J.Value)] -> J.Object
|
||||
o = H.fromList
|
||||
params = case chatMsgEvent of
|
||||
|
||||
+75
-28
@@ -95,6 +95,9 @@ module Simplex.Chat.Store
|
||||
createNewMessageAndRcvMsgDelivery,
|
||||
createSndMsgDeliveryEvent,
|
||||
createRcvMsgDeliveryEvent,
|
||||
createPendingGroupMessage,
|
||||
getPendingGroupMessages,
|
||||
deletePendingGroupMessage,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -119,7 +122,9 @@ import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||
import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), SQLError, (:.) (..))
|
||||
import qualified Database.SQLite.Simple as DB
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Migrations.M20220101_initial
|
||||
import Simplex.Chat.Migrations.M20220122_pending_group_messages
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (AParty (..), AgentMsgId, ConnId, InvitationId, MsgMeta (..))
|
||||
@@ -132,7 +137,8 @@ import UnliftIO.STM
|
||||
|
||||
schemaMigrations :: [(String, Query)]
|
||||
schemaMigrations =
|
||||
[ ("20220101_initial", m20220101_initial)
|
||||
[ ("20220101_initial", m20220101_initial),
|
||||
("20220122_pending_group_messages", m20220122_pending_group_messages)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
@@ -303,18 +309,18 @@ getContact :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m Contact
|
||||
getContact st userId localDisplayName =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ getContact_ db userId localDisplayName
|
||||
|
||||
updateUserProfile :: StoreMonad m => SQLiteStore -> User -> Profile -> m User
|
||||
updateUserProfile st u@User {userId, userContactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName}
|
||||
updateUserProfile :: StoreMonad m => SQLiteStore -> User -> Profile -> m ()
|
||||
updateUserProfile st User {userId, userContactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName}
|
||||
| displayName == newName =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
updateContactProfile_ db userId userContactId p' $> (u :: User) {profile = p'}
|
||||
updateContactProfile_ db userId userContactId p'
|
||||
| otherwise =
|
||||
liftIOEither . checkConstraint SEDuplicateName . withTransaction st $ \db -> do
|
||||
DB.execute db "UPDATE users SET local_display_name = ? WHERE user_id = ?" (newName, userId)
|
||||
DB.execute db "INSERT INTO display_names (local_display_name, ldn_base, user_id) VALUES (?, ?, ?)" (newName, newName, userId)
|
||||
updateContactProfile_ db userId userContactId p'
|
||||
updateContact_ db userId userContactId localDisplayName newName
|
||||
pure . Right $ (u :: User) {localDisplayName = newName, profile = p'}
|
||||
pure $ Right ()
|
||||
|
||||
updateContactProfile :: StoreMonad m => SQLiteStore -> UserId -> Contact -> Profile -> m Contact
|
||||
updateContactProfile st userId c@Contact {contactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName}
|
||||
@@ -994,19 +1000,23 @@ getUserGroups st user@User {userId} =
|
||||
groupNames <- map fromOnly <$> DB.query db "SELECT local_display_name FROM groups WHERE user_id = ?" (Only userId)
|
||||
map fst . rights <$> mapM (runExceptT . getGroup_ db user) groupNames
|
||||
|
||||
getUserGroupDetails :: MonadUnliftIO m => SQLiteStore -> UserId -> m [(GroupName, Text, GroupMemberStatus)]
|
||||
getUserGroupDetails :: MonadUnliftIO m => SQLiteStore -> UserId -> m [GroupInfo]
|
||||
getUserGroupDetails st userId =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT g.local_display_name, p.full_name, m.member_status
|
||||
FROM groups g
|
||||
JOIN group_profiles p USING (group_profile_id)
|
||||
JOIN group_members m USING (group_id)
|
||||
WHERE g.user_id = ? AND m.member_category = 'user'
|
||||
|]
|
||||
(Only userId)
|
||||
map groupInfo
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT g.group_id, g.local_display_name, p.display_name, p.full_name, m.member_status
|
||||
FROM groups g
|
||||
JOIN group_profiles p USING (group_profile_id)
|
||||
JOIN group_members m USING (group_id)
|
||||
WHERE g.user_id = ? AND m.member_category = 'user'
|
||||
|]
|
||||
(Only userId)
|
||||
where
|
||||
groupInfo (groupId, localDisplayName, displayName, fullName, userMemberStatus) =
|
||||
GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName, fullName}, userMemberStatus}
|
||||
|
||||
getGroupInvitation :: StoreMonad m => SQLiteStore -> User -> GroupName -> m ReceivedGroupInvitation
|
||||
getGroupInvitation st user localDisplayName =
|
||||
@@ -1139,8 +1149,8 @@ createIntroductions st Group {members} toMember = do
|
||||
introId <- insertedRowId db
|
||||
pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing}
|
||||
|
||||
updateIntroStatus :: MonadUnliftIO m => SQLiteStore -> GroupMemberIntro -> GroupMemberIntroStatus -> m ()
|
||||
updateIntroStatus st GroupMemberIntro {introId} introStatus' =
|
||||
updateIntroStatus :: MonadUnliftIO m => SQLiteStore -> Int64 -> GroupMemberIntroStatus -> m ()
|
||||
updateIntroStatus st introId introStatus =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.executeNamed
|
||||
db
|
||||
@@ -1149,7 +1159,7 @@ updateIntroStatus st GroupMemberIntro {introId} introStatus' =
|
||||
SET intro_status = :intro_status
|
||||
WHERE group_member_intro_id = :intro_id
|
||||
|]
|
||||
[":intro_status" := introStatus', ":intro_id" := introId]
|
||||
[":intro_status" := introStatus, ":intro_id" := introId]
|
||||
|
||||
saveIntroInvitation :: StoreMonad m => SQLiteStore -> GroupMember -> GroupMember -> IntroInvitation -> m GroupMemberIntro
|
||||
saveIntroInvitation st reMember toMember introInv = do
|
||||
@@ -1625,7 +1635,7 @@ getSndFileTransfers_ db userId fileId =
|
||||
Just recipientDisplayName -> Right SndFileTransfer {..}
|
||||
Nothing -> Left $ SESndFileInvalid fileId
|
||||
|
||||
createNewMessage :: MonadUnliftIO m => SQLiteStore -> NewMessage -> m MessageId
|
||||
createNewMessage :: MonadUnliftIO m => SQLiteStore -> NewMessage -> m Message
|
||||
createNewMessage st newMsg =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
createNewMessage_ db newMsg
|
||||
@@ -1636,12 +1646,13 @@ createSndMsgDelivery st sndMsgDelivery messageId =
|
||||
msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId
|
||||
createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent
|
||||
|
||||
createNewMessageAndRcvMsgDelivery :: MonadUnliftIO m => SQLiteStore -> NewMessage -> RcvMsgDelivery -> m ()
|
||||
createNewMessageAndRcvMsgDelivery :: MonadUnliftIO m => SQLiteStore -> NewMessage -> RcvMsgDelivery -> m Message
|
||||
createNewMessageAndRcvMsgDelivery st newMsg rcvMsgDelivery =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
messageId <- createNewMessage_ db newMsg
|
||||
msgDeliveryId <- createRcvMsgDelivery_ db rcvMsgDelivery messageId
|
||||
msg@Message {msgId} <- createNewMessage_ db newMsg
|
||||
msgDeliveryId <- createRcvMsgDelivery_ db rcvMsgDelivery msgId
|
||||
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent
|
||||
pure msg
|
||||
|
||||
createSndMsgDeliveryEvent :: StoreMonad m => SQLiteStore -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> m ()
|
||||
createSndMsgDeliveryEvent st connId agentMsgId sndMsgDeliveryStatus =
|
||||
@@ -1655,17 +1666,18 @@ createRcvMsgDeliveryEvent st connId agentMsgId rcvMsgDeliveryStatus =
|
||||
msgDeliveryId <- ExceptT $ getMsgDeliveryId_ db connId agentMsgId
|
||||
liftIO $ createMsgDeliveryEvent_ db msgDeliveryId rcvMsgDeliveryStatus
|
||||
|
||||
createNewMessage_ :: DB.Connection -> NewMessage -> IO MessageId
|
||||
createNewMessage_ db NewMessage {direction, chatMsgEventType, msgBody} = do
|
||||
createNewMessage_ :: DB.Connection -> NewMessage -> IO Message
|
||||
createNewMessage_ db NewMessage {direction, cmEventTag, chatTs, msgBody} = do
|
||||
createdAt <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO messages
|
||||
(msg_sent, chat_msg_event, msg_body, created_at) VALUES (?,?,?,?);
|
||||
(msg_sent, chat_msg_event, chat_ts, msg_body, created_at) VALUES (?,?,?,?,?);
|
||||
|]
|
||||
(direction, chatMsgEventType, msgBody, createdAt)
|
||||
insertedRowId db
|
||||
(direction, cmEventTag, chatTs, msgBody, createdAt)
|
||||
msgId <- insertedRowId db
|
||||
pure Message {msgId, direction, cmEventTag, chatTs, msgBody, createdAt}
|
||||
|
||||
createSndMsgDelivery_ :: DB.Connection -> SndMsgDelivery -> MessageId -> IO Int64
|
||||
createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId = do
|
||||
@@ -1720,6 +1732,41 @@ getMsgDeliveryId_ db connId agentMsgId =
|
||||
toMsgDeliveryId [Only msgDeliveryId] = Right msgDeliveryId
|
||||
toMsgDeliveryId _ = Left $ SENoMsgDelivery connId agentMsgId
|
||||
|
||||
createPendingGroupMessage :: MonadUnliftIO m => SQLiteStore -> Int64 -> MessageId -> Maybe Int64 -> m ()
|
||||
createPendingGroupMessage st groupMemberId messageId introId_ =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
createdAt <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO pending_group_messages
|
||||
(group_member_id, message_id, group_member_intro_id, created_at) VALUES (?,?,?,?)
|
||||
|]
|
||||
(groupMemberId, messageId, introId_, createdAt)
|
||||
|
||||
getPendingGroupMessages :: MonadUnliftIO m => SQLiteStore -> Int64 -> m [PendingGroupMessage]
|
||||
getPendingGroupMessages st groupMemberId =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
map pendingGroupMessage
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT pgm.message_id, m.chat_msg_event, m.msg_body, pgm.group_member_intro_id
|
||||
FROM pending_group_messages pgm
|
||||
JOIN messages m USING (message_id)
|
||||
WHERE pgm.group_member_id = ?
|
||||
ORDER BY pgm.message_id ASC
|
||||
|]
|
||||
(Only groupMemberId)
|
||||
where
|
||||
pendingGroupMessage (msgId, cmEventTag, msgBody, introId_) =
|
||||
PendingGroupMessage {msgId, cmEventTag, msgBody, introId_}
|
||||
|
||||
deletePendingGroupMessage :: MonadUnliftIO m => SQLiteStore -> Int64 -> MessageId -> m ()
|
||||
deletePendingGroupMessage st groupMemberId messageId =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.execute db "DELETE FROM pending_group_messages WHERE group_member_id = ? AND message_id = ?" (groupMemberId, messageId)
|
||||
|
||||
-- | Saves unique local display name based on passed displayName, suffixed with _N if required.
|
||||
-- This function should be called inside transaction.
|
||||
withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO a) -> IO (Either StoreError a)
|
||||
|
||||
@@ -21,6 +21,7 @@ import Simplex.Chat.Markdown
|
||||
import System.Console.ANSI.Types
|
||||
|
||||
data StyledString = Styled [SGR] String | StyledString :<>: StyledString
|
||||
deriving (Show)
|
||||
|
||||
instance Semigroup StyledString where (<>) = (:<>:)
|
||||
|
||||
|
||||
@@ -1,5 +1,3 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Simplex.Chat.Terminal where
|
||||
|
||||
import Control.Logger.Simple
|
||||
@@ -24,15 +22,15 @@ simplexChat cfg opts t
|
||||
| otherwise = initRun
|
||||
where
|
||||
initRun = do
|
||||
sendNotification <- initializeNotifications
|
||||
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
|
||||
cc <- newChatController st user cfg opts sendNotification'
|
||||
runSimplexChat user ct cc
|
||||
|
||||
runSimplexChat :: User -> ChatTerminal -> ChatController -> IO ()
|
||||
runSimplexChat user ct = runReaderT $ do
|
||||
whenM (asks firstTime) . liftIO . printToTerminal ct $ chatWelcome user
|
||||
raceAny_ [runTerminalInput ct, runTerminalOutput ct, runChatController]
|
||||
raceAny_ [runTerminalInput ct, runTerminalOutput ct, runInputLoop ct, runChatController]
|
||||
|
||||
@@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Chat.Terminal.Input where
|
||||
|
||||
@@ -8,8 +9,10 @@ import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Data.List (dropWhileEnd)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Terminal.Output
|
||||
import Simplex.Chat.View
|
||||
import System.Exit (exitSuccess)
|
||||
import System.Terminal hiding (insertChars)
|
||||
import UnliftIO.STM
|
||||
@@ -21,6 +24,14 @@ getKey =
|
||||
Right (KeyEvent key ms) -> pure (key, ms)
|
||||
_ -> getKey
|
||||
|
||||
runInputLoop :: (MonadUnliftIO m, MonadReader ChatController m) => ChatTerminal -> m ()
|
||||
runInputLoop ct = do
|
||||
q <- asks inputQ
|
||||
forever $ do
|
||||
s <- atomically $ readTBQueue q
|
||||
r <- execChatCommand s
|
||||
liftIO . printToTerminal ct $ responseToView s r
|
||||
|
||||
runTerminalInput :: (MonadUnliftIO m, MonadReader ChatController m) => ChatTerminal -> m ()
|
||||
runTerminalInput ct = do
|
||||
cc <- ask
|
||||
@@ -45,7 +56,7 @@ receiveFromTTY ChatController {inputQ, activeTo} ct@ChatTerminal {termSize, term
|
||||
ts <- readTVar termState
|
||||
let s = inputString ts
|
||||
writeTVar termState $ ts {inputString = "", inputPosition = 0, previousInput = s}
|
||||
writeTBQueue inputQ $ InputCommand s
|
||||
writeTBQueue inputQ s
|
||||
|
||||
updateTermState :: ActiveTo -> Int -> (Key, Modifiers) -> TerminalState -> TerminalState
|
||||
updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p} = case key of
|
||||
|
||||
@@ -12,6 +12,7 @@ import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.View
|
||||
import System.Console.ANSI.Types
|
||||
import System.Terminal
|
||||
import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal)
|
||||
@@ -75,7 +76,7 @@ runTerminalOutput :: (MonadUnliftIO m, MonadReader ChatController m) => ChatTerm
|
||||
runTerminalOutput ct = do
|
||||
ChatController {outputQ} <- ask
|
||||
forever $
|
||||
atomically (readTBQueue outputQ) >>= liftIO . printToTerminal ct
|
||||
atomically (readTBQueue outputQ) >>= liftIO . printToTerminal ct . responseToView "" . snd
|
||||
|
||||
printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
|
||||
printToTerminal ct s =
|
||||
|
||||
+19
-128
@@ -8,7 +8,6 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.Chat.Types where
|
||||
|
||||
@@ -16,15 +15,11 @@ import Data.Aeson (FromJSON, ToJSON, (.:), (.=))
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Types as JT
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Type.Equality
|
||||
import Data.Typeable (Typeable)
|
||||
import Database.SQLite.Simple (ResultError (..), SQLData (..))
|
||||
import Database.SQLite.Simple.FromField (FieldParser, FromField (..), returnError)
|
||||
@@ -32,10 +27,9 @@ import Database.SQLite.Simple.Internal (Field (..))
|
||||
import Database.SQLite.Simple.Ok (Ok (Ok))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import GHC.Generics
|
||||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, MsgMeta (..), serializeMsgIntegrity)
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (MsgBody)
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
|
||||
class IsContact a where
|
||||
@@ -60,7 +54,7 @@ data User = User
|
||||
profile :: Profile,
|
||||
activeUser :: Bool
|
||||
}
|
||||
deriving (Generic, FromJSON)
|
||||
deriving (Show, Generic, FromJSON)
|
||||
|
||||
instance ToJSON User where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
@@ -110,6 +104,14 @@ data Group = Group
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data GroupInfo = GroupInfo
|
||||
{ groupId :: Int64,
|
||||
localDisplayName :: GroupName,
|
||||
groupProfile :: GroupProfile,
|
||||
userMemberStatus :: GroupMemberStatus
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data Profile = Profile
|
||||
{ displayName :: ContactName,
|
||||
fullName :: Text
|
||||
@@ -409,7 +411,7 @@ serializeMemberStatus = \case
|
||||
GSMemCreator -> "creator"
|
||||
|
||||
data SndFileTransfer = SndFileTransfer
|
||||
{ fileId :: Int64,
|
||||
{ fileId :: FileTransferId,
|
||||
fileName :: String,
|
||||
filePath :: String,
|
||||
fileSize :: Integer,
|
||||
@@ -421,6 +423,8 @@ data SndFileTransfer = SndFileTransfer
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type FileTransferId = Int64
|
||||
|
||||
data FileInvitation = FileInvitation
|
||||
{ fileName :: String,
|
||||
fileSize :: Integer,
|
||||
@@ -446,7 +450,7 @@ instance ToJSON FileInvitation where
|
||||
<> "fileConnReq" .= fileConnReq
|
||||
|
||||
data RcvFileTransfer = RcvFileTransfer
|
||||
{ fileId :: Int64,
|
||||
{ fileId :: FileTransferId,
|
||||
fileInvitation :: FileInvitation,
|
||||
fileStatus :: RcvFileStatus,
|
||||
senderDisplayName :: ContactName,
|
||||
@@ -470,6 +474,7 @@ data RcvFileInfo = RcvFileInfo
|
||||
deriving (Eq, Show)
|
||||
|
||||
data FileTransfer = FTSnd [SndFileTransfer] | FTRcv RcvFileTransfer
|
||||
deriving (Show)
|
||||
|
||||
data FileStatus = FSNew | FSAccepted | FSConnected | FSComplete | FSCancelled deriving (Eq, Ord, Show)
|
||||
|
||||
@@ -592,6 +597,7 @@ data GroupMemberIntro = GroupMemberIntro
|
||||
introStatus :: GroupMemberIntroStatus,
|
||||
introInvitation :: Maybe IntroInvitation
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data GroupMemberIntroStatus
|
||||
= GMIntroPending
|
||||
@@ -601,6 +607,7 @@ data GroupMemberIntroStatus
|
||||
| GMIntroReConnected
|
||||
| GMIntroToConnected
|
||||
| GMIntroConnected
|
||||
deriving (Show)
|
||||
|
||||
instance FromField GroupMemberIntroStatus where fromField = fromTextField_ introStatusT
|
||||
|
||||
@@ -627,124 +634,8 @@ serializeIntroStatus = \case
|
||||
GMIntroToConnected -> "to-con"
|
||||
GMIntroConnected -> "con"
|
||||
|
||||
data NewMessage = NewMessage
|
||||
{ direction :: MsgDirection,
|
||||
chatMsgEventType :: Text,
|
||||
msgBody :: MsgBody
|
||||
}
|
||||
|
||||
type MessageId = Int64
|
||||
|
||||
data MsgDirection = MDRcv | MDSnd
|
||||
|
||||
data SMsgDirection (d :: MsgDirection) where
|
||||
SMDRcv :: SMsgDirection 'MDRcv
|
||||
SMDSnd :: SMsgDirection 'MDSnd
|
||||
|
||||
instance TestEquality SMsgDirection where
|
||||
testEquality SMDRcv SMDRcv = Just Refl
|
||||
testEquality SMDSnd SMDSnd = Just Refl
|
||||
testEquality _ _ = Nothing
|
||||
|
||||
class MsgDirectionI (d :: MsgDirection) where
|
||||
msgDirection :: SMsgDirection d
|
||||
|
||||
instance MsgDirectionI 'MDRcv where msgDirection = SMDRcv
|
||||
|
||||
instance MsgDirectionI 'MDSnd where msgDirection = SMDSnd
|
||||
|
||||
instance ToField MsgDirection where toField = toField . msgDirectionInt
|
||||
|
||||
msgDirectionInt :: MsgDirection -> Int
|
||||
msgDirectionInt = \case
|
||||
MDRcv -> 0
|
||||
MDSnd -> 1
|
||||
|
||||
msgDirectionIntP :: Int -> Maybe MsgDirection
|
||||
msgDirectionIntP = \case
|
||||
0 -> Just MDRcv
|
||||
1 -> Just MDSnd
|
||||
_ -> Nothing
|
||||
|
||||
data SndMsgDelivery = SndMsgDelivery
|
||||
{ connId :: Int64,
|
||||
agentMsgId :: AgentMsgId
|
||||
}
|
||||
|
||||
data RcvMsgDelivery = RcvMsgDelivery
|
||||
{ connId :: Int64,
|
||||
agentMsgId :: AgentMsgId,
|
||||
agentMsgMeta :: MsgMeta
|
||||
}
|
||||
|
||||
data MsgMetaJSON = MsgMetaJSON
|
||||
{ integrity :: Text,
|
||||
rcvId :: Int64,
|
||||
rcvTs :: UTCTime,
|
||||
serverId :: Text,
|
||||
serverTs :: UTCTime,
|
||||
sndId :: Int64
|
||||
}
|
||||
deriving (Eq, Show, FromJSON, Generic)
|
||||
|
||||
instance ToJSON MsgMetaJSON where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
msgMetaToJson :: MsgMeta -> MsgMetaJSON
|
||||
msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId, serverTs), sndMsgId = sndId} =
|
||||
MsgMetaJSON
|
||||
{ integrity = (decodeLatin1 . serializeMsgIntegrity) integrity,
|
||||
rcvId,
|
||||
rcvTs,
|
||||
serverId = (decodeLatin1 . B64.encode) serverId,
|
||||
serverTs,
|
||||
sndId
|
||||
}
|
||||
|
||||
msgMetaJson :: MsgMeta -> Text
|
||||
msgMetaJson = decodeLatin1 . LB.toStrict . J.encode . msgMetaToJson
|
||||
|
||||
data MsgDeliveryStatus (d :: MsgDirection) where
|
||||
MDSRcvAgent :: MsgDeliveryStatus 'MDRcv
|
||||
MDSRcvAcknowledged :: MsgDeliveryStatus 'MDRcv
|
||||
MDSSndPending :: MsgDeliveryStatus 'MDSnd
|
||||
MDSSndAgent :: MsgDeliveryStatus 'MDSnd
|
||||
MDSSndSent :: MsgDeliveryStatus 'MDSnd
|
||||
MDSSndReceived :: MsgDeliveryStatus 'MDSnd
|
||||
MDSSndRead :: MsgDeliveryStatus 'MDSnd
|
||||
|
||||
data AMsgDeliveryStatus = forall d. AMDS (SMsgDirection d) (MsgDeliveryStatus d)
|
||||
|
||||
instance (Typeable d, MsgDirectionI d) => FromField (MsgDeliveryStatus d) where
|
||||
fromField = fromTextField_ msgDeliveryStatusT'
|
||||
|
||||
instance ToField (MsgDeliveryStatus d) where toField = toField . serializeMsgDeliveryStatus
|
||||
|
||||
serializeMsgDeliveryStatus :: MsgDeliveryStatus d -> Text
|
||||
serializeMsgDeliveryStatus = \case
|
||||
MDSRcvAgent -> "rcv_agent"
|
||||
MDSRcvAcknowledged -> "rcv_acknowledged"
|
||||
MDSSndPending -> "snd_pending"
|
||||
MDSSndAgent -> "snd_agent"
|
||||
MDSSndSent -> "snd_sent"
|
||||
MDSSndReceived -> "snd_received"
|
||||
MDSSndRead -> "snd_read"
|
||||
|
||||
msgDeliveryStatusT :: Text -> Maybe AMsgDeliveryStatus
|
||||
msgDeliveryStatusT = \case
|
||||
"rcv_agent" -> Just $ AMDS SMDRcv MDSRcvAgent
|
||||
"rcv_acknowledged" -> Just $ AMDS SMDRcv MDSRcvAcknowledged
|
||||
"snd_pending" -> Just $ AMDS SMDSnd MDSSndPending
|
||||
"snd_agent" -> Just $ AMDS SMDSnd MDSSndAgent
|
||||
"snd_sent" -> Just $ AMDS SMDSnd MDSSndSent
|
||||
"snd_received" -> Just $ AMDS SMDSnd MDSSndReceived
|
||||
"snd_read" -> Just $ AMDS SMDSnd MDSSndRead
|
||||
_ -> Nothing
|
||||
|
||||
msgDeliveryStatusT' :: forall d. MsgDirectionI d => Text -> Maybe (MsgDeliveryStatus d)
|
||||
msgDeliveryStatusT' s =
|
||||
msgDeliveryStatusT s >>= \(AMDS d st) ->
|
||||
case testEquality d (msgDirection @d) of
|
||||
Just Refl -> Just st
|
||||
_ -> Nothing
|
||||
|
||||
data Notification = Notification {title :: Text, text :: Text}
|
||||
|
||||
type JSONString = String
|
||||
|
||||
+154
-289
@@ -1,114 +1,125 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.View
|
||||
( 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
|
||||
module Simplex.Chat.View where
|
||||
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Composition ((.:))
|
||||
import Data.Function (on)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (groupBy, intersperse, sort, sortOn)
|
||||
import Data.List (groupBy, intersperse, sortOn)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (DiffTime, UTCTime)
|
||||
import Data.Time.Clock (DiffTime)
|
||||
import Data.Time.Format (defaultTimeLocale, formatTime)
|
||||
import Data.Time.LocalTime (TimeZone, ZonedTime, getCurrentTimeZone, getZonedTime, localDay, localTimeOfDay, timeOfDayToTime, utcToLocalTime, zonedTimeToLocalTime)
|
||||
import Data.Time.LocalTime (ZonedTime (..), localDay, localTimeOfDay, timeOfDayToTime, utcToZonedTime)
|
||||
import Numeric (showFFloat)
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Help
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Store (StoreError (..))
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Util (safeDecodeUtf8)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import System.Console.ANSI.Types
|
||||
|
||||
viewSentConfirmation :: [StyledString]
|
||||
viewSentConfirmation = ["confirmation sent!"]
|
||||
serializeChatResponse :: ChatResponse -> String
|
||||
serializeChatResponse = unlines . map unStyle . responseToView ""
|
||||
|
||||
viewSentInvitation :: [StyledString]
|
||||
viewSentInvitation = ["connection request sent!"]
|
||||
responseToView :: String -> ChatResponse -> [StyledString]
|
||||
responseToView cmd = \case
|
||||
CRSentMessage c mc meta -> viewSentMessage (ttyToContact c) mc meta
|
||||
CRSentGroupMessage g mc meta -> viewSentMessage (ttyToGroup g) mc meta
|
||||
CRSentFileInvitation c fId fPath meta -> viewSentFileInvitation (ttyToContact c) fId fPath meta
|
||||
CRSentGroupFileInvitation g fId fPath meta -> viewSentFileInvitation (ttyToGroup g) fId fPath meta
|
||||
CRReceivedMessage c meta mc mOk -> viewReceivedMessage (ttyFromContact c) meta mc mOk
|
||||
CRReceivedGroupMessage g c meta mc mOk -> viewReceivedMessage (ttyFromGroup g c) meta mc mOk
|
||||
CRReceivedFileInvitation c meta ft mOk -> viewReceivedFileInvitation (ttyFromContact c) meta ft mOk
|
||||
CRReceivedGroupFileInvitation g c meta ft mOk -> viewReceivedFileInvitation (ttyFromGroup g c) meta ft mOk
|
||||
CRCommandAccepted _ -> r []
|
||||
CRChatHelp section -> case section of
|
||||
HSMain -> r chatHelpInfo
|
||||
HSFiles -> r filesHelpInfo
|
||||
HSGroups -> r groupsHelpInfo
|
||||
HSMyAddress -> r myAddressHelpInfo
|
||||
HSMarkdown -> r markdownInfo
|
||||
CRWelcome user -> r $ chatWelcome user
|
||||
CRContactsList cs -> r $ viewContactsList cs
|
||||
CRUserContactLink cReq -> r $ connReqContact_ "Your chat address:" cReq
|
||||
CRContactRequestRejected c -> r [ttyContact c <> ": contact request rejected"]
|
||||
CRGroupCreated g -> r $ viewGroupCreated g
|
||||
CRGroupMembers g -> r $ viewGroupMembers g
|
||||
CRGroupsList gs -> r $ viewGroupsList gs
|
||||
CRSentGroupInvitation g c -> r ["invitation to join the group " <> ttyGroup g <> " sent to " <> ttyContact c]
|
||||
CRFileTransferStatus ftStatus -> r $ viewFileTransferStatus ftStatus
|
||||
CRUserProfile p -> r $ viewUserProfile p
|
||||
CRUserProfileNoChange -> r ["user profile did not change"]
|
||||
CRVersionInfo -> r [plain versionStr, plain updateStr]
|
||||
CRChatCmdError e -> r $ viewChatError e
|
||||
CRInvitation cReq -> r' $ viewConnReqInvitation cReq
|
||||
CRSentConfirmation -> r' ["confirmation sent!"]
|
||||
CRSentInvitation -> r' ["connection request sent!"]
|
||||
CRContactDeleted c -> r' [ttyContact c <> ": contact is deleted"]
|
||||
CRAcceptingContactRequest c -> r' [ttyContact c <> ": accepting contact request..."]
|
||||
CRUserContactLinkCreated cReq -> r' $ connReqContact_ "Your new chat address is created!" cReq
|
||||
CRUserContactLinkDeleted -> r' viewUserContactLinkDeleted
|
||||
CRUserAcceptedGroupSent _gn -> r' [] -- [ttyGroup g <> ": joining the group..."]
|
||||
CRUserDeletedMember g m -> r' [ttyGroup g <> ": you removed " <> ttyMember m <> " from the group"]
|
||||
CRLeftMemberUser g -> r' $ [ttyGroup g <> ": you left the group"] <> groupPreserved g
|
||||
CRGroupDeletedUser g -> r' [ttyGroup g <> ": you deleted the group"]
|
||||
CRRcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath ->
|
||||
r' ["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath]
|
||||
CRRcvFileAcceptedSndCancelled ft -> r' $ viewRcvFileSndCancelled ft
|
||||
CRSndGroupFileCancelled fts -> r' $ viewSndGroupFileCancelled fts
|
||||
CRRcvFileCancelled ft -> r' $ receivingFile_ "cancelled" ft
|
||||
CRUserProfileUpdated p p' -> r' $ viewUserProfileUpdated p p'
|
||||
CRContactUpdated c c' -> viewContactUpdated c c'
|
||||
CRContactsMerged intoCt mergedCt -> viewContactsMerged intoCt mergedCt
|
||||
CRReceivedContactRequest c p -> viewReceivedContactRequest c p
|
||||
CRRcvFileStart ft -> receivingFile_ "started" ft
|
||||
CRRcvFileComplete ft -> receivingFile_ "completed" ft
|
||||
CRRcvFileSndCancelled ft -> viewRcvFileSndCancelled ft
|
||||
CRSndFileStart ft -> sendingFile_ "started" ft
|
||||
CRSndFileComplete ft -> sendingFile_ "completed" ft
|
||||
CRSndFileCancelled ft -> sendingFile_ "cancelled" ft
|
||||
CRSndFileRcvCancelled ft@SndFileTransfer {recipientDisplayName = c} ->
|
||||
[ttyContact c <> " cancelled receiving " <> sndFile ft]
|
||||
CRContactConnected ct -> [ttyFullContact ct <> ": contact is connected"]
|
||||
CRContactAnotherClient c -> [ttyContact c <> ": contact is connected to another client"]
|
||||
CRContactDisconnected c -> [ttyContact c <> ": disconnected from server (messages will be queued)"]
|
||||
CRContactSubscribed c -> [ttyContact c <> ": connected to server"]
|
||||
CRContactSubError c e -> [ttyContact c <> ": contact error " <> sShow e]
|
||||
CRGroupInvitation Group {localDisplayName = ldn, groupProfile = GroupProfile {fullName}} ->
|
||||
[groupInvitation ldn fullName]
|
||||
CRReceivedGroupInvitation g c role -> viewReceivedGroupInvitation g c role
|
||||
CRUserJoinedGroup g -> [ttyGroup g <> ": you joined the group"]
|
||||
CRJoinedGroupMember g m -> [ttyGroup g <> ": " <> ttyMember m <> " joined the group "]
|
||||
CRJoinedGroupMemberConnecting g host m -> [ttyGroup g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"]
|
||||
CRConnectedToGroupMember g m -> [ttyGroup g <> ": " <> connectedMember m <> " is connected"]
|
||||
CRDeletedMemberUser g by -> [ttyGroup g <> ": " <> ttyMember by <> " removed you from the group"] <> groupPreserved g
|
||||
CRDeletedMember g by m -> [ttyGroup g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group"]
|
||||
CRLeftMember g m -> [ttyGroup g <> ": " <> ttyMember m <> " left the group"]
|
||||
CRGroupEmpty g -> [ttyFullGroup g <> ": group is empty"]
|
||||
CRGroupRemoved g -> [ttyFullGroup g <> ": you are no longer a member or group deleted"]
|
||||
CRGroupDeleted gn m -> [ttyGroup gn <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> gn) <> " to delete the local copy of the group"]
|
||||
CRMemberSubError gn c e -> [ttyGroup gn <> " member " <> ttyContact c <> " error: " <> sShow e]
|
||||
CRGroupSubscribed g -> [ttyFullGroup g <> ": connected to server(s)"]
|
||||
CRSndFileSubError SndFileTransfer {fileId, fileName} e ->
|
||||
["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
|
||||
CRRcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e ->
|
||||
["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
|
||||
CRUserContactLinkSubscribed -> ["Your address is active! To show: " <> highlight' "/sa"]
|
||||
CRUserContactLinkSubError e -> ["user address error: " <> sShow e, "to delete your address: " <> highlight' "/da"]
|
||||
CRMessageError prefix err -> [plain prefix <> ": " <> plain err]
|
||||
CRChatError e -> viewChatError e
|
||||
where
|
||||
r = (plain cmd :)
|
||||
-- this function should be `id` in case of asynchronous command responses
|
||||
r' = r
|
||||
|
||||
viewInvalidConnReq :: [StyledString]
|
||||
viewInvalidConnReq =
|
||||
@@ -118,9 +129,6 @@ viewInvalidConnReq =
|
||||
plain updateStr
|
||||
]
|
||||
|
||||
viewUserContactLinkSubscribed :: [StyledString]
|
||||
viewUserContactLinkSubscribed = ["Your address is active! To show: " <> highlight' "/sa"]
|
||||
|
||||
viewConnReqInvitation :: ConnReqInvitation -> [StyledString]
|
||||
viewConnReqInvitation cReq =
|
||||
[ "pass this invitation link to your contact (via another channel): ",
|
||||
@@ -130,49 +138,17 @@ viewConnReqInvitation cReq =
|
||||
"and ask them to connect: " <> highlight' "/c <invitation_link_above>"
|
||||
]
|
||||
|
||||
viewContactDeleted :: ContactName -> [StyledString]
|
||||
viewContactDeleted c = [ttyContact c <> ": contact is deleted"]
|
||||
|
||||
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
|
||||
|
||||
viewContactsList :: [Contact] -> [StyledString]
|
||||
viewContactsList =
|
||||
let ldn = T.toLower . (localDisplayName :: Contact -> ContactName)
|
||||
in map ttyFullContact . sortOn ldn
|
||||
|
||||
viewContactConnected :: Contact -> [StyledString]
|
||||
viewContactConnected ct = [ttyFullContact ct <> ": contact is connected"]
|
||||
|
||||
viewContactDisconnected :: ContactName -> [StyledString]
|
||||
viewContactDisconnected c = [ttyContact c <> ": disconnected from server (messages will be queued)"]
|
||||
|
||||
viewContactAnotherClient :: ContactName -> [StyledString]
|
||||
viewContactAnotherClient c = [ttyContact c <> ": contact is connected to another client"]
|
||||
|
||||
viewContactSubscribed :: ContactName -> [StyledString]
|
||||
viewContactSubscribed c = [ttyContact c <> ": connected to server"]
|
||||
|
||||
viewContactSubError :: ContactName -> ChatError -> [StyledString]
|
||||
viewContactSubError c e = [ttyContact c <> ": contact error " <> sShow e]
|
||||
|
||||
viewUserContactLinkCreated :: ConnReqContact -> [StyledString]
|
||||
viewUserContactLinkCreated = connReqContact_ "Your new chat address is created!"
|
||||
|
||||
viewUserContactLinkDeleted :: [StyledString]
|
||||
viewUserContactLinkDeleted =
|
||||
[ "Your chat address is deleted - accepted contacts will remain connected.",
|
||||
"To create a new chat address use " <> highlight' "/ad"
|
||||
]
|
||||
|
||||
viewUserContactLink :: ConnReqContact -> [StyledString]
|
||||
viewUserContactLink = connReqContact_ "Your chat address:"
|
||||
|
||||
connReqContact_ :: StyledString -> ConnReqContact -> [StyledString]
|
||||
connReqContact_ intro cReq =
|
||||
[ intro,
|
||||
@@ -191,48 +167,12 @@ viewReceivedContactRequest c Profile {fullName} =
|
||||
"to reject: " <> highlight ("/rc " <> c) <> " (the sender will NOT be notified)"
|
||||
]
|
||||
|
||||
viewAcceptingContactRequest :: ContactName -> [StyledString]
|
||||
viewAcceptingContactRequest c = [ttyContact c <> ": accepting contact request..."]
|
||||
|
||||
viewContactRequestRejected :: ContactName -> [StyledString]
|
||||
viewContactRequestRejected c = [ttyContact c <> ": contact request rejected"]
|
||||
|
||||
viewUserContactLinkSubError :: ChatError -> [StyledString]
|
||||
viewUserContactLinkSubError e =
|
||||
[ "user address error: " <> sShow e,
|
||||
"to delete your address: " <> highlight' "/da"
|
||||
]
|
||||
|
||||
viewGroupSubscribed :: Group -> [StyledString]
|
||||
viewGroupSubscribed g = [ttyFullGroup g <> ": connected to server(s)"]
|
||||
|
||||
viewGroupEmpty :: Group -> [StyledString]
|
||||
viewGroupEmpty g = [ttyFullGroup g <> ": group is empty"]
|
||||
|
||||
viewGroupRemoved :: Group -> [StyledString]
|
||||
viewGroupRemoved g = [ttyFullGroup g <> ": you are no longer a member or group deleted"]
|
||||
|
||||
viewMemberSubError :: GroupName -> ContactName -> ChatError -> [StyledString]
|
||||
viewMemberSubError g c e = [ttyGroup g <> " member " <> ttyContact c <> " error: " <> sShow e]
|
||||
|
||||
viewGroupCreated :: Group -> [StyledString]
|
||||
viewGroupCreated g@Group {localDisplayName} =
|
||||
[ "group " <> ttyFullGroup g <> " is created",
|
||||
"use " <> highlight ("/a " <> localDisplayName <> " <name>") <> " to add members"
|
||||
]
|
||||
|
||||
viewGroupDeletedUser :: GroupName -> [StyledString]
|
||||
viewGroupDeletedUser g = groupDeleted_ g Nothing
|
||||
|
||||
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"]
|
||||
|
||||
viewSentGroupInvitation :: GroupName -> ContactName -> [StyledString]
|
||||
viewSentGroupInvitation g c = ["invitation to join the group " <> ttyGroup g <> " sent to " <> ttyContact c]
|
||||
|
||||
viewCannotResendInvitation :: GroupName -> ContactName -> [StyledString]
|
||||
viewCannotResendInvitation g c =
|
||||
[ ttyContact c <> " is already invited to group " <> ttyGroup g,
|
||||
@@ -245,39 +185,9 @@ viewReceivedGroupInvitation g@Group {localDisplayName} c role =
|
||||
"use " <> highlight ("/j " <> localDisplayName) <> " to accept"
|
||||
]
|
||||
|
||||
viewJoinedGroupMember :: GroupName -> GroupMember -> [StyledString]
|
||||
viewJoinedGroupMember g m = [ttyGroup g <> ": " <> ttyMember m <> " joined the group "]
|
||||
|
||||
viewUserJoinedGroup :: GroupName -> [StyledString]
|
||||
viewUserJoinedGroup g = [ttyGroup g <> ": you joined the group"]
|
||||
|
||||
viewJoinedGroupMemberConnecting :: GroupName -> GroupMember -> GroupMember -> [StyledString]
|
||||
viewJoinedGroupMemberConnecting g host m = [ttyGroup g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"]
|
||||
|
||||
viewConnectedToGroupMember :: GroupName -> GroupMember -> [StyledString]
|
||||
viewConnectedToGroupMember g m = [ttyGroup g <> ": " <> connectedMember m <> " is connected"]
|
||||
|
||||
viewDeletedMember :: GroupName -> Maybe GroupMember -> Maybe GroupMember -> [StyledString]
|
||||
viewDeletedMember g by m = [ttyGroup g <> ": " <> memberOrUser by <> " removed " <> memberOrUser m <> " from the group"]
|
||||
|
||||
viewDeletedMemberUser :: GroupName -> GroupMember -> [StyledString]
|
||||
viewDeletedMemberUser g by = viewDeletedMember g (Just by) Nothing <> groupPreserved g
|
||||
|
||||
viewLeftMemberUser :: GroupName -> [StyledString]
|
||||
viewLeftMemberUser g = leftMember_ g Nothing <> groupPreserved g
|
||||
|
||||
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"]
|
||||
|
||||
groupPreserved :: GroupName -> [StyledString]
|
||||
groupPreserved g = ["use " <> highlight ("/d #" <> g) <> " to delete the group"]
|
||||
|
||||
memberOrUser :: Maybe GroupMember -> StyledString
|
||||
memberOrUser = maybe "you" ttyMember
|
||||
|
||||
connectedMember :: GroupMember -> StyledString
|
||||
connectedMember m = case memberCategory m of
|
||||
GCPreMember -> "member " <> ttyFullMember m
|
||||
@@ -304,16 +214,15 @@ viewGroupMembers Group {membership, members} = map groupMember . filter (not . r
|
||||
GSMemCreator -> "created group"
|
||||
_ -> ""
|
||||
|
||||
viewGroupsList :: [(GroupName, Text, GroupMemberStatus)] -> [StyledString]
|
||||
viewGroupsList :: [GroupInfo] -> [StyledString]
|
||||
viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"]
|
||||
viewGroupsList gs = map groupSS $ sort gs
|
||||
viewGroupsList gs = map groupSS $ sortOn ldn_ 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]
|
||||
ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName)
|
||||
groupSS GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, userMemberStatus} =
|
||||
case userMemberStatus of
|
||||
GSMemInvited -> groupInvitation ldn fullName
|
||||
_ -> ttyGroup ldn <> optFullName ldn fullName
|
||||
|
||||
groupInvitation :: GroupName -> Text -> StyledString
|
||||
groupInvitation displayName fullName =
|
||||
@@ -326,7 +235,7 @@ groupInvitation displayName fullName =
|
||||
<> " to delete invitation)"
|
||||
|
||||
viewContactsMerged :: Contact -> Contact -> [StyledString]
|
||||
viewContactsMerged _to@Contact {localDisplayName = c1} _from@Contact {localDisplayName = c2} =
|
||||
viewContactsMerged _into@Contact {localDisplayName = c1} _merged@Contact {localDisplayName = c2} =
|
||||
[ "contact " <> ttyContact c2 <> " is merged into " <> ttyContact c1,
|
||||
"use " <> ttyToContact c1 <> highlight' "<message>" <> " to send messages"
|
||||
]
|
||||
@@ -338,15 +247,13 @@ viewUserProfile Profile {displayName, fullName} =
|
||||
"(the updated profile will be sent to all your contacts)"
|
||||
]
|
||||
|
||||
viewUserProfileUpdated :: User -> User -> [StyledString]
|
||||
viewUserProfileUpdated
|
||||
User {localDisplayName = n, profile = Profile {fullName}}
|
||||
User {localDisplayName = n', profile = Profile {fullName = fullName'}}
|
||||
| n == n' && fullName == fullName' = []
|
||||
| n == n' = ["user full name " <> (if T.null fullName' || fullName' == n' then "removed" else "changed to " <> plain fullName') <> notified]
|
||||
| otherwise = ["user profile is changed to " <> ttyFullName n' fullName' <> notified]
|
||||
where
|
||||
notified = " (your contacts are notified)"
|
||||
viewUserProfileUpdated :: Profile -> Profile -> [StyledString]
|
||||
viewUserProfileUpdated Profile {displayName = n, fullName} Profile {displayName = n', fullName = fullName'}
|
||||
| n == n' && fullName == fullName' = []
|
||||
| n == n' = ["user full name " <> (if T.null fullName' || fullName' == n' then "removed" else "changed to " <> plain fullName') <> notified]
|
||||
| otherwise = ["user profile is changed to " <> ttyFullName n' fullName' <> notified]
|
||||
where
|
||||
notified = " (your contacts are notified)"
|
||||
|
||||
viewContactUpdated :: Contact -> Contact -> [StyledString]
|
||||
viewContactUpdated
|
||||
@@ -361,25 +268,19 @@ viewContactUpdated
|
||||
where
|
||||
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
|
||||
|
||||
viewMessageError :: Text -> Text -> [StyledString]
|
||||
viewMessageError prefix err = [plain prefix <> ": " <> plain err]
|
||||
viewReceivedMessage :: StyledString -> ChatMsgMeta -> MsgContent -> MsgIntegrity -> [StyledString]
|
||||
viewReceivedMessage from meta mc = receivedWithTime_ from meta (ttyMsgContent mc)
|
||||
|
||||
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
|
||||
receivedWithTime_ :: StyledString -> ChatMsgMeta -> [StyledString] -> MsgIntegrity -> [StyledString]
|
||||
receivedWithTime_ from ChatMsgMeta {localChatTs, createdAt} styledMsg mOk = do
|
||||
prependFirst (formattedTime <> " " <> from) styledMsg ++ showIntegrity mOk
|
||||
where
|
||||
formatUTCTime :: TimeZone -> ZonedTime -> StyledString
|
||||
formatUTCTime localTz currentTime =
|
||||
let localTime = utcToLocalTime localTz utcTime
|
||||
formattedTime :: StyledString
|
||||
formattedTime =
|
||||
let localTime = zonedTimeToLocalTime localChatTs
|
||||
tz = zonedTimeZone localChatTs
|
||||
format =
|
||||
if (localDay localTime < localDay (zonedTimeToLocalTime currentTime))
|
||||
if (localDay localTime < localDay (zonedTimeToLocalTime $ utcToZonedTime tz createdAt))
|
||||
&& (timeOfDayToTime (localTimeOfDay localTime) > (6 * 60 * 60 :: DiffTime))
|
||||
then "%m-%d" -- if message is from yesterday or before and 6 hours has passed since midnight
|
||||
else "%H:%M"
|
||||
@@ -396,28 +297,26 @@ viewReceivedMessage_ from utcTime msg mOk = do
|
||||
msgError :: String -> [StyledString]
|
||||
msgError s = [styled (Colored Red) s]
|
||||
|
||||
viewSentMessage :: ContactName -> ByteString -> IO [StyledString]
|
||||
viewSentMessage = viewSentMessage_ . ttyToContact
|
||||
viewSentMessage :: StyledString -> MsgContent -> ChatMsgMeta -> [StyledString]
|
||||
viewSentMessage to = sentWithTime_ . prependFirst to . ttyMsgContent
|
||||
|
||||
viewSentGroupMessage :: GroupName -> ByteString -> IO [StyledString]
|
||||
viewSentGroupMessage = viewSentMessage_ . ttyToGroup
|
||||
viewSentFileInvitation :: StyledString -> FileTransferId -> FilePath -> ChatMsgMeta -> [StyledString]
|
||||
viewSentFileInvitation to fId fPath = sentWithTime_ $ ttySentFile to fId fPath
|
||||
|
||||
viewSentMessage_ :: StyledString -> ByteString -> IO [StyledString]
|
||||
viewSentMessage_ to msg = sentWithTime_ to . msgPlain $ safeDecodeUtf8 msg
|
||||
sentWithTime_ :: [StyledString] -> ChatMsgMeta -> [StyledString]
|
||||
sentWithTime_ styledMsg ChatMsgMeta {localChatTs} =
|
||||
prependFirst (ttyMsgTime localChatTs <> " ") styledMsg
|
||||
|
||||
viewSentFileInvitation :: ContactName -> FilePath -> IO [StyledString]
|
||||
viewSentFileInvitation = viewSentFileInvitation_ . ttyToContact
|
||||
ttyMsgTime :: ZonedTime -> StyledString
|
||||
ttyMsgTime = styleTime . formatTime defaultTimeLocale "%H:%M"
|
||||
|
||||
viewSentGroupFileInvitation :: GroupName -> FilePath -> IO [StyledString]
|
||||
viewSentGroupFileInvitation = viewSentFileInvitation_ . ttyToGroup
|
||||
ttyMsgContent :: MsgContent -> [StyledString]
|
||||
ttyMsgContent = \case
|
||||
MCText t -> msgPlain t
|
||||
MCUnknown -> ["unknown message type"]
|
||||
|
||||
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
|
||||
ttySentFile :: StyledString -> FileTransferId -> FilePath -> [StyledString]
|
||||
ttySentFile to fId fPath = ["/f " <> to <> ttyFilePath fPath, "use " <> highlight ("/fc " <> show fId) <> " to cancel sending"]
|
||||
|
||||
prependFirst :: StyledString -> [StyledString] -> [StyledString]
|
||||
prependFirst s [] = [s]
|
||||
@@ -426,18 +325,9 @@ prependFirst s (s' : ss) = (s <> s') : ss
|
||||
msgPlain :: Text -> [StyledString]
|
||||
msgPlain = map styleMarkdownText . T.lines
|
||||
|
||||
viewSentFileInfo :: Int64 -> [StyledString]
|
||||
viewSentFileInfo fileId =
|
||||
["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"]
|
||||
|
||||
viewSndFileStart :: SndFileTransfer -> [StyledString]
|
||||
viewSndFileStart = sendingFile_ "started"
|
||||
|
||||
viewSndFileComplete :: SndFileTransfer -> [StyledString]
|
||||
viewSndFileComplete = sendingFile_ "completed"
|
||||
|
||||
viewSndFileCancelled :: SndFileTransfer -> [StyledString]
|
||||
viewSndFileCancelled = sendingFile_ "cancelled"
|
||||
viewRcvFileSndCancelled :: RcvFileTransfer -> [StyledString]
|
||||
viewRcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} =
|
||||
[ttyContact c <> " cancelled sending " <> rcvFile ft]
|
||||
|
||||
viewSndGroupFileCancelled :: [SndFileTransfer] -> [StyledString]
|
||||
viewSndGroupFileCancelled fts =
|
||||
@@ -449,18 +339,11 @@ sendingFile_ :: StyledString -> SndFileTransfer -> [StyledString]
|
||||
sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
|
||||
[status <> " sending " <> sndFile ft <> " to " <> ttyContact 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
|
||||
|
||||
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_
|
||||
viewReceivedFileInvitation :: StyledString -> ChatMsgMeta -> RcvFileTransfer -> MsgIntegrity -> [StyledString]
|
||||
viewReceivedFileInvitation from meta ft = receivedWithTime_ from meta (receivedFileInvitation_ ft)
|
||||
|
||||
receivedFileInvitation_ :: RcvFileTransfer -> [StyledString]
|
||||
receivedFileInvitation_ RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName, fileSize}} =
|
||||
@@ -480,27 +363,10 @@ humanReadableSize size
|
||||
mB = kB * 1024
|
||||
gB = mB * 1024
|
||||
|
||||
viewRcvFileAccepted :: RcvFileTransfer -> FilePath -> [StyledString]
|
||||
viewRcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath =
|
||||
["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath]
|
||||
|
||||
viewRcvFileStart :: RcvFileTransfer -> [StyledString]
|
||||
viewRcvFileStart = receivingFile_ "started"
|
||||
|
||||
viewRcvFileComplete :: RcvFileTransfer -> [StyledString]
|
||||
viewRcvFileComplete = receivingFile_ "completed"
|
||||
|
||||
viewRcvFileCancelled :: RcvFileTransfer -> [StyledString]
|
||||
viewRcvFileCancelled = receivingFile_ "cancelled"
|
||||
|
||||
receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString]
|
||||
receivingFile_ status ft@RcvFileTransfer {senderDisplayName = c} =
|
||||
[status <> " receiving " <> rcvFile ft <> " from " <> ttyContact c]
|
||||
|
||||
viewRcvFileSndCancelled :: RcvFileTransfer -> [StyledString]
|
||||
viewRcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} =
|
||||
[ttyContact c <> " cancelled sending " <> rcvFile ft]
|
||||
|
||||
rcvFile :: RcvFileTransfer -> StyledString
|
||||
rcvFile RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} = fileTransfer fileId fileName
|
||||
|
||||
@@ -550,17 +416,11 @@ fileProgress :: [Integer] -> Integer -> Integer -> StyledString
|
||||
fileProgress chunksNum chunkSize fileSize =
|
||||
sShow (sum chunksNum * chunkSize * 100 `div` fileSize) <> "% of " <> humanReadableSize fileSize
|
||||
|
||||
viewSndFileSubError :: SndFileTransfer -> ChatError -> [StyledString]
|
||||
viewSndFileSubError SndFileTransfer {fileId, fileName} e =
|
||||
["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
|
||||
|
||||
viewRcvFileSubError :: RcvFileTransfer -> ChatError -> [StyledString]
|
||||
viewRcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e =
|
||||
["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
|
||||
|
||||
viewChatError :: ChatError -> [StyledString]
|
||||
viewChatError = \case
|
||||
ChatError err -> case err of
|
||||
CEInvalidConnReq -> viewInvalidConnReq
|
||||
CEContactGroups c gNames -> [ttyContact c <> ": contact cannot be deleted, it is a member of the group(s) " <> ttyGroups gNames]
|
||||
CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"]
|
||||
CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"]
|
||||
CEGroupUserRole -> ["you have insufficient permissions for this group command"]
|
||||
@@ -569,6 +429,8 @@ viewChatError = \case
|
||||
CEGroupMemberNotActive -> ["you cannot invite other members yet, try later"]
|
||||
CEGroupMemberUserRemoved -> ["you are no longer a member of the group"]
|
||||
CEGroupMemberNotFound c -> ["contact " <> ttyContact c <> " is not a group member"]
|
||||
CEGroupMemberIntroNotFound c -> ["group member intro not found for " <> ttyContact c]
|
||||
CEGroupCantResendInvitation g c -> viewCannotResendInvitation g c
|
||||
CEGroupInternal s -> ["chat group bug: " <> plain s]
|
||||
CEFileNotFound f -> ["file not found: " <> plain f]
|
||||
CEFileAlreadyReceiving f -> ["file is already accepted: " <> plain f]
|
||||
@@ -579,6 +441,7 @@ viewChatError = \case
|
||||
CEFileRcvChunk e -> ["error receiving file: " <> plain e]
|
||||
CEFileInternal e -> ["file error: " <> plain e]
|
||||
CEAgentVersion -> ["unsupported agent version"]
|
||||
CECommandError e -> ["bad chat command: " <> plain e]
|
||||
-- e -> ["chat error: " <> sShow e]
|
||||
ChatErrorStore err -> case err of
|
||||
SEDuplicateName -> ["this display name is already used by user, contact or group"]
|
||||
@@ -626,6 +489,11 @@ ttyFromContact c = styled (Colored Yellow) $ c <> "> "
|
||||
ttyGroup :: GroupName -> StyledString
|
||||
ttyGroup g = styled (Colored Blue) $ "#" <> g
|
||||
|
||||
ttyGroups :: [GroupName] -> StyledString
|
||||
ttyGroups [] = ""
|
||||
ttyGroups [g] = ttyGroup g
|
||||
ttyGroups (g : gs) = ttyGroup g <> ", " <> ttyGroups gs
|
||||
|
||||
ttyFullGroup :: Group -> StyledString
|
||||
ttyFullGroup Group {localDisplayName, groupProfile = GroupProfile {fullName}} =
|
||||
ttyGroup localDisplayName <> optFullName localDisplayName fullName
|
||||
@@ -652,6 +520,3 @@ highlight' = highlight
|
||||
|
||||
styleTime :: String -> StyledString
|
||||
styleTime = Styled [SetColor Foreground Vivid Black]
|
||||
|
||||
clientVersionInfo :: [StyledString]
|
||||
clientVersionInfo = [plain versionStr, plain updateStr]
|
||||
|
||||
Reference in New Issue
Block a user