mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-06-29 04:39:53 +00:00
* core: member mentions, types and rfc * update * update rfc * save/get mentions (WIP) * markdown * store received mentions and userMention flag * sent mentions * update message with mentions * db queries * CLI mentions, test passes * use maps for mentions * tests * comment * save mentions on sent messages * postresql schema * refactor * M.empty * include both displayName and localAlias into MentionedMemberInfo * fix saving sent mentions * include mentions in previews * update plans
2450 lines
131 KiB
Haskell
2450 lines
131 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Simplex.Chat.View where
|
|
|
|
import qualified Data.Aeson as J
|
|
import qualified Data.Aeson.TH as JQ
|
|
import qualified Data.ByteString.Char8 as B
|
|
import qualified Data.ByteString.Lazy.Char8 as LB
|
|
import Data.Char (isSpace, toUpper)
|
|
import Data.Function (on)
|
|
import Data.Int (Int64)
|
|
import Data.List (groupBy, intercalate, intersperse, partition, sortOn)
|
|
import Data.List.NonEmpty (NonEmpty (..))
|
|
import qualified Data.List.NonEmpty as L
|
|
import Data.Map.Strict (Map)
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
|
|
import Data.String
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (decodeLatin1)
|
|
import Data.Time (LocalTime (..), TimeOfDay (..), TimeZone (..), utcToLocalTime)
|
|
import Data.Time.Calendar (addDays)
|
|
import Data.Time.Clock (UTCTime)
|
|
import Data.Time.Format (defaultTimeLocale, formatTime)
|
|
import qualified Data.Version as V
|
|
import qualified Network.HTTP.Types as Q
|
|
import Numeric (showFFloat)
|
|
import Simplex.Chat (defaultChatConfig)
|
|
import Simplex.Chat.Call
|
|
import Simplex.Chat.Controller
|
|
import Simplex.Chat.Help
|
|
import Simplex.Chat.Library.Commands (maxImageSize)
|
|
import Simplex.Chat.Markdown
|
|
import Simplex.Chat.Messages hiding (NewChatItem (..))
|
|
import Simplex.Chat.Messages.CIContent
|
|
import Simplex.Chat.Operators
|
|
import Simplex.Chat.Protocol
|
|
import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange)
|
|
import Simplex.Chat.Remote.Types
|
|
import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..))
|
|
import Simplex.Chat.Styled
|
|
import Simplex.Chat.Types
|
|
import Simplex.Chat.Types.Preferences
|
|
import Simplex.Chat.Types.Shared
|
|
import Simplex.Chat.Types.UITheme
|
|
import qualified Simplex.FileTransfer.Transport as XFTP
|
|
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..))
|
|
import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..), ServerRoles (..))
|
|
import Simplex.Messaging.Agent.Protocol
|
|
import Simplex.Messaging.Client (SMPProxyFallback, SMPProxyMode (..), SocksMode (..))
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
|
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
|
import Simplex.Messaging.Encoding
|
|
import Simplex.Messaging.Encoding.String
|
|
import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON)
|
|
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType, BlockingInfo (..), BlockingReason (..), ProtocolServer (..), ProtocolTypeI, SProtocolType (..), UserProtocol)
|
|
import qualified Simplex.Messaging.Protocol as SMP
|
|
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
|
import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
|
|
import Simplex.Messaging.Version hiding (version)
|
|
import Simplex.RemoteControl.Types (RCCtrlAddress (..), RCErrorType (..))
|
|
import System.Console.ANSI.Types
|
|
#if !defined(dbPostgres)
|
|
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
|
|
#endif
|
|
|
|
type CurrentTime = UTCTime
|
|
|
|
data WCallCommand
|
|
= WCCallStart {media :: CallMedia, aesKey :: Maybe String, useWorker :: Bool}
|
|
| WCCallOffer {offer :: Text, iceCandidates :: Text, media :: CallMedia, aesKey :: Maybe String, useWorker :: Bool}
|
|
| WCCallAnswer {answer :: Text, iceCandidates :: Text}
|
|
|
|
$(JQ.deriveToJSON (taggedObjectJSON $ dropPrefix "WCCall") ''WCallCommand)
|
|
|
|
serializeChatResponse :: (Maybe RemoteHostId, Maybe User) -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> String
|
|
serializeChatResponse user_ ts tz remoteHost_ = unlines . map unStyle . responseToView user_ defaultChatConfig False ts tz remoteHost_
|
|
|
|
responseToView :: (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Bool -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> [StyledString]
|
|
responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showReceipts, testView} liveItems ts tz outputRH = \case
|
|
CRActiveUser User {profile, uiThemes} -> viewUserProfile (fromLocalProfile profile) <> viewUITheme uiThemes
|
|
CRUsersList users -> viewUsersList users
|
|
CRChatStarted -> ["chat started"]
|
|
CRChatRunning -> ["chat is running"]
|
|
CRChatStopped -> ["chat stopped"]
|
|
CRChatSuspended -> ["chat suspended"]
|
|
CRApiChats u chats -> ttyUser u $ if testView then testViewChats chats else [viewJSON chats]
|
|
CRChats chats -> viewChats ts tz chats
|
|
CRApiChat u chat _ -> ttyUser u $ if testView then testViewChat chat else [viewJSON chat]
|
|
CRChatTags u tags -> ttyUser u $ [viewJSON tags]
|
|
CRApiParsedMarkdown ft -> [viewJSON ft]
|
|
CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure
|
|
CRServerOperatorConditions (ServerOperatorConditions ops _ ca) -> viewServerOperators ops ca
|
|
CRUserServers u uss -> ttyUser u $ concatMap viewUserServers uss <> (if testView then [] else serversUserHelp)
|
|
CRUserServersValidation {} -> []
|
|
CRUsageConditions current _ accepted_ -> viewUsageConditions current accepted_
|
|
CRChatItemTTL u ttl -> ttyUser u $ viewChatItemTTL ttl
|
|
CRNetworkConfig cfg -> viewNetworkConfig cfg
|
|
CRContactInfo u ct cStats customUserProfile -> ttyUser u $ viewContactInfo ct cStats customUserProfile
|
|
CRGroupInfo u g s -> ttyUser u $ viewGroupInfo g s
|
|
CRGroupMemberInfo u g m cStats -> ttyUser u $ viewGroupMemberInfo g m cStats
|
|
CRQueueInfo _ msgInfo qInfo ->
|
|
[ "last received msg: " <> maybe "none" viewJSON msgInfo,
|
|
"server queue info: " <> viewJSON qInfo
|
|
]
|
|
CRContactSwitchStarted {} -> ["switch started"]
|
|
CRGroupMemberSwitchStarted {} -> ["switch started"]
|
|
CRContactSwitchAborted {} -> ["switch aborted"]
|
|
CRGroupMemberSwitchAborted {} -> ["switch aborted"]
|
|
CRContactSwitch u ct progress -> ttyUser u $ viewContactSwitch ct progress
|
|
CRGroupMemberSwitch u g m progress -> ttyUser u $ viewGroupMemberSwitch g m progress
|
|
CRContactRatchetSyncStarted {} -> ["connection synchronization started"]
|
|
CRGroupMemberRatchetSyncStarted {} -> ["connection synchronization started"]
|
|
CRContactRatchetSync u ct progress -> ttyUser u $ viewContactRatchetSync ct progress
|
|
CRGroupMemberRatchetSync u g m progress -> ttyUser u $ viewGroupMemberRatchetSync g m progress
|
|
CRContactVerificationReset u ct -> ttyUser u $ viewContactVerificationReset ct
|
|
CRGroupMemberVerificationReset u g m -> ttyUser u $ viewGroupMemberVerificationReset g m
|
|
CRConnectionVerified u verified code -> ttyUser u [plain $ if verified then "connection verified" else "connection not verified, current code is " <> code]
|
|
CRContactCode u ct code -> ttyUser u $ viewContactCode ct code testView
|
|
CRGroupMemberCode u g m code -> ttyUser u $ viewGroupMemberCode g m code testView
|
|
CRNewChatItems u chatItems
|
|
| length chatItems > 20 ->
|
|
if
|
|
| all (\aci -> aChatItemDir aci == MDRcv) chatItems -> ttyUser u [sShow (length chatItems) <> " new messages"]
|
|
| all (\aci -> aChatItemDir aci == MDSnd) chatItems -> ttyUser u [sShow (length chatItems) <> " messages sent"]
|
|
| otherwise -> ttyUser u [sShow (length chatItems) <> " new messages created"]
|
|
| otherwise ->
|
|
concatMap
|
|
(\(AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewChatItem chat item False ts tz <> viewItemReactions item)
|
|
chatItems
|
|
CRChatItems u _ chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item) chatItems
|
|
CRChatItemInfo u ci ciInfo -> ttyUser u $ viewChatItemInfo ci ciInfo tz
|
|
CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId]
|
|
CRChatItemsStatusesUpdated u chatItems
|
|
| length chatItems <= 20 ->
|
|
concatMap
|
|
(\ci -> ttyUser u $ viewChatItemStatusUpdated ci ts tz testView showReceipts)
|
|
chatItems
|
|
| testView && showReceipts ->
|
|
ttyUser u [sShow (length chatItems) <> " message statuses updated"]
|
|
| otherwise -> []
|
|
CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewItemUpdate chat item liveItems ts tz
|
|
CRChatItemNotChanged u ci -> ttyUser u $ viewItemNotChanged ci
|
|
CRTagsUpdated u _ _ -> ttyUser u ["chat tags updated"]
|
|
CRChatItemsDeleted u deletions byUser timed -> case deletions of
|
|
[ChatItemDeletion (AChatItem _ _ chat deletedItem) toItem] ->
|
|
ttyUser u $ unmuted u chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts tz testView
|
|
deletions' -> ttyUser u [sShow (length deletions') <> " messages deleted"]
|
|
CRGroupChatItemsDeleted u g ciIds byUser member_ -> ttyUser u [ttyGroup' g <> ": " <> sShow (length ciIds) <> " messages deleted by " <> if byUser then "user" else "member" <> maybe "" (\m -> " " <> ttyMember m) member_]
|
|
CRChatItemReaction u added (ACIReaction _ _ chat reaction) -> ttyUser u $ unmutedReaction u chat reaction $ viewItemReaction showReactions chat reaction added ts tz
|
|
CRReactionMembers u memberReactions -> ttyUser u $ viewReactionMembers memberReactions
|
|
CRChatItemDeletedNotFound u Contact {localDisplayName = c} _ -> ttyUser u [ttyFrom $ c <> "> [deleted - original message not found]"]
|
|
CRBroadcastSent u mc s f t -> ttyUser u $ viewSentBroadcast mc s f ts tz t
|
|
CRMsgIntegrityError u mErr -> ttyUser u $ viewMsgIntegrityError mErr
|
|
CRCmdAccepted _ -> []
|
|
CRCmdOk u_ -> ttyUser' u_ ["ok"]
|
|
CRChatHelp section -> case section of
|
|
HSMain -> chatHelpInfo
|
|
HSFiles -> filesHelpInfo
|
|
HSGroups -> groupsHelpInfo
|
|
HSContacts -> contactsHelpInfo
|
|
HSMyAddress -> myAddressHelpInfo
|
|
HSIncognito -> incognitoHelpInfo
|
|
HSMessages -> messagesHelpInfo
|
|
HSMarkdown -> markdownInfo
|
|
HSRemote -> remoteHelpInfo
|
|
HSSettings -> settingsInfo
|
|
HSDatabase -> databaseHelpInfo
|
|
CRWelcome user -> chatWelcome user
|
|
CRContactsList u cs -> ttyUser u $ viewContactsList cs
|
|
CRUserContactLink u UserContactLink {connReqContact, autoAccept} -> ttyUser u $ connReqContact_ "Your chat address:" connReqContact <> autoAcceptStatus_ autoAccept
|
|
CRUserContactLinkUpdated u UserContactLink {autoAccept} -> ttyUser u $ autoAcceptStatus_ autoAccept
|
|
CRContactRequestRejected u UserContactRequest {localDisplayName = c} -> ttyUser u [ttyContact c <> ": contact request rejected"]
|
|
CRGroupCreated u g -> ttyUser u $ viewGroupCreated g testView
|
|
CRGroupMembers u g -> ttyUser u $ viewGroupMembers g
|
|
CRGroupsList u gs -> ttyUser u $ viewGroupsList gs
|
|
CRSentGroupInvitation u g c _ ->
|
|
ttyUser u $
|
|
case contactConn c of
|
|
Just Connection {viaGroupLink}
|
|
| viaGroupLink -> [ttyContact' c <> " invited to group " <> ttyGroup' g <> " via your group link"]
|
|
| otherwise -> ["invitation to join the group " <> ttyGroup' g <> " sent to " <> ttyContact' c]
|
|
Nothing -> []
|
|
CRFileTransferStatus u ftStatus -> ttyUser u $ viewFileTransferStatus ftStatus
|
|
CRFileTransferStatusXFTP u ci -> ttyUser u $ viewFileTransferStatusXFTP ci
|
|
CRUserProfile u p -> ttyUser u $ viewUserProfile p
|
|
CRUserProfileNoChange u -> ttyUser u ["user profile did not change"]
|
|
CRUserPrivacy u u' -> ttyUserPrefix u $ viewUserPrivacy u u'
|
|
CRVersionInfo info _ _ -> viewVersionInfo logLevel info
|
|
CRInvitation u cReq _ -> ttyUser u $ viewConnReqInvitation cReq
|
|
CRConnectionIncognitoUpdated u c -> ttyUser u $ viewConnectionIncognitoUpdated c
|
|
CRConnectionUserChanged u c c' nu -> ttyUser u $ viewConnectionUserChanged u c nu c'
|
|
CRConnectionPlan u connectionPlan -> ttyUser u $ viewConnectionPlan connectionPlan
|
|
CRSentConfirmation u _ -> ttyUser u ["confirmation sent!"]
|
|
CRSentInvitation u _ customUserProfile -> ttyUser u $ viewSentInvitation customUserProfile testView
|
|
CRSentInvitationToContact u _c customUserProfile -> ttyUser u $ viewSentInvitation customUserProfile testView
|
|
CRContactDeleted u c -> ttyUser u [ttyContact' c <> ": contact is deleted"]
|
|
CRContactDeletedByContact u c -> ttyUser u [ttyFullContact c <> " deleted contact with you"]
|
|
CRChatCleared u chatInfo -> ttyUser u $ viewChatCleared chatInfo
|
|
CRAcceptingContactRequest u c -> ttyUser u $ viewAcceptingContactRequest c
|
|
CRAcceptingBusinessRequest u g -> ttyUser u $ viewAcceptingBusinessRequest g
|
|
CRContactAlreadyExists u c -> ttyUser u [ttyFullContact c <> ": contact already exists"]
|
|
CRContactRequestAlreadyAccepted u c -> ttyUser u [ttyFullContact c <> ": sent you a duplicate contact request, but you are already connected, no action needed"]
|
|
CRBusinessRequestAlreadyAccepted u g -> ttyUser u [ttyFullGroup g <> ": sent you a duplicate connection request, but you are already connected, no action needed"]
|
|
CRUserContactLinkCreated u cReq -> ttyUser u $ connReqContact_ "Your new chat address is created!" cReq
|
|
CRUserContactLinkDeleted u -> ttyUser u viewUserContactLinkDeleted
|
|
CRUserAcceptedGroupSent u _g _ -> ttyUser u [] -- [ttyGroup' g <> ": joining the group..."]
|
|
CRGroupLinkConnecting u g _ -> ttyUser u [ttyGroup' g <> ": joining the group..."]
|
|
CRBusinessLinkConnecting u g _ _ -> ttyUser u [ttyGroup' g <> ": joining the group..."]
|
|
CRUserDeletedMember u g m -> ttyUser u [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group"]
|
|
CRLeftMemberUser u g -> ttyUser u $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g
|
|
CRUnknownMemberCreated u g fwdM um -> ttyUser u [ttyGroup' g <> ": " <> ttyMember fwdM <> " forwarded a message from an unknown member, creating unknown member record " <> ttyMember um]
|
|
CRUnknownMemberBlocked u g byM um -> ttyUser u [ttyGroup' g <> ": " <> ttyMember byM <> " blocked an unknown member, creating unknown member record " <> ttyMember um]
|
|
CRUnknownMemberAnnounced u g _ um m -> ttyUser u [ttyGroup' g <> ": unknown member " <> ttyMember um <> " updated to " <> ttyMember m]
|
|
CRGroupDeletedUser u g -> ttyUser u [ttyGroup' g <> ": you deleted the group"]
|
|
CRForwardPlan u count itemIds fc -> ttyUser u $ viewForwardPlan count itemIds fc
|
|
CRRcvFileDescrReady _ _ _ _ -> []
|
|
CRRcvFileProgressXFTP {} -> []
|
|
CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci
|
|
CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft
|
|
CRSndFileCancelled u _ ftm fts -> ttyUser u $ viewSndFileCancelled ftm fts
|
|
CRRcvFileCancelled u _ ft -> ttyUser u $ receivingFile_ "cancelled" ft
|
|
CRUserProfileUpdated u p p' summary -> ttyUser u $ viewUserProfileUpdated p p' summary
|
|
CRUserProfileImage u p -> ttyUser u $ viewUserProfileImage p
|
|
CRContactPrefsUpdated {user = u, fromContact, toContact} -> ttyUser u $ viewUserContactPrefsUpdated u fromContact toContact
|
|
CRContactAliasUpdated u c -> ttyUser u $ viewContactAliasUpdated c
|
|
CRGroupAliasUpdated u g -> ttyUser u $ viewGroupAliasUpdated g
|
|
CRConnectionAliasUpdated u c -> ttyUser u $ viewConnectionAliasUpdated c
|
|
CRContactUpdated {user = u, fromContact = c, toContact = c'} -> ttyUser u $ viewContactUpdated c c' <> viewContactPrefsUpdated u c c'
|
|
CRGroupMemberUpdated {} -> []
|
|
CRContactsMerged u intoCt mergedCt ct' -> ttyUser u $ viewContactsMerged intoCt mergedCt ct'
|
|
CRReceivedContactRequest u UserContactRequest {localDisplayName = c, profile} -> ttyUser u $ viewReceivedContactRequest c profile
|
|
CRRcvStandaloneFileCreated u ft -> ttyUser u $ receivingFileStandalone "started" ft
|
|
CRRcvFileStart u ci -> ttyUser u $ receivingFile_' hu testView "started" ci
|
|
CRRcvFileComplete u ci -> ttyUser u $ receivingFile_' hu testView "completed" ci
|
|
CRRcvStandaloneFileComplete u _ ft -> ttyUser u $ receivingFileStandalone "completed" ft
|
|
CRRcvFileSndCancelled u _ ft -> ttyUser u $ viewRcvFileSndCancelled ft
|
|
CRRcvFileError u (Just ci) e _ -> ttyUser u $ receivingFile_' hu testView "error" ci <> [sShow e]
|
|
CRRcvFileError u Nothing e ft -> ttyUser u $ receivingFileStandalone "error" ft <> [sShow e]
|
|
CRRcvFileWarning u (Just ci) e _ -> ttyUser u $ receivingFile_' hu testView "warning: " ci <> [sShow e]
|
|
CRRcvFileWarning u Nothing e ft -> ttyUser u $ receivingFileStandalone "warning: " ft <> [sShow e]
|
|
CRSndFileStart u _ ft -> ttyUser u $ sendingFile_ "started" ft
|
|
CRSndFileComplete u _ ft -> ttyUser u $ sendingFile_ "completed" ft
|
|
CRSndStandaloneFileCreated u ft -> ttyUser u $ uploadingFileStandalone "started" ft
|
|
CRSndFileStartXFTP {} -> []
|
|
CRSndFileProgressXFTP {} -> []
|
|
CRSndFileRedirectStartXFTP u ft ftRedirect -> ttyUser u $ standaloneUploadRedirect ft ftRedirect
|
|
CRSndStandaloneFileComplete u ft uris -> ttyUser u $ standaloneUploadComplete ft uris
|
|
CRSndFileCompleteXFTP u ci _ -> ttyUser u $ uploadingFile "completed" ci
|
|
CRSndFileCancelledXFTP {} -> []
|
|
CRSndFileError u Nothing ft e -> ttyUser u $ uploadingFileStandalone "error" ft <> [plain e]
|
|
CRSndFileError u (Just ci) _ e -> ttyUser u $ uploadingFile "error" ci <> [plain e]
|
|
CRSndFileWarning u Nothing ft e -> ttyUser u $ uploadingFileStandalone "warning: " ft <> [plain e]
|
|
CRSndFileWarning u (Just ci) _ e -> ttyUser u $ uploadingFile "warning: " ci <> [plain e]
|
|
CRSndFileRcvCancelled u _ ft@SndFileTransfer {recipientDisplayName = c} ->
|
|
ttyUser u [ttyContact c <> " cancelled receiving " <> sndFile ft]
|
|
CRStandaloneFileInfo info_ -> maybe ["no file information in URI"] (\j -> [viewJSON j]) info_
|
|
CRContactConnecting u _ -> ttyUser u []
|
|
CRContactConnected u ct userCustomProfile -> ttyUser u $ viewContactConnected ct userCustomProfile testView
|
|
CRContactSndReady u ct -> ttyUser u [ttyFullContact ct <> ": you can send messages to contact"]
|
|
CRContactAnotherClient u c -> ttyUser u [ttyContact' c <> ": contact is connected to another client"]
|
|
CRSubscriptionEnd u acEntity ->
|
|
let Connection {connId} = entityConnection acEntity
|
|
in ttyUser u [sShow connId <> ": END"]
|
|
CRContactsDisconnected srv cs -> [plain $ "server disconnected " <> showSMPServer srv <> " (" <> contactList cs <> ")"]
|
|
CRContactsSubscribed srv cs -> [plain $ "server connected " <> showSMPServer srv <> " (" <> contactList cs <> ")"]
|
|
CRContactSubError u c e -> ttyUser u [ttyContact' c <> ": contact error " <> sShow e]
|
|
CRContactSubSummary u summary ->
|
|
ttyUser u $ [sShow (length subscribed) <> " contacts connected (use " <> highlight' "/cs" <> " for the list)" | not (null subscribed)] <> viewErrorsSummary errors " contact errors"
|
|
where
|
|
(errors, subscribed) = partition (isJust . contactError) summary
|
|
CRUserContactSubSummary u summary ->
|
|
ttyUser u $
|
|
map addressSS addresses
|
|
<> ([sShow (length groupLinksSubscribed) <> " group links active" | not (null groupLinksSubscribed)] <> viewErrorsSummary groupLinkErrors " group link errors")
|
|
where
|
|
(addresses, groupLinks) = partition (\UserContactSubStatus {userContact} -> isNothing . userContactGroupId $ userContact) summary
|
|
addressSS UserContactSubStatus {userContactError} = maybe ("Your address is active! To show: " <> highlight' "/sa") (\e -> "User address error: " <> sShow e <> ", to delete your address: " <> highlight' "/da") userContactError
|
|
(groupLinkErrors, groupLinksSubscribed) = partition (isJust . userContactError) groupLinks
|
|
CRNetworkStatus status conns -> if testView then [plain $ show (length conns) <> " connections " <> netStatusStr status] else []
|
|
CRNetworkStatuses u statuses -> if testView then ttyUser' u $ viewNetworkStatuses statuses else []
|
|
CRGroupInvitation u g -> ttyUser u [groupInvitationSub g]
|
|
CRReceivedGroupInvitation {user = u, groupInfo = g, contact = c, memberRole = r} -> ttyUser u $ viewReceivedGroupInvitation g c r
|
|
CRUserJoinedGroup u g _ -> ttyUser u $ viewUserJoinedGroup g
|
|
CRJoinedGroupMember u g m -> ttyUser u $ viewJoinedGroupMember g m
|
|
CRHostConnected p h -> [plain $ "connected to " <> viewHostEvent p h]
|
|
CRHostDisconnected p h -> [plain $ "disconnected from " <> viewHostEvent p h]
|
|
CRJoinedGroupMemberConnecting u g host m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"]
|
|
CRConnectedToGroupMember u g m _ -> ttyUser u [ttyGroup' g <> ": " <> connectedMember m <> " is connected"]
|
|
CRMemberRole u g by m r r' -> ttyUser u $ viewMemberRoleChanged g by m r r'
|
|
CRMemberRoleUser u g m r r' -> ttyUser u $ viewMemberRoleUserChanged g m r r'
|
|
CRMemberBlockedForAll u g by m blocked -> ttyUser u $ viewMemberBlockedForAll g by m blocked
|
|
CRMemberBlockedForAllUser u g m blocked -> ttyUser u $ viewMemberBlockedForAllUser g m blocked
|
|
CRDeletedMemberUser u g by -> ttyUser u $ [ttyGroup' g <> ": " <> ttyMember by <> " removed you from the group"] <> groupPreserved g
|
|
CRDeletedMember u g by m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group"]
|
|
CRLeftMember u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " left the group"]
|
|
CRGroupEmpty u ShortGroupInfo {groupName = g} -> ttyUser u [ttyGroup g <> ": group is empty"]
|
|
CRGroupDeleted u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the local copy of the group"]
|
|
CRGroupUpdated u g g' m -> ttyUser u $ viewGroupUpdated g g' m
|
|
CRGroupProfile u g -> ttyUser u $ viewGroupProfile g
|
|
CRGroupDescription u g -> ttyUser u $ viewGroupDescription g
|
|
CRGroupLinkCreated u g cReq mRole -> ttyUser u $ groupLink_ "Group link is created!" g cReq mRole
|
|
CRGroupLink u g cReq mRole -> ttyUser u $ groupLink_ "Group link:" g cReq mRole
|
|
CRGroupLinkDeleted u g -> ttyUser u $ viewGroupLinkDeleted g
|
|
CRAcceptingGroupJoinRequest _ g c -> [ttyFullContact c <> ": accepting request to join group " <> ttyGroup' g <> "..."]
|
|
CRAcceptingGroupJoinRequestMember _ g m -> [ttyFullMember m <> ": accepting request to join group " <> ttyGroup' g <> "..."]
|
|
CRNoMemberContactCreating u g m -> ttyUser u ["member " <> ttyGroup' g <> " " <> ttyMember m <> " does not have direct connection, creating"]
|
|
CRNewMemberContact u _ g m -> ttyUser u ["contact for member " <> ttyGroup' g <> " " <> ttyMember m <> " is created"]
|
|
CRNewMemberContactSentInv u _ct g m -> ttyUser u ["sent invitation to connect directly to member " <> ttyGroup' g <> " " <> ttyMember m]
|
|
CRNewMemberContactReceivedInv u ct g m -> ttyUser u [ttyGroup' g <> " " <> ttyMember m <> " is creating direct contact " <> ttyContact' ct <> " with you"]
|
|
CRContactAndMemberAssociated u ct g m ct' -> ttyUser u $ viewContactAndMemberAssociated ct g m ct'
|
|
CRMemberSubError u ShortGroupInfo {groupName = g} ShortGroupMember {memberName = n} e -> ttyUser u [ttyGroup g <> " member " <> ttyContact n <> " error: " <> sShow e]
|
|
CRMemberSubSummary u summary -> ttyUser u $ viewErrorsSummary (filter (isJust . memberError) summary) " group member errors"
|
|
CRGroupSubscribed u ShortGroupInfo {groupName = g} -> ttyUser u $ viewGroupSubscribed g
|
|
CRPendingSubSummary u _ -> ttyUser u []
|
|
CRSndFileSubError u SndFileTransfer {fileId, fileName} e ->
|
|
ttyUser u ["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
|
|
CRRcvFileSubError u RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e ->
|
|
ttyUser u ["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
|
|
CRCallInvitation RcvCallInvitation {user, contact, callType, sharedKey} -> ttyUser user $ viewCallInvitation contact callType sharedKey
|
|
CRCallOffer {user = u, contact, callType, offer, sharedKey} -> ttyUser u $ viewCallOffer contact callType offer sharedKey
|
|
CRCallAnswer {user = u, contact, answer} -> ttyUser u $ viewCallAnswer contact answer
|
|
CRCallExtraInfo {user = u, contact} -> ttyUser u ["call extra info from " <> ttyContact' contact]
|
|
CRCallEnded {user = u, contact} -> ttyUser u ["call with " <> ttyContact' contact <> " ended"]
|
|
CRCallInvitations _ -> []
|
|
CRUserContactLinkSubscribed -> ["Your address is active! To show: " <> highlight' "/sa"]
|
|
CRUserContactLinkSubError e -> ["user address error: " <> sShow e, "to delete your address: " <> highlight' "/da"]
|
|
CRContactConnectionDeleted u PendingContactConnection {pccConnId} -> ttyUser u ["connection :" <> sShow pccConnId <> " deleted"]
|
|
CRNtfTokenStatus status -> ["device token status: " <> plain (smpEncode status)]
|
|
CRNtfToken _ status mode srv -> ["device token status: " <> plain (smpEncode status) <> ", notifications mode: " <> plain (strEncode mode) <> ", server: " <> sShow srv]
|
|
CRNtfConns {} -> []
|
|
CRConnNtfMessages {} -> []
|
|
CRNtfMessage {} -> []
|
|
CRCurrentRemoteHost rhi_ ->
|
|
[ maybe
|
|
"Using local profile"
|
|
(\RemoteHostInfo {remoteHostId = rhId, hostDeviceName} -> "Using remote host " <> sShow rhId <> " (" <> plain hostDeviceName <> ")")
|
|
rhi_
|
|
]
|
|
CRRemoteHostList hs -> viewRemoteHosts hs
|
|
CRRemoteHostStarted {remoteHost_, invitation, localAddrs = RCCtrlAddress {address} :| _, ctrlPort} ->
|
|
[ plain $ maybe ("new remote host" <> started) (\RemoteHostInfo {remoteHostId = rhId} -> "remote host " <> show rhId <> started) remoteHost_,
|
|
"Remote session invitation:",
|
|
plain invitation
|
|
]
|
|
where
|
|
started = " started on " <> B.unpack (strEncode address) <> ":" <> ctrlPort
|
|
CRRemoteHostSessionCode {remoteHost_, sessionCode} ->
|
|
[ maybe "new remote host connecting" (\RemoteHostInfo {remoteHostId = rhId} -> "remote host " <> sShow rhId <> " connecting") remoteHost_,
|
|
"Compare session code with host:",
|
|
plain sessionCode
|
|
]
|
|
CRNewRemoteHost RemoteHostInfo {remoteHostId = rhId, hostDeviceName} -> ["new remote host " <> sShow rhId <> " added: " <> plain hostDeviceName]
|
|
CRRemoteHostConnected RemoteHostInfo {remoteHostId = rhId} -> ["remote host " <> sShow rhId <> " connected"]
|
|
CRRemoteHostStopped {remoteHostId_} ->
|
|
[ maybe "new remote host" (mappend "remote host " . sShow) remoteHostId_ <> " stopped"
|
|
]
|
|
CRRemoteFileStored rhId (CryptoFile filePath cfArgs_) ->
|
|
[plain $ "file " <> filePath <> " stored on remote host " <> show rhId]
|
|
<> maybe [] ((: []) . cryptoFileArgsStr testView) cfArgs_
|
|
CRRemoteCtrlList cs -> viewRemoteCtrls cs
|
|
CRRemoteCtrlFound {remoteCtrl = RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName}, ctrlAppInfo_, appVersion, compatible} ->
|
|
[ ("remote controller " <> sShow remoteCtrlId <> " found: ")
|
|
<> maybe (deviceName <> "not compatible") (\info -> viewRemoteCtrl info appVersion compatible) ctrlAppInfo_
|
|
]
|
|
<> ["use " <> highlight ("/confirm remote ctrl " <> show remoteCtrlId) <> " to connect" | isJust ctrlAppInfo_ && compatible]
|
|
where
|
|
deviceName = if T.null ctrlDeviceName then "" else plain ctrlDeviceName <> ", "
|
|
CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion} ->
|
|
[ (maybe "connecting new remote controller" (\RemoteCtrlInfo {remoteCtrlId} -> "connecting remote controller " <> sShow remoteCtrlId) remoteCtrl_ <> ": ")
|
|
<> viewRemoteCtrl ctrlAppInfo appVersion True
|
|
]
|
|
CRRemoteCtrlSessionCode {remoteCtrl_, sessionCode} ->
|
|
[ maybe "new remote controller connected" (\RemoteCtrlInfo {remoteCtrlId} -> "remote controller " <> sShow remoteCtrlId <> " connected") remoteCtrl_,
|
|
"Compare session code with controller and use:",
|
|
"/verify remote ctrl " <> plain sessionCode -- TODO maybe pass rcId
|
|
]
|
|
CRRemoteCtrlConnected RemoteCtrlInfo {remoteCtrlId = rcId, ctrlDeviceName} ->
|
|
["remote controller " <> sShow rcId <> " session started with " <> plain ctrlDeviceName]
|
|
CRRemoteCtrlStopped {rcStopReason} -> viewRemoteCtrlStopped rcStopReason
|
|
CRContactPQEnabled u c (CR.PQEncryption pqOn) -> ttyUser u [ttyContact' c <> ": " <> (if pqOn then "quantum resistant" else "standard") <> " end-to-end encryption enabled"]
|
|
CRSQLResult rows -> map plain rows
|
|
#if !defined(dbPostgres)
|
|
CRArchiveExported archiveErrs -> if null archiveErrs then ["ok"] else ["archive export errors: " <> plain (show archiveErrs)]
|
|
CRArchiveImported archiveErrs -> if null archiveErrs then ["ok"] else ["archive import errors: " <> plain (show archiveErrs)]
|
|
CRSlowSQLQueries {chatQueries, agentQueries} ->
|
|
let viewQuery SlowSQLQuery {query, queryStats = SlowQueryStats {count, timeMax, timeAvg}} =
|
|
("count: " <> sShow count)
|
|
<> (" :: max: " <> sShow timeMax <> " ms")
|
|
<> (" :: avg: " <> sShow timeAvg <> " ms")
|
|
<> (" :: " <> plain (T.unwords $ T.lines query))
|
|
in ("Chat queries" : map viewQuery chatQueries) <> [""] <> ("Agent queries" : map viewQuery agentQueries)
|
|
#endif
|
|
CRDebugLocks {chatLockName, chatEntityLocks, agentLocks} ->
|
|
[ maybe "no chat lock" (("chat lock: " <>) . plain) chatLockName,
|
|
"chat entity locks: " <> viewJSON chatEntityLocks,
|
|
"agent locks: " <> viewJSON agentLocks
|
|
]
|
|
CRAgentSubsTotal u subsTotal _ -> ttyUser u ["total subscriptions: " <> sShow subsTotal]
|
|
CRAgentServersSummary u serversSummary -> ttyUser u ["agent servers summary: " <> viewJSON serversSummary]
|
|
CRAgentSubs {activeSubs, pendingSubs, removedSubs} ->
|
|
[plain $ "Subscriptions: active = " <> show (sum activeSubs) <> ", pending = " <> show (sum pendingSubs) <> ", removed = " <> show (sum $ M.map length removedSubs)]
|
|
<> ("active subscriptions:" : listSubs activeSubs)
|
|
<> ("pending subscriptions:" : listSubs pendingSubs)
|
|
<> ("removed subscriptions:" : listSubs removedSubs)
|
|
where
|
|
listSubs :: Show a => Map Text a -> [StyledString]
|
|
listSubs = map (\(srv, info) -> plain $ srv <> ": " <> tshow info) . M.assocs
|
|
CRAgentSubsDetails SubscriptionsInfo {activeSubscriptions, pendingSubscriptions, removedSubscriptions} ->
|
|
("active subscriptions:" : map sShow activeSubscriptions)
|
|
<> ("pending subscriptions: " : map sShow pendingSubscriptions)
|
|
<> ("removed subscriptions: " : map sShow removedSubscriptions)
|
|
CRAgentWorkersSummary {agentWorkersSummary} -> ["agent workers summary: " <> viewJSON agentWorkersSummary]
|
|
CRAgentWorkersDetails {agentWorkersDetails} ->
|
|
[ "agent workers details:",
|
|
viewJSON agentWorkersDetails -- this would be huge, but copypastable when has its own line
|
|
]
|
|
CRAgentQueuesInfo {agentQueuesInfo} ->
|
|
[ "agent queues info:",
|
|
plain . LB.unpack $ J.encode agentQueuesInfo
|
|
]
|
|
CRContactDisabled u c -> ttyUser u ["[" <> ttyContact' c <> "] connection is disabled, to enable: " <> highlight ("/enable " <> viewContactName c) <> ", to delete: " <> highlight ("/d " <> viewContactName c)]
|
|
CRConnectionDisabled entity -> viewConnectionEntityDisabled entity
|
|
CRConnectionInactive entity inactive -> viewConnectionEntityInactive entity inactive
|
|
CRAgentRcvQueuesDeleted delQs -> ["completed deleting rcv queues: " <> sShow (length delQs) | logLevel <= CLLInfo]
|
|
CRAgentConnsDeleted acIds -> ["completed deleting connections: " <> sShow (length acIds) | logLevel <= CLLInfo]
|
|
CRAgentUserDeleted auId -> ["completed deleting user" <> if logLevel <= CLLInfo then ", agent user id: " <> sShow auId else ""]
|
|
CRMessageError u prefix err -> ttyUser u [plain prefix <> ": " <> plain err | prefix == "error" || logLevel <= CLLWarning]
|
|
CRChatCmdError u e -> ttyUserPrefix' u $ viewChatError True logLevel testView e
|
|
CRChatError u e -> ttyUser' u $ viewChatError False logLevel testView e
|
|
CRChatErrors u errs -> ttyUser' u $ concatMap (viewChatError False logLevel testView) errs
|
|
CRAppSettings as -> ["app settings: " <> viewJSON as]
|
|
CRTimedAction _ _ -> []
|
|
CRCustomChatResponse u r -> ttyUser' u $ map plain $ T.lines r
|
|
where
|
|
ttyUser :: User -> [StyledString] -> [StyledString]
|
|
ttyUser user@User {showNtfs, activeUser, viewPwdHash} ss
|
|
| (showNtfs && isNothing viewPwdHash) || activeUser = ttyUserPrefix user ss
|
|
| otherwise = []
|
|
ttyUserPrefix :: User -> [StyledString] -> [StyledString]
|
|
ttyUserPrefix _ [] = []
|
|
ttyUserPrefix User {userId, localDisplayName = u} ss
|
|
| null prefix = ss
|
|
| otherwise = prependFirst ("[" <> mconcat prefix <> "] ") ss
|
|
where
|
|
prefix = intersperse ", " $ remotePrefix <> userPrefix
|
|
remotePrefix = [maybe "local" (("remote: " <>) . highlight . show) outputRH | outputRH /= currentRH]
|
|
userPrefix = ["user: " <> highlight u | Just userId /= currentUserId]
|
|
currentUserId = (\User {userId = uId} -> uId) <$> user_
|
|
ttyUser' :: Maybe User -> [StyledString] -> [StyledString]
|
|
ttyUser' = maybe id ttyUser
|
|
ttyUserPrefix' :: Maybe User -> [StyledString] -> [StyledString]
|
|
ttyUserPrefix' = maybe id ttyUserPrefix
|
|
testViewChats :: [AChat] -> [StyledString]
|
|
testViewChats chats = [sShow $ map toChatView chats]
|
|
where
|
|
toChatView :: AChat -> (Text, Text, Maybe ConnStatus)
|
|
toChatView (AChat _ (Chat (DirectChat Contact {localDisplayName, activeConn}) items _)) = ("@" <> localDisplayName, toCIPreview items Nothing, connStatus <$> activeConn)
|
|
toChatView (AChat _ (Chat (GroupChat GroupInfo {membership, localDisplayName}) items _)) = ("#" <> localDisplayName, toCIPreview items (Just membership), Nothing)
|
|
toChatView (AChat _ (Chat (LocalChat _) items _)) = ("*", toCIPreview items Nothing, Nothing)
|
|
toChatView (AChat _ (Chat (ContactRequest UserContactRequest {localDisplayName}) items _)) = ("<@" <> localDisplayName, toCIPreview items Nothing, Nothing)
|
|
toChatView (AChat _ (Chat (ContactConnection PendingContactConnection {pccConnId, pccConnStatus}) items _)) = (":" <> T.pack (show pccConnId), toCIPreview items Nothing, Just pccConnStatus)
|
|
toCIPreview :: [CChatItem c] -> Maybe GroupMember -> Text
|
|
toCIPreview (ci : _) membership_ = testViewItem ci membership_
|
|
toCIPreview _ _ = ""
|
|
testViewChat :: AChat -> [StyledString]
|
|
testViewChat (AChat _ Chat {chatInfo, chatItems}) = [sShow $ map toChatView chatItems]
|
|
where
|
|
toChatView :: CChatItem c -> ((Int, Text), Maybe (Int, Text), Maybe String)
|
|
toChatView ci@(CChatItem dir ChatItem {quotedItem, file}) =
|
|
((msgDirectionInt $ toMsgDirection dir, testViewItem ci (chatInfoMembership chatInfo)), qItem, fPath)
|
|
where
|
|
qItem = case quotedItem of
|
|
Nothing -> Nothing
|
|
Just CIQuote {chatDir = quoteDir, content} ->
|
|
Just (msgDirectionInt $ quoteMsgDirection quoteDir, msgContentText content)
|
|
fPath = case file of
|
|
Just CIFile {fileSource = Just (CryptoFile fp _)} -> Just fp
|
|
_ -> Nothing
|
|
testViewItem :: CChatItem c -> Maybe GroupMember -> Text
|
|
testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText}}) membership_ =
|
|
let deleted_ = maybe "" (\t -> " [" <> t <> "]") (chatItemDeletedText ci membership_)
|
|
in itemText <> deleted_
|
|
viewErrorsSummary :: [a] -> StyledString -> [StyledString]
|
|
viewErrorsSummary summary s = [ttyError (T.pack . show $ length summary) <> s <> " (run with -c option to show each error)" | not (null summary)]
|
|
contactList :: [ContactRef] -> String
|
|
contactList cs = T.unpack . T.intercalate ", " $ map (\ContactRef {localDisplayName = n} -> "@" <> n) cs
|
|
unmuted :: User -> ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString]
|
|
unmuted u chat ci@ChatItem {chatDir} = unmuted' u chat chatDir $ isUserMention ci
|
|
unmutedReaction :: User -> ChatInfo c -> CIReaction c d -> [StyledString] -> [StyledString]
|
|
unmutedReaction u chat CIReaction {chatDir} = unmuted' u chat chatDir False
|
|
unmuted' :: User -> ChatInfo c -> CIDirection c d -> Bool -> [StyledString] -> [StyledString]
|
|
unmuted' u chat chatDir mention s
|
|
| chatDirNtf u chat chatDir mention = s
|
|
| testView = map (<> " <muted>") s
|
|
| otherwise = []
|
|
|
|
userNtf :: User -> Bool
|
|
userNtf User {showNtfs, activeUser} = showNtfs || activeUser
|
|
|
|
chatDirNtf :: User -> ChatInfo c -> CIDirection c d -> Bool -> Bool
|
|
chatDirNtf user cInfo chatDir mention = case (cInfo, chatDir) of
|
|
(DirectChat ct, CIDirectRcv) -> contactNtf user ct mention
|
|
(GroupChat g, CIGroupRcv m) -> groupNtf user g mention && not (blockedByAdmin m) && showMessages (memberSettings m)
|
|
_ -> True
|
|
|
|
contactNtf :: User -> Contact -> Bool -> Bool
|
|
contactNtf user Contact {chatSettings} mention =
|
|
userNtf user && showMessageNtf chatSettings mention
|
|
|
|
groupNtf :: User -> GroupInfo -> Bool -> Bool
|
|
groupNtf user GroupInfo {chatSettings} mention =
|
|
userNtf user && showMessageNtf chatSettings mention
|
|
|
|
showMessageNtf :: ChatSettings -> Bool -> Bool
|
|
showMessageNtf ChatSettings {enableNtfs} mention =
|
|
enableNtfs == MFAll || (mention && enableNtfs == MFMentions)
|
|
|
|
chatItemDeletedText :: ChatItem c d -> Maybe GroupMember -> Maybe Text
|
|
chatItemDeletedText ChatItem {meta = CIMeta {itemDeleted}, content} membership_ =
|
|
deletedText <$> itemDeleted
|
|
where
|
|
deletedText = \case
|
|
CIModerated _ m -> markedDeleted content <> byMember m
|
|
CIDeleted _ -> markedDeleted content
|
|
CIBlocked _ -> "blocked"
|
|
CIBlockedByAdmin _ -> "blocked by admin"
|
|
markedDeleted = \case
|
|
CISndModerated -> "deleted"
|
|
CIRcvModerated -> "deleted"
|
|
_ -> "marked deleted"
|
|
byMember GroupMember {groupMemberId = mId, localDisplayName = n} = case membership_ of
|
|
Just GroupMember {groupMemberId = membershipId} ->
|
|
" by " <> if mId == membershipId then "you" else n
|
|
_ -> ""
|
|
|
|
viewUsersList :: [UserInfo] -> [StyledString]
|
|
viewUsersList us =
|
|
let ss = mapMaybe userInfo $ sortOn ldn us
|
|
in if null ss then ["no users"] else ss
|
|
where
|
|
ldn (UserInfo User {localDisplayName = n} _) = T.toLower n
|
|
userInfo (UserInfo User {localDisplayName = n, profile = LocalProfile {fullName}, activeUser, showNtfs, viewPwdHash} count)
|
|
| activeUser || isNothing viewPwdHash = Just $ ttyFullName n fullName <> infoStr
|
|
| otherwise = Nothing
|
|
where
|
|
infoStr = if null info then "" else " (" <> mconcat (intersperse ", " info) <> ")"
|
|
info =
|
|
[highlight' "active" | activeUser]
|
|
<> [highlight' "hidden" | isJust viewPwdHash]
|
|
<> ["muted" | not showNtfs]
|
|
<> [plain ("unread: " <> show count) | count /= 0]
|
|
|
|
viewGroupSubscribed :: GroupName -> [StyledString]
|
|
viewGroupSubscribed g = [ttyGroup g <> ": connected to server(s)"]
|
|
|
|
showSMPServer :: SMPServer -> String
|
|
showSMPServer ProtocolServer {host} = B.unpack $ strEncode host
|
|
|
|
viewHostEvent :: AProtocolType -> TransportHost -> String
|
|
viewHostEvent p h = map toUpper (B.unpack $ strEncode p) <> " host " <> B.unpack (strEncode h)
|
|
|
|
viewChats :: CurrentTime -> TimeZone -> [AChat] -> [StyledString]
|
|
viewChats ts tz = concatMap chatPreview . reverse
|
|
where
|
|
chatPreview (AChat _ (Chat chat items _)) = case items of
|
|
CChatItem _ ci : _ -> case viewChatItem chat ci True ts tz of
|
|
s : _ -> [let s' = sTake 120 s in if sLength s' < sLength s then s' <> "..." else s']
|
|
_ -> chatName
|
|
_ -> chatName
|
|
where
|
|
chatName = case chat of
|
|
DirectChat ct -> [" " <> ttyToContact' ct]
|
|
GroupChat g -> [" " <> ttyToGroup g]
|
|
_ -> []
|
|
|
|
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
|
|
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwardedByMember, userMention}, content, quotedItem, file} doShow ts tz =
|
|
withGroupMsgForwarded . withItemDeleted <$> viewCI
|
|
where
|
|
viewCI = case chat of
|
|
DirectChat c -> case chatDir of
|
|
CIDirectSnd -> case content of
|
|
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to context mc
|
|
CISndGroupEvent {} -> showSndItemProhibited to
|
|
_ -> showSndItem to
|
|
where
|
|
to = ttyToContact' c
|
|
CIDirectRcv -> case content of
|
|
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from context mc
|
|
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
|
|
CIRcvGroupEvent {} -> showRcvItemProhibited from
|
|
_ -> showRcvItem from
|
|
where
|
|
from = ttyFromContact c
|
|
where
|
|
context =
|
|
maybe
|
|
(maybe [] forwardedFrom itemForwarded)
|
|
(directQuote chatDir)
|
|
quotedItem
|
|
GroupChat g -> case chatDir of
|
|
CIGroupSnd -> case content of
|
|
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to context mc
|
|
CISndGroupInvitation {} -> showSndItemProhibited to
|
|
_ -> showSndItem to
|
|
where
|
|
to = ttyToGroup g
|
|
CIGroupRcv m -> case content of
|
|
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from context mc
|
|
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
|
|
CIRcvGroupInvitation {} -> showRcvItemProhibited from
|
|
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) context meta [plainContent content] False
|
|
CIRcvBlocked {} -> receivedWithTime_ ts tz (ttyFromGroup g m) context meta [plainContent content] False
|
|
_ -> showRcvItem from
|
|
where
|
|
from = ttyFromGroupAttention g m userMention
|
|
where
|
|
context =
|
|
maybe
|
|
(maybe [] forwardedFrom itemForwarded)
|
|
(groupQuote g)
|
|
quotedItem
|
|
LocalChat _ -> case chatDir of
|
|
CILocalSnd -> case content of
|
|
CISndMsgContent mc -> hideLive meta $ withLocalFile to $ sndMsg to context mc
|
|
CISndGroupEvent {} -> showSndItemProhibited to
|
|
_ -> showSndItem to
|
|
where
|
|
to = "* "
|
|
CILocalRcv -> case content of
|
|
CIRcvMsgContent mc -> withLocalFile from $ rcvMsg from context mc
|
|
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
|
|
CIRcvGroupEvent {} -> showRcvItemProhibited from
|
|
_ -> showRcvItem from
|
|
where
|
|
from = "* "
|
|
where
|
|
context = maybe [] forwardedFrom itemForwarded
|
|
ContactRequest {} -> []
|
|
ContactConnection {} -> []
|
|
withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of
|
|
Nothing -> item
|
|
Just t -> item <> styled (colored Red) (" [" <> t <> "]")
|
|
withGroupMsgForwarded item = case forwardedByMember of
|
|
Nothing -> item
|
|
Just _ -> item <> styled (colored Yellow) (" [>>]" :: String)
|
|
withSndFile = withFile viewSentFileInvitation
|
|
withRcvFile = withFile viewReceivedFileInvitation
|
|
withLocalFile = withFile viewLocalFile
|
|
withFile view dir l = maybe l (\f -> l <> view dir f ts tz meta) file
|
|
sndMsg = msg viewSentMessage
|
|
rcvMsg = msg viewReceivedMessage
|
|
msg view dir context mc = case (msgContentText mc, file, context) of
|
|
("", Just _, []) -> []
|
|
("", Just CIFile {fileName}, _) -> view dir context (MCText $ T.pack fileName) ts tz meta
|
|
_ -> view dir context mc ts tz meta
|
|
showSndItem to = showItem $ sentWithTime_ ts tz [to <> plainContent content] meta
|
|
showRcvItem from = showItem $ receivedWithTime_ ts tz from [] meta [plainContent content] False
|
|
showSndItemProhibited to = showItem $ sentWithTime_ ts tz [to <> plainContent content <> " " <> prohibited] meta
|
|
showRcvItemProhibited from = showItem $ receivedWithTime_ ts tz from [] meta [plainContent content <> " " <> prohibited] False
|
|
showItem ss = if doShow then ss else []
|
|
plainContent = plain . ciContentToText
|
|
prohibited = styled (colored Red) ("[unexpected chat item created, please report to developers]" :: String)
|
|
|
|
viewChatItemInfo :: AChatItem -> ChatItemInfo -> TimeZone -> [StyledString]
|
|
viewChatItemInfo (AChatItem _ msgDir _ ChatItem {meta = CIMeta {itemTs, itemTimed, createdAt}}) ChatItemInfo {itemVersions, forwardedFromChatItem} tz =
|
|
["sent at: " <> ts itemTs]
|
|
<> receivedAt
|
|
<> toBeDeletedAt
|
|
<> versions
|
|
<> forwardedFrom'
|
|
where
|
|
ts = styleTime . localTs tz
|
|
receivedAt = case msgDir of
|
|
SMDRcv -> ["received at: " <> ts createdAt]
|
|
SMDSnd -> []
|
|
toBeDeletedAt = case itemTimed >>= timedDeleteAt' of
|
|
Just d -> ["to be deleted at: " <> ts d]
|
|
Nothing -> []
|
|
versions =
|
|
if null itemVersions
|
|
then []
|
|
else ["message history:"] <> concatMap version itemVersions
|
|
where
|
|
version ChatItemVersion {msgContent, itemVersionTs} = prependFirst (ts itemVersionTs <> styleTime ": ") $ ttyMsgContent msgContent
|
|
forwardedFrom' =
|
|
case forwardedFromChatItem of
|
|
Just fwdACI@(AChatItem _ fwdMsgDir fwdChatInfo _) ->
|
|
[plain $ "forwarded from: " <> maybe "" (<> ", ") fwdDir_ <> fwdItemId]
|
|
where
|
|
fwdDir_ = case (fwdMsgDir, fwdChatInfo) of
|
|
(SMDSnd, DirectChat ct) -> Just $ "you @" <> viewContactName ct
|
|
(SMDRcv, DirectChat ct) -> Just $ "@" <> viewContactName ct
|
|
(SMDSnd, GroupChat gInfo) -> Just $ "you #" <> viewGroupName gInfo
|
|
(SMDRcv, GroupChat gInfo) -> Just $ "#" <> viewGroupName gInfo
|
|
_ -> Nothing
|
|
fwdItemId = "chat item id: " <> (T.pack . show $ aChatItemId fwdACI)
|
|
_ -> []
|
|
|
|
localTs :: TimeZone -> UTCTime -> String
|
|
localTs tz ts = do
|
|
let localTime = utcToLocalTime tz ts
|
|
formattedTime = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" localTime
|
|
formattedTime
|
|
|
|
viewChatItemStatusUpdated :: AChatItem -> CurrentTime -> TimeZone -> Bool -> Bool -> [StyledString]
|
|
viewChatItemStatusUpdated (AChatItem _ _ chat item@ChatItem {meta = CIMeta {itemStatus}}) ts tz testView showReceipts =
|
|
case itemStatus of
|
|
CISSndRcvd rcptStatus SSPPartial ->
|
|
if testView && showReceipts
|
|
then prependFirst (viewDeliveryReceiptPartial rcptStatus <> " ") $ viewChatItem chat item False ts tz
|
|
else []
|
|
CISSndRcvd rcptStatus SSPComplete ->
|
|
if testView && showReceipts
|
|
then prependFirst (viewDeliveryReceipt rcptStatus <> " ") $ viewChatItem chat item False ts tz
|
|
else []
|
|
_ -> []
|
|
|
|
viewDeliveryReceiptPartial :: MsgReceiptStatus -> StyledString
|
|
viewDeliveryReceiptPartial = \case
|
|
MROk -> "%"
|
|
MRBadMsgHash -> ttyError' "%!"
|
|
|
|
viewDeliveryReceipt :: MsgReceiptStatus -> StyledString
|
|
viewDeliveryReceipt = \case
|
|
MROk -> "⩗"
|
|
MRBadMsgHash -> ttyError' "⩗!"
|
|
|
|
viewItemUpdate :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
|
|
viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, itemEdited, itemLive}, content, quotedItem} liveItems ts tz = case chat of
|
|
DirectChat c -> case chatDir of
|
|
CIDirectRcv -> case content of
|
|
CIRcvMsgContent mc
|
|
| itemLive == Just True && not liveItems -> []
|
|
| otherwise -> viewReceivedUpdatedMessage from context mc ts tz meta
|
|
_ -> []
|
|
where
|
|
from = if itemEdited then ttyFromContactEdited c else ttyFromContact c
|
|
CIDirectSnd -> case content of
|
|
CISndMsgContent mc -> hideLive meta $ viewSentMessage to context mc ts tz meta
|
|
_ -> []
|
|
where
|
|
to = if itemEdited then ttyToContactEdited' c else ttyToContact' c
|
|
where
|
|
context =
|
|
maybe
|
|
(maybe [] forwardedFrom itemForwarded)
|
|
(directQuote chatDir)
|
|
quotedItem
|
|
GroupChat g -> case chatDir of
|
|
CIGroupRcv m -> case content of
|
|
CIRcvMsgContent mc
|
|
| itemLive == Just True && not liveItems -> []
|
|
| otherwise -> viewReceivedUpdatedMessage from context mc ts tz meta
|
|
_ -> []
|
|
where
|
|
from = if itemEdited then ttyFromGroupEdited g m else ttyFromGroup g m
|
|
CIGroupSnd -> case content of
|
|
CISndMsgContent mc -> hideLive meta $ viewSentMessage to context mc ts tz meta
|
|
_ -> []
|
|
where
|
|
to = if itemEdited then ttyToGroupEdited g else ttyToGroup g
|
|
where
|
|
context =
|
|
maybe
|
|
(maybe [] forwardedFrom itemForwarded)
|
|
(groupQuote g)
|
|
quotedItem
|
|
_ -> []
|
|
|
|
hideLive :: CIMeta c d -> [StyledString] -> [StyledString]
|
|
hideLive CIMeta {itemLive = Just True} _ = []
|
|
hideLive _ s = s
|
|
|
|
viewItemNotChanged :: AChatItem -> [StyledString]
|
|
viewItemNotChanged (AChatItem _ msgDir _ _) = case msgDir of
|
|
SMDSnd -> ["message didn't change"]
|
|
SMDRcv -> []
|
|
|
|
viewItemDelete :: ChatInfo c -> ChatItem c d -> Maybe AChatItem -> Bool -> Bool -> CurrentTime -> TimeZone -> Bool -> [StyledString]
|
|
viewItemDelete chat ci@ChatItem {chatDir, meta, content = deletedContent} toItem byUser timed ts tz testView
|
|
| timed = [plain ("timed message deleted: " <> T.unpack (ciContentToText deletedContent)) | testView]
|
|
| byUser = [plain $ "message " <> T.unpack (fromMaybe "deleted" deletedText_)] -- deletedText_ Nothing should be impossible here
|
|
| otherwise = case chat of
|
|
DirectChat c -> case (chatDir, deletedContent) of
|
|
(CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c deletedText_) [] mc ts tz meta
|
|
_ -> prohibited
|
|
GroupChat g -> case ciMsgContent deletedContent of
|
|
Just mc ->
|
|
let m = chatItemMember g ci
|
|
in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta
|
|
_ -> prohibited
|
|
_ -> prohibited
|
|
where
|
|
deletedText_ :: Maybe Text
|
|
deletedText_ = case toItem of
|
|
Nothing -> Just "deleted"
|
|
Just (AChatItem _ _ _ ci') -> chatItemDeletedText ci' $ chatInfoMembership chat
|
|
prohibited = [styled (colored Red) ("[unexpected message deletion, please report to developers]" :: String)]
|
|
|
|
viewItemReaction :: forall c d. Bool -> ChatInfo c -> CIReaction c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
|
|
viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md ChatItem {chatDir = itemDir, content}, sentAt, reaction} added ts tz =
|
|
case (chat, chatDir) of
|
|
(DirectChat c, CIDirectRcv) -> case ciMsgContent content of
|
|
Just mc -> view from $ reactionMsg mc
|
|
_ -> []
|
|
where
|
|
from = ttyFromContact c
|
|
reactionMsg mc = quoteText mc $ if toMsgDirection md == MDSnd then ">>" else ">"
|
|
(GroupChat g, CIGroupRcv m) -> case ciMsgContent content of
|
|
Just mc -> view from $ reactionMsg mc
|
|
_ -> []
|
|
where
|
|
from = ttyFromGroup g m
|
|
reactionMsg mc = quoteText mc . ttyQuotedMember . Just $ sentByMember' g itemDir
|
|
(LocalChat _, CILocalRcv) -> case ciMsgContent content of
|
|
Just mc -> view from $ reactionMsg mc
|
|
_ -> []
|
|
where
|
|
from = "* "
|
|
reactionMsg mc = quoteText mc $ if toMsgDirection md == MDSnd then ">>" else ">"
|
|
(_, CIDirectSnd) -> [sentText]
|
|
(_, CIGroupSnd) -> [sentText]
|
|
(_, CILocalSnd) -> [sentText]
|
|
where
|
|
view from msg
|
|
| showReactions = viewReceivedReaction from msg reactionText ts tz sentAt
|
|
| otherwise = []
|
|
reactionText = plain $ (if added then "+ " else "- ") <> [emoji]
|
|
emoji = case reaction of
|
|
MREmoji (MREmojiChar c) -> c
|
|
_ -> '?'
|
|
sentText = plain $ (if added then "added " else "removed ") <> [emoji]
|
|
|
|
viewItemReactions :: ChatItem c d -> [StyledString]
|
|
viewItemReactions ChatItem {reactions} = [" " <> viewReactions reactions | not (null reactions)]
|
|
where
|
|
viewReactions = mconcat . intersperse " " . map viewReaction
|
|
viewReaction CIReactionCount {reaction = MRUnknown {}} = "?"
|
|
viewReaction CIReactionCount {reaction = MREmoji (MREmojiChar emoji), userReacted, totalReacted} =
|
|
plain [emoji, ' '] <> (if userReacted then styled Italic else plain) (show totalReacted)
|
|
|
|
viewReactionMembers :: [MemberReaction] -> [StyledString]
|
|
viewReactionMembers memberReactions = [sShow (length memberReactions) <> " member(s) reacted"]
|
|
|
|
directQuote :: forall d'. MsgDirectionI d' => CIDirection 'CTDirect d' -> CIQuote 'CTDirect -> [StyledString]
|
|
directQuote _ CIQuote {content = qmc, chatDir = quoteDir} =
|
|
quoteText qmc $ if toMsgDirection (msgDirection @d') == quoteMsgDirection quoteDir then ">>" else ">"
|
|
|
|
groupQuote :: GroupInfo -> CIQuote 'CTGroup -> [StyledString]
|
|
groupQuote g CIQuote {content = qmc, chatDir = quoteDir} = quoteText qmc . ttyQuotedMember $ sentByMember g quoteDir
|
|
|
|
forwardedFrom :: CIForwardedFrom -> [StyledString]
|
|
forwardedFrom = \case
|
|
CIFFUnknown -> ["-> forwarded"]
|
|
CIFFContact c MDSnd _ _ -> ["<- you @" <> (plain . viewName) c]
|
|
CIFFContact c MDRcv _ _ -> ["<- @" <> (plain . viewName) c]
|
|
CIFFGroup g MDSnd _ _ -> ["<- you #" <> (plain . viewName) g]
|
|
CIFFGroup g MDRcv _ _ -> ["<- #" <> (plain . viewName) g]
|
|
|
|
sentByMember :: GroupInfo -> CIQDirection 'CTGroup -> Maybe GroupMember
|
|
sentByMember GroupInfo {membership} = \case
|
|
CIQGroupSnd -> Just membership
|
|
CIQGroupRcv m -> m
|
|
|
|
sentByMember' :: GroupInfo -> CIDirection 'CTGroup d -> GroupMember
|
|
sentByMember' GroupInfo {membership} = \case
|
|
CIGroupSnd -> membership
|
|
CIGroupRcv m -> m
|
|
|
|
quoteText :: MsgContent -> StyledString -> [StyledString]
|
|
quoteText qmc sentBy = prependFirst (sentBy <> " ") $ msgPreview qmc
|
|
|
|
msgPreview :: MsgContent -> [StyledString]
|
|
msgPreview = msgPlain . preview . msgContentText
|
|
where
|
|
preview t
|
|
| T.length t <= 120 = t
|
|
| otherwise = T.take 120 t <> "..."
|
|
|
|
viewRcvIntegrityError :: StyledString -> MsgErrorType -> CurrentTime -> TimeZone -> CIMeta c 'MDRcv -> [StyledString]
|
|
viewRcvIntegrityError from msgErr ts tz meta = receivedWithTime_ ts tz from [] meta (viewMsgIntegrityError msgErr) False
|
|
|
|
viewMsgIntegrityError :: MsgErrorType -> [StyledString]
|
|
viewMsgIntegrityError err = [ttyError $ msgIntegrityError err]
|
|
|
|
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
|
|
]
|
|
|
|
viewConnReqInvitation :: ConnReqInvitation -> [StyledString]
|
|
viewConnReqInvitation cReq =
|
|
[ "pass this invitation link to your contact (via another channel): ",
|
|
"",
|
|
(plain . strEncode) (simplexChatInvitation cReq),
|
|
"",
|
|
"and ask them to connect: " <> highlight' "/c <invitation_link_above>"
|
|
]
|
|
|
|
simplexChatInvitation :: ConnReqInvitation -> ConnReqInvitation
|
|
simplexChatInvitation (CRInvitationUri crData e2e) = CRInvitationUri crData {crScheme = simplexChat} e2e
|
|
|
|
viewContactNotFound :: ContactName -> Maybe (GroupInfo, GroupMember) -> [StyledString]
|
|
viewContactNotFound cName suspectedMember =
|
|
["no contact " <> ttyContact cName <> useMessageMember]
|
|
where
|
|
useMessageMember = case suspectedMember of
|
|
Just (g, m) -> ", use " <> highlight ("@#" <> viewGroupName g <> " " <> viewMemberName m <> " <your message>")
|
|
_ -> ""
|
|
|
|
viewChatCleared :: AChatInfo -> [StyledString]
|
|
viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of
|
|
DirectChat ct -> [ttyContact' ct <> ": all messages are removed locally ONLY"]
|
|
GroupChat gi -> [ttyGroup' gi <> ": all messages are removed locally ONLY"]
|
|
LocalChat _ -> ["notes: all messages are removed"]
|
|
ContactRequest _ -> []
|
|
ContactConnection _ -> []
|
|
|
|
viewContactsList :: [Contact] -> [StyledString]
|
|
viewContactsList =
|
|
let getLDN :: Contact -> ContactName
|
|
getLDN Contact {localDisplayName} = localDisplayName
|
|
ldn = T.toLower . getLDN
|
|
in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn
|
|
where
|
|
muted' Contact {chatSettings, localDisplayName = ldn}
|
|
| chatHasNtfs chatSettings = ""
|
|
| otherwise = " (muted, you can " <> highlight ("/unmute @" <> ldn) <> ")"
|
|
alias Contact {profile = LocalProfile {localAlias}}
|
|
| localAlias == "" = ""
|
|
| otherwise = " (alias: " <> plain localAlias <> ")"
|
|
|
|
viewUserContactLinkDeleted :: [StyledString]
|
|
viewUserContactLinkDeleted =
|
|
[ "Your chat address is deleted - accepted contacts will remain connected.",
|
|
"To create a new chat address use " <> highlight' "/ad"
|
|
]
|
|
|
|
viewForwardPlan :: Int -> [ChatItemId] -> Maybe ForwardConfirmation -> [StyledString]
|
|
viewForwardPlan count itemIds = maybe [forwardCount] $ \fc -> [confirmation fc, forwardCount]
|
|
where
|
|
confirmation = \case
|
|
FCFilesNotAccepted fileIds -> plain $ "Files can be received: " <> intercalate ", " (map show fileIds)
|
|
FCFilesInProgress cnt -> plain $ "Still receiving " <> show cnt <> " file(s)"
|
|
FCFilesMissing cnt -> plain $ show cnt <> " file(s) are missing"
|
|
FCFilesFailed cnt -> plain $ "Receiving " <> show cnt <> " file(s) failed"
|
|
forwardCount
|
|
| count == len = "all messages can be forwarded"
|
|
| len == 0 = "nothing to forward"
|
|
| otherwise = plain $ show len <> " message(s) out of " <> show count <> " can be forwarded"
|
|
len = length itemIds
|
|
|
|
connReqContact_ :: StyledString -> ConnReqContact -> [StyledString]
|
|
connReqContact_ intro cReq =
|
|
[ intro,
|
|
"",
|
|
(plain . strEncode) (simplexChatContact cReq),
|
|
"",
|
|
"Anybody can send you contact requests with: " <> highlight' "/c <contact_link_above>",
|
|
"to show it again: " <> highlight' "/sa",
|
|
"to share with your contacts: " <> highlight' "/profile_address on",
|
|
"to delete it: " <> highlight' "/da" <> " (accepted contacts will remain connected)"
|
|
]
|
|
|
|
simplexChatContact :: ConnReqContact -> ConnReqContact
|
|
simplexChatContact (CRContactUri crData) = CRContactUri crData {crScheme = simplexChat}
|
|
|
|
autoAcceptStatus_ :: Maybe AutoAccept -> [StyledString]
|
|
autoAcceptStatus_ = \case
|
|
Just AutoAccept {businessAddress, acceptIncognito, autoReply} ->
|
|
("auto_accept on" <> aaInfo)
|
|
: maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply
|
|
where
|
|
aaInfo
|
|
| businessAddress = ", business"
|
|
| acceptIncognito = ", incognito"
|
|
| otherwise = ""
|
|
_ -> ["auto_accept off"]
|
|
|
|
groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> GroupMemberRole -> [StyledString]
|
|
groupLink_ intro g cReq mRole =
|
|
[ intro,
|
|
"",
|
|
(plain . strEncode) (simplexChatContact cReq),
|
|
"",
|
|
"Anybody can connect to you and join group as " <> showRole mRole <> " with: " <> highlight' "/c <group_link_above>",
|
|
"to show it again: " <> highlight ("/show link #" <> viewGroupName g),
|
|
"to delete it: " <> highlight ("/delete link #" <> viewGroupName g) <> " (joined members will remain connected to you)"
|
|
]
|
|
|
|
viewGroupLinkDeleted :: GroupInfo -> [StyledString]
|
|
viewGroupLinkDeleted g =
|
|
[ "Group link is deleted - joined members will remain connected.",
|
|
"To create a new group link use " <> highlight ("/create link #" <> viewGroupName g)
|
|
]
|
|
|
|
viewSentInvitation :: Maybe Profile -> Bool -> [StyledString]
|
|
viewSentInvitation incognitoProfile testView =
|
|
case incognitoProfile of
|
|
Just profile ->
|
|
if testView
|
|
then incognitoProfile' profile : message
|
|
else message
|
|
where
|
|
message = ["connection request sent incognito!"]
|
|
Nothing -> ["connection request sent!"]
|
|
|
|
viewAcceptingContactRequest :: Contact -> [StyledString]
|
|
viewAcceptingContactRequest ct
|
|
| contactReady ct = [ttyFullContact ct <> ": accepting contact request, you can send messages to contact"]
|
|
| otherwise = [ttyFullContact ct <> ": accepting contact request..."]
|
|
|
|
viewAcceptingBusinessRequest :: GroupInfo -> [StyledString]
|
|
viewAcceptingBusinessRequest g = [ttyFullGroup g <> ": accepting business address request..."]
|
|
|
|
viewReceivedContactRequest :: ContactName -> Profile -> [StyledString]
|
|
viewReceivedContactRequest c Profile {fullName} =
|
|
[ ttyFullName c fullName <> " wants to connect to you!",
|
|
"to accept: " <> highlight ("/ac " <> viewName c),
|
|
"to reject: " <> highlight ("/rc " <> viewName c) <> " (the sender will NOT be notified)"
|
|
]
|
|
|
|
viewGroupCreated :: GroupInfo -> Bool -> [StyledString]
|
|
viewGroupCreated g testView =
|
|
case incognitoMembershipProfile g of
|
|
Just localProfile
|
|
| testView -> incognitoProfile' profile : message
|
|
| otherwise -> message
|
|
where
|
|
profile = fromLocalProfile localProfile
|
|
message =
|
|
[ "group " <> ttyFullGroup g <> " is created, your incognito profile for this group is " <> incognitoProfile' profile,
|
|
"to add members use " <> highlight ("/create link #" <> viewGroupName g)
|
|
]
|
|
Nothing ->
|
|
[ "group " <> ttyFullGroup g <> " is created",
|
|
"to add members use " <> highlight ("/a " <> viewGroupName g <> " <name>") <> " or " <> highlight ("/create link #" <> viewGroupName g)
|
|
]
|
|
|
|
viewCannotResendInvitation :: GroupInfo -> ContactName -> [StyledString]
|
|
viewCannotResendInvitation g c =
|
|
[ ttyContact c <> " is already invited to group " <> ttyGroup' g,
|
|
"to re-send invitation: " <> highlight ("/rm " <> viewGroupName g <> " " <> c) <> ", " <> highlight ("/a " <> viewGroupName g <> " " <> viewName c)
|
|
]
|
|
|
|
viewDirectMessagesProhibited :: MsgDirection -> Contact -> [StyledString]
|
|
viewDirectMessagesProhibited MDSnd c = ["direct messages to indirect contact " <> ttyContact' c <> " are prohibited"]
|
|
viewDirectMessagesProhibited MDRcv c = ["received prohibited direct message from indirect contact " <> ttyContact' c <> " (discarded)"]
|
|
|
|
viewNetworkStatuses :: [ConnNetworkStatus] -> [StyledString]
|
|
viewNetworkStatuses = map viewStatuses . L.groupBy ((==) `on` netStatus) . sortOn netStatus
|
|
where
|
|
netStatus ConnNetworkStatus {networkStatus} = networkStatus
|
|
viewStatuses ss@(s :| _) = plain $ show (L.length ss) <> " connections " <> netStatusStr (netStatus s)
|
|
|
|
viewUserJoinedGroup :: GroupInfo -> [StyledString]
|
|
viewUserJoinedGroup g =
|
|
case incognitoMembershipProfile g of
|
|
Just mp -> [ttyGroup' g <> ": you joined the group incognito as " <> incognitoProfile' (fromLocalProfile mp)]
|
|
Nothing -> [ttyGroup' g <> ": you joined the group"]
|
|
|
|
viewJoinedGroupMember :: GroupInfo -> GroupMember -> [StyledString]
|
|
viewJoinedGroupMember g m =
|
|
[ttyGroup' g <> ": " <> ttyMember m <> " joined the group "]
|
|
|
|
viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString]
|
|
viewReceivedGroupInvitation g c role =
|
|
ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role)
|
|
: case incognitoMembershipProfile g of
|
|
Just mp -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to join incognito as " <> incognitoProfile' (fromLocalProfile mp)]
|
|
Nothing -> ["use " <> highlight ("/j " <> viewGroupName g) <> " to accept"]
|
|
|
|
groupPreserved :: GroupInfo -> [StyledString]
|
|
groupPreserved g = ["use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the group"]
|
|
|
|
connectedMember :: GroupMember -> StyledString
|
|
connectedMember m = case memberCategory m of
|
|
GCPreMember -> "member " <> ttyFullMember m
|
|
GCPostMember -> "new member " <> ttyMember m -- without fullName as as it was shown in joinedGroupMemberConnecting
|
|
_ -> "member " <> ttyMember m -- these case is not used
|
|
|
|
viewMemberRoleChanged :: GroupInfo -> GroupMember -> GroupMember -> GroupMemberRole -> GroupMemberRole -> [StyledString]
|
|
viewMemberRoleChanged g@GroupInfo {membership} by m r r'
|
|
| r == r' = [ttyGroup' g <> ": member role did not change"]
|
|
| groupMemberId' membership == memId = view "your role"
|
|
| groupMemberId' by == memId = view "the role"
|
|
| otherwise = view $ "the role of " <> ttyMember m
|
|
where
|
|
memId = groupMemberId' m
|
|
view s = [ttyGroup' g <> ": " <> ttyMember by <> " changed " <> s <> " from " <> showRole r <> " to " <> showRole r']
|
|
|
|
viewMemberRoleUserChanged :: GroupInfo -> GroupMember -> GroupMemberRole -> GroupMemberRole -> [StyledString]
|
|
viewMemberRoleUserChanged g@GroupInfo {membership} m r r'
|
|
| r == r' = [ttyGroup' g <> ": member role did not change"]
|
|
| groupMemberId' membership == groupMemberId' m = view "your role"
|
|
| otherwise = view $ "the role of " <> ttyMember m
|
|
where
|
|
view s = [ttyGroup' g <> ": you changed " <> s <> " from " <> showRole r <> " to " <> showRole r']
|
|
|
|
viewMemberBlockedForAll :: GroupInfo -> GroupMember -> GroupMember -> Bool -> [StyledString]
|
|
viewMemberBlockedForAll g by m blocked =
|
|
[ttyGroup' g <> ": " <> ttyMember by <> " " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m]
|
|
|
|
viewMemberBlockedForAllUser :: GroupInfo -> GroupMember -> Bool -> [StyledString]
|
|
viewMemberBlockedForAllUser g m blocked =
|
|
[ttyGroup' g <> ": you " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m]
|
|
|
|
showRole :: GroupMemberRole -> StyledString
|
|
showRole = plain . strEncode
|
|
|
|
viewGroupMembers :: Group -> [StyledString]
|
|
viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filter (not . removedOrLeft) $ membership : members
|
|
where
|
|
removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft
|
|
groupMember m = memIncognito m <> ttyFullMember m <> ": " <> plain (intercalate ", " $ [role m] <> category m <> status m <> muted m)
|
|
role :: GroupMember -> String
|
|
role GroupMember {memberRole} = B.unpack $ strEncode memberRole
|
|
category m = case memberCategory m of
|
|
GCUserMember -> ["you"]
|
|
GCInviteeMember -> ["invited"]
|
|
GCHostMember -> ["host"]
|
|
_ -> []
|
|
status m = case memberStatus m of
|
|
GSMemRemoved -> ["removed"]
|
|
GSMemLeft -> ["left"]
|
|
GSMemUnknown -> ["status unknown"]
|
|
GSMemInvited -> ["not yet joined"]
|
|
GSMemConnected -> ["connected"]
|
|
GSMemComplete -> ["connected"]
|
|
GSMemCreator -> ["created group"]
|
|
_ -> []
|
|
muted m
|
|
| blockedByAdmin m = ["blocked by admin"]
|
|
| not (showMessages $ memberSettings m) = ["blocked"]
|
|
| otherwise = []
|
|
|
|
viewContactConnected :: Contact -> Maybe Profile -> Bool -> [StyledString]
|
|
viewContactConnected ct userIncognitoProfile testView =
|
|
case userIncognitoProfile of
|
|
Just profile ->
|
|
if testView
|
|
then incognitoProfile' profile : message
|
|
else message
|
|
where
|
|
message =
|
|
[ ttyFullContact ct <> ": contact is connected, your incognito profile for this contact is " <> incognitoProfile' profile,
|
|
"use " <> highlight ("/i " <> viewContactName ct) <> " to print out this incognito profile again"
|
|
]
|
|
Nothing ->
|
|
[ttyFullContact ct <> ": contact is connected"]
|
|
|
|
viewGroupsList :: [(GroupInfo, GroupSummary)] -> [StyledString]
|
|
viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"]
|
|
viewGroupsList gs = map groupSS $ sortOn (ldn_ . fst) gs
|
|
where
|
|
ldn_ :: GroupInfo -> Text
|
|
ldn_ GroupInfo {localDisplayName} = T.toLower localDisplayName
|
|
groupSS (g@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}}, GroupSummary {currentMembers}) =
|
|
case memberStatus membership of
|
|
GSMemInvited -> groupInvitation' g
|
|
s -> membershipIncognito g <> ttyFullGroup g <> viewMemberStatus s <> alias g
|
|
where
|
|
viewMemberStatus = \case
|
|
GSMemRemoved -> delete "you are removed"
|
|
GSMemLeft -> delete "you left"
|
|
GSMemGroupDeleted -> delete "group deleted"
|
|
_ -> " (" <> memberCount <> viewNtf <> ")"
|
|
where
|
|
viewNtf = case enableNtfs of
|
|
MFAll -> ""
|
|
MFNone -> ", muted, " <> unmute
|
|
MFMentions -> ", mentions only, " <> unmute
|
|
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g)
|
|
delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")"
|
|
memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s"
|
|
alias GroupInfo {localAlias}
|
|
| localAlias == "" = ""
|
|
| otherwise = " (alias: " <> plain localAlias <> ")"
|
|
|
|
groupInvitation' :: GroupInfo -> StyledString
|
|
groupInvitation' g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}} =
|
|
highlight ("#" <> viewName ldn)
|
|
<> optFullName ldn fullName
|
|
<> " - you are invited ("
|
|
<> highlight ("/j " <> viewName ldn)
|
|
<> joinText
|
|
<> highlight ("/d #" <> viewName ldn)
|
|
<> " to delete invitation)"
|
|
where
|
|
joinText = case incognitoMembershipProfile g of
|
|
Just mp -> " to join as " <> incognitoProfile' (fromLocalProfile mp) <> ", "
|
|
Nothing -> " to join, "
|
|
|
|
groupInvitationSub :: ShortGroupInfo -> StyledString
|
|
groupInvitationSub ShortGroupInfo {groupName = ldn} =
|
|
highlight ("#" <> viewName ldn)
|
|
<> " - you are invited ("
|
|
<> highlight ("/j " <> viewName ldn)
|
|
<> " to join, "
|
|
<> highlight ("/d #" <> viewName ldn)
|
|
<> " to delete invitation)"
|
|
|
|
viewContactsMerged :: Contact -> Contact -> Contact -> [StyledString]
|
|
viewContactsMerged c1 c2 ct' =
|
|
[ "contact " <> ttyContact' c2 <> " is merged into " <> ttyContact' c1,
|
|
"use " <> ttyToContact' ct' <> highlight' "<message>" <> " to send messages"
|
|
]
|
|
|
|
viewContactAndMemberAssociated :: Contact -> GroupInfo -> GroupMember -> Contact -> [StyledString]
|
|
viewContactAndMemberAssociated ct g m ct' =
|
|
[ "contact and member are merged: " <> ttyContact' ct <> ", " <> ttyGroup' g <> " " <> ttyMember m,
|
|
"use " <> ttyToContact' ct' <> highlight' "<message>" <> " to send messages"
|
|
]
|
|
|
|
viewUserProfile :: Profile -> [StyledString]
|
|
viewUserProfile Profile {displayName, fullName} =
|
|
[ "user profile: " <> ttyFullName displayName fullName,
|
|
"use " <> highlight' "/p <display name>" <> " to change it",
|
|
"(the updated profile will be sent to all your contacts)"
|
|
]
|
|
|
|
viewUserPrivacy :: User -> User -> [StyledString]
|
|
viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', showNtfs, viewPwdHash} =
|
|
[ plain $ (if userId == userId' then "current " else "") <> "user " <> viewName n' <> ":",
|
|
"messages are " <> if showNtfs then "shown" else "hidden (use /tail to view)",
|
|
"profile is " <> if isJust viewPwdHash then "hidden" else "visible"
|
|
]
|
|
|
|
viewUserServers :: UserOperatorServers -> [StyledString]
|
|
viewUserServers (UserOperatorServers _ [] []) = []
|
|
viewUserServers UserOperatorServers {operator, smpServers, xftpServers} =
|
|
[plain $ maybe "Your servers" shortViewOperator operator]
|
|
<> viewServers SPSMP smpServers
|
|
<> viewServers SPXFTP xftpServers
|
|
where
|
|
viewServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [UserServer p] -> [StyledString]
|
|
viewServers _ [] = []
|
|
viewServers p srvs
|
|
| maybe True (\ServerOperator {enabled} -> enabled) operator =
|
|
[" " <> protocolName p <> " servers" <> maybe "" ((" " <>) . viewRoles) operator]
|
|
<> map (plain . (" " <>) . viewServer) srvs
|
|
| otherwise = []
|
|
where
|
|
viewServer UserServer {server, preset, tested, enabled} = safeDecodeUtf8 (strEncode server) <> serverInfo
|
|
where
|
|
serverInfo = if null serverInfo_ then "" else parens $ T.intercalate ", " serverInfo_
|
|
serverInfo_ = ["preset" | preset] <> testedInfo <> ["disabled" | not enabled]
|
|
testedInfo = maybe [] (\t -> ["test: " <> if t then "passed" else "failed"]) tested
|
|
viewRoles op@ServerOperator {enabled}
|
|
| not enabled = "disabled"
|
|
| storage rs && proxy rs = "enabled"
|
|
| storage rs = "enabled storage"
|
|
| proxy rs = "enabled proxy"
|
|
| otherwise = "disabled (servers known)"
|
|
where
|
|
rs = operatorRoles p op
|
|
|
|
serversUserHelp :: [StyledString]
|
|
serversUserHelp =
|
|
[ "",
|
|
"use " <> highlight' "/smp test <srv>" <> " to test SMP server connection",
|
|
"use " <> highlight' "/smp <srv1[,srv2,...]>" <> " to configure SMP servers",
|
|
"or the same commands starting from /xftp for XFTP servers",
|
|
"chat options " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") and " <> highlight' "--xftp-servers" <> " have precedence over preset servers for new user profiles"
|
|
]
|
|
|
|
protocolName :: ProtocolTypeI p => SProtocolType p -> StyledString
|
|
protocolName = plain . map toUpper . T.unpack . decodeLatin1 . strEncode
|
|
|
|
viewServerTestResult :: AProtoServerWithAuth -> Maybe ProtocolTestFailure -> [StyledString]
|
|
viewServerTestResult (AProtoServerWithAuth p _) = \case
|
|
Just ProtocolTestFailure {testStep, testError} ->
|
|
result
|
|
<> [pName <> " server requires authorization to create queues, check password" | testStep == TSCreateQueue && (case testError of SMP _ SMP.AUTH -> True; _ -> False)]
|
|
<> [pName <> " server requires authorization to upload files, check password" | testStep == TSCreateFile && (case testError of XFTP _ XFTP.AUTH -> True; _ -> False)]
|
|
<> ["Possibly, certificate fingerprint in " <> pName <> " server address is incorrect" | testStep == TSConnect && brokerErr]
|
|
where
|
|
result = [pName <> " server test failed at " <> plain (drop 2 $ show testStep) <> ", error: " <> sShow testError]
|
|
brokerErr = case testError of
|
|
BROKER _ NETWORK -> True
|
|
_ -> False
|
|
_ -> [pName <> " server test passed"]
|
|
where
|
|
pName = protocolName p
|
|
|
|
viewServerOperators :: [ServerOperator] -> Maybe UsageConditionsAction -> [StyledString]
|
|
viewServerOperators ops ca = map (plain . viewOperator) ops <> maybe [] viewConditionsAction ca
|
|
|
|
viewOperator :: ServerOperator' s -> Text
|
|
viewOperator op@ServerOperator {tradeName, legalName, serverDomains, conditionsAcceptance} =
|
|
viewOpIdTag op
|
|
<> tradeName
|
|
<> maybe "" parens legalName
|
|
<> (", domains: " <> T.intercalate ", " serverDomains)
|
|
<> (", servers: " <> viewOpEnabled op)
|
|
<> (", conditions: " <> viewOpConditions conditionsAcceptance)
|
|
|
|
shortViewOperator :: ServerOperator -> Text
|
|
shortViewOperator ServerOperator {operatorId = DBEntityId opId, tradeName, enabled} =
|
|
tshow opId <> ". " <> tradeName <> parens (if enabled then "enabled" else "disabled")
|
|
|
|
viewOpIdTag :: ServerOperator' s -> Text
|
|
viewOpIdTag ServerOperator {operatorId, operatorTag} = case operatorId of
|
|
DBEntityId i -> tshow i <> tag
|
|
DBNewEntity -> tag
|
|
where
|
|
tag = maybe "" (parens . textEncode) operatorTag <> ". "
|
|
|
|
viewOpConditions :: ConditionsAcceptance -> Text
|
|
viewOpConditions = \case
|
|
CAAccepted ts _ -> viewCond "accepted" ts
|
|
CARequired ts -> viewCond "required" ts
|
|
where
|
|
viewCond w ts = w <> maybe "" (parens . tshow) ts
|
|
|
|
viewOpEnabled :: ServerOperator' s -> Text
|
|
viewOpEnabled ServerOperator {enabled, smpRoles, xftpRoles}
|
|
| not enabled = "disabled"
|
|
| no smpRoles && no xftpRoles = "disabled (servers known)"
|
|
| both smpRoles && both xftpRoles = "enabled"
|
|
| otherwise = "SMP " <> viewRoles smpRoles <> ", XFTP " <> viewRoles xftpRoles
|
|
where
|
|
no rs = not $ storage rs || proxy rs
|
|
both rs = storage rs && proxy rs
|
|
viewRoles rs
|
|
| both rs = "enabled"
|
|
| storage rs = "enabled storage"
|
|
| proxy rs = "enabled proxy"
|
|
| otherwise = "disabled (servers known)"
|
|
|
|
viewConditionsAction :: UsageConditionsAction -> [StyledString]
|
|
viewConditionsAction = \case
|
|
UCAReview {operators, deadline, showNotice} | showNotice -> case deadline of
|
|
Just ts -> [plain $ "The new conditions will be accepted for " <> ops <> " at " <> tshow ts]
|
|
Nothing -> [plain $ "The new conditions have to be accepted for " <> ops]
|
|
where
|
|
ops = T.intercalate ", " $ map legalName_ operators
|
|
legalName_ ServerOperator {tradeName, legalName} = fromMaybe tradeName legalName
|
|
_ -> []
|
|
|
|
viewUsageConditions :: UsageConditions -> Maybe UsageConditions -> [StyledString]
|
|
viewUsageConditions current accepted_ =
|
|
[plain $ "Current conditions: " <> viewConds current <> maybe "" (\ac -> ", accepted conditions: " <> viewConds ac) accepted_]
|
|
where
|
|
viewConds UsageConditions {conditionsId, conditionsCommit, notifiedAt} =
|
|
tshow conditionsId <> maybe "" (const " (notified)") notifiedAt <> ". " <> conditionsCommit
|
|
|
|
viewChatItemTTL :: Maybe Int64 -> [StyledString]
|
|
viewChatItemTTL = \case
|
|
Nothing -> ["old messages are set to delete according to default user config"]
|
|
Just ttl
|
|
| ttl == 0 -> ["old messages are not being deleted"]
|
|
| ttl == 86400 -> deletedAfter "one day"
|
|
| ttl == 7 * 86400 -> deletedAfter "one week"
|
|
| ttl == 30 * 86400 -> deletedAfter "one month"
|
|
| ttl == 365 * 86400 -> deletedAfter "one year"
|
|
| otherwise -> deletedAfter $ sShow ttl <> " second(s)"
|
|
where
|
|
deletedAfter ttlStr = ["old messages are set to be deleted after: " <> ttlStr]
|
|
|
|
viewNetworkConfig :: NetworkConfig -> [StyledString]
|
|
viewNetworkConfig NetworkConfig {socksProxy, socksMode, tcpTimeout, smpProxyMode, smpProxyFallback} =
|
|
[ plain $ maybe "direct network connection" ((\sp -> "using SOCKS5 proxy " <> sp <> if socksMode == SMOnion then " for onion servers ONLY." else " for ALL servers.") . show) socksProxy,
|
|
"TCP timeout: " <> sShow tcpTimeout,
|
|
plain $ smpProxyModeStr smpProxyMode smpProxyFallback,
|
|
"use " <> highlight' "/network socks=<on/off/[ipv4]:port>[ socks-mode=always/onion][ smp-proxy=always/unknown/unprotected/never][ smp-proxy-fallback=no/protected/yes][ timeout=<seconds>]" <> " to change settings"
|
|
]
|
|
|
|
smpProxyModeStr :: SMPProxyMode -> SMPProxyFallback -> String
|
|
smpProxyModeStr SPMNever _ = "private message routing disabled."
|
|
smpProxyModeStr mode fallback = T.unpack $ safeDecodeUtf8 $ "private message routing mode: " <> strEncode mode <> ", fallback: " <> strEncode fallback
|
|
|
|
viewContactInfo :: Contact -> Maybe ConnectionStats -> Maybe Profile -> [StyledString]
|
|
viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}, activeConn, uiThemes, customData} stats incognitoProfile =
|
|
["contact ID: " <> sShow contactId]
|
|
<> maybe [] viewConnectionStats stats
|
|
<> maybe [] (\l -> ["contact address: " <> (plain . strEncode) (simplexChatContact l)]) contactLink
|
|
<> maybe
|
|
["you've shared main profile with this contact"]
|
|
(\p -> ["you've shared incognito profile with this contact: " <> incognitoProfile' p])
|
|
incognitoProfile
|
|
<> ["alias: " <> plain localAlias | localAlias /= ""]
|
|
<> [viewConnectionVerified (contactSecurityCode ct)]
|
|
<> ["quantum resistant end-to-end encryption" | contactPQEnabled ct == CR.PQEncOn]
|
|
<> maybe [] (\ac -> [viewPeerChatVRange (peerChatVRange ac)]) activeConn
|
|
<> viewUITheme uiThemes
|
|
<> viewCustomData customData
|
|
|
|
viewGroupInfo :: GroupInfo -> GroupSummary -> [StyledString]
|
|
viewGroupInfo GroupInfo {groupId, uiThemes, customData} s =
|
|
[ "group ID: " <> sShow groupId,
|
|
"current members: " <> sShow (currentMembers s)
|
|
]
|
|
<> viewUITheme uiThemes
|
|
<> viewCustomData customData
|
|
|
|
viewUITheme :: Maybe UIThemeEntityOverrides -> [StyledString]
|
|
viewUITheme = maybe [] (\uiThemes -> ["UI themes: " <> viewJSON uiThemes])
|
|
|
|
viewCustomData :: Maybe CustomData -> [StyledString]
|
|
viewCustomData = maybe [] (\(CustomData v) -> ["custom data: " <> viewJSON (J.Object v)])
|
|
|
|
viewGroupMemberInfo :: GroupInfo -> GroupMember -> Maybe ConnectionStats -> [StyledString]
|
|
viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias, contactLink}, activeConn} stats =
|
|
[ "group ID: " <> sShow groupId,
|
|
"member ID: " <> sShow groupMemberId
|
|
]
|
|
<> maybe ["member not connected"] viewConnectionStats stats
|
|
<> maybe [] (\l -> ["contact address: " <> (plain . strEncode) (simplexChatContact l)]) contactLink
|
|
<> ["alias: " <> plain localAlias | localAlias /= ""]
|
|
<> [viewConnectionVerified (memberSecurityCode m) | isJust stats]
|
|
<> maybe [] (\ac -> [viewPeerChatVRange (peerChatVRange ac)]) activeConn
|
|
|
|
viewConnectionVerified :: Maybe SecurityCode -> StyledString
|
|
viewConnectionVerified (Just _) = "connection verified" -- TODO show verification time?
|
|
viewConnectionVerified _ = "connection not verified, use " <> highlight' "/code" <> " command to see security code"
|
|
|
|
viewPeerChatVRange :: VersionRangeChat -> StyledString
|
|
viewPeerChatVRange (VersionRange minVer maxVer) = "peer chat protocol version range: (" <> sShow minVer <> ", " <> sShow maxVer <> ")"
|
|
|
|
viewConnectionStats :: ConnectionStats -> [StyledString]
|
|
viewConnectionStats ConnectionStats {rcvQueuesInfo, sndQueuesInfo} =
|
|
["receiving messages via: " <> viewRcvQueuesInfo rcvQueuesInfo | not $ null rcvQueuesInfo]
|
|
<> ["sending messages via: " <> viewSndQueuesInfo sndQueuesInfo | not $ null sndQueuesInfo]
|
|
|
|
viewRcvQueuesInfo :: [RcvQueueInfo] -> StyledString
|
|
viewRcvQueuesInfo = plain . intercalate ", " . map showQueueInfo
|
|
where
|
|
showQueueInfo RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch} =
|
|
let switchCanBeAborted = if canAbortSwitch then ", can be aborted" else ""
|
|
in showSMPServer rcvServer
|
|
<> maybe "" (\s -> " (" <> showSwitchStatus s <> switchCanBeAborted <> ")") rcvSwitchStatus
|
|
showSwitchStatus = \case
|
|
RSSwitchStarted -> "switch started"
|
|
RSSendingQADD -> "switch started"
|
|
RSSendingQUSE -> "switch confirmed"
|
|
RSReceivedMessage -> "switch secured"
|
|
|
|
viewSndQueuesInfo :: [SndQueueInfo] -> StyledString
|
|
viewSndQueuesInfo = plain . intercalate ", " . map showQueueInfo
|
|
where
|
|
showQueueInfo SndQueueInfo {sndServer, sndSwitchStatus} =
|
|
showSMPServer sndServer
|
|
<> maybe "" (\s -> " (" <> showSwitchStatus s <> ")") sndSwitchStatus
|
|
showSwitchStatus = \case
|
|
SSSendingQKEY -> "switch started"
|
|
SSSendingQTEST -> "switch secured"
|
|
|
|
viewContactSwitch :: Contact -> SwitchProgress -> [StyledString]
|
|
viewContactSwitch _ (SwitchProgress _ SPConfirmed _) = []
|
|
viewContactSwitch _ (SwitchProgress _ SPSecured _) = []
|
|
viewContactSwitch ct (SwitchProgress qd phase _) = case qd of
|
|
QDRcv -> [ttyContact' ct <> ": you " <> viewSwitchPhase phase]
|
|
QDSnd -> [ttyContact' ct <> " " <> viewSwitchPhase phase <> " for you"]
|
|
|
|
viewGroupMemberSwitch :: GroupInfo -> GroupMember -> SwitchProgress -> [StyledString]
|
|
viewGroupMemberSwitch _ _ (SwitchProgress _ SPConfirmed _) = []
|
|
viewGroupMemberSwitch _ _ (SwitchProgress _ SPSecured _) = []
|
|
viewGroupMemberSwitch g m (SwitchProgress qd phase _) = case qd of
|
|
QDRcv -> [ttyGroup' g <> ": you " <> viewSwitchPhase phase <> " for " <> ttyMember m]
|
|
QDSnd -> [ttyGroup' g <> ": " <> ttyMember m <> " " <> viewSwitchPhase phase <> " for you"]
|
|
|
|
viewContactRatchetSync :: Contact -> RatchetSyncProgress -> [StyledString]
|
|
viewContactRatchetSync ct RatchetSyncProgress {ratchetSyncStatus = rss} =
|
|
[ttyContact' ct <> ": " <> (plain . ratchetSyncStatusToText) rss]
|
|
<> help
|
|
where
|
|
help = ["use " <> highlight ("/sync " <> viewContactName ct) <> " to synchronize" | rss `elem` [RSAllowed, RSRequired]]
|
|
|
|
viewGroupMemberRatchetSync :: GroupInfo -> GroupMember -> RatchetSyncProgress -> [StyledString]
|
|
viewGroupMemberRatchetSync g m RatchetSyncProgress {ratchetSyncStatus = rss} =
|
|
[ttyGroup' g <> " " <> ttyMember m <> ": " <> (plain . ratchetSyncStatusToText) rss]
|
|
<> help
|
|
where
|
|
help = ["use " <> highlight ("/sync #" <> viewGroupName g <> " " <> viewMemberName m) <> " to synchronize" | rss `elem` [RSAllowed, RSRequired]]
|
|
|
|
viewContactVerificationReset :: Contact -> [StyledString]
|
|
viewContactVerificationReset ct =
|
|
[ttyContact' ct <> ": security code changed"]
|
|
|
|
viewGroupMemberVerificationReset :: GroupInfo -> GroupMember -> [StyledString]
|
|
viewGroupMemberVerificationReset g m =
|
|
[ttyGroup' g <> " " <> ttyMember m <> ": security code changed"]
|
|
|
|
viewContactCode :: Contact -> Text -> Bool -> [StyledString]
|
|
viewContactCode ct = viewSecurityCode (ttyContact' ct) ("/verify " <> viewContactName ct <> " <code from your contact>")
|
|
|
|
viewGroupMemberCode :: GroupInfo -> GroupMember -> Text -> Bool -> [StyledString]
|
|
viewGroupMemberCode g m = viewSecurityCode (ttyGroup' g <> " " <> ttyMember m) ("/verify #" <> viewGroupName g <> " " <> viewMemberName m <> " <code from your contact>")
|
|
|
|
viewSecurityCode :: StyledString -> Text -> Text -> Bool -> [StyledString]
|
|
viewSecurityCode name cmd code testView
|
|
| testView = [plain code]
|
|
| otherwise = [name <> " security code:", plain code, "pass this code to your contact and use " <> highlight cmd <> " to verify"]
|
|
|
|
viewSwitchPhase :: SwitchPhase -> StyledString
|
|
viewSwitchPhase = \case
|
|
SPStarted -> "started changing address"
|
|
SPConfirmed -> "confirmed changing address"
|
|
SPSecured -> "secured new address"
|
|
SPCompleted -> "changed address"
|
|
|
|
viewUserProfileUpdated :: Profile -> Profile -> UserProfileUpdateSummary -> [StyledString]
|
|
viewUserProfileUpdated Profile {displayName = n, fullName, image, contactLink, preferences} Profile {displayName = n', fullName = fullName', image = image', contactLink = contactLink', preferences = prefs'} summary =
|
|
profileUpdated <> viewPrefsUpdated preferences prefs'
|
|
where
|
|
UserProfileUpdateSummary {updateSuccesses = s, updateFailures = f} = summary
|
|
profileUpdated
|
|
| n == n' && fullName == fullName' && image == image' && contactLink == contactLink' = []
|
|
| n == n' && fullName == fullName' && image == image' = [if isNothing contactLink' then "contact address removed" else "new contact address set"]
|
|
| n == n' && fullName == fullName' = [if isNothing image' then "profile image removed" else "profile image updated"]
|
|
| n == n' = ["user full name " <> (if T.null fullName' || fullName' == n' then "removed" else "changed to " <> plain fullName') <> notified]
|
|
| otherwise = ["user profile is changed to " <> ttyFullName n' fullName' <> notified]
|
|
notified = " (your " <> sShow s <> " contacts are notified" <> failures <> ")"
|
|
failures
|
|
| f > 0 = ", " <> sShow f <> " failures"
|
|
| otherwise = ""
|
|
|
|
viewUserProfileImage :: Profile -> [StyledString]
|
|
viewUserProfileImage Profile {image} = case image of
|
|
Just (ImageData img) -> ["Profile image:", plain img]
|
|
_ -> ["No profile image"]
|
|
|
|
viewUserContactPrefsUpdated :: User -> Contact -> Contact -> [StyledString]
|
|
viewUserContactPrefsUpdated user ct ct'@Contact {mergedPreferences = cups}
|
|
| null prefs = ["your preferences for " <> ttyContact' ct' <> " did not change"]
|
|
| otherwise = ("you updated preferences for " <> ttyContact' ct' <> ":") : prefs
|
|
where
|
|
prefs = viewContactPreferences user ct ct' cups
|
|
|
|
viewContactPrefsUpdated :: User -> Contact -> Contact -> [StyledString]
|
|
viewContactPrefsUpdated user ct ct'@Contact {mergedPreferences = cups}
|
|
| null prefs = []
|
|
| otherwise = (ttyContact' ct' <> " updated preferences for you:") : prefs
|
|
where
|
|
prefs = viewContactPreferences user ct ct' cups
|
|
|
|
viewContactPreferences :: User -> Contact -> Contact -> ContactUserPreferences -> [StyledString]
|
|
viewContactPreferences user ct ct' cups =
|
|
mapMaybe (viewContactPref (mergeUserChatPrefs user ct) (mergeUserChatPrefs user ct') (preferences' ct) cups) allChatFeatures
|
|
|
|
viewContactPref :: FullPreferences -> FullPreferences -> Maybe Preferences -> ContactUserPreferences -> AChatFeature -> Maybe StyledString
|
|
viewContactPref userPrefs userPrefs' ctPrefs cups (ACF f)
|
|
| userPref == userPref' && ctPref == contactPreference = Nothing
|
|
| otherwise = Just . plain $ chatFeatureNameText' f <> ": " <> prefEnabledToText (chatFeature f) enabled (prefParam userPref') <> " (you allow: " <> countactUserPrefText userPreference <> ", contact allows: " <> preferenceText contactPreference <> ")"
|
|
where
|
|
userPref = getPreference f userPrefs
|
|
userPref' = getPreference f userPrefs'
|
|
ctPref = getPreference f ctPrefs
|
|
ContactUserPreference {enabled, userPreference, contactPreference} = getContactUserPreference f cups
|
|
|
|
viewPrefsUpdated :: Maybe Preferences -> Maybe Preferences -> [StyledString]
|
|
viewPrefsUpdated ps ps'
|
|
| null prefs = []
|
|
| otherwise = "updated preferences:" : prefs
|
|
where
|
|
prefs = mapMaybe viewPref allChatFeatures
|
|
viewPref (ACF f)
|
|
| pref ps == pref ps' = Nothing
|
|
| otherwise = Just . plain $ chatFeatureNameText' f <> " allowed: " <> preferenceText (pref ps')
|
|
where
|
|
pref pss = getPreference f $ mergePreferences pss Nothing
|
|
|
|
countactUserPrefText :: FeatureI f => ContactUserPref (FeaturePreference f) -> Text
|
|
countactUserPrefText cup = case cup of
|
|
CUPUser p -> "default (" <> preferenceText p <> ")"
|
|
CUPContact p -> preferenceText p
|
|
|
|
viewGroupUpdated :: GroupInfo -> GroupInfo -> Maybe GroupMember -> [StyledString]
|
|
viewGroupUpdated
|
|
GroupInfo {localDisplayName = n, groupProfile = GroupProfile {fullName, description, image, groupPreferences = gps}}
|
|
g'@GroupInfo {localDisplayName = n', groupProfile = GroupProfile {fullName = fullName', description = description', image = image', groupPreferences = gps'}}
|
|
m = do
|
|
let update = groupProfileUpdated <> groupPrefsUpdated
|
|
if null update
|
|
then []
|
|
else memberUpdated <> update
|
|
where
|
|
memberUpdated = maybe [] (\m' -> [ttyMember m' <> " updated group " <> ttyGroup n <> ":"]) m
|
|
groupProfileUpdated =
|
|
["changed to " <> ttyFullGroup g' | n /= n']
|
|
<> ["full name " <> if T.null fullName' || fullName' == n' then "removed" else "changed to: " <> plain fullName' | n == n' && fullName /= fullName']
|
|
<> ["profile image " <> maybe "removed" (const "updated") image' | image /= image']
|
|
<> (if description == description' then [] else maybe ["description removed"] ((bold' "description changed to:" :) . map plain . T.lines) description')
|
|
groupPrefsUpdated
|
|
| null prefs = []
|
|
| otherwise = bold' "updated group preferences:" : prefs
|
|
where
|
|
prefs = mapMaybe viewPref allGroupFeatures
|
|
viewPref (AGF f)
|
|
| pref gps == pref gps' = Nothing
|
|
| otherwise = Just . plain $ groupPreferenceText (pref gps')
|
|
where
|
|
pref = getGroupPreference f . mergeGroupPreferences
|
|
|
|
viewGroupProfile :: GroupInfo -> [StyledString]
|
|
viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {description, image, groupPreferences = gps}} =
|
|
[ttyFullGroup g]
|
|
<> maybe [] (const ["has profile image"]) image
|
|
<> maybe [] ((bold' "description:" :) . map plain . T.lines) description
|
|
<> (bold' "group preferences:" : map viewPref allGroupFeatures)
|
|
where
|
|
viewPref (AGF f) = plain $ groupPreferenceText (pref gps)
|
|
where
|
|
pref = getGroupPreference f . mergeGroupPreferences
|
|
|
|
viewGroupDescription :: GroupInfo -> [StyledString]
|
|
viewGroupDescription GroupInfo {groupProfile = GroupProfile {description}} =
|
|
maybe ["No welcome message!"] ((bold' "Welcome message:" :) . map plain . T.lines) description
|
|
|
|
bold' :: String -> StyledString
|
|
bold' = styled Bold
|
|
|
|
viewContactAliasUpdated :: Contact -> [StyledString]
|
|
viewContactAliasUpdated ct@Contact {profile = LocalProfile {localAlias}}
|
|
| localAlias == "" = ["contact " <> ttyContact' ct <> " alias removed"]
|
|
| otherwise = ["contact " <> ttyContact' ct <> " alias updated: " <> plain localAlias]
|
|
|
|
viewGroupAliasUpdated :: GroupInfo -> [StyledString]
|
|
viewGroupAliasUpdated g@GroupInfo {localAlias}
|
|
| localAlias == "" = ["group " <> ttyGroup' g <> " alias removed"]
|
|
| otherwise = ["group " <> ttyGroup' g <> " alias updated: " <> plain localAlias]
|
|
|
|
viewConnectionAliasUpdated :: PendingContactConnection -> [StyledString]
|
|
viewConnectionAliasUpdated PendingContactConnection {pccConnId, localAlias}
|
|
| localAlias == "" = ["connection " <> sShow pccConnId <> " alias removed"]
|
|
| otherwise = ["connection " <> sShow pccConnId <> " alias updated: " <> plain localAlias]
|
|
|
|
viewConnectionIncognitoUpdated :: PendingContactConnection -> [StyledString]
|
|
viewConnectionIncognitoUpdated PendingContactConnection {pccConnId, customUserProfileId}
|
|
| isJust customUserProfileId = ["connection " <> sShow pccConnId <> " changed to incognito"]
|
|
| otherwise = ["connection " <> sShow pccConnId <> " changed to non incognito"]
|
|
|
|
viewConnectionUserChanged :: User -> PendingContactConnection -> User -> PendingContactConnection -> [StyledString]
|
|
viewConnectionUserChanged User {localDisplayName = n} PendingContactConnection {pccConnId, connReqInv} User {localDisplayName = n'} PendingContactConnection {connReqInv = connReqInv'} =
|
|
case (connReqInv, connReqInv') of
|
|
(Just cReqInv, Just cReqInv')
|
|
| cReqInv /= cReqInv' -> [userChangedStr <> ", new link:"] <> newLink cReqInv'
|
|
_ -> [userChangedStr]
|
|
where
|
|
userChangedStr = "connection " <> sShow pccConnId <> " changed from user " <> plain n <> " to user " <> plain n'
|
|
newLink cReqInv =
|
|
[ "",
|
|
(plain . strEncode) (simplexChatInvitation cReqInv),
|
|
""
|
|
]
|
|
|
|
viewConnectionPlan :: ConnectionPlan -> [StyledString]
|
|
viewConnectionPlan = \case
|
|
CPInvitationLink ilp -> case ilp of
|
|
ILPOk -> [invLink "ok to connect"]
|
|
ILPOwnLink -> [invLink "own link"]
|
|
ILPConnecting Nothing -> [invLink "connecting"]
|
|
ILPConnecting (Just ct) -> [invLink ("connecting to contact " <> ttyContact' ct)]
|
|
ILPKnown ct ->
|
|
[ invLink ("known contact " <> ttyContact' ct),
|
|
"use " <> ttyToContact' ct <> highlight' "<message>" <> " to send messages"
|
|
]
|
|
where
|
|
invLink = ("invitation link: " <>)
|
|
CPContactAddress cap -> case cap of
|
|
CAPOk -> [ctAddr "ok to connect"]
|
|
CAPOwnLink -> [ctAddr "own address"]
|
|
CAPConnectingConfirmReconnect -> [ctAddr "connecting, allowed to reconnect"]
|
|
CAPConnectingProhibit ct -> [ctAddr ("connecting to contact " <> ttyContact' ct)]
|
|
CAPKnown ct ->
|
|
[ ctAddr ("known contact " <> ttyContact' ct),
|
|
"use " <> ttyToContact' ct <> highlight' "<message>" <> " to send messages"
|
|
]
|
|
CAPContactViaAddress ct -> [ctAddr ("known contact without connection " <> ttyContact' ct)]
|
|
where
|
|
ctAddr = ("contact address: " <>)
|
|
CPGroupLink glp -> case glp of
|
|
GLPOk -> [grpLink "ok to connect"]
|
|
GLPOwnLink g -> [grpLink "own link for group " <> ttyGroup' g]
|
|
GLPConnectingConfirmReconnect -> [grpLink "connecting, allowed to reconnect"]
|
|
GLPConnectingProhibit Nothing -> [grpLink "connecting"]
|
|
GLPConnectingProhibit (Just g) -> [grpOrBiz g <> " link: connecting to " <> grpOrBiz g <> " " <> ttyGroup' g]
|
|
GLPKnown g ->
|
|
[ grpOrBiz g <> " link: known " <> grpOrBiz g <> " " <> ttyGroup' g,
|
|
"use " <> ttyToGroup g <> highlight' "<message>" <> " to send messages"
|
|
]
|
|
where
|
|
grpLink = ("group link: " <>)
|
|
grpOrBiz GroupInfo {businessChat} = case businessChat of
|
|
Just _ -> "business"
|
|
Nothing -> "group"
|
|
|
|
viewContactUpdated :: Contact -> Contact -> [StyledString]
|
|
viewContactUpdated
|
|
Contact {localDisplayName = n, profile = LocalProfile {fullName, contactLink}}
|
|
Contact {localDisplayName = n', profile = LocalProfile {fullName = fullName', contactLink = contactLink'}}
|
|
| n == n' && fullName == fullName' && contactLink == contactLink' = []
|
|
| n == n' && fullName == fullName' =
|
|
if isNothing contactLink'
|
|
then [ttyContact n <> " removed contact address"]
|
|
else [ttyContact n <> " set new contact address, use " <> highlight ("/info " <> n) <> " to view"]
|
|
| n == n' = ["contact " <> ttyContact n <> fullNameUpdate]
|
|
| otherwise =
|
|
[ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName',
|
|
"use " <> ttyToContact n' <> highlight' "<message>" <> " to send messages"
|
|
]
|
|
where
|
|
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
|
|
|
|
viewReceivedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
|
viewReceivedMessage = viewReceivedMessage_ False
|
|
|
|
viewReceivedUpdatedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
|
viewReceivedUpdatedMessage = viewReceivedMessage_ True
|
|
|
|
viewReceivedMessage_ :: Bool -> StyledString -> [StyledString] -> MsgContent -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
|
viewReceivedMessage_ updated from context mc ts tz meta = receivedWithTime_ ts tz from context meta (ttyMsgContent mc) updated
|
|
|
|
viewReceivedReaction :: StyledString -> [StyledString] -> StyledString -> CurrentTime -> TimeZone -> UTCTime -> [StyledString]
|
|
viewReceivedReaction from styledMsg reactionText ts tz reactionTs =
|
|
prependFirst (ttyMsgTime ts tz reactionTs <> " " <> from) (styledMsg <> [" " <> reactionText])
|
|
|
|
receivedWithTime_ :: CurrentTime -> TimeZone -> StyledString -> [StyledString] -> CIMeta c d -> [StyledString] -> Bool -> [StyledString]
|
|
receivedWithTime_ ts tz from context CIMeta {itemId, itemTs, itemEdited, itemDeleted, itemLive} styledMsg updated = do
|
|
prependFirst (ttyMsgTime ts tz itemTs <> " " <> from) (context <> prependFirst (indent <> live) styledMsg)
|
|
where
|
|
indent = if null context then "" else " "
|
|
live
|
|
| itemEdited || isJust itemDeleted = ""
|
|
| otherwise = case itemLive of
|
|
Just True
|
|
| updated -> ttyFrom "[LIVE] "
|
|
| otherwise -> ttyFrom "[LIVE started]" <> " use " <> highlight' ("/show [on/off/" <> show itemId <> "] ")
|
|
Just False -> ttyFrom "[LIVE ended] "
|
|
_ -> ""
|
|
|
|
ttyMsgTime :: CurrentTime -> TimeZone -> UTCTime -> StyledString
|
|
ttyMsgTime now tz time =
|
|
let fmt = if recent now tz time then "%H:%M" else "%m-%d"
|
|
localTime = utcToLocalTime tz time
|
|
in styleTime $ formatTime defaultTimeLocale fmt localTime
|
|
|
|
recent :: CurrentTime -> TimeZone -> UTCTime -> Bool
|
|
recent now tz time = do
|
|
let localNow = utcToLocalTime tz now
|
|
localNowDay = localDay localNow
|
|
localTime = utcToLocalTime tz time
|
|
localTimeDay = localDay localTime
|
|
previousDay18 = LocalTime (addDays (-1) localNowDay) (TimeOfDay 18 0 0)
|
|
currentDay12 = LocalTime localNowDay (TimeOfDay 12 0 0)
|
|
localNowDay == localTimeDay
|
|
|| (localNow < currentDay12 && localTime >= previousDay18 && localTimeDay < localNowDay)
|
|
|
|
viewSentMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
|
viewSentMessage to context mc ts tz meta@CIMeta {itemEdited, itemDeleted, itemLive} = sentWithTime_ ts tz (prependFirst to $ context <> prependFirst (indent <> live) (ttyMsgContent mc)) meta
|
|
where
|
|
indent = if null context then "" else " "
|
|
live
|
|
| itemEdited || isJust itemDeleted = ""
|
|
| otherwise = case itemLive of
|
|
Just True -> ttyTo "[LIVE started] "
|
|
Just False -> ttyTo "[LIVE] "
|
|
_ -> ""
|
|
|
|
viewSentBroadcast :: MsgContent -> Int -> Int -> CurrentTime -> TimeZone -> UTCTime -> [StyledString]
|
|
viewSentBroadcast mc s f ts tz time = prependFirst (highlight' "/feed" <> " (" <> sShow s <> failures <> ") " <> ttyMsgTime ts tz time <> " ") (ttyMsgContent mc)
|
|
where
|
|
failures
|
|
| f > 0 = ", " <> sShow f <> " failures"
|
|
| otherwise = ""
|
|
|
|
viewSentFileInvitation :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
|
viewSentFileInvitation to CIFile {fileId, fileSource, fileStatus} ts tz = case fileSource of
|
|
Just (CryptoFile fPath _) -> sentWithTime_ ts tz $ ttySentFile fPath
|
|
_ -> const []
|
|
where
|
|
ttySentFile fPath = ["/f " <> to <> ttyFilePath fPath] <> cancelSending
|
|
cancelSending = case fileStatus of
|
|
CIFSSndTransfer _ _ -> []
|
|
_ -> ["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"]
|
|
|
|
sentWithTime_ :: CurrentTime -> TimeZone -> [StyledString] -> CIMeta c d -> [StyledString]
|
|
sentWithTime_ ts tz styledMsg CIMeta {itemTs} =
|
|
prependFirst (ttyMsgTime ts tz itemTs <> " ") styledMsg
|
|
|
|
ttyMsgContent :: MsgContent -> [StyledString]
|
|
ttyMsgContent = msgPlain . msgContentText
|
|
|
|
prependFirst :: StyledString -> [StyledString] -> [StyledString]
|
|
prependFirst s [] = [s]
|
|
prependFirst s (s' : ss) = (s <> s') : ss
|
|
|
|
msgPlain :: Text -> [StyledString]
|
|
msgPlain = map (styleMarkdownList . parseMarkdownList) . T.lines
|
|
|
|
viewRcvFileSndCancelled :: RcvFileTransfer -> [StyledString]
|
|
viewRcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} =
|
|
[ttyContact c <> " cancelled sending " <> rcvFile ft]
|
|
|
|
viewSndFileCancelled :: FileTransferMeta -> [SndFileTransfer] -> [StyledString]
|
|
viewSndFileCancelled FileTransferMeta {fileId, fileName} fts =
|
|
case filter (\SndFileTransfer {fileStatus = s} -> s /= FSCancelled && s /= FSComplete) fts of
|
|
[] -> ["cancelled sending " <> fileTransferStr fileId fileName]
|
|
ts -> ["cancelled sending " <> fileTransferStr fileId fileName <> " to " <> listRecipients ts]
|
|
|
|
sendingFile_ :: StyledString -> SndFileTransfer -> [StyledString]
|
|
sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
|
|
[status <> " sending " <> sndFile ft <> " to " <> ttyContact c]
|
|
|
|
uploadingFile :: StyledString -> AChatItem -> [StyledString]
|
|
uploadingFile status = \case
|
|
AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectSnd} ->
|
|
[status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyContact c]
|
|
AChatItem _ _ (GroupChat g) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupSnd} ->
|
|
[status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyGroup' g]
|
|
_ -> [status <> " uploading file"]
|
|
|
|
uploadingFileStandalone :: StyledString -> FileTransferMeta -> [StyledString]
|
|
uploadingFileStandalone status FileTransferMeta {fileId, fileName} = [status <> " standalone uploading " <> fileTransferStr fileId fileName]
|
|
|
|
standaloneUploadRedirect :: FileTransferMeta -> FileTransferMeta -> [StyledString]
|
|
standaloneUploadRedirect FileTransferMeta {fileId, fileName} FileTransferMeta {fileId = redirectId} =
|
|
[fileTransferStr fileId fileName <> " uploaded, preparing redirect file " <> sShow redirectId]
|
|
|
|
standaloneUploadComplete :: FileTransferMeta -> [Text] -> [StyledString]
|
|
standaloneUploadComplete FileTransferMeta {fileId, fileName} = \case
|
|
[] -> [fileTransferStr fileId fileName <> " upload complete."]
|
|
uris ->
|
|
fileTransferStr fileId fileName <> " upload complete. download with:"
|
|
: map plain uris
|
|
|
|
sndFile :: SndFileTransfer -> StyledString
|
|
sndFile SndFileTransfer {fileId, fileName} = fileTransferStr fileId fileName
|
|
|
|
viewReceivedFileInvitation :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
|
viewReceivedFileInvitation from file ts tz meta = receivedWithTime_ ts tz from [] meta (receivedFileInvitation_ file) False
|
|
|
|
receivedFileInvitation_ :: CIFile d -> [StyledString]
|
|
receivedFileInvitation_ CIFile {fileId, fileName, fileSize, fileStatus} =
|
|
["sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)"]
|
|
<> case fileStatus of
|
|
CIFSRcvAccepted -> []
|
|
_ -> ["use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"]
|
|
|
|
humanReadableSize :: Integer -> StyledString
|
|
humanReadableSize size
|
|
| size < kB = sShow size <> " bytes"
|
|
| size < mB = hrSize kB "KiB"
|
|
| size < gB = hrSize mB "MiB"
|
|
| otherwise = hrSize gB "GiB"
|
|
where
|
|
hrSize sB name = plain $ unwords [showFFloat (Just 1) (fromIntegral size / (fromIntegral sB :: Double)) "", name]
|
|
kB = 1024
|
|
mB = kB * 1024
|
|
gB = mB * 1024
|
|
|
|
savingFile' :: AChatItem -> [StyledString]
|
|
savingFile' (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileSource = Just (CryptoFile filePath _)}, chatDir}) =
|
|
["saving file " <> sShow fileId <> fileFrom chat chatDir <> " to " <> plain filePath]
|
|
savingFile' _ = ["saving file"] -- shouldn't happen
|
|
|
|
receivingFile_' :: (Maybe RemoteHostId, Maybe User) -> Bool -> String -> AChatItem -> [StyledString]
|
|
receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileName, fileSource = Just f@(CryptoFile _ cfArgs_)}, chatDir}) =
|
|
[plain status <> " receiving " <> fileTransferStr fileId fileName <> fileFrom chat chatDir] <> cfArgsStr cfArgs_ <> getRemoteFileStr
|
|
where
|
|
cfArgsStr (Just cfArgs) = [cryptoFileArgsStr testView cfArgs | status == "completed"]
|
|
cfArgsStr _ = []
|
|
getRemoteFileStr = case hu of
|
|
(Just rhId, Just User {userId})
|
|
| status == "completed" ->
|
|
[ "File received to connected remote host " <> sShow rhId,
|
|
"To download to this device use:",
|
|
highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f}))
|
|
]
|
|
_ -> []
|
|
receivingFile_' _ _ status _ = [plain status <> " receiving file"]
|
|
|
|
receivingFileStandalone :: String -> RcvFileTransfer -> [StyledString]
|
|
receivingFileStandalone status RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} =
|
|
[plain status <> " standalone receiving " <> fileTransferStr fileId fileName]
|
|
|
|
viewLocalFile :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
|
viewLocalFile to CIFile {fileId, fileSource} ts tz = case fileSource of
|
|
Just (CryptoFile fPath _) -> sentWithTime_ ts tz [to <> fileTransferStr fileId fPath]
|
|
_ -> const []
|
|
|
|
cryptoFileArgsStr :: Bool -> CryptoFileArgs -> StyledString
|
|
cryptoFileArgsStr testView cfArgs@(CFArgs key nonce)
|
|
| testView = viewJSON cfArgs
|
|
| otherwise = plain $ "encryption key: " <> strEncode key <> ", nonce: " <> strEncode nonce
|
|
|
|
fileFrom :: ChatInfo c -> CIDirection c d -> StyledString
|
|
fileFrom (DirectChat ct) CIDirectRcv = " from " <> ttyContact' ct
|
|
fileFrom _ (CIGroupRcv m) = " from " <> ttyMember m
|
|
fileFrom _ _ = ""
|
|
|
|
receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString]
|
|
receivingFile_ status ft@RcvFileTransfer {senderDisplayName = c} =
|
|
[status <> " receiving " <> rcvFile ft <> if c == "" then "" else " from " <> ttyContact c]
|
|
|
|
rcvFile :: RcvFileTransfer -> StyledString
|
|
rcvFile RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} = fileTransferStr fileId fileName
|
|
|
|
fileTransferStr :: Int64 -> String -> StyledString
|
|
fileTransferStr fileId fileName = "file " <> sShow fileId <> " (" <> ttyFilePath fileName <> ")"
|
|
|
|
viewFileTransferStatus :: (FileTransfer, [Integer]) -> [StyledString]
|
|
viewFileTransferStatus (FTSnd FileTransferMeta {fileId, fileName, cancelled} [], _) =
|
|
["sending " <> fileTransferStr fileId fileName <> ": no file transfers"]
|
|
<> ["file transfer cancelled" | cancelled]
|
|
viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksNum) =
|
|
recipientStatuses <> ["file transfer cancelled" | cancelled]
|
|
where
|
|
recipientStatuses =
|
|
case concatMap recipientsTransferStatus $ groupBy ((==) `on` fs) $ sortOn fs fts of
|
|
[recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus]
|
|
recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses
|
|
fs :: SndFileTransfer -> FileStatus
|
|
fs SndFileTransfer {fileStatus} = fileStatus
|
|
recipientsTransferStatus [] = []
|
|
recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts]
|
|
where
|
|
sndStatus = case fileStatus of
|
|
FSNew -> "not accepted"
|
|
FSAccepted -> "just started"
|
|
FSConnected -> "in progress (" <> sShow (sum chunksNum * chunkSize * 100 `div` (toInteger (length chunksNum) * fileSize)) <> "%)"
|
|
FSComplete -> "complete"
|
|
FSCancelled -> "cancelled"
|
|
viewFileTransferStatus (FTRcv ft@RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, fileStatus, chunkSize}, chunksNum) =
|
|
["receiving " <> rcvFile ft <> " " <> rcvStatus]
|
|
where
|
|
rcvStatus = case fileStatus of
|
|
RFSNew -> "not accepted yet, use " <> highlight ("/fr " <> show fileId) <> " to receive file"
|
|
RFSAccepted _ -> "just started"
|
|
RFSConnected _ -> "progress " <> fileProgress chunksNum chunkSize fileSize
|
|
RFSComplete RcvFileInfo {filePath} -> "complete, path: " <> plain filePath
|
|
RFSCancelled (Just RcvFileInfo {filePath}) -> "cancelled, received part path: " <> plain filePath
|
|
RFSCancelled Nothing -> "cancelled"
|
|
|
|
viewFileTransferStatusXFTP :: AChatItem -> [StyledString]
|
|
viewFileTransferStatusXFTP (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName, fileSize, fileStatus, fileSource}}) =
|
|
case fileStatus of
|
|
CIFSSndStored -> ["sending " <> fstr <> " just started"]
|
|
CIFSSndTransfer progress total -> ["sending " <> fstr <> " in progress " <> fileProgressXFTP progress total fileSize]
|
|
CIFSSndCancelled -> ["sending " <> fstr <> " cancelled"]
|
|
CIFSSndComplete -> ["sending " <> fstr <> " complete"]
|
|
CIFSSndError sndFileErr -> ["sending " <> fstr <> " error: " <> plain (show sndFileErr)]
|
|
CIFSSndWarning sndFileErr -> ["sending " <> fstr <> " warning: " <> plain (show sndFileErr)]
|
|
CIFSRcvInvitation -> ["receiving " <> fstr <> " not accepted yet, use " <> highlight ("/fr " <> show fileId) <> " to receive file"]
|
|
CIFSRcvAccepted -> ["receiving " <> fstr <> " just started"]
|
|
CIFSRcvTransfer progress total -> ["receiving " <> fstr <> " progress " <> fileProgressXFTP progress total fileSize]
|
|
CIFSRcvAborted -> ["receiving " <> fstr <> " aborted, use " <> highlight ("/fr " <> show fileId) <> " to receive file"]
|
|
CIFSRcvComplete -> ["receiving " <> fstr <> " complete" <> maybe "" (\(CryptoFile fp _) -> ", path: " <> plain fp) fileSource]
|
|
CIFSRcvCancelled -> ["receiving " <> fstr <> " cancelled"]
|
|
CIFSRcvError rcvFileErr -> ["receiving " <> fstr <> " error: " <> plain (show rcvFileErr)]
|
|
CIFSRcvWarning rcvFileErr -> ["receiving " <> fstr <> " warning: " <> plain (show rcvFileErr)]
|
|
CIFSInvalid text -> [fstr <> " invalid status: " <> plain text]
|
|
where
|
|
fstr = fileTransferStr fileId fileName
|
|
viewFileTransferStatusXFTP _ = ["no file status"]
|
|
|
|
listRecipients :: [SndFileTransfer] -> StyledString
|
|
listRecipients = mconcat . intersperse ", " . map (ttyContact . recipientDisplayName)
|
|
|
|
fileProgress :: [Integer] -> Integer -> Integer -> StyledString
|
|
fileProgress chunksNum chunkSize fileSize =
|
|
sShow (sum chunksNum * chunkSize * 100 `div` fileSize) <> "% of " <> humanReadableSize fileSize
|
|
|
|
fileProgressXFTP :: Int64 -> Int64 -> Integer -> StyledString
|
|
fileProgressXFTP progress total fileSize =
|
|
sShow (progress * 100 `div` total) <> "% of " <> humanReadableSize fileSize
|
|
|
|
viewCallInvitation :: Contact -> CallType -> Maybe C.Key -> [StyledString]
|
|
viewCallInvitation ct@Contact {contactId} callType@CallType {media} sharedKey =
|
|
[ ttyContact' ct <> " wants to connect with you via WebRTC " <> callMediaStr callType <> " call " <> encryptedCallText callType,
|
|
"To accept the call, please open the link below in your browser" <> supporedBrowsers callType,
|
|
"",
|
|
"https://simplex.chat/call#" <> plain queryString
|
|
]
|
|
where
|
|
aesKey = B.unpack . strEncode . C.unKey <$> sharedKey
|
|
queryString =
|
|
Q.renderSimpleQuery
|
|
False
|
|
[ ("command", LB.toStrict . J.encode $ WCCallStart {media, aesKey, useWorker = True}),
|
|
("contact_id", B.pack $ show contactId)
|
|
]
|
|
|
|
viewCallOffer :: Contact -> CallType -> WebRTCSession -> Maybe C.Key -> [StyledString]
|
|
viewCallOffer ct@Contact {contactId} callType@CallType {media} WebRTCSession {rtcSession = offer, rtcIceCandidates = iceCandidates} sharedKey =
|
|
[ ttyContact' ct <> " accepted your WebRTC " <> callMediaStr callType <> " call " <> encryptedCallText callType,
|
|
"To connect, please open the link below in your browser" <> supporedBrowsers callType,
|
|
"",
|
|
"https://simplex.chat/call#" <> plain queryString
|
|
]
|
|
where
|
|
aesKey = B.unpack . strEncode . C.unKey <$> sharedKey
|
|
queryString =
|
|
Q.renderSimpleQuery
|
|
False
|
|
[ ("command", LB.toStrict . J.encode $ WCCallOffer {offer, iceCandidates, media, aesKey, useWorker = True}),
|
|
("contact_id", B.pack $ show contactId)
|
|
]
|
|
|
|
viewCallAnswer :: Contact -> WebRTCSession -> [StyledString]
|
|
viewCallAnswer ct WebRTCSession {rtcSession = answer, rtcIceCandidates = iceCandidates} =
|
|
[ ttyContact' ct <> " continued the WebRTC call",
|
|
"To connect, please paste the data below in your browser window you opened earlier and click Connect button",
|
|
"",
|
|
viewJSON WCCallAnswer {answer, iceCandidates}
|
|
]
|
|
|
|
callMediaStr :: CallType -> StyledString
|
|
callMediaStr CallType {media} = case media of
|
|
CMVideo -> "video"
|
|
CMAudio -> "audio"
|
|
|
|
encryptedCallText :: CallType -> StyledString
|
|
encryptedCallText callType
|
|
| encryptedCall callType = "(e2e encrypted)"
|
|
| otherwise = "(not e2e encrypted)"
|
|
|
|
supporedBrowsers :: CallType -> StyledString
|
|
supporedBrowsers callType
|
|
| encryptedCall callType = " (only Chrome and Safari support e2e encryption for WebRTC, Safari may require enabling WebRTC insertable streams)"
|
|
| otherwise = ""
|
|
|
|
viewVersionInfo :: ChatLogLevel -> CoreVersionInfo -> [StyledString]
|
|
viewVersionInfo logLevel CoreVersionInfo {version, simplexmqVersion, simplexmqCommit} =
|
|
map plain $
|
|
if logLevel <= CLLInfo
|
|
then [versionString version, updateStr, "simplexmq: " <> simplexmqVersion <> parens simplexmqCommit]
|
|
else [versionString version, updateStr]
|
|
where
|
|
|
|
parens :: (IsString a, Semigroup a) => a -> a
|
|
parens s = " (" <> s <> ")"
|
|
|
|
viewRemoteHosts :: [RemoteHostInfo] -> [StyledString]
|
|
viewRemoteHosts = \case
|
|
[] -> ["No remote hosts"]
|
|
hs -> "Remote hosts: " : map viewRemoteHostInfo hs
|
|
where
|
|
viewRemoteHostInfo RemoteHostInfo {remoteHostId, hostDeviceName, sessionState, bindAddress_, bindPort_} =
|
|
plain $ tshow remoteHostId <> ". " <> hostDeviceName <> maybe "" viewSessionState sessionState <> ctrlBinds bindAddress_ bindPort_
|
|
ctrlBinds Nothing Nothing = ""
|
|
ctrlBinds rca_ port_ = mconcat [" [", maybe "" rca rca_, maybe "" port port_, "]"]
|
|
where
|
|
rca RCCtrlAddress {interface, address} = interface <> " " <> decodeLatin1 (strEncode address)
|
|
port p = ":" <> tshow p
|
|
viewSessionState = \case
|
|
RHSStarting -> " (starting)"
|
|
RHSConnecting _ -> " (connecting)"
|
|
RHSPendingConfirmation {sessionCode} -> " (pending confirmation, code: " <> sessionCode <> ")"
|
|
RHSConfirmed _ -> " (confirmed)"
|
|
RHSConnected _ -> " (connected)"
|
|
|
|
viewRemoteCtrls :: [RemoteCtrlInfo] -> [StyledString]
|
|
viewRemoteCtrls = \case
|
|
[] -> ["No remote controllers"]
|
|
hs -> "Remote controllers: " : map viewRemoteCtrlInfo hs
|
|
where
|
|
viewRemoteCtrlInfo RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionState} =
|
|
plain $ tshow remoteCtrlId <> ". " <> ctrlDeviceName <> maybe "" viewSessionState sessionState
|
|
viewSessionState = \case
|
|
RCSStarting -> " (starting)"
|
|
RCSSearching -> " (searching)"
|
|
RCSConnecting -> " (connecting)"
|
|
RCSPendingConfirmation {sessionCode} -> " (pending confirmation, code: " <> sessionCode <> ")"
|
|
RCSConnected _ -> " (connected)"
|
|
|
|
viewRemoteCtrl :: CtrlAppInfo -> AppVersion -> Bool -> StyledString
|
|
viewRemoteCtrl CtrlAppInfo {deviceName, appVersionRange = AppVersionRange _ (AppVersion ctrlVersion)} (AppVersion v) compatible =
|
|
(if T.null deviceName then "" else plain deviceName <> ", ")
|
|
<> ("v" <> plain (V.showVersion ctrlVersion) <> ctrlVersionInfo)
|
|
where
|
|
ctrlVersionInfo
|
|
| ctrlVersion < v = " (older than this app - upgrade controller" <> showCompatible <> ")"
|
|
| ctrlVersion > v = " (newer than this app - upgrade it" <> showCompatible <> ")"
|
|
| otherwise = ""
|
|
showCompatible = if compatible then "" else ", " <> bold' "not compatible"
|
|
|
|
viewRemoteCtrlStopped :: RemoteCtrlStopReason -> [StyledString]
|
|
viewRemoteCtrlStopped = \case
|
|
RCSRConnectionFailed (ChatErrorAgent (RCP RCEIdentity) _) ->
|
|
["remote controller stopped: this link was used with another controller, please create a new link on the host"]
|
|
_ -> ["remote controller stopped"]
|
|
|
|
viewChatError :: Bool -> ChatLogLevel -> Bool -> ChatError -> [StyledString]
|
|
viewChatError isCmd logLevel testView = \case
|
|
ChatError err -> case err of
|
|
CENoActiveUser -> ["error: active user is required"]
|
|
CENoConnectionUser agentConnId -> ["error: message user not found, conn id: " <> sShow agentConnId | logLevel <= CLLError]
|
|
CENoSndFileUser aFileId -> ["error: snd file user not found, file id: " <> sShow aFileId | logLevel <= CLLError]
|
|
CENoRcvFileUser aFileId -> ["error: rcv file user not found, file id: " <> sShow aFileId | logLevel <= CLLError]
|
|
CEActiveUserExists -> ["error: active user already exists"]
|
|
CEUserExists name -> ["user with the name " <> ttyContact name <> " already exists"]
|
|
CEUserUnknown -> ["user does not exist or incorrect password"]
|
|
CEDifferentActiveUser commandUserId activeUserId -> ["error: different active user, command user id: " <> sShow commandUserId <> ", active user id: " <> sShow activeUserId]
|
|
CECantDeleteActiveUser _ -> ["cannot delete active user"]
|
|
CECantDeleteLastUser _ -> ["cannot delete last user"]
|
|
CECantHideLastUser _ -> ["cannot hide the only not hidden user"]
|
|
CEHiddenUserAlwaysMuted _ -> ["hidden user always muted when inactive"]
|
|
CEEmptyUserPassword _ -> ["user password is required"]
|
|
CEUserAlreadyHidden _ -> ["user is already hidden"]
|
|
CEUserNotHidden _ -> ["user is not hidden"]
|
|
CEInvalidDisplayName {displayName, validName} ->
|
|
map plain $
|
|
[if T.null displayName then "display name can't be empty" else "invalid display name: " <> viewName displayName]
|
|
<> ["you could use this one: " <> viewName validName | not (T.null validName)]
|
|
CEChatNotStarted -> ["error: chat not started"]
|
|
CEChatNotStopped -> ["error: chat not stopped"]
|
|
CEChatStoreChanged -> ["error: chat store changed, please restart chat"]
|
|
CEConnectionPlan connectionPlan -> viewConnectionPlan connectionPlan
|
|
CEInvalidConnReq -> viewInvalidConnReq
|
|
CEInvalidChatMessage Connection {connId} msgMeta_ msg e ->
|
|
[ plain $
|
|
("chat message error: " <> e <> " (" <> T.unpack (T.take 120 msg) <> ")")
|
|
<> (", connection id: " <> show connId)
|
|
<> maybe "" (\MsgMetaJSON {rcvId} -> ", agent msg rcv id: " <> show rcvId) msgMeta_
|
|
]
|
|
CEContactNotFound cName m_ -> viewContactNotFound cName m_
|
|
CEContactNotReady c -> [ttyContact' c <> ": not ready"]
|
|
CEContactDisabled ct -> [ttyContact' ct <> ": disabled, to enable: " <> highlight ("/enable " <> viewContactName ct) <> ", to delete: " <> highlight ("/d " <> viewContactName ct)]
|
|
CEContactNotActive c -> [ttyContact' c <> ": not active"]
|
|
CEConnectionDisabled Connection {connId, connType} -> [plain $ "connection " <> textEncode connType <> " (" <> tshow connId <> ") is disabled" | logLevel <= CLLWarning]
|
|
CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"]
|
|
CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"]
|
|
CEGroupUserRole g role ->
|
|
(: []) . (ttyGroup' g <>) $ case role of
|
|
GRAuthor -> ": you don't have permission to send messages"
|
|
_ -> ": you have insufficient permissions for this action, the required role is " <> plain (strEncode role)
|
|
CEGroupMemberInitialRole g role -> [ttyGroup' g <> ": initial role for group member cannot be " <> plain (strEncode role) <> ", use member or observer"]
|
|
CEContactIncognitoCantInvite -> ["you're using your main profile for this group - prohibited to invite contacts to whom you are connected incognito"]
|
|
CEGroupIncognitoCantInvite -> ["you are using an incognito profile for this group - prohibited to invite contacts"]
|
|
CEGroupContactRole c -> ["contact " <> ttyContact c <> " has insufficient permissions for this group action"]
|
|
CEGroupNotJoined g -> ["you did not join this group, use " <> highlight ("/join #" <> viewGroupName g)]
|
|
CEGroupMemberNotActive -> ["your group connection is not active yet, try later"]
|
|
CECantBlockMemberForSelf g m showMsgs ->
|
|
[ "admins or above can't block member for self, use "
|
|
<> highlight
|
|
( (if showMsgs then "/unblock for all" else "/block for all")
|
|
<> (" #" <> viewGroupName g <> " " <> viewMemberName m)
|
|
)
|
|
]
|
|
CEGroupMemberUserRemoved -> ["you are no longer a member of the group"]
|
|
CEGroupMemberNotFound -> ["group doesn't have this member"]
|
|
CEGroupCantResendInvitation g c -> viewCannotResendInvitation g c
|
|
CEGroupInternal s -> ["chat group bug: " <> plain s]
|
|
CEFileNotFound f -> ["file not found: " <> plain f]
|
|
CEFileSize f -> ["file size exceeds the limit: " <> plain f]
|
|
CEFileAlreadyReceiving f -> ["file is already being received: " <> plain f]
|
|
CEFileCancelled f -> ["file cancelled: " <> plain f]
|
|
CEFileCancel fileId e -> ["error cancelling file " <> sShow fileId <> ": " <> sShow e]
|
|
CEFileAlreadyExists f -> ["file already exists: " <> plain f]
|
|
CEFileRead f e -> ["cannot read file " <> plain f <> ": " <> plain e]
|
|
CEFileWrite f e -> ["cannot write file " <> plain f <> ": " <> plain e]
|
|
CEFileSend fileId e -> ["error sending file " <> sShow fileId <> ": " <> sShow e]
|
|
CEFileRcvChunk e -> ["error receiving file: " <> plain e]
|
|
CEFileInternal e -> ["file error: " <> plain e]
|
|
CEFileImageType _ -> ["image type must be jpg, send as a file using " <> highlight' "/f"]
|
|
CEFileImageSize _ -> ["max image size: " <> sShow maxImageSize <> " bytes, resize it or send as a file using " <> highlight' "/f"]
|
|
CEFileNotReceived fileId -> ["file " <> sShow fileId <> " not received"]
|
|
CEFileNotApproved fileId unknownSrvs -> ["file " <> sShow fileId <> " aborted, unknwon XFTP servers:"] <> map (plain . show) unknownSrvs
|
|
CEFallbackToSMPProhibited fileId -> ["recipient tried to accept file " <> sShow fileId <> " via old protocol, prohibited"]
|
|
CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."]
|
|
CEInvalidForward -> ["cannot forward message(s)"]
|
|
CEInvalidChatItemUpdate -> ["cannot update this item"]
|
|
CEInvalidChatItemDelete -> ["cannot delete this item"]
|
|
CEHasCurrentCall -> ["call already in progress"]
|
|
CENoCurrentCall -> ["no call in progress"]
|
|
CECallContact _ -> []
|
|
CECallState _ -> []
|
|
CEDirectMessagesProhibited dir ct -> viewDirectMessagesProhibited dir ct
|
|
CEAgentVersion -> ["unsupported agent version"]
|
|
CEAgentNoSubResult connId -> ["no subscription result for connection: " <> sShow connId]
|
|
CEServerProtocol p -> [plain $ "Servers for protocol " <> strEncode p <> " cannot be configured by the users"]
|
|
CECommandError e -> ["bad chat command: " <> plain e]
|
|
CEAgentCommandError e -> ["agent command error: " <> plain e]
|
|
CEInvalidFileDescription e -> ["invalid file description: " <> plain e]
|
|
CEConnectionIncognitoChangeProhibited -> ["incognito mode change prohibited"]
|
|
CEConnectionUserChangeProhibited -> ["incognito mode change prohibited for user"]
|
|
CEPeerChatVRangeIncompatible -> ["peer chat protocol version range incompatible"]
|
|
CEInternalError e -> ["internal chat error: " <> plain e]
|
|
CEException e -> ["exception: " <> plain e]
|
|
-- e -> ["chat error: " <> sShow e]
|
|
ChatErrorStore err -> case err of
|
|
SEDuplicateName -> ["this display name is already used by user, contact or group"]
|
|
SEUserNotFoundByName u -> ["no user " <> ttyContact u]
|
|
SEContactNotFoundByName c -> ["no contact " <> ttyContact c]
|
|
SEContactNotReady c -> ["contact " <> ttyContact c <> " is not active yet"]
|
|
SEGroupNotFoundByName g -> ["no group " <> ttyGroup g]
|
|
SEGroupAlreadyJoined -> ["you already joined this group"]
|
|
SEFileNotFound fileId -> fileNotFound fileId
|
|
SESndFileNotFound fileId -> fileNotFound fileId
|
|
SERcvFileNotFound fileId -> fileNotFound fileId
|
|
SEDuplicateContactLink -> ["you already have chat address, to show: " <> highlight' "/sa"]
|
|
SEUserContactLinkNotFound -> ["no chat address, to create: " <> highlight' "/ad"]
|
|
SEContactRequestNotFoundByName c -> ["no contact request from " <> ttyContact c]
|
|
SEFileIdNotFoundBySharedMsgId _ -> [] -- recipient tried to accept cancelled file
|
|
SEConnectionNotFound agentConnId -> ["event connection not found, agent ID: " <> sShow agentConnId | logLevel <= CLLWarning] -- mutes delete group error
|
|
SEChatItemNotFoundByText text -> ["message not found by text: " <> plain text]
|
|
SEDuplicateGroupLink g -> ["you already have link for this group, to show: " <> highlight ("/show link #" <> viewGroupName g)]
|
|
SEGroupLinkNotFound g -> ["no group link, to create: " <> highlight ("/create link #" <> viewGroupName g)]
|
|
SERemoteCtrlNotFound rcId -> ["no remote controller " <> sShow rcId]
|
|
SERemoteHostNotFound rhId -> ["no remote host " <> sShow rhId]
|
|
SEDuplicateGroupMessage {groupId, sharedMsgId}
|
|
| testView -> ["duplicate group message, group id: " <> sShow groupId <> ", message id: " <> sShow sharedMsgId]
|
|
| otherwise -> []
|
|
SEUserNoteFolderNotFound -> ["no notes folder"]
|
|
e -> ["chat db error: " <> sShow e]
|
|
ChatErrorDatabase err -> case err of
|
|
DBErrorEncrypted -> ["error: chat database is already encrypted"]
|
|
DBErrorPlaintext -> ["error: chat database is not encrypted"]
|
|
DBErrorExport e -> ["error encrypting database: " <> sqliteError' e]
|
|
DBErrorOpen e -> ["error opening database after encryption: " <> sqliteError' e]
|
|
e -> ["chat database error: " <> sShow e]
|
|
ChatErrorAgent err entity_ -> case err of
|
|
CMD PROHIBITED cxt -> [withConnEntity <> plain ("error: command is prohibited, " <> cxt)]
|
|
SMP _ SMP.AUTH ->
|
|
[ withConnEntity
|
|
<> "error: connection authorization failed - this could happen if connection was deleted, secured with different credentials, or due to a bug - please re-create the connection"
|
|
]
|
|
SMP _ (SMP.BLOCKED BlockingInfo {reason}) ->
|
|
[withConnEntity <> "error: connection blocked by server operator: " <> reasonStr]
|
|
where
|
|
reasonStr = case reason of
|
|
BRSpam -> "spam"
|
|
BRContent -> "content violates conditions of use"
|
|
BROKER _ NETWORK | not isCmd -> []
|
|
BROKER _ TIMEOUT | not isCmd -> []
|
|
AGENT A_DUPLICATE -> [withConnEntity <> "error: AGENT A_DUPLICATE" | logLevel == CLLDebug || isCmd]
|
|
AGENT (A_PROHIBITED e) -> [withConnEntity <> "error: AGENT A_PROHIBITED, " <> plain e | logLevel <= CLLWarning || isCmd]
|
|
CONN NOT_FOUND -> [withConnEntity <> "error: CONN NOT_FOUND" | logLevel <= CLLWarning || isCmd]
|
|
CRITICAL restart e -> [plain $ "critical error: " <> e] <> ["please restart the app" | restart]
|
|
INTERNAL e -> [plain $ "internal error: " <> e]
|
|
e -> [withConnEntity <> "smp agent error: " <> sShow e | logLevel <= CLLWarning || isCmd]
|
|
where
|
|
withConnEntity = case entity_ of
|
|
Just entity@(RcvDirectMsgConnection conn contact_) -> case contact_ of
|
|
Just Contact {contactId} ->
|
|
"[" <> connEntityLabel entity <> ", contactId: " <> sShow contactId <> ", connId: " <> cId conn <> "] "
|
|
Nothing ->
|
|
"[" <> connEntityLabel entity <> ", connId: " <> cId conn <> "] "
|
|
Just entity@(RcvGroupMsgConnection conn GroupInfo {groupId} GroupMember {groupMemberId}) ->
|
|
"[" <> connEntityLabel entity <> ", groupId: " <> sShow groupId <> ", memberId: " <> sShow groupMemberId <> ", connId: " <> cId conn <> "] "
|
|
Just entity@(RcvFileConnection conn RcvFileTransfer {fileId}) ->
|
|
"[" <> connEntityLabel entity <> ", fileId: " <> sShow fileId <> ", connId: " <> cId conn <> "] "
|
|
Just entity@(SndFileConnection conn SndFileTransfer {fileId}) ->
|
|
"[" <> connEntityLabel entity <> ", fileId: " <> sShow fileId <> ", connId: " <> cId conn <> "] "
|
|
Just entity@(UserContactConnection conn UserContact {userContactLinkId}) ->
|
|
"[" <> connEntityLabel entity <> ", userContactLinkId: " <> sShow userContactLinkId <> ", connId: " <> cId conn <> "] "
|
|
Nothing -> ""
|
|
cId :: Connection -> StyledString
|
|
cId Connection {connId} = sShow connId
|
|
ChatErrorRemoteCtrl e -> [plain $ "remote controller error: " <> show e]
|
|
ChatErrorRemoteHost RHNew e -> [plain $ "new remote host error: " <> show e]
|
|
ChatErrorRemoteHost (RHId rhId) e -> [plain $ "remote host " <> show rhId <> " error: " <> show e]
|
|
where
|
|
fileNotFound fileId = ["file " <> sShow fileId <> " not found"]
|
|
sqliteError' = \case
|
|
SQLiteErrorNotADatabase -> "wrong passphrase or invalid database file"
|
|
SQLiteError e -> sShow e
|
|
|
|
viewConnectionEntityDisabled :: ConnectionEntity -> [StyledString]
|
|
viewConnectionEntityDisabled entity = case entity of
|
|
RcvDirectMsgConnection _ (Just c) -> ["[" <> entityLabel <> "] connection is disabled, to enable: " <> highlight ("/enable " <> viewContactName c) <> ", to delete: " <> highlight ("/d " <> viewContactName c)]
|
|
RcvGroupMsgConnection _ g m -> ["[" <> entityLabel <> "] connection is disabled, to enable: " <> highlight ("/enable #" <> viewGroupName g <> " " <> viewMemberName m)]
|
|
_ -> ["[" <> entityLabel <> "] connection is disabled"]
|
|
where
|
|
entityLabel = connEntityLabel entity
|
|
|
|
viewConnectionEntityInactive :: ConnectionEntity -> Bool -> [StyledString]
|
|
viewConnectionEntityInactive entity inactive
|
|
| inactive = ["[" <> connEntityLabel entity <> "] connection is marked as inactive"]
|
|
| otherwise = ["[" <> connEntityLabel entity <> "] inactive connection is marked as active"]
|
|
|
|
viewJSON :: J.ToJSON a => a -> StyledString
|
|
viewJSON = plain . LB.toStrict . J.encode
|
|
|
|
connEntityLabel :: ConnectionEntity -> StyledString
|
|
connEntityLabel = \case
|
|
RcvDirectMsgConnection _ (Just Contact {localDisplayName = c}) -> plain c
|
|
RcvDirectMsgConnection _ Nothing -> "rcv direct msg"
|
|
RcvGroupMsgConnection _ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} -> plain $ "#" <> g <> " " <> m
|
|
RcvFileConnection _ RcvFileTransfer {fileInvitation = FileInvitation {fileName}} -> plain $ "rcv file " <> T.pack fileName
|
|
SndFileConnection _ SndFileTransfer {fileName} -> plain $ "snd file " <> T.pack fileName
|
|
UserContactConnection _ UserContact {} -> "contact address"
|
|
|
|
ttyContact :: ContactName -> StyledString
|
|
ttyContact = styled (colored Green) . viewName
|
|
|
|
ttyContact' :: Contact -> StyledString
|
|
ttyContact' Contact {localDisplayName = c} = ttyContact c
|
|
|
|
ttyFullContact :: Contact -> StyledString
|
|
ttyFullContact Contact {localDisplayName, profile = LocalProfile {fullName}} =
|
|
ttyFullName localDisplayName fullName
|
|
|
|
ttyMember :: GroupMember -> StyledString
|
|
ttyMember GroupMember {localDisplayName} = ttyContact localDisplayName
|
|
|
|
ttyFullMember :: GroupMember -> StyledString
|
|
ttyFullMember GroupMember {localDisplayName, memberProfile = LocalProfile {fullName}} =
|
|
ttyFullName localDisplayName fullName
|
|
|
|
ttyFullName :: ContactName -> Text -> StyledString
|
|
ttyFullName c fullName = ttyContact c <> optFullName c fullName
|
|
|
|
ttyToContact :: ContactName -> StyledString
|
|
ttyToContact c = ttyTo $ "@" <> viewName c <> " "
|
|
|
|
ttyToContact' :: Contact -> StyledString
|
|
ttyToContact' ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyToContact c
|
|
|
|
ttyToContactEdited' :: Contact -> StyledString
|
|
ttyToContactEdited' ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyTo ("@" <> viewName c <> " [edited] ")
|
|
|
|
ttyQuotedContact :: Contact -> StyledString
|
|
ttyQuotedContact Contact {localDisplayName = c} = ttyFrom $ viewName c <> ">"
|
|
|
|
ttyQuotedMember :: Maybe GroupMember -> StyledString
|
|
ttyQuotedMember (Just GroupMember {localDisplayName = c}) = "> " <> ttyFrom (viewName c)
|
|
ttyQuotedMember _ = "> " <> ttyFrom "?"
|
|
|
|
ttyFromContact :: Contact -> StyledString
|
|
ttyFromContact ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (viewName c <> "> ")
|
|
|
|
ttyFromContactEdited :: Contact -> StyledString
|
|
ttyFromContactEdited ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (viewName c <> "> [edited] ")
|
|
|
|
ttyFromContactDeleted :: Contact -> Maybe Text -> StyledString
|
|
ttyFromContactDeleted ct@Contact {localDisplayName = c} deletedText_ =
|
|
ctIncognito ct <> ttyFrom (viewName c <> "> " <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
|
|
|
|
ttyGroup :: GroupName -> StyledString
|
|
ttyGroup g = styled (colored Blue) $ "#" <> viewName g
|
|
|
|
ttyGroup' :: GroupInfo -> StyledString
|
|
ttyGroup' = ttyGroup . groupName'
|
|
|
|
viewContactName :: Contact -> Text
|
|
viewContactName = viewName . localDisplayName'
|
|
|
|
viewGroupName :: GroupInfo -> Text
|
|
viewGroupName = viewName . groupName'
|
|
|
|
viewMemberName :: GroupMember -> Text
|
|
viewMemberName GroupMember {localDisplayName = n} = viewName n
|
|
|
|
ttyGroups :: [GroupName] -> StyledString
|
|
ttyGroups [] = ""
|
|
ttyGroups [g] = ttyGroup g
|
|
ttyGroups (g : gs) = ttyGroup g <> ", " <> ttyGroups gs
|
|
|
|
ttyFullGroup :: GroupInfo -> StyledString
|
|
ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullName}} =
|
|
ttyGroup g <> optFullName g fullName
|
|
|
|
ttyFromGroup :: GroupInfo -> GroupMember -> StyledString
|
|
ttyFromGroup g m = ttyFromGroupAttention g m False
|
|
|
|
ttyFromGroupAttention :: GroupInfo -> GroupMember -> Bool -> StyledString
|
|
ttyFromGroupAttention g m attention = membershipIncognito g <> ttyFrom (fromGroupAttention_ g m attention)
|
|
|
|
ttyFromGroupEdited :: GroupInfo -> GroupMember -> StyledString
|
|
ttyFromGroupEdited g m = membershipIncognito g <> ttyFrom (fromGroup_ g m <> "[edited] ")
|
|
|
|
ttyFromGroupDeleted :: GroupInfo -> GroupMember -> Maybe Text -> StyledString
|
|
ttyFromGroupDeleted g m deletedText_ =
|
|
membershipIncognito g <> ttyFrom (fromGroup_ g m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
|
|
|
|
fromGroup_ :: GroupInfo -> GroupMember -> Text
|
|
fromGroup_ g m = fromGroupAttention_ g m False
|
|
|
|
fromGroupAttention_ :: GroupInfo -> GroupMember -> Bool -> Text
|
|
fromGroupAttention_ g m attention =
|
|
let attn = if attention then "!" else ""
|
|
in "#" <> viewGroupName g <> " " <> viewMemberName m <> attn <> "> "
|
|
|
|
ttyFrom :: Text -> StyledString
|
|
ttyFrom = styled $ colored Yellow
|
|
|
|
ttyTo :: Text -> StyledString
|
|
ttyTo = styled $ colored Cyan
|
|
|
|
ttyToGroup :: GroupInfo -> StyledString
|
|
ttyToGroup g = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> " ")
|
|
|
|
ttyToGroupEdited :: GroupInfo -> StyledString
|
|
ttyToGroupEdited g = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> " [edited] ")
|
|
|
|
viewName :: Text -> Text
|
|
viewName s = if T.any isSpace s then "'" <> s <> "'" else s
|
|
|
|
ttyFilePath :: FilePath -> StyledString
|
|
ttyFilePath = plain
|
|
|
|
optFullName :: ContactName -> Text -> StyledString
|
|
optFullName localDisplayName fullName = plain $ optionalFullName localDisplayName fullName
|
|
|
|
ctIncognito :: Contact -> StyledString
|
|
ctIncognito ct = if contactConnIncognito ct then incognitoPrefix else ""
|
|
|
|
membershipIncognito :: GroupInfo -> StyledString
|
|
membershipIncognito = memIncognito . membership
|
|
|
|
memIncognito :: GroupMember -> StyledString
|
|
memIncognito m = if memberIncognito m then incognitoPrefix else ""
|
|
|
|
incognitoPrefix :: StyledString
|
|
incognitoPrefix = styleIncognito' "i "
|
|
|
|
incognitoProfile' :: Profile -> StyledString
|
|
incognitoProfile' Profile {displayName} = styleIncognito displayName
|
|
|
|
highlight :: StyledFormat a => a -> StyledString
|
|
highlight = styled $ colored Cyan
|
|
|
|
highlight' :: String -> StyledString
|
|
highlight' = highlight
|
|
|
|
styleIncognito :: StyledFormat a => a -> StyledString
|
|
styleIncognito = styled $ colored Magenta
|
|
|
|
styleIncognito' :: String -> StyledString
|
|
styleIncognito' = styleIncognito
|
|
|
|
styleTime :: String -> StyledString
|
|
styleTime = Styled [SetColor Foreground Vivid Black]
|
|
|
|
ttyError :: StyledFormat a => a -> StyledString
|
|
ttyError = styled $ colored Red
|
|
|
|
ttyError' :: String -> StyledString
|
|
ttyError' = ttyError
|