dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-05-25 12:04:22 +00:00
Code Issues Packages Projects Releases Wiki Activity

export C interface, started mobile app (#210)

Browse Source 
* initial mobile app design draft

* add proposals

* xcode project

* refactor function to send to view as parameter

* export C interface

* remove unused files

* run chat from chatInit

* split chatStart to a separate function

* replace file-embed with QQ

* add mobile views

* server using IP address

* pass dbFilePrefix as parameter to chatInit

* comment on enabling logging

* fix mobile db config

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

* restore SMP server addresses

* revert the change in the tests

* flip dependency - now Controller depends on Terminal

* make ChatController independent of terminal package

* fix Main.hs

* add iOS .gitignore

* refactor Simplex.Chat.Terminal

Co-authored-by: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
2022-01-21 11:09:33 +00:00
committed by GitHub
parent f47494e5c8
commit 64381be91d
36 changed files with 2211 additions and 777 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+120 -135
View File
@@ -38,15 +38,12 @@ import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word32)
import Simplex.Chat.Controller
import Simplex.Chat.Help
import Simplex.Chat.Input
import Simplex.Chat.Notification
import Simplex.Chat.Options (ChatOpts (..))
import Simplex.Chat.Protocol
import Simplex.Chat.Store
import Simplex.Chat.Styled (plain)
import Simplex.Chat.Terminal
import Simplex.Chat.Styled
import Simplex.Chat.Types
import Simplex.Chat.Util (ifM, unlessM, whenM)
import Simplex.Chat.Util (ifM, unlessM)
import Simplex.Chat.View
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), defaultAgentConfig)
@@ -62,7 +59,6 @@ import System.Exit (exitFailure, exitSuccess)
import System.FilePath (combine, splitExtensions, takeFileName)
import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout)
import Text.Read (readMaybe)
import UnliftIO.Async (race_)
import UnliftIO.Concurrent (forkIO, threadDelay)
import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getFileSize, getHomeDirectory, getTemporaryDirectory)
import qualified UnliftIO.Exception as E
@@ -126,45 +122,29 @@ defaultChatConfig =
logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
simplexChat :: WithTerminal t => ChatConfig -> ChatOpts -> t -> IO ()
simplexChat cfg opts@ChatOpts {logging} t
| logging = do
setLogLevel LogInfo -- LogError
withGlobalLogging logCfg initRun
| otherwise = initRun
where
initRun =
initializeNotifications
>>= newChatController cfg opts t
>>= runSimplexChat
newChatController :: WithTerminal t => ChatConfig -> ChatOpts -> t -> (Notification -> IO ()) -> IO ChatController
newChatController config@ChatConfig {agentConfig = cfg, dbPoolSize, tbqSize} ChatOpts {dbFile, smpServers} t sendNotification = do
let f = chatStoreFile dbFile
newChatController :: SQLiteStore -> User -> ChatConfig -> ChatOpts -> (Notification -> IO ()) -> IO ChatController
newChatController chatStore user config@ChatConfig {agentConfig = cfg, tbqSize} ChatOpts {dbFilePrefix, smpServers} sendNotification = do
let f = chatStoreFile dbFilePrefix
activeTo <- newTVarIO ActiveNone
firstTime <- not <$> doesFileExist f
chatStore <- createStore f dbPoolSize
currentUser <- newTVarIO =<< getCreateActiveUser chatStore
chatTerminal <- newChatTerminal t
smpAgent <- getSMPAgentClient cfg {dbFile = dbFile <> "_agent.db", smpServers}
currentUser <- newTVarIO user
smpAgent <- getSMPAgentClient cfg {dbFile = dbFilePrefix <> "_agent.db", smpServers}
idsDrg <- newTVarIO =<< drgNew
inputQ <- newTBQueueIO tbqSize
outputQ <- newTBQueueIO tbqSize
notifyQ <- newTBQueueIO tbqSize
chatLock <- newTMVarIO ()
sndFiles <- newTVarIO M.empty
rcvFiles <- newTVarIO M.empty
pure ChatController {..}
runSimplexChat :: ChatController -> IO ()
runSimplexChat = runReaderT $ do
user <- readTVarIO =<< asks currentUser
whenM (asks firstTime) . printToView $ chatWelcome user
race_ runTerminalInput runChatController
pure ChatController {activeTo, firstTime, currentUser, smpAgent, chatStore, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, config, sendNotification}
runChatController :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m ()
runChatController =
runChatController = do
q <- asks outputQ
let toView = atomically . writeTBQueue q
raceAny_
[ inputSubscriber,
agentSubscriber,
[ inputSubscriber toView,
agentSubscriber toView,
notificationSubscriber
]
@@ -174,8 +154,8 @@ withLock lock =
(void . atomically $ takeTMVar lock)
(atomically $ putTMVar lock ())
inputSubscriber :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m ()
inputSubscriber = do
inputSubscriber :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => ([StyledString] -> m ()) -> m ()
inputSubscriber toView = do
q <- asks inputQ
l <- asks chatLock
a <- asks smpAgent
@@ -184,34 +164,36 @@ inputSubscriber = do
InputControl _ -> pure ()
InputCommand s ->
case parseAll chatCommandP . B.dropWhileEnd isSpace . encodeUtf8 $ T.pack s of
Left e -> printToView [plain s, "invalid input: " <> plain e]
Left e -> toView [plain s, "invalid input: " <> plain e]
Right cmd -> do
case cmd of
SendMessage c msg -> showSentMessage c msg
SendGroupMessage g msg -> showSentGroupMessage g msg
SendFile c f -> showSentFileInvitation c f
SendGroupFile g f -> showSentGroupFileInvitation g f
_ -> printToView [plain s]
SendMessage c msg -> toView =<< liftIO (viewSentMessage c msg)
SendGroupMessage g msg -> toView =<< liftIO (viewSentGroupMessage g msg)
SendFile c f -> toView =<< liftIO (viewSentFileInvitation c f)
SendGroupFile g f -> toView =<< liftIO (viewSentGroupFileInvitation g f)
_ -> toView [plain s]
user <- readTVarIO =<< asks currentUser
withAgentLock a . withLock l . void . runExceptT $
processChatCommand user cmd `catchError` showChatError
processChatCommand toView' user cmd `catchError` (toView' . viewChatError)
where
toView' = ExceptT . fmap Right . toView
processChatCommand :: forall m. ChatMonad m => User -> ChatCommand -> m ()
processChatCommand user@User {userId, profile} = \case
ChatHelp -> printToView chatHelpInfo
FilesHelp -> printToView filesHelpInfo
GroupsHelp -> printToView groupsHelpInfo
MyAddressHelp -> printToView myAddressHelpInfo
MarkdownHelp -> printToView markdownInfo
Welcome -> printToView $ chatWelcome user
processChatCommand :: forall m. ChatMonad m => ([StyledString] -> m ()) -> User -> ChatCommand -> m ()
processChatCommand toView user@User {userId, profile} = \case
ChatHelp -> toView chatHelpInfo
FilesHelp -> toView filesHelpInfo
GroupsHelp -> toView groupsHelpInfo
MyAddressHelp -> toView myAddressHelpInfo
MarkdownHelp -> toView markdownInfo
Welcome -> toView $ chatWelcome user
AddContact -> do
(connId, cReq) <- withAgent (`createConnection` SCMInvitation)
withStore $ \st -> createDirectConnection st userId connId
showInvitation cReq
Connect (Just (ACR SCMInvitation cReq)) -> connect cReq (XInfo profile) >> showSentConfirmation
Connect (Just (ACR SCMContact cReq)) -> connect cReq (XContact profile Nothing) >> showSentInvitation
Connect Nothing -> showInvalidConnReq
ConnectAdmin -> connect adminContactReq (XContact profile Nothing) >> showSentInvitation
toView $ viewConnReqInvitation cReq
Connect (Just (ACR SCMInvitation cReq)) -> connect cReq (XInfo profile) >> toView viewSentConfirmation
Connect (Just (ACR SCMContact cReq)) -> connect cReq (XContact profile Nothing) >> toView viewSentInvitation
Connect Nothing -> toView viewInvalidConnReq
ConnectAdmin -> connect adminContactReq (XContact profile Nothing) >> toView viewSentInvitation
DeleteContact cName ->
withStore (\st -> getContactGroupNames st userId cName) >>= \case
[] -> do
@@ -220,39 +202,39 @@ processChatCommand user@User {userId, profile} = \case
deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
withStore $ \st -> deleteContact st userId cName
unsetActive $ ActiveC cName
showContactDeleted cName
gs -> showContactGroups cName gs
ListContacts -> withStore (`getUserContacts` user) >>= showContactsList
toView $ viewContactDeleted cName
gs -> toView $ viewContactGroups cName gs
ListContacts -> withStore (`getUserContacts` user) >>= toView . viewContactsList
CreateMyAddress -> do
(connId, cReq) <- withAgent (`createConnection` SCMContact)
withStore $ \st -> createUserContactLink st userId connId cReq
showUserContactLinkCreated cReq
toView $ viewUserContactLinkCreated cReq
DeleteMyAddress -> do
conns <- withStore $ \st -> getUserContactLinkConnections st userId
withAgent $ \a -> forM_ conns $ \Connection {agentConnId} ->
deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
withStore $ \st -> deleteUserContactLink st userId
showUserContactLinkDeleted
toView viewUserContactLinkDeleted
ShowMyAddress -> do
cReq <- withStore $ \st -> getUserContactLink st userId
showUserContactLink cReq
toView $ viewUserContactLink cReq
AcceptContact cName -> do
UserContactRequest {agentInvitationId, profileId} <- withStore $ \st ->
getContactRequest st userId cName
connId <- withAgent $ \a -> acceptContact a agentInvitationId . directMessage $ XInfo profile
withStore $ \st -> createAcceptedContact st userId connId cName profileId
showAcceptingContactRequest cName
toView $ viewAcceptingContactRequest cName
RejectContact cName -> do
UserContactRequest {agentContactConnId, agentInvitationId} <- withStore $ \st ->
getContactRequest st userId cName
`E.finally` deleteContactRequest st userId cName
withAgent $ \a -> rejectContact a agentContactConnId agentInvitationId
showContactRequestRejected cName
toView $ viewContactRequestRejected cName
SendMessage cName msg -> sendMessageCmd cName msg
NewGroup gProfile -> do
gVar <- asks idsDrg
group <- withStore $ \st -> createNewGroup st gVar user gProfile
showGroupCreated group
toView $ viewGroupCreated group
AddMember gName cName memRole -> do
(group, contact) <- withStore $ \st -> (,) <$> getGroup st user gName <*> getContact st userId cName
let Group {groupId, groupProfile, membership, members} = group
@@ -263,7 +245,7 @@ processChatCommand user@User {userId, profile} = \case
let sendInvitation memberId cReq = do
sendDirectMessage (contactConn contact) $
XGrpInv $ GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile
showSentGroupInvitation gName cName
toView $ viewSentGroupInvitation gName cName
setActive $ ActiveG gName
case contactMember contact members of
Nothing -> do
@@ -275,7 +257,7 @@ processChatCommand user@User {userId, profile} = \case
| memberStatus == GSMemInvited ->
withStore (\st -> getMemberInvitation st user groupMemberId) >>= \case
Just cReq -> sendInvitation memberId cReq
Nothing -> showCannotResendInvitation gName cName
Nothing -> toView $ viewCannotResendInvitation gName cName
| otherwise -> chatError (CEGroupDuplicateMember cName)
JoinGroup gName -> do
ReceivedGroupInvitation {fromMember, userMember, connRequest} <- withStore $ \st -> getGroupInvitation st user gName
@@ -295,13 +277,13 @@ processChatCommand user@User {userId, profile} = \case
when (mStatus /= GSMemInvited) . sendGroupMessage members $ XGrpMemDel mId
deleteMemberConnection m
withStore $ \st -> updateGroupMemberStatus st userId m GSMemRemoved
showDeletedMember gName Nothing (Just m)
toView $ viewDeletedMember gName Nothing (Just m)
LeaveGroup gName -> do
Group {membership, members} <- withStore $ \st -> getGroup st user gName
sendGroupMessage members XGrpLeave
mapM_ deleteMemberConnection members
withStore $ \st -> updateGroupMemberStatus st userId membership GSMemLeft
showLeftMemberUser gName
toView $ viewLeftMemberUser gName
DeleteGroup gName -> do
g@Group {membership, members} <- withStore $ \st -> getGroup st user gName
let s = memberStatus membership
@@ -312,11 +294,11 @@ processChatCommand user@User {userId, profile} = \case
when (memberActive membership) $ sendGroupMessage members XGrpDel
mapM_ deleteMemberConnection members
withStore $ \st -> deleteGroup st user g
showGroupDeletedUser gName
toView $ viewGroupDeletedUser gName
ListMembers gName -> do
group <- withStore $ \st -> getGroup st user gName
showGroupMembers group
ListGroups -> withStore (`getUserGroupDetails` userId) >>= showGroupsList
toView $ viewGroupMembers group
ListGroups -> withStore (`getUserGroupDetails` userId) >>= toView . viewGroupsList
SendGroupMessage gName msg -> do
-- TODO save pending message delivery for members without connections
Group {members, membership} <- withStore $ \st -> getGroup st user gName
@@ -332,7 +314,7 @@ processChatCommand user@User {userId, profile} = \case
SndFileTransfer {fileId} <- withStore $ \st ->
createSndFileTransfer st userId contact f fileInv agentConnId chSize
sendDirectMessage (contactConn contact) $ XFile fileInv
showSentFileInfo fileId
toView $ viewSentFileInfo fileId
setActive $ ActiveC cName
SendGroupFile gName f -> do
(fileSize, chSize) <- checkSndFile f
@@ -346,7 +328,7 @@ processChatCommand user@User {userId, profile} = \case
-- TODO sendGroupMessage - same file invitation to all
forM_ ms $ \(m, _, fileInv) ->
traverse (`sendDirectMessage` XFile fileInv) $ memberConn m
showSentFileInfo fileId
toView $ viewSentFileInfo fileId
setActive $ ActiveG gName
ReceiveFile fileId filePath_ -> do
ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileConnReq}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId
@@ -355,29 +337,29 @@ processChatCommand user@User {userId, profile} = \case
Right agentConnId -> do
filePath <- getRcvFilePath fileId filePath_ fileName
withStore $ \st -> acceptRcvFileTransfer st userId fileId agentConnId filePath
showRcvFileAccepted ft filePath
Left (ChatErrorAgent (SMP SMP.AUTH)) -> showRcvFileSndCancelled ft
Left (ChatErrorAgent (CONN DUPLICATE)) -> showRcvFileSndCancelled ft
toView $ viewRcvFileAccepted ft filePath
Left (ChatErrorAgent (SMP SMP.AUTH)) -> toView $ viewRcvFileSndCancelled ft
Left (ChatErrorAgent (CONN DUPLICATE)) -> toView $ viewRcvFileSndCancelled ft
Left e -> throwError e
CancelFile fileId ->
withStore (\st -> getFileTransfer st userId fileId) >>= \case
FTSnd fts -> do
forM_ fts $ \ft -> cancelSndFileTransfer ft
showSndGroupFileCancelled fts
toView $ viewSndGroupFileCancelled fts
FTRcv ft -> do
cancelRcvFileTransfer ft
showRcvFileCancelled ft
toView $ viewRcvFileCancelled ft
FileStatus fileId ->
withStore (\st -> getFileTransferProgress st userId fileId) >>= showFileTransferStatus
withStore (\st -> getFileTransferProgress st userId fileId) >>= toView . viewFileTransferStatus
UpdateProfile p -> unless (p == profile) $ do
user' <- withStore $ \st -> updateUserProfile st user p
asks currentUser >>= atomically . (`writeTVar` user')
contacts <- withStore (`getUserContacts` user)
forM_ contacts $ \ct -> sendDirectMessage (contactConn ct) $ XInfo p
showUserProfileUpdated user user'
ShowProfile -> showUserProfile profile
toView $ viewUserProfileUpdated user user'
ShowProfile -> toView $ viewUserProfile profile
QuitChat -> liftIO exitSuccess
ShowVersion -> printToView clientVersionInfo
ShowVersion -> toView clientVersionInfo
where
connect :: ConnectionRequestUri c -> ChatMsgEvent -> m ()
connect cReq msg = do
@@ -429,19 +411,21 @@ processChatCommand user@User {userId, profile} = \case
f = filePath `combine` (name <> suffix <> ext)
in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f)
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m ()
agentSubscriber = do
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => ([StyledString] -> m ()) -> m ()
agentSubscriber toView = do
q <- asks $ subQ . smpAgent
l <- asks chatLock
subscribeUserConnections
subscribeUserConnections toView
forever $ do
(_, connId, msg) <- atomically $ readTBQueue q
user <- readTVarIO =<< asks currentUser
withLock l . void . runExceptT $
processAgentMessage user connId msg `catchError` showChatError
processAgentMessage toView' user connId msg `catchError` (toView' . viewChatError)
where
toView' = ExceptT . fmap Right . toView
subscribeUserConnections :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m ()
subscribeUserConnections = void . runExceptT $ do
subscribeUserConnections :: forall m. (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => ([StyledString] -> m ()) -> m ()
subscribeUserConnections toView = void . runExceptT $ do
user <- readTVarIO =<< asks currentUser
subscribeContacts user
subscribeGroups user
@@ -449,39 +433,40 @@ subscribeUserConnections = void . runExceptT $ do
subscribePendingConnections user
subscribeUserContactLink user
where
toView' = ExceptT . fmap Right . toView
subscribeContacts user = do
contacts <- withStore (`getUserContacts` user)
forM_ contacts $ \ct@Contact {localDisplayName = c} ->
(subscribe (contactConnId ct) >> showContactSubscribed c) `catchError` showContactSubError c
(subscribe (contactConnId ct) >> toView' (viewContactSubscribed c)) `catchError` (toView' . viewContactSubError c)
subscribeGroups user = do
groups <- withStore (`getUserGroups` user)
forM_ groups $ \g@Group {members, membership, localDisplayName = gn} -> do
let connectedMembers = mapMaybe (\m -> (m,) <$> memberConnId m) members
if memberStatus membership == GSMemInvited
then showGroupInvitation g
then toView' $ viewGroupInvitation g
else
if null connectedMembers
then
if memberActive membership
then showGroupEmpty g
else showGroupRemoved g
then toView' $ viewGroupEmpty g
else toView' $ viewGroupRemoved g
else do
forM_ connectedMembers $ \(GroupMember {localDisplayName = c}, cId) ->
subscribe cId `catchError` showMemberSubError gn c
showGroupSubscribed g
subscribe cId `catchError` (toView' . viewMemberSubError gn c)
toView' $ viewGroupSubscribed g
subscribeFiles user = do
withStore (`getLiveSndFileTransfers` user) >>= mapM_ subscribeSndFile
withStore (`getLiveRcvFileTransfers` user) >>= mapM_ subscribeRcvFile
where
subscribeSndFile ft@SndFileTransfer {fileId, fileStatus, agentConnId} = do
subscribe agentConnId `catchError` showSndFileSubError ft
subscribe agentConnId `catchError` (toView' . viewSndFileSubError ft)
void . forkIO $ do
threadDelay 1000000
l <- asks chatLock
a <- asks smpAgent
unless (fileStatus == FSNew) . unlessM (isFileActive fileId sndFiles) $
withAgentLock a . withLock l $
sendFileChunk ft
sendFileChunk toView' ft
subscribeRcvFile ft@RcvFileTransfer {fileStatus} =
case fileStatus of
RFSAccepted fInfo -> resume fInfo
@@ -489,22 +474,22 @@ subscribeUserConnections = void . runExceptT $ do
_ -> pure ()
where
resume RcvFileInfo {agentConnId} =
subscribe agentConnId `catchError` showRcvFileSubError ft
subscribe agentConnId `catchError` (toView' . viewRcvFileSubError ft)
subscribePendingConnections user = do
cs <- withStore (`getPendingConnections` user)
subscribeConns cs `catchError` \_ -> pure ()
subscribeUserContactLink User {userId} = do
cs <- withStore (`getUserContactLinkConnections` userId)
(subscribeConns cs >> showUserContactLinkSubscribed)
`catchError` showUserContactLinkSubError
(subscribeConns cs >> toView' viewUserContactLinkSubscribed)
`catchError` (toView' . viewUserContactLinkSubError)
subscribe cId = withAgent (`subscribeConnection` cId)
subscribeConns conns =
withAgent $ \a ->
forM_ conns $ \Connection {agentConnId} ->
subscribeConnection a agentConnId
processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agent -> m ()
processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
processAgentMessage :: forall m. ChatMonad m => ([StyledString] -> m ()) -> User -> ConnId -> ACommand 'Agent -> m ()
processAgentMessage toView user@User {userId, profile} agentConnId agentMessage = do
chatDirection <- withStore $ \st -> getConnectionChatDirection st user agentConnId
forM_ (agentMsgConnStatus agentMessage) $ \status ->
withStore $ \st -> updateConnectionStatus st (fromConnection chatDirection) status
@@ -594,7 +579,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
CON ->
withStore (\st -> getViaGroupMember st user ct) >>= \case
Nothing -> do
showContactConnected ct
toView $ viewContactConnected ct
setActive $ ActiveC c
showToast (c <> "> ") "connected"
Just (gName, m) ->
@@ -604,14 +589,14 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
SENT msgId ->
sentMsgDeliveryEvent conn msgId
END -> do
showContactAnotherClient c
toView $ viewContactAnotherClient c
showToast (c <> "> ") "connected to another client"
unsetActive $ ActiveC c
DOWN -> do
showContactDisconnected c
toView $ viewContactDisconnected c
showToast (c <> "> ") "disconnected"
UP -> do
showContactSubscribed c
toView $ viewContactSubscribed c
showToast (c <> "> ") "is active"
setActive $ ActiveC c
-- TODO print errors
@@ -662,11 +647,11 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
-- TODO forward any pending (GMIntroInvReceived) introductions
case memberCategory m of
GCHostMember -> do
showUserJoinedGroup gName
toView $ viewUserJoinedGroup gName
setActive $ ActiveG gName
showToast ("#" <> gName) "you are connected to group"
GCInviteeMember -> do
showJoinedGroupMember gName m
toView $ viewJoinedGroupMember gName m
setActive $ ActiveG gName
showToast ("#" <> gName) $ "member " <> localDisplayName (m :: GroupMember) <> " is connected"
intros <- withStore $ \st -> createIntroductions st group m
@@ -723,15 +708,15 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
_ -> messageError "CONF from file connection must have x.file.acpt"
CON -> do
withStore $ \st -> updateSndFileStatus st ft FSConnected
showSndFileStart ft
sendFileChunk ft
toView $ viewSndFileStart ft
sendFileChunk toView ft
SENT msgId -> do
withStore $ \st -> updateSndFileChunkSent st ft msgId
unless (fileStatus == FSCancelled) $ sendFileChunk ft
unless (fileStatus == FSCancelled) $ sendFileChunk toView ft
MERR _ err -> do
cancelSndFileTransfer ft
case err of
SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ showSndFileRcvCancelled ft
SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ toView $ viewSndFileRcvCancelled ft
_ -> chatError $ CEFileSend fileId err
MSG meta _ ->
withAckMessage agentConnId meta $ pure ()
@@ -745,12 +730,12 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
case agentMsg of
CON -> do
withStore $ \st -> updateRcvFileStatus st ft FSConnected
showRcvFileStart ft
toView $ viewRcvFileStart ft
MSG meta@MsgMeta {recipient = (msgId, _), integrity} msgBody -> withAckMessage agentConnId meta $ do
parseFileChunk msgBody >>= \case
FileChunkCancel -> do
cancelRcvFileTransfer ft
showRcvFileSndCancelled ft
toView $ viewRcvFileSndCancelled ft
FileChunk {chunkNo, chunkBytes = chunk} -> do
case integrity of
MsgOk -> pure ()
@@ -770,7 +755,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
withStore $ \st -> do
updateRcvFileStatus st ft FSComplete
deleteRcvFileChunks st ft
showRcvFileComplete ft
toView $ viewRcvFileComplete ft
closeFileHandle fileId rcvFiles
withAgent (`deleteConnection` agentConnId)
RcvChunkDuplicate -> pure ()
@@ -799,7 +784,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
profileContactRequest :: InvitationId -> Profile -> m ()
profileContactRequest invId p = do
cName <- withStore $ \st -> createContactRequest st userId userContactLinkId invId p
showReceivedContactRequest cName p
toView $ viewReceivedContactRequest cName p
showToast (cName <> "> ") "wants to connect to you"
withAckMessage :: ConnId -> MsgMeta -> m () -> m ()
@@ -824,7 +809,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
notifyMemberConnected :: GroupName -> GroupMember -> m ()
notifyMemberConnected gName m@GroupMember {localDisplayName} = do
showConnectedToGroupMember gName m
toView $ viewConnectedToGroupMember gName m
setActive $ ActiveG gName
showToast ("#" <> gName) $ "member " <> localDisplayName <> " is connected"
@@ -842,20 +827,20 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
withStore $ \st -> createSentProbeHash st userId probeId c
messageWarning :: Text -> m ()
messageWarning = showMessageError "warning"
messageWarning = toView . viewMessageError "warning"
messageError :: Text -> m ()
messageError = showMessageError "error"
messageError = toView . viewMessageError "error"
newTextMessage :: ContactName -> MsgMeta -> Text -> m ()
newTextMessage c meta text = do
showReceivedMessage c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta))
toView =<< liftIO (viewReceivedMessage c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta)))
showToast (c <> "> ") text
setActive $ ActiveC c
newGroupTextMessage :: GroupName -> GroupMember -> MsgMeta -> Text -> m ()
newGroupTextMessage gName GroupMember {localDisplayName = c} meta text = do
showReceivedGroupMessage gName c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta))
toView =<< liftIO (viewReceivedGroupMessage gName c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta)))
showToast ("#" <> gName <> " " <> c <> "> ") text
setActive $ ActiveG gName
@@ -864,7 +849,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
-- TODO chunk size has to be sent as part of invitation
chSize <- asks $ fileChunkSize . config
ft <- withStore $ \st -> createRcvFileTransfer st userId contact fInv chSize
showReceivedMessage c (snd $ broker meta) (receivedFileInvitation ft) (integrity (meta :: MsgMeta))
toView =<< liftIO (viewReceivedFileInvitation c (snd $ broker meta) ft (integrity (meta :: MsgMeta)))
showToast (c <> "> ") "wants to send a file"
setActive $ ActiveC c
@@ -872,7 +857,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
processGroupFileInvitation gName m@GroupMember {localDisplayName = c} meta fInv = do
chSize <- asks $ fileChunkSize . config
ft <- withStore $ \st -> createRcvGroupFileTransfer st userId m fInv chSize
showReceivedGroupMessage gName c (snd $ broker meta) (receivedFileInvitation ft) (integrity (meta :: MsgMeta))
toView =<< liftIO (viewReceivedGroupFileInvitation gName c (snd $ broker meta) ft (integrity (meta :: MsgMeta)))
showToast ("#" <> gName <> " " <> c <> "> ") "wants to send a file"
setActive $ ActiveG gName
@@ -881,13 +866,13 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
when (fromRole < GRAdmin || fromRole < memRole) $ chatError (CEGroupContactRole c)
when (fromMemId == memId) $ chatError CEGroupDuplicateMemberId
group@Group {localDisplayName = gName} <- withStore $ \st -> createGroupInvitation st user ct inv
showReceivedGroupInvitation group c memRole
toView $ viewReceivedGroupInvitation group c memRole
showToast ("#" <> gName <> " " <> c <> "> ") $ "invited you to join the group"
xInfo :: Contact -> Profile -> m ()
xInfo c@Contact {profile = p} p' = unless (p == p') $ do
c' <- withStore $ \st -> updateContactProfile st userId c p'
showContactUpdated c c'
toView $ viewContactUpdated c c'
xInfoProbe :: Contact -> Probe -> m ()
xInfoProbe c2 probe = do
@@ -913,7 +898,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
mergeContacts :: Contact -> Contact -> m ()
mergeContacts to from = do
withStore $ \st -> mergeContactRecords st userId to from
showContactsMerged to from
toView $ viewContactsMerged to from
saveConnInfo :: Connection -> ConnInfo -> m ()
saveConnInfo activeConn connInfo = do
@@ -932,7 +917,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
then messageError "x.grp.mem.new error: member already exists"
else do
newMember <- withStore $ \st -> createNewGroupMember st user group memInfo GCPostMember GSMemAnnounced
showJoinedGroupMemberConnecting gName m newMember
toView $ viewJoinedGroupMemberConnecting gName m newMember
xGrpMemIntro :: Connection -> GroupName -> GroupMember -> MemberInfo -> m ()
xGrpMemIntro conn gName m memInfo@(MemberInfo memId _ _) =
@@ -989,7 +974,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
then do
mapM_ deleteMemberConnection members
withStore $ \st -> updateGroupMemberStatus st userId membership GSMemRemoved
showDeletedMemberUser gName m
toView $ viewDeletedMemberUser gName m
else case find (sameMemberId memId) members of
Nothing -> messageError "x.grp.mem.del with unknown member ID"
Just member -> do
@@ -999,7 +984,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
else do
deleteMemberConnection member
withStore $ \st -> updateGroupMemberStatus st userId member GSMemRemoved
showDeletedMember gName (Just m) (Just member)
toView $ viewDeletedMember gName (Just m) (Just member)
sameMemberId :: MemberId -> GroupMember -> Bool
sameMemberId memId GroupMember {memberId} = memId == memberId
@@ -1008,7 +993,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
xGrpLeave gName m = do
deleteMemberConnection m
withStore $ \st -> updateGroupMemberStatus st userId m GSMemLeft
showLeftMember gName m
toView $ viewLeftMember gName m
xGrpDel :: GroupName -> GroupMember -> m ()
xGrpDel gName m@GroupMember {memberRole} = do
@@ -1018,13 +1003,13 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
updateGroupMemberStatus st userId membership GSMemGroupDeleted
pure members
mapM_ deleteMemberConnection ms
showGroupDeleted gName m
toView $ viewGroupDeleted gName m
parseChatMessage :: ByteString -> Either ChatError ChatMessage
parseChatMessage = first ChatErrorMessage . strDecode
sendFileChunk :: ChatMonad m => SndFileTransfer -> m ()
sendFileChunk ft@SndFileTransfer {fileId, fileStatus, agentConnId} =
sendFileChunk :: ChatMonad m => ([StyledString] -> m ()) -> SndFileTransfer -> m ()
sendFileChunk toView ft@SndFileTransfer {fileId, fileStatus, agentConnId} =
unless (fileStatus == FSComplete || fileStatus == FSCancelled) $
withStore (`createSndFileChunk` ft) >>= \case
Just chunkNo -> sendFileChunkNo ft chunkNo
@@ -1032,7 +1017,7 @@ sendFileChunk ft@SndFileTransfer {fileId, fileStatus, agentConnId} =
withStore $ \st -> do
updateSndFileStatus st ft FSComplete
deleteSndFileChunks st ft
showSndFileComplete ft
toView $ viewSndFileComplete ft
closeFileHandle fileId sndFiles
withAgent (`deleteConnection` agentConnId)
src/Simplex/Chat/Controller.hs
+9 -5
View File
@@ -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'
src/Simplex/Chat/Migrations/M20220101_initial.hs
+270
View File
@@ -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)
);
|]
src/Simplex/Chat/Mobile.hs
+126
View File
@@ -0,0 +1,126 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.Mobile where
import Control.Concurrent (forkIO)
import Control.Concurrent.STM
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson ((.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.List (find)
import Foreign.C.String
import Foreign.StablePtr
import Simplex.Chat
import Simplex.Chat.Controller
import Simplex.Chat.Options
import Simplex.Chat.Store
import Simplex.Chat.Styled
import Simplex.Chat.Types
foreign export ccall "chat_init_store" cChatInitStore :: CString -> IO (StablePtr ChatStore)
foreign export ccall "chat_get_user" cChatGetUser :: StablePtr ChatStore -> IO CJSONString
foreign export ccall "chat_create_user" cChatCreateUser :: StablePtr ChatStore -> CJSONString -> IO CJSONString
foreign export ccall "chat_start" cChatStart :: StablePtr ChatStore -> IO (StablePtr ChatController)
foreign export ccall "chat_send_cmd" cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString
foreign export ccall "chat_recv_msg" cChatRecvMsg :: StablePtr ChatController -> IO CString
-- | creates or connects to chat store
cChatInitStore :: CString -> IO (StablePtr ChatStore)
cChatInitStore fp = peekCString fp >>= chatInitStore >>= newStablePtr
-- | returns JSON in the form `{"user": <user object>}` or `{}` in case there is no active user (to show dialog to enter displayName/fullName)
cChatGetUser :: StablePtr ChatStore -> IO CJSONString
cChatGetUser cc = deRefStablePtr cc >>= chatGetUser >>= newCString
-- | accepts Profile JSON, returns JSON `{"user": <user object>}` or `{"error": "<error>"}`
cChatCreateUser :: StablePtr ChatStore -> CJSONString -> IO CJSONString
cChatCreateUser cPtr profileCJson = do
c <- deRefStablePtr cPtr
p <- peekCString profileCJson
newCString =<< chatCreateUser c p
-- | this function starts chat - it cannot be started during initialization right now, as it cannot work without user (to be fixed later)
cChatStart :: StablePtr ChatStore -> IO (StablePtr ChatController)
cChatStart st = deRefStablePtr st >>= chatStart >>= newStablePtr
-- | send command to chat (same syntax as in terminal for now)
cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString
cChatSendCmd cPtr cCmd = do
c <- deRefStablePtr cPtr
cmd <- peekCString cCmd
newCString =<< chatSendCmd c cmd
-- | receive message from chat (blocking)
cChatRecvMsg :: StablePtr ChatController -> IO CString
cChatRecvMsg cc = deRefStablePtr cc >>= chatRecvMsg >>= newCString
mobileChatOpts :: ChatOpts
mobileChatOpts =
ChatOpts
{ dbFilePrefix = "simplex_v1", -- two database files will be created: simplex_v1_chat.db and simplex_v1_agent.db
smpServers = defaultSMPServers,
logging = False
}
type CJSONString = CString
type JSONString = String
data ChatStore = ChatStore
{ dbFilePrefix :: FilePath,
chatStore :: SQLiteStore
}
chatInitStore :: String -> IO ChatStore
chatInitStore dbFilePrefix = do
let f = chatStoreFile dbFilePrefix
chatStore <- createStore f $ dbPoolSize defaultChatConfig
pure ChatStore {dbFilePrefix, chatStore}
getActiveUser_ :: SQLiteStore -> IO (Maybe User)
getActiveUser_ st = find activeUser <$> getUsers st
-- | returns JSON in the form `{"user": <user object>}` or `{}`
chatGetUser :: ChatStore -> IO JSONString
chatGetUser ChatStore {chatStore} =
maybe "{}" (jsonObject . ("user" .=)) <$> getActiveUser_ chatStore
-- | returns JSON in the form `{"user": <user object>}` or `{"error": "<error>"}`
chatCreateUser :: ChatStore -> JSONString -> IO JSONString
chatCreateUser ChatStore {chatStore} profileJson =
case J.eitherDecodeStrict' $ B.pack profileJson of
Left e -> err e
Right p ->
runExceptT (createUser chatStore p True) >>= \case
Right user -> pure . jsonObject $ "user" .= user
Left e -> err e
where
err e = pure . jsonObject $ "error" .= show e
chatStart :: ChatStore -> IO ChatController
chatStart ChatStore {dbFilePrefix, chatStore} = do
Just user <- getActiveUser_ chatStore
cc <- newChatController chatStore user defaultChatConfig mobileChatOpts {dbFilePrefix} . const $ pure ()
void . forkIO $ runReaderT runChatController cc
pure cc
chatSendCmd :: ChatController -> String -> IO JSONString
chatSendCmd ChatController {inputQ} s = atomically (writeTBQueue inputQ $ InputCommand s) >> pure "{}"
chatRecvMsg :: ChatController -> IO String
chatRecvMsg ChatController {outputQ} = unlines . map unStyle <$> atomically (readTBQueue outputQ)
jsonObject :: J.Series -> JSONString
jsonObject = LB.unpack . JE.encodingToLazyByteString . J.pairs
src/Simplex/Chat/Options.hs
+17 -9
View File
@@ -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"
src/Simplex/Chat/Store.hs
+10 -9
View File
@@ -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
src/Simplex/Chat/Styled.hs
+5
View File
@@ -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
src/Simplex/Chat/Terminal.hs
+31 -169
View File
@@ -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]
src/Simplex/Chat/Input.hs → src/Simplex/Chat/Terminal/Input.hs
+8 -8
View File
@@ -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 ()
src/Simplex/Chat/Notification.hs → src/Simplex/Chat/Terminal/Notification.hs
+2 -3
View File
@@ -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
src/Simplex/Chat/Terminal/Output.hs
+179
View File
@@ -0,0 +1,179 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Chat.Terminal.Output where
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Simplex.Chat.Controller
import Simplex.Chat.Styled
import System.Console.ANSI.Types
import System.Terminal
import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal)
import UnliftIO.STM
data ChatTerminal = ChatTerminal
{ termDevice :: TerminalDevice,
termState :: TVar TerminalState,
termSize :: Size,
nextMessageRow :: TVar Int,
termLock :: TMVar ()
}
data TerminalState = TerminalState
{ inputPrompt :: String,
inputString :: String,
inputPosition :: Int,
previousInput :: String
}
class Terminal t => WithTerminal t where
withTerm :: (MonadIO m, MonadMask m) => t -> (t -> m a) -> m a
data TerminalDevice = forall t. WithTerminal t => TerminalDevice t
instance WithTerminal LocalTerminal where
withTerm _ = withTerminal
instance WithTerminal VirtualTerminal where
withTerm t = ($ t)
withChatTerm :: (MonadIO m, MonadMask m) => ChatTerminal -> (forall t. WithTerminal t => TerminalT t m a) -> m a
withChatTerm ChatTerminal {termDevice = TerminalDevice t} action = withTerm t $ runTerminalT action
newChatTerminal :: WithTerminal t => t -> IO ChatTerminal
newChatTerminal t = do
termSize <- withTerm t . runTerminalT $ getWindowSize
let lastRow = height termSize - 1
termState <- newTVarIO mkTermState
termLock <- newTMVarIO ()
nextMessageRow <- newTVarIO lastRow
-- threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
return ChatTerminal {termDevice = TerminalDevice t, termState, termSize, nextMessageRow, termLock}
mkTermState :: TerminalState
mkTermState =
TerminalState
{ inputString = "",
inputPosition = 0,
inputPrompt = "> ",
previousInput = ""
}
withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m ()
withTermLock ChatTerminal {termLock} action = do
_ <- atomically $ takeTMVar termLock
action
atomically $ putTMVar termLock ()
runTerminalOutput :: (MonadUnliftIO m, MonadReader ChatController m) => ChatTerminal -> m ()
runTerminalOutput ct = do
ChatController {outputQ} <- ask
forever $
atomically (readTBQueue outputQ) >>= liftIO . printToTerminal ct
printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
printToTerminal ct s =
withChatTerm ct $
withTermLock ct $ do
printMessage ct s
updateInput ct
updateInput :: forall m. MonadTerminal m => ChatTerminal -> m ()
updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessageRow} = do
hideCursor
ts <- readTVarIO termState
nmr <- readTVarIO nextMessageRow
let ih = inputHeight ts
iStart = height - ih
prompt = inputPrompt ts
Position {row, col} = positionRowColumn width $ length prompt + inputPosition ts
if nmr >= iStart
then atomically $ writeTVar nextMessageRow iStart
else clearLines nmr iStart
setCursorPosition $ Position {row = max nmr iStart, col = 0}
putString $ prompt <> inputString ts <> " "
eraseInLine EraseForward
setCursorPosition $ Position {row = iStart + row, col}
showCursor
flush
where
clearLines :: Int -> Int -> m ()
clearLines from till
| from >= till = return ()
| otherwise = do
setCursorPosition $ Position {row = from, col = 0}
eraseInLine EraseForward
clearLines (from + 1) till
inputHeight :: TerminalState -> Int
inputHeight ts = length (inputPrompt ts <> inputString ts) `div` width + 1
positionRowColumn :: Int -> Int -> Position
positionRowColumn wid pos =
let row = pos `div` wid
col = pos - row * wid
in Position {row, col}
printMessage :: forall m. MonadTerminal m => ChatTerminal -> [StyledString] -> m ()
printMessage ChatTerminal {termSize = Size {height, width}, nextMessageRow} msg = do
nmr <- readTVarIO nextMessageRow
setCursorPosition $ Position {row = nmr, col = 0}
mapM_ printStyled msg
flush
let lc = sum $ map lineCount msg
atomically . writeTVar nextMessageRow $ min (height - 1) (nmr + lc)
where
lineCount :: StyledString -> Int
lineCount s = sLength s `div` width + 1
printStyled :: StyledString -> m ()
printStyled s = do
putStyled s
eraseInLine EraseForward
putLn
-- Currently it is assumed that the message does not have internal line breaks.
-- Previous implementation "kind of" supported them,
-- but it was not determining the number of printed lines correctly
-- because of accounting for control sequences in length
putStyled :: MonadTerminal m => StyledString -> m ()
putStyled (s1 :<>: s2) = putStyled s1 >> putStyled s2
putStyled (Styled [] s) = putString s
putStyled (Styled sgr s) = setSGR sgr >> putString s >> resetAttributes
setSGR :: MonadTerminal m => [SGR] -> m ()
setSGR = mapM_ $ \case
Reset -> resetAttributes
SetConsoleIntensity BoldIntensity -> setAttribute bold
SetConsoleIntensity _ -> resetAttribute bold
SetItalicized True -> setAttribute italic
SetItalicized _ -> resetAttribute italic
SetUnderlining NoUnderline -> resetAttribute underlined
SetUnderlining _ -> setAttribute underlined
SetSwapForegroundBackground True -> setAttribute inverted
SetSwapForegroundBackground _ -> resetAttribute inverted
SetColor l i c -> setAttribute . layer l . intensity i $ color c
SetBlinkSpeed _ -> pure ()
SetVisible _ -> pure ()
SetRGBColor _ _ -> pure ()
SetPaletteColor _ _ -> pure ()
SetDefaultColor _ -> pure ()
where
layer = \case
Foreground -> foreground
Background -> background
intensity = \case
Dull -> id
Vivid -> bright
color = \case
Black -> black
Red -> red
Green -> green
Yellow -> yellow
Blue -> blue
Magenta -> magenta
Cyan -> cyan
White -> white
src/Simplex/Chat/Types.hs
+5
View File
@@ -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}
src/Simplex/Chat/View.hs
+238 -418
View File
@@ -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)