mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-08-29 01:09:15 +00:00
Merge branch 'master' into ep/forward-api
This commit is contained in:
spaced4ndy
@@ -59,9 +59,10 @@ import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Remote.AppVersion
|
||||
import Simplex.Chat.Remote.Types
|
||||
import Simplex.Chat.Store (AutoAccept, StoreError (..), UserContactLink, UserMsgReceiptSettings)
|
||||
import Simplex.Chat.Store (AutoAccept, ChatLockEntity, StoreError (..), UserContactLink, UserMsgReceiptSettings)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Util (liftIOEither)
|
||||
import Simplex.FileTransfer.Description (FileDescriptionURI)
|
||||
import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo)
|
||||
@@ -165,7 +166,7 @@ defaultChatHooks =
|
||||
ChatHooks
|
||||
{ preCmdHook = \_ -> pure . Right,
|
||||
eventHook = \_ -> pure
|
||||
}
|
||||
}
|
||||
|
||||
data DefaultAgentServers = DefaultAgentServers
|
||||
{ smp :: NonEmpty SMPServerWithAuth,
|
||||
@@ -208,6 +209,7 @@ data ChatController = ChatController
|
||||
connNetworkStatuses :: TMap AgentConnId NetworkStatus,
|
||||
subscriptionMode :: TVar SubscriptionMode,
|
||||
chatLock :: Lock,
|
||||
entityLocks :: TMap ChatLockEntity Lock,
|
||||
sndFiles :: TVar (Map Int64 Handle),
|
||||
rcvFiles :: TVar (Map Int64 Handle),
|
||||
currentCalls :: TMap ContactId Call,
|
||||
@@ -464,7 +466,8 @@ data ChatCommand
|
||||
| ShowProfileImage
|
||||
| SetUserFeature AChatFeature FeatureAllowed -- UserId (not used in UI)
|
||||
| SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed)
|
||||
| SetGroupFeature AGroupFeature GroupName GroupFeatureEnabled
|
||||
| SetGroupFeature AGroupFeatureNoRole GroupName GroupFeatureEnabled
|
||||
| SetGroupFeatureRole AGroupFeatureRole GroupName GroupFeatureEnabled (Maybe GroupMemberRole)
|
||||
| SetUserTimedMessages Bool -- UserId (not used in UI)
|
||||
| SetContactTimedMessages ContactName (Maybe TimedMessagesEnabled)
|
||||
| SetGroupTimedMessages GroupName (Maybe Int)
|
||||
@@ -495,9 +498,9 @@ data ChatCommand
|
||||
| GetAgentSubsDetails
|
||||
| GetAgentWorkers
|
||||
| GetAgentWorkersDetails
|
||||
-- The parser will return this command for strings that start from "//".
|
||||
-- This command should be processed in preCmdHook
|
||||
| CustomChatCommand ByteString
|
||||
| -- The parser will return this command for strings that start from "//".
|
||||
-- This command should be processed in preCmdHook
|
||||
CustomChatCommand ByteString
|
||||
deriving (Show)
|
||||
|
||||
allowRemoteCommand :: ChatCommand -> Bool -- XXX: consider using Relay/Block/ForceLocal
|
||||
@@ -735,7 +738,7 @@ data ChatResponse
|
||||
| CRContactPQEnabled {user :: User, contact :: Contact, pqEnabled :: PQEncryption}
|
||||
| CRSQLResult {rows :: [Text]}
|
||||
| CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]}
|
||||
| CRDebugLocks {chatLockName :: Maybe String, agentLocks :: AgentLocks}
|
||||
| CRDebugLocks {chatLockName :: Maybe String, chatEntityLocks :: Map String String, agentLocks :: AgentLocks}
|
||||
| CRAgentStats {agentStats :: [[String]]}
|
||||
| CRAgentWorkersDetails {agentWorkersDetails :: AgentWorkersDetails}
|
||||
| CRAgentWorkersSummary {agentWorkersSummary :: AgentWorkersSummary}
|
||||
@@ -1358,7 +1361,7 @@ handleDBErrors =
|
||||
[ E.Handler $ \(e :: SQLError) ->
|
||||
let se = SQL.sqlError e
|
||||
busy = se == SQL.ErrorBusy || se == SQL.ErrorLocked
|
||||
in pure . Left . ChatErrorStore $ if busy then SEDBBusyError $ show se else SEDBException $ show e,
|
||||
in pure . Left . ChatErrorStore $ if busy then SEDBBusyError $ show se else SEDBException $ show e,
|
||||
E.Handler $ \(E.SomeException e) -> pure . Left . ChatErrorStore . SEDBException $ show e
|
||||
]
|
||||
|
||||
|
||||
@@ -144,6 +144,15 @@ markdownToList (m1 :|: m2) = markdownToList m1 <> markdownToList m2
|
||||
parseMarkdown :: Text -> Markdown
|
||||
parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInput) s
|
||||
|
||||
containsFormat :: (Format -> Bool) -> Markdown -> Bool
|
||||
containsFormat p (Markdown f _) = maybe False p f
|
||||
containsFormat p (m1 :|: m2) = containsFormat p m1 || containsFormat p m2
|
||||
|
||||
isSimplexLink :: Format -> Bool
|
||||
isSimplexLink = \case
|
||||
SimplexLink {} -> True;
|
||||
_ -> False
|
||||
|
||||
markdownP :: Parser Markdown
|
||||
markdownP = mconcat <$> A.many' fragmentP
|
||||
where
|
||||
|
||||
@@ -24,6 +24,7 @@ import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Encoding as JE
|
||||
import qualified Data.Aeson.TH as JQ
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Char (isSpace)
|
||||
import Data.Int (Int64)
|
||||
@@ -47,7 +48,6 @@ import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptStatus (..))
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..))
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import qualified Simplex.Messaging.Encoding.Base64 as B64
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON)
|
||||
import Simplex.Messaging.Protocol (MsgBody)
|
||||
|
||||
@@ -28,6 +28,7 @@ import Simplex.Chat.Messages.CIContent.Events
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.Messaging.Agent.Protocol (MsgErrorType (..), RatchetSyncState (..), SwitchPhase (..))
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption, pattern PQEncOn, pattern PQEncOff)
|
||||
@@ -134,8 +135,8 @@ data CIContent (d :: MsgDirection) where
|
||||
CISndChatFeature :: ChatFeature -> PrefEnabled -> Maybe Int -> CIContent 'MDSnd
|
||||
CIRcvChatPreference :: ChatFeature -> FeatureAllowed -> Maybe Int -> CIContent 'MDRcv
|
||||
CISndChatPreference :: ChatFeature -> FeatureAllowed -> Maybe Int -> CIContent 'MDSnd
|
||||
CIRcvGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDRcv
|
||||
CISndGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDSnd
|
||||
CIRcvGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent 'MDRcv
|
||||
CISndGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent 'MDSnd
|
||||
CIRcvChatFeatureRejected :: ChatFeature -> CIContent 'MDRcv
|
||||
CIRcvGroupFeatureRejected :: GroupFeature -> CIContent 'MDRcv
|
||||
CISndModerated :: CIContent 'MDSnd
|
||||
@@ -255,8 +256,8 @@ ciContentToText = \case
|
||||
CISndChatFeature feature enabled param -> featureStateText feature enabled param
|
||||
CIRcvChatPreference feature allowed param -> prefStateText feature allowed param
|
||||
CISndChatPreference feature allowed param -> "you " <> prefStateText feature allowed param
|
||||
CIRcvGroupFeature feature pref param -> groupPrefStateText feature pref param
|
||||
CISndGroupFeature feature pref param -> groupPrefStateText feature pref param
|
||||
CIRcvGroupFeature feature pref param role -> groupPrefStateText feature pref param role
|
||||
CISndGroupFeature feature pref param role -> groupPrefStateText feature pref param role
|
||||
CIRcvChatFeatureRejected feature -> chatFeatureNameText feature <> ": received, prohibited"
|
||||
CIRcvGroupFeatureRejected feature -> groupFeatureNameText feature <> ": received, prohibited"
|
||||
CISndModerated -> ciModeratedText
|
||||
@@ -413,8 +414,8 @@ data JSONCIContent
|
||||
| JCISndChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int}
|
||||
| JCIRcvChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| JCISndChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| JCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| JCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| JCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int, memberRole_ :: Maybe GroupMemberRole}
|
||||
| JCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int, memberRole_ :: Maybe GroupMemberRole}
|
||||
| JCIRcvChatFeatureRejected {feature :: ChatFeature}
|
||||
| JCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
|
||||
| JCISndModerated
|
||||
@@ -447,8 +448,8 @@ jsonCIContent = \case
|
||||
CISndChatFeature feature enabled param -> JCISndChatFeature {feature, enabled, param}
|
||||
CIRcvChatPreference feature allowed param -> JCIRcvChatPreference {feature, allowed, param}
|
||||
CISndChatPreference feature allowed param -> JCISndChatPreference {feature, allowed, param}
|
||||
CIRcvGroupFeature groupFeature preference param -> JCIRcvGroupFeature {groupFeature, preference, param}
|
||||
CISndGroupFeature groupFeature preference param -> JCISndGroupFeature {groupFeature, preference, param}
|
||||
CIRcvGroupFeature groupFeature preference param memberRole_ -> JCIRcvGroupFeature {groupFeature, preference, param, memberRole_}
|
||||
CISndGroupFeature groupFeature preference param memberRole_ -> JCISndGroupFeature {groupFeature, preference, param, memberRole_}
|
||||
CIRcvChatFeatureRejected feature -> JCIRcvChatFeatureRejected {feature}
|
||||
CIRcvGroupFeatureRejected groupFeature -> JCIRcvGroupFeatureRejected {groupFeature}
|
||||
CISndModerated -> JCISndModerated
|
||||
@@ -481,8 +482,8 @@ aciContentJSON = \case
|
||||
JCISndChatFeature {feature, enabled, param} -> ACIContent SMDSnd $ CISndChatFeature feature enabled param
|
||||
JCIRcvChatPreference {feature, allowed, param} -> ACIContent SMDRcv $ CIRcvChatPreference feature allowed param
|
||||
JCISndChatPreference {feature, allowed, param} -> ACIContent SMDSnd $ CISndChatPreference feature allowed param
|
||||
JCIRcvGroupFeature {groupFeature, preference, param} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param
|
||||
JCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
|
||||
JCIRcvGroupFeature {groupFeature, preference, param, memberRole_} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param memberRole_
|
||||
JCISndGroupFeature {groupFeature, preference, param, memberRole_} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param memberRole_
|
||||
JCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
|
||||
JCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
|
||||
JCISndModerated -> ACIContent SMDSnd CISndModerated
|
||||
@@ -516,8 +517,8 @@ data DBJSONCIContent
|
||||
| DBJCISndChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int}
|
||||
| DBJCIRcvChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| DBJCISndChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| DBJCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| DBJCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| DBJCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int, memberRole_ :: Maybe GroupMemberRole}
|
||||
| DBJCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int, memberRole_ :: Maybe GroupMemberRole}
|
||||
| DBJCIRcvChatFeatureRejected {feature :: ChatFeature}
|
||||
| DBJCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
|
||||
| DBJCISndModerated
|
||||
@@ -550,8 +551,8 @@ dbJsonCIContent = \case
|
||||
CISndChatFeature feature enabled param -> DBJCISndChatFeature {feature, enabled, param}
|
||||
CIRcvChatPreference feature allowed param -> DBJCIRcvChatPreference {feature, allowed, param}
|
||||
CISndChatPreference feature allowed param -> DBJCISndChatPreference {feature, allowed, param}
|
||||
CIRcvGroupFeature groupFeature preference param -> DBJCIRcvGroupFeature {groupFeature, preference, param}
|
||||
CISndGroupFeature groupFeature preference param -> DBJCISndGroupFeature {groupFeature, preference, param}
|
||||
CIRcvGroupFeature groupFeature preference param memberRole_ -> DBJCIRcvGroupFeature {groupFeature, preference, param, memberRole_}
|
||||
CISndGroupFeature groupFeature preference param memberRole_ -> DBJCISndGroupFeature {groupFeature, preference, param, memberRole_}
|
||||
CIRcvChatFeatureRejected feature -> DBJCIRcvChatFeatureRejected {feature}
|
||||
CIRcvGroupFeatureRejected groupFeature -> DBJCIRcvGroupFeatureRejected {groupFeature}
|
||||
CISndModerated -> DBJCISndModerated
|
||||
@@ -584,8 +585,8 @@ aciContentDBJSON = \case
|
||||
DBJCISndChatFeature {feature, enabled, param} -> ACIContent SMDSnd $ CISndChatFeature feature enabled param
|
||||
DBJCIRcvChatPreference {feature, allowed, param} -> ACIContent SMDRcv $ CIRcvChatPreference feature allowed param
|
||||
DBJCISndChatPreference {feature, allowed, param} -> ACIContent SMDSnd $ CISndChatPreference feature allowed param
|
||||
DBJCIRcvGroupFeature {groupFeature, preference, param} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param
|
||||
DBJCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
|
||||
DBJCIRcvGroupFeature {groupFeature, preference, param, memberRole_} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param memberRole_
|
||||
DBJCISndGroupFeature {groupFeature, preference, param, memberRole_} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param memberRole_
|
||||
DBJCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
|
||||
DBJCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
|
||||
DBJCISndModerated -> ACIContent SMDSnd CISndModerated
|
||||
|
||||
@@ -7,6 +7,7 @@ module Simplex.Chat.Messages.CIContent.Events where
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson.TH as J
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Messaging.Agent.Protocol (RatchetSyncState (..), SwitchPhase (..))
|
||||
import Simplex.Messaging.Parsers (dropPrefix, singleFieldJSON, sumTypeJSON)
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption)
|
||||
|
||||
@@ -17,6 +17,7 @@ import qualified Data.Aeson.TH as JQ
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteArray (ScrubbedBytes)
|
||||
import qualified Data.ByteArray as BA
|
||||
import qualified Data.ByteString.Base64.URL as U
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
@@ -49,7 +50,6 @@ import Simplex.Messaging.Agent.Env.SQLite (createAgentStore)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError, closeSQLiteStore, reopenSQLiteStore)
|
||||
import Simplex.Messaging.Client (defaultNetworkConfig)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Encoding.Base64.URL as U
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), BasicAuth (..), CorrId (..), ProtoServerWithAuth (..), ProtocolServer (..))
|
||||
|
||||
@@ -17,6 +17,7 @@ import Data.Bifunctor (bimap)
|
||||
import qualified Data.ByteArray as BA
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Base64.URL as U
|
||||
import Data.Either (fromLeft)
|
||||
import Data.Word (Word8)
|
||||
import Foreign.C (CInt, CString, newCAString)
|
||||
@@ -25,7 +26,6 @@ import Foreign.StablePtr
|
||||
import Simplex.Chat.Controller (ChatController (..))
|
||||
import Simplex.Chat.Mobile.Shared
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Encoding.Base64.URL as U
|
||||
import UnliftIO (atomically)
|
||||
|
||||
cChatEncryptMedia :: StablePtr ChatController -> CString -> Ptr Word8 -> CInt -> IO CString
|
||||
|
||||
@@ -45,10 +45,11 @@ import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import Simplex.Chat.Call
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.Messaging.Agent.Protocol (VersionSMPA, pqdrSMPAgentVersion)
|
||||
import Simplex.Messaging.Compression (compress1, decompressBatch)
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQSupport (..), pattern PQSupportOn, pattern PQSupportOff)
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQSupport (..), pattern PQSupportOff, pattern PQSupportOn)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON)
|
||||
|
||||
@@ -22,6 +22,7 @@ import Crypto.Random (getRandomBytes)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Types as JT
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Base64.URL as B64U
|
||||
import Data.ByteString.Builder (Builder)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
@@ -55,7 +56,6 @@ import Simplex.Messaging.Agent
|
||||
import Simplex.Messaging.Agent.Protocol (AgentErrorType (RCP))
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import qualified Simplex.Messaging.Encoding.Base64.URL as B64U
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (TLS, closeConnection, tlsUniq)
|
||||
|
||||
@@ -1,6 +1,7 @@
|
||||
module Simplex.Chat.Store
|
||||
( SQLiteStore,
|
||||
StoreError (..),
|
||||
ChatLockEntity (..),
|
||||
UserMsgReceiptSettings (..),
|
||||
UserContactLink (..),
|
||||
AutoAccept (..),
|
||||
|
||||
@@ -3,11 +3,13 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Chat.Store.Connections
|
||||
( getConnectionEntity,
|
||||
( getChatLockEntity,
|
||||
getConnectionEntity,
|
||||
getConnectionEntityByConnReq,
|
||||
getContactConnEntityByConnReqHash,
|
||||
getConnectionsToSubscribe,
|
||||
@@ -37,6 +39,31 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQSupport)
|
||||
import Simplex.Messaging.Util (eitherToMaybe)
|
||||
|
||||
getChatLockEntity :: DB.Connection -> AgentConnId -> ExceptT StoreError IO ChatLockEntity
|
||||
getChatLockEntity db agentConnId = do
|
||||
((connId, connType) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId)) <-
|
||||
ExceptT . firstRow id (SEConnectionNotFound agentConnId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT connection_id, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id
|
||||
FROM connections
|
||||
WHERE agent_conn_id = ?
|
||||
|]
|
||||
(Only agentConnId)
|
||||
let err = throwError $ SEInternalError $ "connection " <> show connType <> " without entity"
|
||||
case connType of
|
||||
ConnMember -> maybe err (fmap CLGroup . getMemberGroupId) groupMemberId
|
||||
ConnContact -> pure $ maybe (CLConnection connId) CLContact contactId
|
||||
ConnSndFile -> maybe err (pure . CLFile) sndFileId
|
||||
ConnRcvFile -> maybe err (pure . CLFile) rcvFileId
|
||||
ConnUserContact -> maybe err (pure . CLUserContact) userContactLinkId
|
||||
where
|
||||
getMemberGroupId :: GroupMemberId -> ExceptT StoreError IO GroupId
|
||||
getMemberGroupId groupMemberId =
|
||||
ExceptT . firstRow fromOnly (SEInternalError "group member connection group_id not found") $
|
||||
DB.query db "SELECT group_id FROM group_members WHERE group_member_id = ?" (Only groupMemberId)
|
||||
|
||||
getConnectionEntity :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
|
||||
getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
|
||||
c@Connection {connType, entityId} <- getConnection_
|
||||
|
||||
@@ -336,10 +336,10 @@ setSndFTAgentDeleted db User {userId} fileId = do
|
||||
"UPDATE files SET agent_snd_file_deleted = 1, updated_at = ? WHERE user_id = ? AND file_id = ?"
|
||||
(currentTs, userId, fileId)
|
||||
|
||||
getXFTPSndFileDBId :: DB.Connection -> User -> AgentSndFileId -> ExceptT StoreError IO FileTransferId
|
||||
getXFTPSndFileDBId db User {userId} aSndFileId =
|
||||
getXFTPSndFileDBId :: DB.Connection -> AgentSndFileId -> ExceptT StoreError IO FileTransferId
|
||||
getXFTPSndFileDBId db aSndFileId =
|
||||
ExceptT . firstRow fromOnly (SESndFileNotFoundXFTP aSndFileId) $
|
||||
DB.query db "SELECT file_id FROM files WHERE user_id = ? AND agent_snd_file_id = ?" (userId, aSndFileId)
|
||||
DB.query db "SELECT file_id FROM files WHERE agent_snd_file_id = ?" (Only aSndFileId)
|
||||
|
||||
getXFTPRcvFileDBId :: DB.Connection -> AgentRcvFileId -> ExceptT StoreError IO FileTransferId
|
||||
getXFTPRcvFileDBId db aRcvFileId =
|
||||
|
||||
@@ -124,6 +124,7 @@ import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Bifunctor (second)
|
||||
import Data.Either (rights)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (partition, sortOn)
|
||||
@@ -139,6 +140,7 @@ import Simplex.Chat.Store.Direct
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId, UserId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
@@ -668,13 +670,13 @@ getGroupSummary db User {userId} groupId = do
|
||||
(userId, groupId, GSMemRemoved, GSMemLeft, GSMemUnknown, GSMemInvited)
|
||||
pure GroupSummary {currentMembers = fromMaybe 0 currentMembers_}
|
||||
|
||||
getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences]
|
||||
getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [(GroupMemberRole, FullGroupPreferences)]
|
||||
getContactGroupPreferences db User {userId} Contact {contactId} = do
|
||||
map (mergeGroupPreferences . fromOnly)
|
||||
map (second mergeGroupPreferences)
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT gp.preferences
|
||||
SELECT m.member_role, gp.preferences
|
||||
FROM groups g
|
||||
JOIN group_profiles gp USING (group_profile_id)
|
||||
JOIN group_members m USING (group_id)
|
||||
|
||||
@@ -81,6 +81,7 @@ import Simplex.Chat.Store.Direct
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
|
||||
@@ -18,6 +18,7 @@ import Control.Monad.Except
|
||||
import Control.Monad.IO.Class
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import qualified Data.Aeson.TH as J
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (fromMaybe, isJust, listToMaybe)
|
||||
@@ -38,13 +39,21 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..))
|
||||
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
||||
import qualified Simplex.Messaging.Encoding.Base64 as B64
|
||||
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
|
||||
import Simplex.Messaging.Protocol (SubscriptionMode (..))
|
||||
import Simplex.Messaging.Util (allFinally)
|
||||
import Simplex.Messaging.Version
|
||||
import UnliftIO.STM
|
||||
|
||||
data ChatLockEntity
|
||||
= CLInvitation ByteString
|
||||
| CLConnection Int64
|
||||
| CLContact ContactId
|
||||
| CLGroup GroupId
|
||||
| CLUserContact Int64
|
||||
| CLFile Int64
|
||||
deriving (Eq, Ord)
|
||||
|
||||
-- These error type constructors must be added to mobile apps
|
||||
data StoreError
|
||||
= SEDuplicateName
|
||||
|
||||
@@ -30,7 +30,6 @@ import qualified Data.Aeson.TH as JQ
|
||||
import qualified Data.Aeson.Types as JT
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString, pack, unpack)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
@@ -45,6 +44,7 @@ import Database.SQLite.Simple.Internal (Field (..))
|
||||
import Database.SQLite.Simple.Ok
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.FileTransfer.Description (FileDigest)
|
||||
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, RcvFileId, SAEntity (..), SndFileId, UserId)
|
||||
@@ -439,9 +439,13 @@ featureAllowed feature forWhom Contact {mergedPreferences} =
|
||||
let ContactUserPreference {enabled} = getContactUserPreference feature mergedPreferences
|
||||
in forWhom enabled
|
||||
|
||||
groupFeatureAllowed :: GroupFeatureI f => SGroupFeature f -> GroupInfo -> Bool
|
||||
groupFeatureAllowed :: GroupFeatureNoRoleI f => SGroupFeature f -> GroupInfo -> Bool
|
||||
groupFeatureAllowed feature gInfo = groupFeatureAllowed' feature $ fullGroupPreferences gInfo
|
||||
|
||||
groupFeatureMemberAllowed :: GroupFeatureRoleI f => SGroupFeature f -> GroupMember -> GroupInfo -> Bool
|
||||
groupFeatureMemberAllowed feature GroupMember {memberRole} =
|
||||
groupFeatureMemberAllowed' feature memberRole . fullGroupPreferences
|
||||
|
||||
mergeUserChatPrefs :: User -> Contact -> FullPreferences
|
||||
mergeUserChatPrefs user ct = mergeUserChatPrefs' user (contactConnIncognito ct) (userPreferences ct)
|
||||
|
||||
@@ -796,41 +800,6 @@ fromInvitedBy userCtId = \case
|
||||
IBContact ctId -> Just ctId
|
||||
IBUser -> Just userCtId
|
||||
|
||||
data GroupMemberRole
|
||||
= GRObserver -- connects to all group members and receives all messages, can't send messages
|
||||
| GRAuthor -- reserved, unused
|
||||
| GRMember -- + can send messages to all group members
|
||||
| GRAdmin -- + add/remove members, change member role (excl. Owners)
|
||||
| GROwner -- + delete and change group information, add/remove/change roles for Owners
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
instance FromField GroupMemberRole where fromField = fromBlobField_ strDecode
|
||||
|
||||
instance ToField GroupMemberRole where toField = toField . strEncode
|
||||
|
||||
instance StrEncoding GroupMemberRole where
|
||||
strEncode = \case
|
||||
GROwner -> "owner"
|
||||
GRAdmin -> "admin"
|
||||
GRMember -> "member"
|
||||
GRAuthor -> "author"
|
||||
GRObserver -> "observer"
|
||||
strDecode = \case
|
||||
"owner" -> Right GROwner
|
||||
"admin" -> Right GRAdmin
|
||||
"member" -> Right GRMember
|
||||
"author" -> Right GRAuthor
|
||||
"observer" -> Right GRObserver
|
||||
r -> Left $ "bad GroupMemberRole " <> B.unpack r
|
||||
strP = strDecode <$?> A.takeByteString
|
||||
|
||||
instance FromJSON GroupMemberRole where
|
||||
parseJSON = strParseJSON "GroupMemberRole"
|
||||
|
||||
instance ToJSON GroupMemberRole where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
data GroupMemberSettings = GroupMemberSettings
|
||||
{ showMessages :: Bool
|
||||
}
|
||||
|
||||
@@ -10,6 +10,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||
@@ -31,6 +32,7 @@ import qualified Data.Text as T
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import GHC.Records.Compat
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON)
|
||||
@@ -148,6 +150,7 @@ data GroupFeature
|
||||
| GFReactions
|
||||
| GFVoice
|
||||
| GFFiles
|
||||
| GFSimplexLinks
|
||||
| GFHistory
|
||||
deriving (Show)
|
||||
|
||||
@@ -158,14 +161,23 @@ data SGroupFeature (f :: GroupFeature) where
|
||||
SGFReactions :: SGroupFeature 'GFReactions
|
||||
SGFVoice :: SGroupFeature 'GFVoice
|
||||
SGFFiles :: SGroupFeature 'GFFiles
|
||||
SGFSimplexLinks :: SGroupFeature 'GFSimplexLinks
|
||||
SGFHistory :: SGroupFeature 'GFHistory
|
||||
|
||||
deriving instance Show (SGroupFeature f)
|
||||
|
||||
data AGroupFeature = forall f. GroupFeatureI f => AGF (SGroupFeature f)
|
||||
|
||||
data AGroupFeatureNoRole = forall f. GroupFeatureNoRoleI f => AGFNR (SGroupFeature f)
|
||||
|
||||
data AGroupFeatureRole = forall f. GroupFeatureRoleI f => AGFR (SGroupFeature f)
|
||||
|
||||
deriving instance Show AGroupFeature
|
||||
|
||||
deriving instance Show AGroupFeatureNoRole
|
||||
|
||||
deriving instance Show AGroupFeatureRole
|
||||
|
||||
groupFeatureNameText :: GroupFeature -> Text
|
||||
groupFeatureNameText = \case
|
||||
GFTimedMessages -> "Disappearing messages"
|
||||
@@ -174,15 +186,21 @@ groupFeatureNameText = \case
|
||||
GFReactions -> "Message reactions"
|
||||
GFVoice -> "Voice messages"
|
||||
GFFiles -> "Files and media"
|
||||
GFSimplexLinks -> "SimpleX links"
|
||||
GFHistory -> "Recent history"
|
||||
|
||||
groupFeatureNameText' :: SGroupFeature f -> Text
|
||||
groupFeatureNameText' = groupFeatureNameText . toGroupFeature
|
||||
|
||||
groupFeatureAllowed' :: GroupFeatureI f => SGroupFeature f -> FullGroupPreferences -> Bool
|
||||
groupFeatureAllowed' :: GroupFeatureNoRoleI f => SGroupFeature f -> FullGroupPreferences -> Bool
|
||||
groupFeatureAllowed' feature prefs =
|
||||
getField @"enable" (getGroupPreference feature prefs) == FEOn
|
||||
|
||||
groupFeatureMemberAllowed' :: GroupFeatureRoleI f => SGroupFeature f -> GroupMemberRole -> FullGroupPreferences -> Bool
|
||||
groupFeatureMemberAllowed' feature role prefs =
|
||||
let pref = getGroupPreference feature prefs
|
||||
in getField @"enable" pref == FEOn && maybe True (role >=) (getField @"role" pref)
|
||||
|
||||
allGroupFeatures :: [AGroupFeature]
|
||||
allGroupFeatures =
|
||||
[ AGF SGFTimedMessages,
|
||||
@@ -191,17 +209,19 @@ allGroupFeatures =
|
||||
AGF SGFReactions,
|
||||
AGF SGFVoice,
|
||||
AGF SGFFiles,
|
||||
AGF SGFSimplexLinks,
|
||||
AGF SGFHistory
|
||||
]
|
||||
|
||||
groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f)
|
||||
groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, history} = case f of
|
||||
groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, history} = case f of
|
||||
SGFTimedMessages -> timedMessages
|
||||
SGFDirectMessages -> directMessages
|
||||
SGFFullDelete -> fullDelete
|
||||
SGFReactions -> reactions
|
||||
SGFVoice -> voice
|
||||
SGFFiles -> files
|
||||
SGFSimplexLinks -> simplexLinks
|
||||
SGFHistory -> history
|
||||
|
||||
toGroupFeature :: SGroupFeature f -> GroupFeature
|
||||
@@ -212,6 +232,7 @@ toGroupFeature = \case
|
||||
SGFReactions -> GFReactions
|
||||
SGFVoice -> GFVoice
|
||||
SGFFiles -> GFFiles
|
||||
SGFSimplexLinks -> GFSimplexLinks
|
||||
SGFHistory -> GFHistory
|
||||
|
||||
class GroupPreferenceI p where
|
||||
@@ -224,13 +245,14 @@ instance GroupPreferenceI (Maybe GroupPreferences) where
|
||||
getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt =<< prefs)
|
||||
|
||||
instance GroupPreferenceI FullGroupPreferences where
|
||||
getGroupPreference f FullGroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, history} = case f of
|
||||
getGroupPreference f FullGroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, history} = case f of
|
||||
SGFTimedMessages -> timedMessages
|
||||
SGFDirectMessages -> directMessages
|
||||
SGFFullDelete -> fullDelete
|
||||
SGFReactions -> reactions
|
||||
SGFVoice -> voice
|
||||
SGFFiles -> files
|
||||
SGFSimplexLinks -> simplexLinks
|
||||
SGFHistory -> history
|
||||
{-# INLINE getGroupPreference #-}
|
||||
|
||||
@@ -242,17 +264,25 @@ data GroupPreferences = GroupPreferences
|
||||
reactions :: Maybe ReactionsGroupPreference,
|
||||
voice :: Maybe VoiceGroupPreference,
|
||||
files :: Maybe FilesGroupPreference,
|
||||
simplexLinks :: Maybe SimplexLinksGroupPreference,
|
||||
history :: Maybe HistoryGroupPreference
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
setGroupPreference :: forall f. GroupFeatureI f => SGroupFeature f -> GroupFeatureEnabled -> Maybe GroupPreferences -> GroupPreferences
|
||||
setGroupPreference :: forall f. GroupFeatureNoRoleI f => SGroupFeature f -> GroupFeatureEnabled -> Maybe GroupPreferences -> GroupPreferences
|
||||
setGroupPreference f enable prefs_ = setGroupPreference_ f pref prefs
|
||||
where
|
||||
prefs = mergeGroupPreferences prefs_
|
||||
pref :: GroupFeaturePreference f
|
||||
pref = setField @"enable" (getGroupPreference f prefs) enable
|
||||
|
||||
setGroupPreferenceRole :: forall f. GroupFeatureRoleI f => SGroupFeature f -> GroupFeatureEnabled -> Maybe GroupMemberRole -> Maybe GroupPreferences -> GroupPreferences
|
||||
setGroupPreferenceRole f enable role prefs_ = setGroupPreference_ f pref prefs
|
||||
where
|
||||
prefs = mergeGroupPreferences prefs_
|
||||
pref :: GroupFeaturePreference f
|
||||
pref = setField @"role" (setField @"enable" (getGroupPreference f prefs) enable) role
|
||||
|
||||
setGroupPreference' :: SGroupFeature f -> GroupFeaturePreference f -> Maybe GroupPreferences -> GroupPreferences
|
||||
setGroupPreference' f pref prefs_ = setGroupPreference_ f pref prefs
|
||||
where
|
||||
@@ -267,6 +297,7 @@ setGroupPreference_ f pref prefs =
|
||||
SGFReactions -> prefs {reactions = pref}
|
||||
SGFVoice -> prefs {voice = pref}
|
||||
SGFFiles -> prefs {files = pref}
|
||||
SGFSimplexLinks -> prefs {simplexLinks = pref}
|
||||
SGFHistory -> prefs {history = pref}
|
||||
|
||||
setGroupTimedMessagesPreference :: TimedMessagesGroupPreference -> Maybe GroupPreferences -> GroupPreferences
|
||||
@@ -295,6 +326,7 @@ data FullGroupPreferences = FullGroupPreferences
|
||||
reactions :: ReactionsGroupPreference,
|
||||
voice :: VoiceGroupPreference,
|
||||
files :: FilesGroupPreference,
|
||||
simplexLinks :: SimplexLinksGroupPreference,
|
||||
history :: HistoryGroupPreference
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@@ -346,16 +378,17 @@ defaultGroupPrefs :: FullGroupPreferences
|
||||
defaultGroupPrefs =
|
||||
FullGroupPreferences
|
||||
{ timedMessages = TimedMessagesGroupPreference {enable = FEOff, ttl = Just 86400},
|
||||
directMessages = DirectMessagesGroupPreference {enable = FEOff},
|
||||
directMessages = DirectMessagesGroupPreference {enable = FEOff, role = Nothing},
|
||||
fullDelete = FullDeleteGroupPreference {enable = FEOff},
|
||||
reactions = ReactionsGroupPreference {enable = FEOn},
|
||||
voice = VoiceGroupPreference {enable = FEOn},
|
||||
files = FilesGroupPreference {enable = FEOn},
|
||||
voice = VoiceGroupPreference {enable = FEOn, role = Nothing},
|
||||
files = FilesGroupPreference {enable = FEOn, role = Nothing},
|
||||
simplexLinks = SimplexLinksGroupPreference {enable = FEOn, role = Nothing},
|
||||
history = HistoryGroupPreference {enable = FEOff}
|
||||
}
|
||||
|
||||
emptyGroupPrefs :: GroupPreferences
|
||||
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
data TimedMessagesPreference = TimedMessagesPreference
|
||||
{ allow :: FeatureAllowed,
|
||||
@@ -431,7 +464,7 @@ data TimedMessagesGroupPreference = TimedMessagesGroupPreference
|
||||
deriving (Eq, Show)
|
||||
|
||||
data DirectMessagesGroupPreference = DirectMessagesGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
{enable :: GroupFeatureEnabled, role :: Maybe GroupMemberRole}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data FullDeleteGroupPreference = FullDeleteGroupPreference
|
||||
@@ -443,11 +476,15 @@ data ReactionsGroupPreference = ReactionsGroupPreference
|
||||
deriving (Eq, Show)
|
||||
|
||||
data VoiceGroupPreference = VoiceGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
{enable :: GroupFeatureEnabled, role :: Maybe GroupMemberRole}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data FilesGroupPreference = FilesGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
{enable :: GroupFeatureEnabled, role :: Maybe GroupMemberRole}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SimplexLinksGroupPreference = SimplexLinksGroupPreference
|
||||
{enable :: GroupFeatureEnabled, role :: Maybe GroupMemberRole}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data HistoryGroupPreference = HistoryGroupPreference
|
||||
@@ -458,6 +495,11 @@ class (Eq (GroupFeaturePreference f), HasField "enable" (GroupFeaturePreference
|
||||
type GroupFeaturePreference (f :: GroupFeature) = p | p -> f
|
||||
sGroupFeature :: SGroupFeature f
|
||||
groupPrefParam :: GroupFeaturePreference f -> Maybe Int
|
||||
groupPrefRole :: GroupFeaturePreference f -> Maybe GroupMemberRole
|
||||
|
||||
class GroupFeatureI f => GroupFeatureNoRoleI f
|
||||
|
||||
class (GroupFeatureI f, HasField "role" (GroupFeaturePreference f) (Maybe GroupMemberRole)) => GroupFeatureRoleI f
|
||||
|
||||
instance HasField "enable" GroupPreference GroupFeatureEnabled where
|
||||
hasField p@GroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
@@ -480,6 +522,9 @@ instance HasField "enable" VoiceGroupPreference GroupFeatureEnabled where
|
||||
instance HasField "enable" FilesGroupPreference GroupFeatureEnabled where
|
||||
hasField p@FilesGroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
|
||||
instance HasField "enable" SimplexLinksGroupPreference GroupFeatureEnabled where
|
||||
hasField p@SimplexLinksGroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
|
||||
instance HasField "enable" HistoryGroupPreference GroupFeatureEnabled where
|
||||
hasField p@HistoryGroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
|
||||
@@ -487,42 +532,84 @@ instance GroupFeatureI 'GFTimedMessages where
|
||||
type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference
|
||||
sGroupFeature = SGFTimedMessages
|
||||
groupPrefParam TimedMessagesGroupPreference {ttl} = ttl
|
||||
groupPrefRole _ = Nothing
|
||||
|
||||
instance GroupFeatureI 'GFDirectMessages where
|
||||
type GroupFeaturePreference 'GFDirectMessages = DirectMessagesGroupPreference
|
||||
sGroupFeature = SGFDirectMessages
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole DirectMessagesGroupPreference {role} = role
|
||||
|
||||
instance GroupFeatureI 'GFFullDelete where
|
||||
type GroupFeaturePreference 'GFFullDelete = FullDeleteGroupPreference
|
||||
sGroupFeature = SGFFullDelete
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole _ = Nothing
|
||||
|
||||
instance GroupFeatureI 'GFReactions where
|
||||
type GroupFeaturePreference 'GFReactions = ReactionsGroupPreference
|
||||
sGroupFeature = SGFReactions
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole _ = Nothing
|
||||
|
||||
instance GroupFeatureI 'GFVoice where
|
||||
type GroupFeaturePreference 'GFVoice = VoiceGroupPreference
|
||||
sGroupFeature = SGFVoice
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole VoiceGroupPreference {role} = role
|
||||
|
||||
instance GroupFeatureI 'GFFiles where
|
||||
type GroupFeaturePreference 'GFFiles = FilesGroupPreference
|
||||
sGroupFeature = SGFFiles
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole FilesGroupPreference {role} = role
|
||||
|
||||
instance GroupFeatureI 'GFSimplexLinks where
|
||||
type GroupFeaturePreference 'GFSimplexLinks = SimplexLinksGroupPreference
|
||||
sGroupFeature = SGFSimplexLinks
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole SimplexLinksGroupPreference {role} = role
|
||||
|
||||
instance GroupFeatureI 'GFHistory where
|
||||
type GroupFeaturePreference 'GFHistory = HistoryGroupPreference
|
||||
sGroupFeature = SGFHistory
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole _ = Nothing
|
||||
|
||||
groupPrefStateText :: HasField "enable" p GroupFeatureEnabled => GroupFeature -> p -> Maybe Int -> Text
|
||||
groupPrefStateText feature pref param =
|
||||
instance GroupFeatureNoRoleI 'GFTimedMessages
|
||||
|
||||
instance GroupFeatureNoRoleI 'GFFullDelete
|
||||
|
||||
instance GroupFeatureNoRoleI 'GFReactions
|
||||
|
||||
instance GroupFeatureNoRoleI 'GFHistory
|
||||
|
||||
instance HasField "role" DirectMessagesGroupPreference (Maybe GroupMemberRole) where
|
||||
hasField p@DirectMessagesGroupPreference {role} = (\r -> p {role = r}, role)
|
||||
|
||||
instance HasField "role" VoiceGroupPreference (Maybe GroupMemberRole) where
|
||||
hasField p@VoiceGroupPreference {role} = (\r -> p {role = r}, role)
|
||||
|
||||
instance HasField "role" FilesGroupPreference (Maybe GroupMemberRole) where
|
||||
hasField p@FilesGroupPreference {role} = (\r -> p {role = r}, role)
|
||||
|
||||
instance HasField "role" SimplexLinksGroupPreference (Maybe GroupMemberRole) where
|
||||
hasField p@SimplexLinksGroupPreference {role} = (\r -> p {role = r}, role)
|
||||
|
||||
instance GroupFeatureRoleI 'GFDirectMessages
|
||||
|
||||
instance GroupFeatureRoleI 'GFVoice
|
||||
|
||||
instance GroupFeatureRoleI 'GFFiles
|
||||
|
||||
instance GroupFeatureRoleI 'GFSimplexLinks
|
||||
|
||||
groupPrefStateText :: HasField "enable" p GroupFeatureEnabled => GroupFeature -> p -> Maybe Int -> Maybe GroupMemberRole -> Text
|
||||
groupPrefStateText feature pref param role =
|
||||
let enabled = getField @"enable" pref
|
||||
paramText = if enabled == FEOn then groupParamText_ feature param else ""
|
||||
in groupFeatureNameText feature <> ": " <> safeDecodeUtf8 (strEncode enabled) <> paramText
|
||||
roleText = maybe "" (\r -> " for " <> safeDecodeUtf8 (strEncode r) <> "s") role
|
||||
in groupFeatureNameText feature <> ": " <> safeDecodeUtf8 (strEncode enabled) <> paramText <> roleText
|
||||
|
||||
groupParamText_ :: GroupFeature -> Maybe Int -> Text
|
||||
groupParamText_ feature param = case feature of
|
||||
@@ -532,7 +619,7 @@ groupParamText_ feature param = case feature of
|
||||
groupPreferenceText :: forall f. GroupFeatureI f => GroupFeaturePreference f -> Text
|
||||
groupPreferenceText pref =
|
||||
let feature = toGroupFeature $ sGroupFeature @f
|
||||
in groupPrefStateText feature pref $ groupPrefParam pref
|
||||
in groupPrefStateText feature pref (groupPrefParam pref) (groupPrefRole pref)
|
||||
|
||||
timedTTLText :: Int -> Text
|
||||
timedTTLText 0 = "0 sec"
|
||||
@@ -602,7 +689,7 @@ instance StrEncoding GroupFeatureEnabled where
|
||||
"on" -> Right FEOn
|
||||
"off" -> Right FEOff
|
||||
r -> Left $ "bad GroupFeatureEnabled " <> B.unpack r
|
||||
strP = strDecode <$?> A.takeByteString
|
||||
strP = strDecode <$?> A.takeTill (== ' ')
|
||||
|
||||
instance FromJSON GroupFeatureEnabled where
|
||||
parseJSON = strParseJSON "GroupFeatureEnabled"
|
||||
@@ -611,11 +698,13 @@ instance ToJSON GroupFeatureEnabled where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
groupFeatureState :: GroupFeatureI f => GroupFeaturePreference f -> (GroupFeatureEnabled, Maybe Int)
|
||||
groupFeatureState :: GroupFeatureI f => GroupFeaturePreference f -> (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
|
||||
groupFeatureState p =
|
||||
let enable = getField @"enable" p
|
||||
param = if enable == FEOn then groupPrefParam p else Nothing
|
||||
in (enable, param)
|
||||
(param, role)
|
||||
| enable == FEOn = (groupPrefParam p, groupPrefRole p)
|
||||
| otherwise = (Nothing, Nothing)
|
||||
in (enable, param, role)
|
||||
|
||||
mergePreferences :: Maybe Preferences -> Maybe Preferences -> FullPreferences
|
||||
mergePreferences contactPrefs userPreferences =
|
||||
@@ -641,6 +730,7 @@ mergeGroupPreferences groupPreferences =
|
||||
reactions = pref SGFReactions,
|
||||
voice = pref SGFVoice,
|
||||
files = pref SGFFiles,
|
||||
simplexLinks = pref SGFSimplexLinks,
|
||||
history = pref SGFHistory
|
||||
}
|
||||
where
|
||||
@@ -656,6 +746,7 @@ toGroupPreferences groupPreferences =
|
||||
reactions = pref SGFReactions,
|
||||
voice = pref SGFVoice,
|
||||
files = pref SGFFiles,
|
||||
simplexLinks = pref SGFSimplexLinks,
|
||||
history = pref SGFHistory
|
||||
}
|
||||
where
|
||||
@@ -762,6 +853,8 @@ $(J.deriveJSON defaultJSON ''VoiceGroupPreference)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''FilesGroupPreference)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''SimplexLinksGroupPreference)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''HistoryGroupPreference)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''GroupPreferences)
|
||||
|
||||
@@ -0,0 +1,48 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Types.Shared where
|
||||
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
|
||||
data GroupMemberRole
|
||||
= GRObserver -- connects to all group members and receives all messages, can't send messages
|
||||
| GRAuthor -- reserved, unused
|
||||
| GRMember -- + can send messages to all group members
|
||||
| GRAdmin -- + add/remove members, change member role (excl. Owners)
|
||||
| GROwner -- + delete and change group information, add/remove/change roles for Owners
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
instance FromField GroupMemberRole where fromField = fromBlobField_ strDecode
|
||||
|
||||
instance ToField GroupMemberRole where toField = toField . strEncode
|
||||
|
||||
instance StrEncoding GroupMemberRole where
|
||||
strEncode = \case
|
||||
GROwner -> "owner"
|
||||
GRAdmin -> "admin"
|
||||
GRMember -> "member"
|
||||
GRAuthor -> "author"
|
||||
GRObserver -> "observer"
|
||||
strDecode = \case
|
||||
"owner" -> Right GROwner
|
||||
"admin" -> Right GRAdmin
|
||||
"member" -> Right GRMember
|
||||
"author" -> Right GRAuthor
|
||||
"observer" -> Right GRObserver
|
||||
r -> Left $ "bad GroupMemberRole " <> B.unpack r
|
||||
strP = strDecode <$?> A.takeByteString
|
||||
|
||||
instance FromJSON GroupMemberRole where
|
||||
parseJSON = strParseJSON "GroupMemberRole"
|
||||
|
||||
instance ToJSON GroupMemberRole where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
@@ -49,6 +49,7 @@ 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 qualified Simplex.FileTransfer.Transport as XFTPTransport
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..))
|
||||
@@ -351,8 +352,9 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
||||
<> (" :: avg: " <> sShow timeAvg <> " ms")
|
||||
<> (" :: " <> plain (T.unwords $ T.lines query))
|
||||
in ("Chat queries" : map viewQuery chatQueries) <> [""] <> ("Agent queries" : map viewQuery agentQueries)
|
||||
CRDebugLocks {chatLockName, agentLocks} ->
|
||||
CRDebugLocks {chatLockName, chatEntityLocks, agentLocks} ->
|
||||
[ maybe "no chat lock" (("chat lock: " <>) . plain) chatLockName,
|
||||
plain $ "chat entity locks: " <> LB.unpack (J.encode chatEntityLocks),
|
||||
plain $ "agent locks: " <> LB.unpack (J.encode agentLocks)
|
||||
]
|
||||
CRAgentStats stats -> map (plain . intercalate ",") stats
|
||||
|
||||
Reference in New Issue
Block a user