mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-06-28 12:19:54 +00:00
3615 lines
172 KiB
Haskell
3615 lines
172 KiB
Haskell
{-# LANGUAGE ConstraintKinds #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
module Simplex.Chat.Store
|
|
( SQLiteStore,
|
|
StoreError (..),
|
|
createStore,
|
|
chatStoreFile,
|
|
createUser,
|
|
getUsers,
|
|
setActiveUser,
|
|
createDirectConnection,
|
|
createConnReqConnection,
|
|
getConnReqContactXContactId,
|
|
createDirectContact,
|
|
getContactGroupNames,
|
|
deleteContact,
|
|
getContactByName,
|
|
getContact,
|
|
getContactIdByName,
|
|
updateUserProfile,
|
|
updateContactProfile,
|
|
getUserContacts,
|
|
createUserContactLink,
|
|
getUserContactLinkConnections,
|
|
deleteUserContactLink,
|
|
getUserContactLink,
|
|
updateUserContactLinkAutoAccept,
|
|
createOrUpdateContactRequest,
|
|
getContactRequest,
|
|
getContactRequestIdByName,
|
|
deleteContactRequest,
|
|
createAcceptedContact,
|
|
getLiveSndFileTransfers,
|
|
getLiveRcvFileTransfers,
|
|
getPendingSndChunks,
|
|
getPendingConnections,
|
|
getContactConnections,
|
|
getConnectionEntity,
|
|
getGroupAndMember,
|
|
updateConnectionStatus,
|
|
createNewGroup,
|
|
createGroupInvitation,
|
|
getGroup,
|
|
getGroupInfo,
|
|
getGroupIdByName,
|
|
getGroupByName,
|
|
getGroupInfoByName,
|
|
getGroupMembers,
|
|
deleteGroup,
|
|
getUserGroups,
|
|
getUserGroupDetails,
|
|
getGroupInvitation,
|
|
createContactMember,
|
|
getMemberInvitation,
|
|
createMemberConnection,
|
|
updateGroupMemberStatus,
|
|
createNewGroupMember,
|
|
deleteGroupMemberConnection,
|
|
createIntroductions,
|
|
updateIntroStatus,
|
|
saveIntroInvitation,
|
|
createIntroReMember,
|
|
createIntroToMemberContact,
|
|
saveMemberInvitation,
|
|
getViaGroupMember,
|
|
getViaGroupContact,
|
|
getMatchingContacts,
|
|
randomBytes,
|
|
createSentProbe,
|
|
createSentProbeHash,
|
|
matchReceivedProbe,
|
|
matchReceivedProbeHash,
|
|
matchSentProbe,
|
|
mergeContactRecords,
|
|
createSndFileTransfer, -- old file protocol
|
|
createSndFileTransferV2,
|
|
createSndFileTransferV2Connection,
|
|
createSndGroupFileTransfer, -- old file protocol
|
|
createSndGroupFileTransferV2,
|
|
createSndGroupFileTransferV2Connection,
|
|
updateFileCancelled,
|
|
updateCIFileStatus,
|
|
getSharedMsgIdByFileId,
|
|
getFileIdBySharedMsgId,
|
|
getGroupFileIdBySharedMsgId,
|
|
updateSndFileStatus,
|
|
createSndFileChunk,
|
|
updateSndFileChunkMsg,
|
|
updateSndFileChunkSent,
|
|
deleteSndFileChunks,
|
|
createRcvFileTransfer,
|
|
createRcvGroupFileTransfer,
|
|
getRcvFileTransfer,
|
|
acceptRcvFileTransfer,
|
|
updateRcvFileStatus,
|
|
createRcvFileChunk,
|
|
updatedRcvFileChunkStored,
|
|
deleteRcvFileChunks,
|
|
updateFileTransferChatItemId,
|
|
getFileTransfer,
|
|
getFileTransferProgress,
|
|
createNewSndMessage,
|
|
createSndMsgDelivery,
|
|
createNewMessageAndRcvMsgDelivery,
|
|
createSndMsgDeliveryEvent,
|
|
createRcvMsgDeliveryEvent,
|
|
createPendingGroupMessage,
|
|
getPendingGroupMessages,
|
|
deletePendingGroupMessage,
|
|
createNewSndChatItem,
|
|
createNewRcvChatItem,
|
|
getChatPreviews,
|
|
getDirectChat,
|
|
getGroupChat,
|
|
getChatItemIdByAgentMsgId,
|
|
getDirectChatItem,
|
|
getDirectChatItemBySharedMsgId,
|
|
getGroupChatItem,
|
|
getGroupChatItemBySharedMsgId,
|
|
getDirectChatItemIdByText,
|
|
getGroupChatItemIdByText,
|
|
updateDirectChatItemStatus,
|
|
updateDirectChatItem,
|
|
deleteDirectChatItemInternal,
|
|
deleteDirectChatItemRcvBroadcast,
|
|
deleteDirectChatItemSndBroadcast,
|
|
updateGroupChatItem,
|
|
deleteGroupChatItemInternal,
|
|
deleteGroupChatItemRcvBroadcast,
|
|
deleteGroupChatItemSndBroadcast,
|
|
updateDirectChatItemsRead,
|
|
updateGroupChatItemsRead,
|
|
getSMPServers,
|
|
overwriteSMPServers,
|
|
)
|
|
where
|
|
|
|
import Control.Applicative ((<|>))
|
|
import Control.Concurrent.STM (stateTVar)
|
|
import Control.Exception (Exception)
|
|
import qualified Control.Exception as E
|
|
import Control.Monad.Except
|
|
import Control.Monad.IO.Unlift
|
|
import Crypto.Random (ChaChaDRG, randomBytesGenerate)
|
|
import Data.Aeson (ToJSON)
|
|
import qualified Data.Aeson as J
|
|
import Data.Bifunctor (first)
|
|
import qualified Data.ByteString.Base64 as B64
|
|
import Data.ByteString.Char8 (ByteString)
|
|
import Data.Either (rights)
|
|
import Data.Function (on)
|
|
import Data.Functor (($>))
|
|
import Data.Int (Int64)
|
|
import Data.List (find, sortBy, sortOn)
|
|
import Data.Maybe (fromMaybe, listToMaybe)
|
|
import Data.Ord (Down (..))
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
|
import Data.Time.LocalTime (TimeZone, getCurrentTimeZone)
|
|
import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), SQLError, (:.) (..))
|
|
import qualified Database.SQLite.Simple as DB
|
|
import Database.SQLite.Simple.QQ (sql)
|
|
import GHC.Generics (Generic)
|
|
import Simplex.Chat.Markdown
|
|
import Simplex.Chat.Messages
|
|
import Simplex.Chat.Migrations.M20220101_initial
|
|
import Simplex.Chat.Migrations.M20220122_v1_1
|
|
import Simplex.Chat.Migrations.M20220205_chat_item_status
|
|
import Simplex.Chat.Migrations.M20220210_deduplicate_contact_requests
|
|
import Simplex.Chat.Migrations.M20220224_messages_fks
|
|
import Simplex.Chat.Migrations.M20220301_smp_servers
|
|
import Simplex.Chat.Migrations.M20220302_profile_images
|
|
import Simplex.Chat.Migrations.M20220304_msg_quotes
|
|
import Simplex.Chat.Migrations.M20220321_chat_item_edited
|
|
import Simplex.Chat.Migrations.M20220404_files_status_fields
|
|
import Simplex.Chat.Protocol
|
|
import Simplex.Chat.Types
|
|
import Simplex.Chat.Util (eitherToMaybe)
|
|
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, InvitationId, MsgMeta (..), SMPServer (..))
|
|
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, firstRow, withTransaction)
|
|
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Encoding.String (StrEncoding (strEncode))
|
|
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
|
|
import Simplex.Messaging.Util (liftIOEither, (<$$>))
|
|
import System.FilePath (takeFileName)
|
|
import UnliftIO.STM
|
|
|
|
schemaMigrations :: [(String, Query)]
|
|
schemaMigrations =
|
|
[ ("20220101_initial", m20220101_initial),
|
|
("20220122_v1_1", m20220122_v1_1),
|
|
("20220205_chat_item_status", m20220205_chat_item_status),
|
|
("20220210_deduplicate_contact_requests", m20220210_deduplicate_contact_requests),
|
|
("20220224_messages_fks", m20220224_messages_fks),
|
|
("20220301_smp_servers", m20220301_smp_servers),
|
|
("20220302_profile_images", m20220302_profile_images),
|
|
("20220304_msg_quotes", m20220304_msg_quotes),
|
|
("20220321_chat_item_edited", m20220321_chat_item_edited),
|
|
("20220404_files_status_fields", m20220404_files_status_fields)
|
|
]
|
|
|
|
-- | The list of migrations in ascending order by date
|
|
migrations :: [Migration]
|
|
migrations = sortBy (compare `on` name) $ map migration schemaMigrations
|
|
where
|
|
migration (name, query) = Migration {name = name, up = fromQuery query}
|
|
|
|
createStore :: FilePath -> Int -> Bool -> IO SQLiteStore
|
|
createStore dbFilePath poolSize = createSQLiteStore dbFilePath poolSize migrations
|
|
|
|
chatStoreFile :: FilePath -> FilePath
|
|
chatStoreFile = (<> "_chat.db")
|
|
|
|
checkConstraint :: StoreError -> IO (Either StoreError a) -> IO (Either StoreError a)
|
|
checkConstraint err action = action `E.catch` (pure . Left . handleSQLError err)
|
|
|
|
handleSQLError :: StoreError -> SQLError -> StoreError
|
|
handleSQLError err e
|
|
| DB.sqlError e == DB.ErrorConstraint = err
|
|
| otherwise = SEInternalError $ show e
|
|
|
|
insertedRowId :: DB.Connection -> IO Int64
|
|
insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"
|
|
|
|
type StoreMonad m = (MonadUnliftIO m, MonadError StoreError m)
|
|
|
|
createUser :: StoreMonad m => SQLiteStore -> Profile -> Bool -> m User
|
|
createUser st Profile {displayName, fullName, image} activeUser =
|
|
liftIOEither . checkConstraint SEDuplicateName . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO users (local_display_name, active_user, contact_id, created_at, updated_at) VALUES (?,?,0,?,?)"
|
|
(displayName, activeUser, currentTs, currentTs)
|
|
userId <- insertedRowId db
|
|
DB.execute
|
|
db
|
|
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(displayName, displayName, userId, currentTs, currentTs)
|
|
DB.execute
|
|
db
|
|
"INSERT INTO contact_profiles (display_name, full_name, image, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(displayName, fullName, image, currentTs, currentTs)
|
|
profileId <- insertedRowId db
|
|
DB.execute
|
|
db
|
|
"INSERT INTO contacts (contact_profile_id, local_display_name, user_id, is_user, created_at, updated_at) VALUES (?,?,?,?,?,?)"
|
|
(profileId, displayName, userId, True, currentTs, currentTs)
|
|
contactId <- insertedRowId db
|
|
DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId)
|
|
pure . Right $ toUser (userId, contactId, activeUser, displayName, fullName, image)
|
|
|
|
getUsers :: SQLiteStore -> IO [User]
|
|
getUsers st =
|
|
withTransaction st $ \db ->
|
|
map toUser
|
|
<$> DB.query_
|
|
db
|
|
[sql|
|
|
SELECT u.user_id, u.contact_id, u.active_user, u.local_display_name, p.full_name, p.image
|
|
FROM users u
|
|
JOIN contacts c ON u.contact_id = c.contact_id
|
|
JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
|
|
|]
|
|
|
|
toUser :: (UserId, Int64, Bool, ContactName, Text, Maybe ImageData) -> User
|
|
toUser (userId, userContactId, activeUser, displayName, fullName, image) =
|
|
let profile = Profile {displayName, fullName, image}
|
|
in User {userId, userContactId, localDisplayName = displayName, profile, activeUser}
|
|
|
|
setActiveUser :: MonadUnliftIO m => SQLiteStore -> UserId -> m ()
|
|
setActiveUser st userId = do
|
|
liftIO . withTransaction st $ \db -> do
|
|
DB.execute_ db "UPDATE users SET active_user = 0"
|
|
DB.execute db "UPDATE users SET active_user = 1 WHERE user_id = ?" (Only userId)
|
|
|
|
createConnReqConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> m ()
|
|
createConnReqConnection st userId acId cReqHash xContactId = do
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO connections (
|
|
user_id, agent_conn_id, conn_status, conn_type,
|
|
created_at, updated_at, via_contact_uri_hash, xcontact_id
|
|
) VALUES (?,?,?,?,?,?,?,?)
|
|
|]
|
|
(userId, acId, ConnNew, ConnContact, currentTs, currentTs, cReqHash, xContactId)
|
|
|
|
getConnReqContactXContactId :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnReqUriHash -> m (Maybe Contact, Maybe XContactId)
|
|
getConnReqContactXContactId st userId cReqHash = do
|
|
liftIO . withTransaction st $ \db ->
|
|
getContact' db >>= \case
|
|
c@(Just _) -> pure (c, Nothing)
|
|
Nothing -> (Nothing,) <$> getXContactId db
|
|
where
|
|
getContact' :: DB.Connection -> IO (Maybe Contact)
|
|
getContact' db =
|
|
fmap toContact . listToMaybe
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- Contact
|
|
ct.contact_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, ct.created_at,
|
|
-- Connection
|
|
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.conn_status, c.conn_type,
|
|
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
|
FROM contacts ct
|
|
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
|
|
JOIN connections c ON c.contact_id = ct.contact_id
|
|
WHERE ct.user_id = ? AND c.via_contact_uri_hash = ?
|
|
ORDER BY c.connection_id DESC
|
|
LIMIT 1
|
|
|]
|
|
(userId, cReqHash)
|
|
getXContactId :: DB.Connection -> IO (Maybe XContactId)
|
|
getXContactId db =
|
|
fmap fromOnly . listToMaybe
|
|
<$> DB.query
|
|
db
|
|
"SELECT xcontact_id FROM connections WHERE user_id = ? AND via_contact_uri_hash = ? LIMIT 1"
|
|
(userId, cReqHash)
|
|
|
|
createDirectConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> m ()
|
|
createDirectConnection st userId agentConnId =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
void $ createContactConnection_ db userId agentConnId Nothing 0 currentTs
|
|
|
|
createContactConnection_ :: DB.Connection -> UserId -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection
|
|
createContactConnection_ db userId = createConnection_ db userId ConnContact Nothing
|
|
|
|
createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection
|
|
createConnection_ db userId connType entityId acId viaContact connLevel currentTs = do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO connections (
|
|
user_id, agent_conn_id, conn_level, via_contact, conn_status, conn_type,
|
|
contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, updated_at
|
|
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
|
|
|]
|
|
( (userId, acId, connLevel, viaContact, ConnNew, connType)
|
|
:. (ent ConnContact, ent ConnMember, ent ConnSndFile, ent ConnRcvFile, ent ConnUserContact, currentTs, currentTs)
|
|
)
|
|
connId <- insertedRowId db
|
|
pure Connection {connId, agentConnId = AgentConnId acId, connType, entityId, viaContact, connLevel, connStatus = ConnNew, createdAt = currentTs}
|
|
where
|
|
ent ct = if connType == ct then entityId else Nothing
|
|
|
|
createDirectContact :: StoreMonad m => SQLiteStore -> UserId -> Connection -> Profile -> m Contact
|
|
createDirectContact st userId activeConn@Connection {connId} profile =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
createdAt <- liftIO getCurrentTime
|
|
(localDisplayName, contactId, _) <- ExceptT $ createContact_ db userId connId profile Nothing createdAt
|
|
pure $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup = Nothing, createdAt}
|
|
|
|
createContact_ :: DB.Connection -> UserId -> Int64 -> Profile -> Maybe Int64 -> UTCTime -> IO (Either StoreError (Text, Int64, Int64))
|
|
createContact_ db userId connId Profile {displayName, fullName, image} viaGroup currentTs =
|
|
withLocalDisplayName db userId displayName $ \ldn -> do
|
|
DB.execute
|
|
db
|
|
"INSERT INTO contact_profiles (display_name, full_name, image, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(displayName, fullName, image, currentTs, currentTs)
|
|
profileId <- insertedRowId db
|
|
DB.execute
|
|
db
|
|
"INSERT INTO contacts (contact_profile_id, local_display_name, user_id, via_group, created_at, updated_at) VALUES (?,?,?,?,?,?)"
|
|
(profileId, ldn, userId, viaGroup, currentTs, currentTs)
|
|
contactId <- insertedRowId db
|
|
DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId)
|
|
pure (ldn, contactId, profileId)
|
|
|
|
getContactGroupNames :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> m [GroupName]
|
|
getContactGroupNames st userId Contact {contactId} =
|
|
liftIO . withTransaction st $ \db -> do
|
|
map fromOnly
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT DISTINCT g.local_display_name
|
|
FROM groups g
|
|
JOIN group_members m ON m.group_id = g.group_id
|
|
WHERE g.user_id = ? AND m.contact_id = ?
|
|
|]
|
|
(userId, contactId)
|
|
|
|
deleteContact :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> m ()
|
|
deleteContact st userId Contact {contactId, localDisplayName} =
|
|
liftIO . withTransaction st $ \db -> do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
DELETE FROM connections WHERE connection_id IN (
|
|
SELECT connection_id
|
|
FROM connections c
|
|
JOIN contacts ct ON ct.contact_id = c.contact_id
|
|
WHERE ct.user_id = ? AND ct.contact_id = ?
|
|
)
|
|
|]
|
|
(userId, contactId)
|
|
DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId)
|
|
DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
|
|
|
|
updateUserProfile :: StoreMonad m => SQLiteStore -> User -> Profile -> m ()
|
|
updateUserProfile st User {userId, userContactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName}
|
|
| displayName == newName =
|
|
liftIO . withTransaction st $ \db ->
|
|
updateContactProfile_ db userId userContactId p'
|
|
| otherwise =
|
|
liftIOEither . checkConstraint SEDuplicateName . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId)
|
|
DB.execute
|
|
db
|
|
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(newName, newName, userId, currentTs, currentTs)
|
|
updateContactProfile_' db userId userContactId p' currentTs
|
|
updateContact_ db userId userContactId localDisplayName newName currentTs
|
|
pure $ Right ()
|
|
|
|
updateContactProfile :: StoreMonad m => SQLiteStore -> UserId -> Contact -> Profile -> m Contact
|
|
updateContactProfile st userId c@Contact {contactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName}
|
|
| displayName == newName =
|
|
liftIO . withTransaction st $ \db ->
|
|
updateContactProfile_ db userId contactId p' $> (c :: Contact) {profile = p'}
|
|
| otherwise =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
withLocalDisplayName db userId newName $ \ldn -> do
|
|
currentTs <- getCurrentTime
|
|
updateContactProfile_' db userId contactId p' currentTs
|
|
updateContact_ db userId contactId localDisplayName ldn currentTs
|
|
pure $ (c :: Contact) {localDisplayName = ldn, profile = p'}
|
|
|
|
updateContactProfile_ :: DB.Connection -> UserId -> Int64 -> Profile -> IO ()
|
|
updateContactProfile_ db userId contactId profile = do
|
|
currentTs <- getCurrentTime
|
|
updateContactProfile_' db userId contactId profile currentTs
|
|
|
|
updateContactProfile_' :: DB.Connection -> UserId -> Int64 -> Profile -> UTCTime -> IO ()
|
|
updateContactProfile_' db userId contactId Profile {displayName, fullName, image} updatedAt = do
|
|
DB.executeNamed
|
|
db
|
|
[sql|
|
|
UPDATE contact_profiles
|
|
SET display_name = :display_name,
|
|
full_name = :full_name,
|
|
image = :image,
|
|
updated_at = :updated_at
|
|
WHERE contact_profile_id IN (
|
|
SELECT contact_profile_id
|
|
FROM contacts
|
|
WHERE user_id = :user_id
|
|
AND contact_id = :contact_id
|
|
)
|
|
|]
|
|
[ ":display_name" := displayName,
|
|
":full_name" := fullName,
|
|
":image" := image,
|
|
":updated_at" := updatedAt,
|
|
":user_id" := userId,
|
|
":contact_id" := contactId
|
|
]
|
|
|
|
updateContact_ :: DB.Connection -> UserId -> Int64 -> ContactName -> ContactName -> UTCTime -> IO ()
|
|
updateContact_ db userId contactId displayName newName updatedAt = do
|
|
DB.execute
|
|
db
|
|
"UPDATE contacts SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?"
|
|
(newName, updatedAt, userId, contactId)
|
|
DB.execute
|
|
db
|
|
"UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?"
|
|
(newName, updatedAt, userId, contactId)
|
|
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (displayName, userId)
|
|
|
|
type ContactRow = (Int64, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, UTCTime)
|
|
|
|
toContact :: ContactRow :. ConnectionRow -> Contact
|
|
toContact ((contactId, localDisplayName, viaGroup, displayName, fullName, image, createdAt) :. connRow) =
|
|
let profile = Profile {displayName, fullName, image}
|
|
activeConn = toConnection connRow
|
|
in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, createdAt}
|
|
|
|
toContactOrError :: ContactRow :. MaybeConnectionRow -> Either StoreError Contact
|
|
toContactOrError ((contactId, localDisplayName, viaGroup, displayName, fullName, image, createdAt) :. connRow) =
|
|
let profile = Profile {displayName, fullName, image}
|
|
in case toMaybeConnection connRow of
|
|
Just activeConn ->
|
|
Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, createdAt}
|
|
_ -> Left $ SEContactNotReady localDisplayName
|
|
|
|
-- TODO return the last connection that is ready, not any last connection
|
|
-- requires updating connection status
|
|
getContactByName :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m Contact
|
|
getContactByName st userId localDisplayName =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
cId <- ExceptT $ getContactIdByName_ db userId localDisplayName
|
|
ExceptT $ getContact_ db userId cId
|
|
|
|
getUserContacts :: MonadUnliftIO m => SQLiteStore -> User -> m [Contact]
|
|
getUserContacts st User {userId} =
|
|
liftIO . withTransaction st $ \db -> do
|
|
contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ?" (Only userId)
|
|
rights <$> mapM (getContact_ db userId) contactIds
|
|
|
|
createUserContactLink :: StoreMonad m => SQLiteStore -> UserId -> ConnId -> ConnReqContact -> m ()
|
|
createUserContactLink st userId agentConnId cReq =
|
|
liftIOEither . checkConstraint SEDuplicateContactLink . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO user_contact_links (user_id, conn_req_contact, created_at, updated_at) VALUES (?,?,?,?)"
|
|
(userId, cReq, currentTs, currentTs)
|
|
userContactLinkId <- insertedRowId db
|
|
Right () <$ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing 0 currentTs
|
|
|
|
getUserContactLinkConnections :: StoreMonad m => SQLiteStore -> UserId -> m [Connection]
|
|
getUserContactLinkConnections st userId =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
connections
|
|
<$> DB.queryNamed
|
|
db
|
|
[sql|
|
|
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
|
|
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
|
FROM connections c
|
|
JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id
|
|
WHERE c.user_id = :user_id
|
|
AND uc.user_id = :user_id
|
|
AND uc.local_display_name = ''
|
|
|]
|
|
[":user_id" := userId]
|
|
where
|
|
connections [] = Left SEUserContactLinkNotFound
|
|
connections rows = Right $ map toConnection rows
|
|
|
|
deleteUserContactLink :: MonadUnliftIO m => SQLiteStore -> UserId -> m ()
|
|
deleteUserContactLink st userId =
|
|
liftIO . withTransaction st $ \db -> do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
DELETE FROM connections WHERE connection_id IN (
|
|
SELECT connection_id
|
|
FROM connections c
|
|
JOIN user_contact_links uc USING (user_contact_link_id)
|
|
WHERE uc.user_id = ? AND uc.local_display_name = ''
|
|
)
|
|
|]
|
|
(Only userId)
|
|
DB.executeNamed
|
|
db
|
|
[sql|
|
|
DELETE FROM display_names
|
|
WHERE user_id = :user_id
|
|
AND local_display_name in (
|
|
SELECT cr.local_display_name
|
|
FROM contact_requests cr
|
|
JOIN user_contact_links uc USING (user_contact_link_id)
|
|
WHERE uc.user_id = :user_id
|
|
AND uc.local_display_name = ''
|
|
)
|
|
|]
|
|
[":user_id" := userId]
|
|
DB.executeNamed
|
|
db
|
|
[sql|
|
|
DELETE FROM contact_profiles
|
|
WHERE contact_profile_id in (
|
|
SELECT cr.contact_profile_id
|
|
FROM contact_requests cr
|
|
JOIN user_contact_links uc USING (user_contact_link_id)
|
|
WHERE uc.user_id = :user_id
|
|
AND uc.local_display_name = ''
|
|
)
|
|
|]
|
|
[":user_id" := userId]
|
|
DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = ''" (Only userId)
|
|
|
|
getUserContactLink :: StoreMonad m => SQLiteStore -> UserId -> m (ConnReqContact, Bool)
|
|
getUserContactLink st userId =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
getUserContactLink_ db userId
|
|
|
|
getUserContactLink_ :: DB.Connection -> UserId -> IO (Either StoreError (ConnReqContact, Bool))
|
|
getUserContactLink_ db userId =
|
|
firstRow id SEUserContactLinkNotFound $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT conn_req_contact, auto_accept
|
|
FROM user_contact_links
|
|
WHERE user_id = ?
|
|
AND local_display_name = ''
|
|
|]
|
|
(Only userId)
|
|
|
|
updateUserContactLinkAutoAccept :: StoreMonad m => SQLiteStore -> UserId -> Bool -> m (ConnReqContact, Bool)
|
|
updateUserContactLinkAutoAccept st userId autoAccept = do
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
(cReqUri, _) <- ExceptT $ getUserContactLink_ db userId
|
|
liftIO $ updateUserContactLinkAutoAccept_ db
|
|
pure (cReqUri, autoAccept)
|
|
where
|
|
updateUserContactLinkAutoAccept_ :: DB.Connection -> IO ()
|
|
updateUserContactLinkAutoAccept_ db =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE user_contact_links
|
|
SET auto_accept = ?
|
|
WHERE user_id = ?
|
|
AND local_display_name = ''
|
|
|]
|
|
(autoAccept, userId)
|
|
|
|
createOrUpdateContactRequest :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> m (Either Contact UserContactRequest)
|
|
createOrUpdateContactRequest st userId userContactLinkId invId profile xContactId_ =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
createOrUpdateContactRequest_ db userId userContactLinkId invId profile xContactId_
|
|
|
|
createOrUpdateContactRequest_ :: DB.Connection -> UserId -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> IO (Either StoreError (Either Contact UserContactRequest))
|
|
createOrUpdateContactRequest_ db userId userContactLinkId invId Profile {displayName, fullName, image} xContactId_ =
|
|
maybeM getContact' xContactId_ >>= \case
|
|
Just contact -> pure . Right $ Left contact
|
|
Nothing -> Right <$$> createOrUpdate_
|
|
where
|
|
maybeM = maybe (pure Nothing)
|
|
createOrUpdate_ :: IO (Either StoreError UserContactRequest)
|
|
createOrUpdate_ =
|
|
maybeM getContactRequest' xContactId_ >>= \case
|
|
Nothing -> createContactRequest
|
|
Just UserContactRequest {contactRequestId, profile = oldProfile} ->
|
|
updateContactRequest contactRequestId oldProfile
|
|
createContactRequest :: IO (Either StoreError UserContactRequest)
|
|
createContactRequest = do
|
|
currentTs <- getCurrentTime
|
|
join <$> withLocalDisplayName db userId displayName (createContactRequest_ currentTs)
|
|
where
|
|
createContactRequest_ currentTs ldn = do
|
|
DB.execute
|
|
db
|
|
"INSERT INTO contact_profiles (display_name, full_name, image, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(displayName, fullName, image, currentTs, currentTs)
|
|
profileId <- insertedRowId db
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO contact_requests
|
|
(user_contact_link_id, agent_invitation_id, contact_profile_id, local_display_name, user_id, created_at, updated_at, xcontact_id)
|
|
VALUES (?,?,?,?,?,?,?,?)
|
|
|]
|
|
(userContactLinkId, invId, profileId, ldn, userId, currentTs, currentTs, xContactId_)
|
|
contactRequestId <- insertedRowId db
|
|
getContactRequest_ db userId contactRequestId
|
|
getContact' :: XContactId -> IO (Maybe Contact)
|
|
getContact' xContactId =
|
|
fmap toContact . listToMaybe
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- Contact
|
|
ct.contact_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, ct.created_at,
|
|
-- Connection
|
|
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.conn_status, c.conn_type,
|
|
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
|
FROM contacts ct
|
|
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
|
|
LEFT JOIN connections c ON c.contact_id = ct.contact_id
|
|
WHERE ct.user_id = ? AND ct.xcontact_id = ?
|
|
ORDER BY c.connection_id DESC
|
|
LIMIT 1
|
|
|]
|
|
(userId, xContactId)
|
|
getContactRequest' :: XContactId -> IO (Maybe UserContactRequest)
|
|
getContactRequest' xContactId =
|
|
fmap toContactRequest . listToMaybe
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id,
|
|
c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, cr.created_at, cr.xcontact_id
|
|
FROM contact_requests cr
|
|
JOIN connections c USING (user_contact_link_id)
|
|
JOIN contact_profiles p USING (contact_profile_id)
|
|
WHERE cr.user_id = ?
|
|
AND cr.xcontact_id = ?
|
|
LIMIT 1
|
|
|]
|
|
(userId, xContactId)
|
|
updateContactRequest :: Int64 -> Profile -> IO (Either StoreError UserContactRequest)
|
|
updateContactRequest cReqId Profile {displayName = oldDisplayName} = do
|
|
currentTs <- liftIO getCurrentTime
|
|
if displayName == oldDisplayName
|
|
then updateContactRequest_ currentTs displayName
|
|
else join <$> withLocalDisplayName db userId displayName (updateContactRequest_ currentTs)
|
|
where
|
|
updateContactRequest_ updatedAt ldn = do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE contact_profiles
|
|
SET display_name = ?,
|
|
full_name = ?,
|
|
image = ?,
|
|
updated_at = ?
|
|
WHERE contact_profile_id IN (
|
|
SELECT contact_profile_id
|
|
FROM contact_requests
|
|
WHERE user_id = ?
|
|
AND contact_request_id = ?
|
|
)
|
|
|]
|
|
(ldn, fullName, image, updatedAt, userId, cReqId)
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE contact_requests
|
|
SET agent_invitation_id = ?,
|
|
local_display_name = ?,
|
|
updated_at = ?
|
|
WHERE user_id = ?
|
|
AND contact_request_id = ?
|
|
|]
|
|
(invId, ldn, updatedAt, userId, cReqId)
|
|
getContactRequest_ db userId cReqId
|
|
|
|
getContactRequest :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m UserContactRequest
|
|
getContactRequest st userId contactRequestId =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
getContactRequest_ db userId contactRequestId
|
|
|
|
getContactRequest_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError UserContactRequest)
|
|
getContactRequest_ db userId contactRequestId =
|
|
firstRow toContactRequest (SEContactRequestNotFound contactRequestId) $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id,
|
|
c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, cr.created_at, cr.xcontact_id
|
|
FROM contact_requests cr
|
|
JOIN connections c USING (user_contact_link_id)
|
|
JOIN contact_profiles p USING (contact_profile_id)
|
|
WHERE cr.user_id = ?
|
|
AND cr.contact_request_id = ?
|
|
|]
|
|
(userId, contactRequestId)
|
|
|
|
type ContactRequestRow = (Int64, ContactName, AgentInvId, Int64, AgentConnId, Int64, ContactName, Text, Maybe ImageData, UTCTime, Maybe XContactId)
|
|
|
|
toContactRequest :: ContactRequestRow -> UserContactRequest
|
|
toContactRequest (contactRequestId, localDisplayName, agentInvitationId, userContactLinkId, agentContactConnId, profileId, displayName, fullName, image, createdAt, xContactId) = do
|
|
let profile = Profile {displayName, fullName, image}
|
|
in UserContactRequest {contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, localDisplayName, profileId, profile, createdAt, xContactId}
|
|
|
|
getContactRequestIdByName :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m Int64
|
|
getContactRequestIdByName st userId cName =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
firstRow fromOnly (SEContactRequestNotFoundByName cName) $
|
|
DB.query db "SELECT contact_request_id FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, cName)
|
|
|
|
deleteContactRequest :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> m ()
|
|
deleteContactRequest st userId contactRequestId =
|
|
liftIO . withTransaction st $ \db -> do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
DELETE FROM display_names
|
|
WHERE user_id = ? AND local_display_name = (
|
|
SELECT local_display_name FROM contact_requests
|
|
WHERE user_id = ? AND contact_request_id = ?
|
|
)
|
|
|]
|
|
(userId, userId, contactRequestId)
|
|
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?" (userId, contactRequestId)
|
|
|
|
createAcceptedContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> ContactName -> Int64 -> Profile -> Maybe XContactId -> m Contact
|
|
createAcceptedContact st userId agentConnId localDisplayName profileId profile xContactId =
|
|
liftIO . withTransaction st $ \db -> do
|
|
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO contacts (user_id, local_display_name, contact_profile_id, created_at, updated_at, xcontact_id) VALUES (?,?,?,?,?,?)"
|
|
(userId, localDisplayName, profileId, currentTs, currentTs, xContactId)
|
|
contactId <- insertedRowId db
|
|
activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId Nothing 0 currentTs
|
|
pure $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup = Nothing, createdAt = currentTs}
|
|
|
|
getLiveSndFileTransfers :: MonadUnliftIO m => SQLiteStore -> User -> m [SndFileTransfer]
|
|
getLiveSndFileTransfers st User {userId} =
|
|
liftIO . withTransaction st $ \db -> do
|
|
fileIds :: [Int64] <-
|
|
map fromOnly
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT DISTINCT f.file_id
|
|
FROM files f
|
|
JOIN snd_files s
|
|
WHERE f.user_id = ? AND s.file_status IN (?, ?, ?)
|
|
|]
|
|
(userId, FSNew, FSAccepted, FSConnected)
|
|
concatMap (filter liveTransfer) . rights <$> mapM (getSndFileTransfers_ db userId) fileIds
|
|
where
|
|
liveTransfer :: SndFileTransfer -> Bool
|
|
liveTransfer SndFileTransfer {fileStatus} = fileStatus `elem` [FSNew, FSAccepted, FSConnected]
|
|
|
|
getLiveRcvFileTransfers :: MonadUnliftIO m => SQLiteStore -> User -> m [RcvFileTransfer]
|
|
getLiveRcvFileTransfers st User {userId} =
|
|
liftIO . withTransaction st $ \db -> do
|
|
fileIds :: [Int64] <-
|
|
map fromOnly
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT f.file_id
|
|
FROM files f
|
|
JOIN rcv_files r
|
|
WHERE f.user_id = ? AND r.file_status IN (?, ?)
|
|
|]
|
|
(userId, FSAccepted, FSConnected)
|
|
rights <$> mapM (getRcvFileTransfer_ db userId) fileIds
|
|
|
|
getPendingSndChunks :: MonadUnliftIO m => SQLiteStore -> Int64 -> Int64 -> m [Integer]
|
|
getPendingSndChunks st fileId connId =
|
|
liftIO . withTransaction st $ \db ->
|
|
map fromOnly
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT chunk_number
|
|
FROM snd_file_chunks
|
|
WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id IS NULL
|
|
ORDER BY chunk_number
|
|
|]
|
|
(fileId, connId)
|
|
|
|
getPendingConnections :: MonadUnliftIO m => SQLiteStore -> User -> m [Connection]
|
|
getPendingConnections st User {userId} =
|
|
liftIO . withTransaction st $ \db ->
|
|
map toConnection
|
|
<$> DB.queryNamed
|
|
db
|
|
[sql|
|
|
SELECT connection_id, agent_conn_id, conn_level, via_contact,
|
|
conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at
|
|
FROM connections
|
|
WHERE user_id = :user_id
|
|
AND conn_type = :conn_type
|
|
AND contact_id IS NULL
|
|
|]
|
|
[":user_id" := userId, ":conn_type" := ConnContact]
|
|
|
|
getContactConnections :: StoreMonad m => SQLiteStore -> UserId -> Contact -> m [Connection]
|
|
getContactConnections st userId Contact {contactId} =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
connections
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
|
|
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
|
FROM connections c
|
|
JOIN contacts ct ON ct.contact_id = c.contact_id
|
|
WHERE c.user_id = ? AND ct.user_id = ? AND ct.contact_id = ?
|
|
|]
|
|
(userId, userId, contactId)
|
|
where
|
|
connections [] = Left $ SEContactNotFound contactId
|
|
connections rows = Right $ map toConnection rows
|
|
|
|
type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, UTCTime)
|
|
|
|
type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe UTCTime)
|
|
|
|
toConnection :: ConnectionRow -> Connection
|
|
toConnection (connId, acId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId, createdAt) =
|
|
let entityId = entityId_ connType
|
|
in Connection {connId, agentConnId = AgentConnId acId, connLevel, viaContact, connStatus, connType, entityId, createdAt}
|
|
where
|
|
entityId_ :: ConnType -> Maybe Int64
|
|
entityId_ ConnContact = contactId
|
|
entityId_ ConnMember = groupMemberId
|
|
entityId_ ConnRcvFile = rcvFileId
|
|
entityId_ ConnSndFile = sndFileId
|
|
entityId_ ConnUserContact = userContactLinkId
|
|
|
|
toMaybeConnection :: MaybeConnectionRow -> Maybe Connection
|
|
toMaybeConnection (Just connId, Just agentConnId, Just connLevel, viaContact, Just connStatus, Just connType, contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId, Just createdAt) =
|
|
Just $ toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId, createdAt)
|
|
toMaybeConnection _ = Nothing
|
|
|
|
getMatchingContacts :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> m [Contact]
|
|
getMatchingContacts st userId Contact {contactId, profile = Profile {displayName, fullName, image}} =
|
|
liftIO . withTransaction st $ \db -> do
|
|
contactIds <-
|
|
map fromOnly
|
|
<$> DB.queryNamed
|
|
db
|
|
[sql|
|
|
SELECT ct.contact_id
|
|
FROM contacts ct
|
|
JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id
|
|
WHERE ct.user_id = :user_id AND ct.contact_id != :contact_id
|
|
AND p.display_name = :display_name AND p.full_name = :full_name
|
|
AND ((p.image IS NULL AND :image IS NULL) OR p.image = :image)
|
|
|]
|
|
[ ":user_id" := userId,
|
|
":contact_id" := contactId,
|
|
":display_name" := displayName,
|
|
":full_name" := fullName,
|
|
":image" := image
|
|
]
|
|
rights <$> mapM (getContact_ db userId) contactIds
|
|
|
|
createSentProbe :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> UserId -> Contact -> m (Probe, Int64)
|
|
createSentProbe st gVar userId _to@Contact {contactId} =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
createWithRandomBytes 32 gVar $ \probe -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sent_probes (contact_id, probe, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(contactId, probe, userId, currentTs, currentTs)
|
|
(Probe probe,) <$> insertedRowId db
|
|
|
|
createSentProbeHash :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> Contact -> m ()
|
|
createSentProbeHash st userId probeId _to@Contact {contactId} =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sent_probe_hashes (sent_probe_id, contact_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(probeId, contactId, userId, currentTs, currentTs)
|
|
|
|
matchReceivedProbe :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> Probe -> m (Maybe Contact)
|
|
matchReceivedProbe st userId _from@Contact {contactId} (Probe probe) =
|
|
liftIO . withTransaction st $ \db -> do
|
|
let probeHash = C.sha256Hash probe
|
|
contactIds <-
|
|
map fromOnly
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT c.contact_id
|
|
FROM contacts c
|
|
JOIN received_probes r ON r.contact_id = c.contact_id
|
|
WHERE c.user_id = ? AND r.probe_hash = ? AND r.probe IS NULL
|
|
|]
|
|
(userId, probeHash)
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO received_probes (contact_id, probe, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
|
|
(contactId, probe, probeHash, userId, currentTs, currentTs)
|
|
case contactIds of
|
|
[] -> pure Nothing
|
|
cId : _ -> eitherToMaybe <$> getContact_ db userId cId
|
|
|
|
matchReceivedProbeHash :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> ProbeHash -> m (Maybe (Contact, Probe))
|
|
matchReceivedProbeHash st userId _from@Contact {contactId} (ProbeHash probeHash) =
|
|
liftIO . withTransaction st $ \db -> do
|
|
namesAndProbes <-
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT c.contact_id, r.probe
|
|
FROM contacts c
|
|
JOIN received_probes r ON r.contact_id = c.contact_id
|
|
WHERE c.user_id = ? AND r.probe_hash = ? AND r.probe IS NOT NULL
|
|
|]
|
|
(userId, probeHash)
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO received_probes (contact_id, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(contactId, probeHash, userId, currentTs, currentTs)
|
|
case namesAndProbes of
|
|
[] -> pure Nothing
|
|
(cId, probe) : _ ->
|
|
either (const Nothing) (Just . (,Probe probe))
|
|
<$> getContact_ db userId cId
|
|
|
|
matchSentProbe :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> Probe -> m (Maybe Contact)
|
|
matchSentProbe st userId _from@Contact {contactId} (Probe probe) =
|
|
liftIO . withTransaction st $ \db -> do
|
|
contactIds <-
|
|
map fromOnly
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT c.contact_id
|
|
FROM contacts c
|
|
JOIN sent_probes s ON s.contact_id = c.contact_id
|
|
JOIN sent_probe_hashes h ON h.sent_probe_id = s.sent_probe_id
|
|
WHERE c.user_id = ? AND s.probe = ? AND h.contact_id = ?
|
|
|]
|
|
(userId, probe, contactId)
|
|
case contactIds of
|
|
[] -> pure Nothing
|
|
cId : _ -> eitherToMaybe <$> getContact_ db userId cId
|
|
|
|
mergeContactRecords :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> Contact -> m ()
|
|
mergeContactRecords st userId Contact {contactId = toContactId} Contact {contactId = fromContactId, localDisplayName} =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"UPDATE connections SET contact_id = ?, updated_at = ? WHERE contact_id = ? AND user_id = ?"
|
|
(toContactId, currentTs, fromContactId, userId)
|
|
DB.execute
|
|
db
|
|
"UPDATE connections SET via_contact = ?, updated_at = ? WHERE via_contact = ? AND user_id = ?"
|
|
(toContactId, currentTs, fromContactId, userId)
|
|
DB.execute
|
|
db
|
|
"UPDATE group_members SET invited_by = ?, updated_at = ? WHERE invited_by = ? AND user_id = ?"
|
|
(toContactId, currentTs, fromContactId, userId)
|
|
DB.executeNamed
|
|
db
|
|
[sql|
|
|
UPDATE group_members
|
|
SET contact_id = :to_contact_id,
|
|
local_display_name = (SELECT local_display_name FROM contacts WHERE contact_id = :to_contact_id),
|
|
contact_profile_id = (SELECT contact_profile_id FROM contacts WHERE contact_id = :to_contact_id),
|
|
updated_at = :updated_at
|
|
WHERE contact_id = :from_contact_id
|
|
AND user_id = :user_id
|
|
|]
|
|
[ ":to_contact_id" := toContactId,
|
|
":from_contact_id" := fromContactId,
|
|
":user_id" := userId,
|
|
":updated_at" := currentTs
|
|
]
|
|
DB.execute db "DELETE FROM contacts WHERE contact_id = ? AND user_id = ?" (fromContactId, userId)
|
|
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId)
|
|
|
|
getConnectionEntity :: StoreMonad m => SQLiteStore -> User -> ConnId -> m ConnectionEntity
|
|
getConnectionEntity st User {userId, userContactId} agentConnId =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
c@Connection {connType, entityId} <- getConnection_ db
|
|
case entityId of
|
|
Nothing ->
|
|
if connType == ConnContact
|
|
then pure $ RcvDirectMsgConnection c Nothing
|
|
else throwError $ SEInternalError $ "connection " <> show connType <> " without entity"
|
|
Just entId ->
|
|
case connType of
|
|
ConnMember -> uncurry (RcvGroupMsgConnection c) <$> getGroupAndMember_ db entId c
|
|
ConnContact -> RcvDirectMsgConnection c . Just <$> getContactRec_ db entId c
|
|
ConnSndFile -> SndFileConnection c <$> getConnSndFileTransfer_ db entId c
|
|
ConnRcvFile -> RcvFileConnection c <$> ExceptT (getRcvFileTransfer_ db userId entId)
|
|
ConnUserContact -> UserContactConnection c <$> getUserContact_ db entId
|
|
where
|
|
getConnection_ :: DB.Connection -> ExceptT StoreError IO Connection
|
|
getConnection_ db = ExceptT $ do
|
|
connection
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT connection_id, agent_conn_id, conn_level, via_contact,
|
|
conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at
|
|
FROM connections
|
|
WHERE user_id = ? AND agent_conn_id = ?
|
|
|]
|
|
(userId, agentConnId)
|
|
connection :: [ConnectionRow] -> Either StoreError Connection
|
|
connection (connRow : _) = Right $ toConnection connRow
|
|
connection _ = Left . SEConnectionNotFound $ AgentConnId agentConnId
|
|
getContactRec_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO Contact
|
|
getContactRec_ db contactId c = ExceptT $ do
|
|
toContact' contactId c
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT c.local_display_name, p.display_name, p.full_name, p.image, c.via_group, c.created_at
|
|
FROM contacts c
|
|
JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
|
|
WHERE c.user_id = ? AND c.contact_id = ?
|
|
|]
|
|
(userId, contactId)
|
|
toContact' :: Int64 -> Connection -> [(ContactName, Text, Text, Maybe ImageData, Maybe Int64, UTCTime)] -> Either StoreError Contact
|
|
toContact' contactId activeConn [(localDisplayName, displayName, fullName, image, viaGroup, createdAt)] =
|
|
let profile = Profile {displayName, fullName, image}
|
|
in Right $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup, createdAt}
|
|
toContact' _ _ _ = Left $ SEInternalError "referenced contact not found"
|
|
getGroupAndMember_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
|
getGroupAndMember_ db groupMemberId c = ExceptT $ do
|
|
firstRow (toGroupAndMember c) (SEInternalError "referenced group member not found") $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- GroupInfo
|
|
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at,
|
|
-- GroupInfo {membership}
|
|
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
|
|
mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id,
|
|
-- GroupInfo {membership = GroupMember {memberProfile}}
|
|
pu.display_name, pu.full_name, pu.image,
|
|
-- from GroupMember
|
|
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
|
|
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, p.image
|
|
FROM group_members m
|
|
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
|
JOIN groups g ON g.group_id = m.group_id
|
|
JOIN group_profiles gp USING (group_profile_id)
|
|
JOIN group_members mu ON g.group_id = mu.group_id
|
|
JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id
|
|
WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ?
|
|
|]
|
|
(groupMemberId, userId, userContactId)
|
|
toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
|
|
toGroupAndMember c (groupInfoRow :. memberRow) =
|
|
let groupInfo = toGroupInfo userContactId groupInfoRow
|
|
member = toGroupMember userContactId memberRow
|
|
in (groupInfo, (member :: GroupMember) {activeConn = Just c})
|
|
getConnSndFileTransfer_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer
|
|
getConnSndFileTransfer_ db fileId Connection {connId} =
|
|
ExceptT $
|
|
sndFileTransfer_ fileId connId
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, cs.local_display_name, m.local_display_name
|
|
FROM snd_files s
|
|
JOIN files f USING (file_id)
|
|
LEFT JOIN contacts cs USING (contact_id)
|
|
LEFT JOIN group_members m USING (group_member_id)
|
|
WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ?
|
|
|]
|
|
(userId, fileId, connId)
|
|
sndFileTransfer_ :: Int64 -> Int64 -> [(FileStatus, String, Integer, Integer, FilePath, Maybe ContactName, Maybe ContactName)] -> Either StoreError SndFileTransfer
|
|
sndFileTransfer_ fileId connId [(fileStatus, fileName, fileSize, chunkSize, filePath, contactName_, memberName_)] =
|
|
case contactName_ <|> memberName_ of
|
|
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId = AgentConnId agentConnId}
|
|
Nothing -> Left $ SESndFileInvalid fileId
|
|
sndFileTransfer_ fileId _ _ = Left $ SESndFileNotFound fileId
|
|
getUserContact_ :: DB.Connection -> Int64 -> ExceptT StoreError IO UserContact
|
|
getUserContact_ db userContactLinkId = ExceptT $ do
|
|
userContact_
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT conn_req_contact
|
|
FROM user_contact_links
|
|
WHERE user_id = ? AND user_contact_link_id = ?
|
|
|]
|
|
(userId, userContactLinkId)
|
|
where
|
|
userContact_ :: [Only ConnReqContact] -> Either StoreError UserContact
|
|
userContact_ [Only cReq] = Right UserContact {userContactLinkId, connReqContact = cReq}
|
|
userContact_ _ = Left SEUserContactLinkNotFound
|
|
|
|
getGroupAndMember :: StoreMonad m => SQLiteStore -> User -> Int64 -> m (GroupInfo, GroupMember)
|
|
getGroupAndMember st User {userId, userContactId} groupMemberId =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
firstRow toGroupAndMember (SEInternalError "referenced group member not found") $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- GroupInfo
|
|
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at,
|
|
-- GroupInfo {membership}
|
|
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
|
|
mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id,
|
|
-- GroupInfo {membership = GroupMember {memberProfile}}
|
|
pu.display_name, pu.full_name, pu.image,
|
|
-- from GroupMember
|
|
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
|
|
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, p.image,
|
|
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
|
|
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
|
FROM group_members m
|
|
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
|
JOIN groups g ON g.group_id = m.group_id
|
|
JOIN group_profiles gp USING (group_profile_id)
|
|
JOIN group_members mu ON g.group_id = mu.group_id
|
|
JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id
|
|
LEFT JOIN connections c ON c.connection_id = (
|
|
SELECT max(cc.connection_id)
|
|
FROM connections cc
|
|
where cc.group_member_id = m.group_member_id
|
|
)
|
|
WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ?
|
|
|]
|
|
(groupMemberId, userId, userContactId)
|
|
where
|
|
toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
|
|
toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
|
|
let groupInfo = toGroupInfo userContactId groupInfoRow
|
|
member = toGroupMember userContactId memberRow
|
|
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
|
|
|
|
updateConnectionStatus :: MonadUnliftIO m => SQLiteStore -> Connection -> ConnStatus -> m ()
|
|
updateConnectionStatus st Connection {connId} connStatus =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId)
|
|
|
|
-- | creates completely new group with a single member - the current user
|
|
createNewGroup :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> User -> GroupProfile -> m GroupInfo
|
|
createNewGroup st gVar user groupProfile =
|
|
liftIOEither . checkConstraint SEDuplicateName . withTransaction st $ \db -> do
|
|
let GroupProfile {displayName, fullName, image} = groupProfile
|
|
uId = userId user
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(displayName, displayName, uId, currentTs, currentTs)
|
|
DB.execute
|
|
db
|
|
"INSERT INTO group_profiles (display_name, full_name, image, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(displayName, fullName, image, currentTs, currentTs)
|
|
profileId <- insertedRowId db
|
|
DB.execute
|
|
db
|
|
"INSERT INTO groups (local_display_name, user_id, group_profile_id, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(displayName, uId, profileId, currentTs, currentTs)
|
|
groupId <- insertedRowId db
|
|
memberId <- randomBytes gVar 12
|
|
membership <- createContactMember_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser currentTs
|
|
pure $ Right GroupInfo {groupId, localDisplayName = displayName, groupProfile, membership, createdAt = currentTs}
|
|
|
|
-- | creates a new group record for the group the current user was invited to, or returns an existing one
|
|
createGroupInvitation ::
|
|
StoreMonad m => SQLiteStore -> User -> Contact -> GroupInvitation -> m GroupInfo
|
|
createGroupInvitation st user@User {userId} contact@Contact {contactId} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} =
|
|
liftIOEither . withTransaction st $ \db -> do
|
|
getInvitationGroupId_ db >>= \case
|
|
Nothing -> createGroupInvitation_ db
|
|
-- TODO treat the case that the invitation details could've changed
|
|
Just gId -> getGroupInfo_ db user gId
|
|
where
|
|
getInvitationGroupId_ :: DB.Connection -> IO (Maybe Int64)
|
|
getInvitationGroupId_ db =
|
|
listToMaybe . map fromOnly
|
|
<$> DB.query db "SELECT group_id FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMIT 1" (connRequest, userId)
|
|
createGroupInvitation_ :: DB.Connection -> IO (Either StoreError GroupInfo)
|
|
createGroupInvitation_ db = do
|
|
let GroupProfile {displayName, fullName, image} = groupProfile
|
|
withLocalDisplayName db userId displayName $ \localDisplayName -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO group_profiles (display_name, full_name, image, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(displayName, fullName, image, currentTs, currentTs)
|
|
profileId <- insertedRowId db
|
|
DB.execute
|
|
db
|
|
"INSERT INTO groups (group_profile_id, local_display_name, inv_queue_info, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
|
|
(profileId, localDisplayName, connRequest, userId, currentTs, currentTs)
|
|
groupId <- insertedRowId db
|
|
_ <- createContactMember_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown currentTs
|
|
membership <- createContactMember_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact contactId) currentTs
|
|
pure $ GroupInfo {groupId, localDisplayName, groupProfile, membership, createdAt = currentTs}
|
|
|
|
-- TODO return the last connection that is ready, not any last connection
|
|
-- requires updating connection status
|
|
getGroupByName :: StoreMonad m => SQLiteStore -> User -> GroupName -> m Group
|
|
getGroupByName st user gName =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
groupId <- ExceptT $ getGroupIdByName_ db user gName
|
|
ExceptT $ getGroup_ db user groupId
|
|
|
|
getGroup :: StoreMonad m => SQLiteStore -> User -> Int64 -> m Group
|
|
getGroup st user groupId =
|
|
liftIOEither . withTransaction st $ \db -> getGroup_ db user groupId
|
|
|
|
getGroup_ :: DB.Connection -> User -> Int64 -> IO (Either StoreError Group)
|
|
getGroup_ db user groupId = runExceptT $ do
|
|
gInfo <- ExceptT $ getGroupInfo_ db user groupId
|
|
members <- liftIO $ getGroupMembers_ db user gInfo
|
|
pure $ Group gInfo members
|
|
|
|
deleteGroup :: MonadUnliftIO m => SQLiteStore -> User -> Group -> m ()
|
|
deleteGroup st User {userId} (Group GroupInfo {groupId, localDisplayName} members) =
|
|
liftIO . withTransaction st $ \db -> do
|
|
forM_ members $ \m -> DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId m)
|
|
DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_id = ?" (userId, groupId)
|
|
DB.execute db "DELETE FROM groups WHERE user_id = ? AND group_id = ?" (userId, groupId)
|
|
-- TODO ? delete group profile
|
|
DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
|
|
|
|
getUserGroups :: MonadUnliftIO m => SQLiteStore -> User -> m [Group]
|
|
getUserGroups st user@User {userId} =
|
|
liftIO . withTransaction st $ \db -> do
|
|
groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId)
|
|
rights <$> mapM (getGroup_ db user) groupIds
|
|
|
|
getUserGroupDetails :: MonadUnliftIO m => SQLiteStore -> User -> m [GroupInfo]
|
|
getUserGroupDetails st User {userId, userContactId} =
|
|
liftIO . withTransaction st $ \db ->
|
|
map (toGroupInfo userContactId)
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at,
|
|
m.group_member_id, g.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
|
|
m.invited_by, m.local_display_name, m.contact_id, mp.display_name, mp.full_name, mp.image
|
|
FROM groups g
|
|
JOIN group_profiles gp USING (group_profile_id)
|
|
JOIN group_members m USING (group_id)
|
|
JOIN contact_profiles mp USING (contact_profile_id)
|
|
WHERE g.user_id = ? AND m.contact_id = ?
|
|
|]
|
|
(userId, userContactId)
|
|
|
|
getGroupInfoByName :: StoreMonad m => SQLiteStore -> User -> GroupName -> m GroupInfo
|
|
getGroupInfoByName st user gName =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
gId <- ExceptT $ getGroupIdByName_ db user gName
|
|
ExceptT $ getGroupInfo_ db user gId
|
|
|
|
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe ImageData, UTCTime) :. GroupMemberRow
|
|
|
|
toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo
|
|
toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, image, createdAt) :. userMemberRow) =
|
|
let membership = toGroupMember userContactId userMemberRow
|
|
in GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName, fullName, image}, membership, createdAt}
|
|
|
|
getGroupMembers :: MonadUnliftIO m => SQLiteStore -> User -> GroupInfo -> m [GroupMember]
|
|
getGroupMembers st user gInfo = liftIO . withTransaction st $ \db -> getGroupMembers_ db user gInfo
|
|
|
|
getGroupMembers_ :: DB.Connection -> User -> GroupInfo -> IO [GroupMember]
|
|
getGroupMembers_ db User {userId, userContactId} GroupInfo {groupId} = do
|
|
map toContactMember
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
|
|
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, p.image,
|
|
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
|
|
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
|
FROM group_members m
|
|
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
|
LEFT JOIN connections c ON c.connection_id = (
|
|
SELECT max(cc.connection_id)
|
|
FROM connections cc
|
|
where cc.group_member_id = m.group_member_id
|
|
)
|
|
WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?)
|
|
|]
|
|
(groupId, userId, userContactId)
|
|
where
|
|
toContactMember :: (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
|
|
toContactMember (memberRow :. connRow) =
|
|
(toGroupMember userContactId memberRow) {activeConn = toMaybeConnection connRow}
|
|
|
|
-- TODO no need to load all members to find the member who invited the used,
|
|
-- instead of findFromContact there could be a query
|
|
getGroupInvitation :: StoreMonad m => SQLiteStore -> User -> GroupName -> m ReceivedGroupInvitation
|
|
getGroupInvitation st user localDisplayName =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
cReq <- getConnRec_ db user
|
|
groupId <- ExceptT $ getGroupIdByName_ db user localDisplayName
|
|
Group groupInfo@GroupInfo {membership} members <- ExceptT $ getGroup_ db user groupId
|
|
when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
|
|
case (cReq, findFromContact (invitedBy membership) members) of
|
|
(Just connRequest, Just fromMember) ->
|
|
pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo}
|
|
_ -> throwError SEGroupInvitationNotFound
|
|
where
|
|
getConnRec_ :: DB.Connection -> User -> ExceptT StoreError IO (Maybe ConnReqInvitation)
|
|
getConnRec_ db User {userId} = ExceptT $ do
|
|
firstRow fromOnly (SEGroupNotFoundByName localDisplayName) $
|
|
DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.local_display_name = ? AND g.user_id = ?" (localDisplayName, userId)
|
|
findFromContact :: InvitedBy -> [GroupMember] -> Maybe GroupMember
|
|
findFromContact (IBContact contactId) = find ((== Just contactId) . memberContactId)
|
|
findFromContact _ = const Nothing
|
|
|
|
type GroupMemberRow = (Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Maybe Int64, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData)
|
|
|
|
type MaybeGroupMemberRow = (Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Int64, Maybe ContactName, Maybe Int64, Maybe ContactName, Maybe Text, Maybe ImageData)
|
|
|
|
toGroupMember :: Int64 -> GroupMemberRow -> GroupMember
|
|
toGroupMember userContactId (groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, localDisplayName, memberContactId, displayName, fullName, image) =
|
|
let memberProfile = Profile {displayName, fullName, image}
|
|
invitedBy = toInvitedBy userContactId invitedById
|
|
activeConn = Nothing
|
|
in GroupMember {..}
|
|
|
|
toMaybeGroupMember :: Int64 -> MaybeGroupMemberRow -> Maybe GroupMember
|
|
toMaybeGroupMember userContactId (Just groupMemberId, Just groupId, Just memberId, Just memberRole, Just memberCategory, Just memberStatus, invitedById, Just localDisplayName, memberContactId, Just displayName, Just fullName, image) =
|
|
Just $ toGroupMember userContactId (groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, localDisplayName, memberContactId, displayName, fullName, image)
|
|
toMaybeGroupMember _ _ = Nothing
|
|
|
|
createContactMember :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> User -> Int64 -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> m GroupMember
|
|
createContactMember st gVar user groupId contact memberRole agentConnId connRequest =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
createWithRandomId gVar $ \memId -> do
|
|
currentTs <- getCurrentTime
|
|
member@GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId contact (MemberIdRole (MemberId memId) memberRole) GCInviteeMember GSMemInvited IBUser (Just connRequest) currentTs
|
|
void $ createMemberConnection_ db (userId user) groupMemberId agentConnId Nothing 0 currentTs
|
|
pure member
|
|
|
|
getMemberInvitation :: StoreMonad m => SQLiteStore -> User -> Int64 -> m (Maybe ConnReqInvitation)
|
|
getMemberInvitation st User {userId} groupMemberId =
|
|
liftIO . withTransaction st $ \db ->
|
|
join . listToMaybe . map fromOnly
|
|
<$> DB.query db "SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? AND user_id = ?" (groupMemberId, userId)
|
|
|
|
createMemberConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> ConnId -> m ()
|
|
createMemberConnection st userId GroupMember {groupMemberId} agentConnId =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs
|
|
|
|
updateGroupMemberStatus :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> GroupMemberStatus -> m ()
|
|
updateGroupMemberStatus st userId GroupMember {groupMemberId} memStatus =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.executeNamed
|
|
db
|
|
[sql|
|
|
UPDATE group_members
|
|
SET member_status = :member_status, updated_at = :updated_at
|
|
WHERE user_id = :user_id AND group_member_id = :group_member_id
|
|
|]
|
|
[ ":user_id" := userId,
|
|
":group_member_id" := groupMemberId,
|
|
":member_status" := memStatus,
|
|
":updated_at" := currentTs
|
|
]
|
|
|
|
-- | add new member with profile
|
|
createNewGroupMember :: StoreMonad m => SQLiteStore -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> m GroupMember
|
|
createNewGroupMember st user@User {userId} gInfo memInfo@(MemberInfo _ _ Profile {displayName, fullName, image}) memCategory memStatus =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
withLocalDisplayName db userId displayName $ \localDisplayName -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO contact_profiles (display_name, full_name, image, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(displayName, fullName, image, currentTs, currentTs)
|
|
memProfileId <- insertedRowId db
|
|
let newMember =
|
|
NewGroupMember
|
|
{ memInfo,
|
|
memCategory,
|
|
memStatus,
|
|
memInvitedBy = IBUnknown,
|
|
localDisplayName,
|
|
memContactId = Nothing,
|
|
memProfileId
|
|
}
|
|
createNewMember_ db user gInfo newMember currentTs
|
|
|
|
createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> UTCTime -> IO GroupMember
|
|
createNewMember_
|
|
db
|
|
User {userId, userContactId}
|
|
GroupInfo {groupId}
|
|
NewGroupMember
|
|
{ memInfo = MemberInfo memberId memberRole memberProfile,
|
|
memCategory = memberCategory,
|
|
memStatus = memberStatus,
|
|
memInvitedBy = invitedBy,
|
|
localDisplayName,
|
|
memContactId = memberContactId,
|
|
memProfileId
|
|
}
|
|
createdAt = do
|
|
let invitedById = fromInvitedBy userContactId invitedBy
|
|
activeConn = Nothing
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO group_members
|
|
(group_id, member_id, member_role, member_category, member_status,
|
|
invited_by, user_id, local_display_name, contact_profile_id, contact_id, created_at, updated_at)
|
|
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|
|
|]
|
|
(groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memProfileId, memberContactId, createdAt, createdAt)
|
|
groupMemberId <- insertedRowId db
|
|
pure GroupMember {..}
|
|
|
|
deleteGroupMemberConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> m ()
|
|
deleteGroupMemberConnection st userId m =
|
|
liftIO . withTransaction st $ \db -> deleteGroupMemberConnection_ db userId m
|
|
|
|
deleteGroupMemberConnection_ :: DB.Connection -> UserId -> GroupMember -> IO ()
|
|
deleteGroupMemberConnection_ db userId GroupMember {groupMemberId} =
|
|
DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId)
|
|
|
|
createIntroductions :: MonadUnliftIO m => SQLiteStore -> [GroupMember] -> GroupMember -> m [GroupMemberIntro]
|
|
createIntroductions st members toMember = do
|
|
let reMembers = filter (\m -> memberCurrent m && groupMemberId m /= groupMemberId toMember) members
|
|
if null reMembers
|
|
then pure []
|
|
else liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
mapM (insertIntro_ db currentTs) reMembers
|
|
where
|
|
insertIntro_ :: DB.Connection -> UTCTime -> GroupMember -> IO GroupMemberIntro
|
|
insertIntro_ db ts reMember = do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO group_member_intros
|
|
(re_group_member_id, to_group_member_id, intro_status, created_at, updated_at)
|
|
VALUES (?,?,?,?,?)
|
|
|]
|
|
(groupMemberId reMember, groupMemberId toMember, GMIntroPending, ts, ts)
|
|
introId <- insertedRowId db
|
|
pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing}
|
|
|
|
updateIntroStatus :: MonadUnliftIO m => SQLiteStore -> Int64 -> GroupMemberIntroStatus -> m ()
|
|
updateIntroStatus st introId introStatus =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.executeNamed
|
|
db
|
|
[sql|
|
|
UPDATE group_member_intros
|
|
SET intro_status = :intro_status, updated_at = :updated_at
|
|
WHERE group_member_intro_id = :intro_id
|
|
|]
|
|
[":intro_status" := introStatus, ":updated_at" := currentTs, ":intro_id" := introId]
|
|
|
|
saveIntroInvitation :: StoreMonad m => SQLiteStore -> GroupMember -> GroupMember -> IntroInvitation -> m GroupMemberIntro
|
|
saveIntroInvitation st reMember toMember introInv = do
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
intro <- getIntroduction_ db reMember toMember
|
|
liftIO $ do
|
|
currentTs <- getCurrentTime
|
|
DB.executeNamed
|
|
db
|
|
[sql|
|
|
UPDATE group_member_intros
|
|
SET intro_status = :intro_status,
|
|
group_queue_info = :group_queue_info,
|
|
direct_queue_info = :direct_queue_info,
|
|
updated_at = :updated_at
|
|
WHERE group_member_intro_id = :intro_id
|
|
|]
|
|
[ ":intro_status" := GMIntroInvReceived,
|
|
":group_queue_info" := groupConnReq introInv,
|
|
":direct_queue_info" := directConnReq introInv,
|
|
":updated_at" := currentTs,
|
|
":intro_id" := introId intro
|
|
]
|
|
pure intro {introInvitation = Just introInv, introStatus = GMIntroInvReceived}
|
|
|
|
saveMemberInvitation :: StoreMonad m => SQLiteStore -> GroupMember -> IntroInvitation -> m ()
|
|
saveMemberInvitation st GroupMember {groupMemberId} IntroInvitation {groupConnReq, directConnReq} =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.executeNamed
|
|
db
|
|
[sql|
|
|
UPDATE group_members
|
|
SET member_status = :member_status,
|
|
group_queue_info = :group_queue_info,
|
|
direct_queue_info = :direct_queue_info,
|
|
updated_at = :updated_at
|
|
WHERE group_member_id = :group_member_id
|
|
|]
|
|
[ ":member_status" := GSMemIntroInvited,
|
|
":group_queue_info" := groupConnReq,
|
|
":direct_queue_info" := directConnReq,
|
|
":updated_at" := currentTs,
|
|
":group_member_id" := groupMemberId
|
|
]
|
|
|
|
getIntroduction_ :: DB.Connection -> GroupMember -> GroupMember -> ExceptT StoreError IO GroupMemberIntro
|
|
getIntroduction_ db reMember toMember = ExceptT $ do
|
|
toIntro
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT group_member_intro_id, group_queue_info, direct_queue_info, intro_status
|
|
FROM group_member_intros
|
|
WHERE re_group_member_id = ? AND to_group_member_id = ?
|
|
|]
|
|
(groupMemberId reMember, groupMemberId toMember)
|
|
where
|
|
toIntro :: [(Int64, Maybe ConnReqInvitation, Maybe ConnReqInvitation, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro
|
|
toIntro [(introId, groupConnReq, directConnReq, introStatus)] =
|
|
let introInvitation = IntroInvitation <$> groupConnReq <*> directConnReq
|
|
in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation}
|
|
toIntro _ = Left SEIntroNotFound
|
|
|
|
createIntroReMember :: StoreMonad m => SQLiteStore -> User -> GroupInfo -> GroupMember -> MemberInfo -> ConnId -> ConnId -> m GroupMember
|
|
createIntroReMember st user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) groupAgentConnId directAgentConnId =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
|
|
currentTs <- liftIO getCurrentTime
|
|
Connection {connId = directConnId} <- liftIO $ createContactConnection_ db userId directAgentConnId memberContactId cLevel currentTs
|
|
(localDisplayName, contactId, memProfileId) <- ExceptT $ createContact_ db userId directConnId memberProfile (Just groupId) currentTs
|
|
liftIO $ do
|
|
let newMember =
|
|
NewGroupMember
|
|
{ memInfo,
|
|
memCategory = GCPreMember,
|
|
memStatus = GSMemIntroduced,
|
|
memInvitedBy = IBUnknown,
|
|
localDisplayName,
|
|
memContactId = Just contactId,
|
|
memProfileId
|
|
}
|
|
member <- createNewMember_ db user gInfo newMember currentTs
|
|
conn <- createMemberConnection_ db userId (groupMemberId member) groupAgentConnId memberContactId cLevel currentTs
|
|
pure (member :: GroupMember) {activeConn = Just conn}
|
|
|
|
createIntroToMemberContact :: StoreMonad m => SQLiteStore -> UserId -> GroupMember -> GroupMember -> ConnId -> ConnId -> m ()
|
|
createIntroToMemberContact st userId GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} groupAgentConnId directAgentConnId =
|
|
liftIO . withTransaction st $ \db -> do
|
|
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
|
|
currentTs <- getCurrentTime
|
|
void $ createMemberConnection_ db userId groupMemberId groupAgentConnId viaContactId cLevel currentTs
|
|
Connection {connId = directConnId} <- createContactConnection_ db userId directAgentConnId viaContactId cLevel currentTs
|
|
contactId <- createMemberContact_ db directConnId currentTs
|
|
updateMember_ db contactId currentTs
|
|
where
|
|
createMemberContact_ :: DB.Connection -> Int64 -> UTCTime -> IO Int64
|
|
createMemberContact_ db connId ts = do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO contacts (contact_profile_id, via_group, local_display_name, user_id, created_at, updated_at)
|
|
SELECT contact_profile_id, group_id, ?, ?, ?, ?
|
|
FROM group_members
|
|
WHERE group_member_id = ?
|
|
|]
|
|
(localDisplayName, userId, ts, ts, groupMemberId)
|
|
contactId <- insertedRowId db
|
|
DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, ts, connId)
|
|
pure contactId
|
|
updateMember_ :: DB.Connection -> Int64 -> UTCTime -> IO ()
|
|
updateMember_ db contactId ts =
|
|
DB.executeNamed
|
|
db
|
|
[sql|
|
|
UPDATE group_members
|
|
SET contact_id = :contact_id, updated_at = :updated_at
|
|
WHERE group_member_id = :group_member_id
|
|
|]
|
|
[":contact_id" := contactId, ":updated_at" := ts, ":group_member_id" := groupMemberId]
|
|
|
|
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection
|
|
createMemberConnection_ db userId groupMemberId = createConnection_ db userId ConnMember (Just groupMemberId)
|
|
|
|
createContactMember_ :: IsContact a => DB.Connection -> User -> Int64 -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> UTCTime -> IO GroupMember
|
|
createContactMember_ db user groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy =
|
|
createContactMemberInv_ db user groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy Nothing
|
|
|
|
createContactMemberInv_ :: IsContact a => DB.Connection -> User -> Int64 -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> Maybe ConnReqInvitation -> UTCTime -> IO GroupMember
|
|
createContactMemberInv_ db User {userId, userContactId} groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy connRequest createdAt = do
|
|
insertMember_
|
|
groupMemberId <- insertedRowId db
|
|
let memberProfile = profile' userOrContact
|
|
memberContactId = Just $ contactId' userOrContact
|
|
localDisplayName = localDisplayName' userOrContact
|
|
activeConn = Nothing
|
|
pure GroupMember {..}
|
|
where
|
|
insertMember_ =
|
|
DB.executeNamed
|
|
db
|
|
[sql|
|
|
INSERT INTO group_members
|
|
( group_id, member_id, member_role, member_category, member_status, invited_by,
|
|
user_id, local_display_name, contact_profile_id, contact_id, sent_inv_queue_info, created_at, updated_at)
|
|
VALUES
|
|
(:group_id,:member_id,:member_role,:member_category,:member_status,:invited_by,
|
|
:user_id,:local_display_name,
|
|
(SELECT contact_profile_id FROM contacts WHERE contact_id = :contact_id),
|
|
:contact_id, :sent_inv_queue_info, :created_at, :updated_at)
|
|
|]
|
|
[ ":group_id" := groupId,
|
|
":member_id" := memberId,
|
|
":member_role" := memberRole,
|
|
":member_category" := memberCategory,
|
|
":member_status" := memberStatus,
|
|
":invited_by" := fromInvitedBy userContactId invitedBy,
|
|
":user_id" := userId,
|
|
":local_display_name" := localDisplayName' userOrContact,
|
|
":contact_id" := contactId' userOrContact,
|
|
":sent_inv_queue_info" := connRequest,
|
|
":created_at" := createdAt,
|
|
":updated_at" := createdAt
|
|
]
|
|
|
|
getViaGroupMember :: MonadUnliftIO m => SQLiteStore -> User -> Contact -> m (Maybe (GroupInfo, GroupMember))
|
|
getViaGroupMember st User {userId, userContactId} Contact {contactId} =
|
|
liftIO . withTransaction st $ \db ->
|
|
toGroupAndMember
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- GroupInfo
|
|
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at,
|
|
-- GroupInfo {membership}
|
|
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
|
|
mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id,
|
|
-- GroupInfo {membership = GroupMember {memberProfile}}
|
|
pu.display_name, pu.full_name, pu.image,
|
|
-- via GroupMember
|
|
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
|
|
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, p.image,
|
|
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
|
|
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
|
FROM group_members m
|
|
JOIN contacts ct ON ct.contact_id = m.contact_id
|
|
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
|
JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group
|
|
JOIN group_profiles gp USING (group_profile_id)
|
|
JOIN group_members mu ON g.group_id = mu.group_id
|
|
JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id
|
|
LEFT JOIN connections c ON c.connection_id = (
|
|
SELECT max(cc.connection_id)
|
|
FROM connections cc
|
|
where cc.group_member_id = m.group_member_id
|
|
)
|
|
WHERE ct.user_id = ? AND ct.contact_id = ? AND mu.contact_id = ?
|
|
|]
|
|
(userId, contactId, userContactId)
|
|
where
|
|
toGroupAndMember :: [GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow] -> Maybe (GroupInfo, GroupMember)
|
|
toGroupAndMember [groupInfoRow :. memberRow :. connRow] =
|
|
let groupInfo = toGroupInfo userContactId groupInfoRow
|
|
member = toGroupMember userContactId memberRow
|
|
in Just (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
|
|
toGroupAndMember _ = Nothing
|
|
|
|
getViaGroupContact :: MonadUnliftIO m => SQLiteStore -> User -> GroupMember -> m (Maybe Contact)
|
|
getViaGroupContact st User {userId} GroupMember {groupMemberId} =
|
|
liftIO . withTransaction st $ \db ->
|
|
toContact'
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
ct.contact_id, ct.local_display_name, p.display_name, p.full_name, p.image, ct.via_group, ct.created_at,
|
|
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
|
|
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
|
FROM contacts ct
|
|
JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id
|
|
JOIN connections c ON c.connection_id = (
|
|
SELECT max(cc.connection_id)
|
|
FROM connections cc
|
|
where cc.contact_id = ct.contact_id
|
|
)
|
|
JOIN groups g ON g.group_id = ct.via_group
|
|
JOIN group_members m ON m.group_id = g.group_id AND m.contact_id = ct.contact_id
|
|
WHERE ct.user_id = ? AND m.group_member_id = ?
|
|
|]
|
|
(userId, groupMemberId)
|
|
where
|
|
toContact' :: [(Int64, ContactName, Text, Text, Maybe ImageData, Maybe Int64, UTCTime) :. ConnectionRow] -> Maybe Contact
|
|
toContact' [(contactId, localDisplayName, displayName, fullName, image, viaGroup, createdAt) :. connRow] =
|
|
let profile = Profile {displayName, fullName, image}
|
|
activeConn = toConnection connRow
|
|
in Just Contact {contactId, localDisplayName, profile, activeConn, viaGroup, createdAt}
|
|
toContact' _ = Nothing
|
|
|
|
createSndFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> FilePath -> FileInvitation -> ConnId -> Integer -> m Int64
|
|
createSndFileTransfer st userId Contact {contactId} filePath FileInvitation {fileName, fileSize} acId chunkSize =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
|
|
(userId, contactId, fileName, filePath, fileSize, chunkSize, CIFSSndStored, currentTs, currentTs)
|
|
fileId <- insertedRowId db
|
|
Connection {connId} <- createSndFileConnection_ db userId fileId acId
|
|
let fileStatus = FSNew
|
|
DB.execute
|
|
db
|
|
"INSERT INTO snd_files (file_id, file_status, connection_id, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(fileId, fileStatus, connId, currentTs, currentTs)
|
|
pure fileId
|
|
|
|
createSndFileTransferV2 :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> FilePath -> FileInvitation -> Integer -> m Int64
|
|
createSndFileTransferV2 st userId Contact {contactId} filePath FileInvitation {fileName, fileSize} chunkSize =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
|
|
(userId, contactId, fileName, filePath, fileSize, chunkSize, CIFSSndStored, currentTs, currentTs)
|
|
insertedRowId db
|
|
|
|
createSndFileTransferV2Connection :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> ConnId -> m ()
|
|
createSndFileTransferV2Connection st userId fileId acId =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
Connection {connId} <- createSndFileConnection_ db userId fileId acId
|
|
DB.execute
|
|
db
|
|
"INSERT INTO snd_files (file_id, file_status, connection_id, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(fileId, FSAccepted, connId, currentTs, currentTs)
|
|
|
|
createSndGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupInfo -> [(GroupMember, ConnId, FileInvitation)] -> FilePath -> Integer -> Integer -> m Int64
|
|
createSndGroupFileTransfer st userId GroupInfo {groupId} ms filePath fileSize chunkSize =
|
|
liftIO . withTransaction st $ \db -> do
|
|
let fileName = takeFileName filePath
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
|
|
(userId, groupId, fileName, filePath, fileSize, chunkSize, CIFSSndStored, currentTs, currentTs)
|
|
fileId <- insertedRowId db
|
|
forM_ ms $ \(GroupMember {groupMemberId}, agentConnId, _) -> do
|
|
Connection {connId} <- createSndFileConnection_ db userId fileId agentConnId
|
|
DB.execute
|
|
db
|
|
"INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
|
|
(fileId, FSNew, connId, groupMemberId, currentTs, currentTs)
|
|
pure fileId
|
|
|
|
createSndGroupFileTransferV2 :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> m Int64
|
|
createSndGroupFileTransferV2 st userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize} chunkSize =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
|
|
(userId, groupId, fileName, filePath, fileSize, chunkSize, CIFSSndStored, currentTs, currentTs)
|
|
insertedRowId db
|
|
|
|
createSndGroupFileTransferV2Connection :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> ConnId -> GroupMember -> m ()
|
|
createSndGroupFileTransferV2Connection st userId fileId acId GroupMember {groupMemberId} =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
Connection {connId} <- createSndFileConnection_ db userId fileId acId
|
|
DB.execute
|
|
db
|
|
"INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
|
|
(fileId, FSAccepted, connId, groupMemberId, currentTs, currentTs)
|
|
|
|
updateFileCancelled :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> m ()
|
|
updateFileCancelled st userId fileId =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute db "UPDATE files SET cancelled = 1, updated_at = ? WHERE user_id = ? AND file_id = ?" (currentTs, userId, fileId)
|
|
|
|
updateCIFileStatus :: MsgDirectionI d => MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> CIFileStatus d -> m ()
|
|
updateCIFileStatus st userId fileId ciFileStatus =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute db "UPDATE files SET ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId)
|
|
|
|
getSharedMsgIdByFileId :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m SharedMsgId
|
|
getSharedMsgIdByFileId st userId fileId =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
firstRow fromOnly (SESharedMsgIdNotFoundByFileId fileId) $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT i.shared_msg_id
|
|
FROM chat_items i
|
|
JOIN files f ON f.chat_item_id = i.chat_item_id
|
|
WHERE f.user_id = ? AND f.file_id = ?
|
|
|]
|
|
(userId, fileId)
|
|
|
|
getFileIdBySharedMsgId :: StoreMonad m => SQLiteStore -> Int64 -> UserId -> SharedMsgId -> m Int64
|
|
getFileIdBySharedMsgId st userId contactId sharedMsgId =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT f.file_id
|
|
FROM files f
|
|
JOIN chat_items i ON i.chat_item_id = f.chat_item_id
|
|
WHERE i.user_id = ? AND i.contact_id = ? AND i.shared_msg_id = ?
|
|
|]
|
|
(userId, contactId, sharedMsgId)
|
|
|
|
getGroupFileIdBySharedMsgId :: StoreMonad m => SQLiteStore -> Int64 -> UserId -> SharedMsgId -> m Int64
|
|
getGroupFileIdBySharedMsgId st userId groupId sharedMsgId =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT f.file_id
|
|
FROM files f
|
|
JOIN chat_items i ON i.chat_item_id = f.chat_item_id
|
|
WHERE i.user_id = ? AND i.group_id = ? AND i.shared_msg_id = ?
|
|
|]
|
|
(userId, groupId, sharedMsgId)
|
|
|
|
createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection
|
|
createSndFileConnection_ db userId fileId agentConnId = do
|
|
currentTs <- getCurrentTime
|
|
createConnection_ db userId ConnSndFile (Just fileId) agentConnId Nothing 0 currentTs
|
|
|
|
updateSndFileStatus :: MonadUnliftIO m => SQLiteStore -> SndFileTransfer -> FileStatus -> m ()
|
|
updateSndFileStatus st SndFileTransfer {fileId, connId} status =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute db "UPDATE snd_files SET file_status = ?, updated_at = ? WHERE file_id = ? AND connection_id = ?" (status, currentTs, fileId, connId)
|
|
|
|
createSndFileChunk :: MonadUnliftIO m => SQLiteStore -> SndFileTransfer -> m (Maybe Integer)
|
|
createSndFileChunk st SndFileTransfer {fileId, connId, fileSize, chunkSize} =
|
|
liftIO . withTransaction st $ \db -> do
|
|
chunkNo <- getLastChunkNo db
|
|
insertChunk db chunkNo
|
|
pure chunkNo
|
|
where
|
|
getLastChunkNo db = do
|
|
ns <- DB.query db "SELECT chunk_number FROM snd_file_chunks WHERE file_id = ? AND connection_id = ? AND chunk_sent = 1 ORDER BY chunk_number DESC LIMIT 1" (fileId, connId)
|
|
pure $ case map fromOnly ns of
|
|
[] -> Just 1
|
|
n : _ -> if n * chunkSize >= fileSize then Nothing else Just (n + 1)
|
|
insertChunk db = \case
|
|
Just chunkNo -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT OR REPLACE INTO snd_file_chunks (file_id, connection_id, chunk_number, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(fileId, connId, chunkNo, currentTs, currentTs)
|
|
Nothing -> pure ()
|
|
|
|
updateSndFileChunkMsg :: MonadUnliftIO m => SQLiteStore -> SndFileTransfer -> Integer -> AgentMsgId -> m ()
|
|
updateSndFileChunkMsg st SndFileTransfer {fileId, connId} chunkNo msgId =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE snd_file_chunks
|
|
SET chunk_agent_msg_id = ?, updated_at = ?
|
|
WHERE file_id = ? AND connection_id = ? AND chunk_number = ?
|
|
|]
|
|
(msgId, currentTs, fileId, connId, chunkNo)
|
|
|
|
updateSndFileChunkSent :: MonadUnliftIO m => SQLiteStore -> SndFileTransfer -> AgentMsgId -> m ()
|
|
updateSndFileChunkSent st SndFileTransfer {fileId, connId} msgId =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE snd_file_chunks
|
|
SET chunk_sent = 1, updated_at = ?
|
|
WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id = ?
|
|
|]
|
|
(currentTs, fileId, connId, msgId)
|
|
|
|
deleteSndFileChunks :: MonadUnliftIO m => SQLiteStore -> SndFileTransfer -> m ()
|
|
deleteSndFileChunks st SndFileTransfer {fileId, connId} =
|
|
liftIO . withTransaction st $ \db ->
|
|
DB.execute db "DELETE FROM snd_file_chunks WHERE file_id = ? AND connection_id = ?" (fileId, connId)
|
|
|
|
createRcvFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> FileInvitation -> Integer -> m RcvFileTransfer
|
|
createRcvFileTransfer st userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq} chunkSize =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
|
|
(userId, contactId, fileName, fileSize, chunkSize, CIFSRcvInvitation, currentTs, currentTs)
|
|
fileId <- insertedRowId db
|
|
DB.execute
|
|
db
|
|
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(fileId, FSNew, fileConnReq, currentTs, currentTs)
|
|
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing}
|
|
|
|
createRcvGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> FileInvitation -> Integer -> m RcvFileTransfer
|
|
createRcvGroupFileTransfer st userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq} chunkSize =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
|
|
(userId, groupId, fileName, fileSize, chunkSize, currentTs, currentTs)
|
|
fileId <- insertedRowId db
|
|
DB.execute
|
|
db
|
|
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
|
|
(fileId, FSNew, fileConnReq, groupMemberId, currentTs, currentTs)
|
|
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId}
|
|
|
|
getRcvFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m RcvFileTransfer
|
|
getRcvFileTransfer st userId fileId =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
getRcvFileTransfer_ db userId fileId
|
|
|
|
getRcvFileTransfer_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError RcvFileTransfer)
|
|
getRcvFileTransfer_ db userId fileId =
|
|
rcvFileTransfer
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
|
|
f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
|
|
f.file_path, c.connection_id, c.agent_conn_id
|
|
FROM rcv_files r
|
|
JOIN files f USING (file_id)
|
|
LEFT JOIN connections c ON r.file_id = c.rcv_file_id
|
|
LEFT JOIN contacts cs USING (contact_id)
|
|
LEFT JOIN group_members m USING (group_member_id)
|
|
WHERE f.user_id = ? AND f.file_id = ?
|
|
|]
|
|
(userId, fileId)
|
|
where
|
|
rcvFileTransfer ::
|
|
[(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe AgentConnId)] ->
|
|
Either StoreError RcvFileTransfer
|
|
rcvFileTransfer [(fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_, contactName_, memberName_, filePath_, connId_, agentConnId_)] =
|
|
let fileInv = FileInvitation {fileName, fileSize, fileConnReq}
|
|
fileInfo = (filePath_, connId_, agentConnId_)
|
|
in case contactName_ <|> memberName_ of
|
|
Nothing -> Left $ SERcvFileInvalid fileId
|
|
Just name ->
|
|
case fileStatus' of
|
|
FSNew -> Right RcvFileTransfer {fileId, fileInvitation = fileInv, fileStatus = RFSNew, senderDisplayName = name, chunkSize, cancelled, grpMemberId}
|
|
FSAccepted -> ft name fileInv RFSAccepted fileInfo
|
|
FSConnected -> ft name fileInv RFSConnected fileInfo
|
|
FSComplete -> ft name fileInv RFSComplete fileInfo
|
|
FSCancelled -> ft name fileInv RFSCancelled fileInfo
|
|
where
|
|
ft senderDisplayName fileInvitation rfs = \case
|
|
(Just filePath, Just connId, Just agentConnId) ->
|
|
let fileStatus = rfs RcvFileInfo {filePath, connId, agentConnId}
|
|
in Right RcvFileTransfer {..}
|
|
_ -> Left $ SERcvFileInvalid fileId
|
|
cancelled = fromMaybe False cancelled_
|
|
rcvFileTransfer _ = Left $ SERcvFileNotFound fileId
|
|
|
|
acceptRcvFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> ConnId -> FilePath -> m ()
|
|
acceptRcvFileTransfer st userId fileId agentConnId filePath =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"UPDATE files SET file_path = ?, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?"
|
|
(filePath, CIFSRcvTransfer, currentTs, userId, fileId)
|
|
DB.execute
|
|
db
|
|
"UPDATE rcv_files SET file_status = ?, updated_at = ? WHERE file_id = ?"
|
|
(FSAccepted, currentTs, fileId)
|
|
DB.execute
|
|
db
|
|
"INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
|
|
(agentConnId, ConnJoined, ConnRcvFile, fileId, userId, currentTs, currentTs)
|
|
|
|
updateRcvFileStatus :: MonadUnliftIO m => SQLiteStore -> RcvFileTransfer -> FileStatus -> m ()
|
|
updateRcvFileStatus st RcvFileTransfer {fileId} status =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute db "UPDATE rcv_files SET file_status = ?, updated_at = ? WHERE file_id = ?" (status, currentTs, fileId)
|
|
|
|
createRcvFileChunk :: MonadUnliftIO m => SQLiteStore -> RcvFileTransfer -> Integer -> AgentMsgId -> m RcvChunkStatus
|
|
createRcvFileChunk st RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, chunkSize} chunkNo msgId =
|
|
liftIO . withTransaction st $ \db -> do
|
|
status <- getLastChunkNo db
|
|
unless (status == RcvChunkError) $ do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT OR REPLACE INTO rcv_file_chunks (file_id, chunk_number, chunk_agent_msg_id, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(fileId, chunkNo, msgId, currentTs, currentTs)
|
|
pure status
|
|
where
|
|
getLastChunkNo db = do
|
|
ns <- DB.query db "SELECT chunk_number FROM rcv_file_chunks WHERE file_id = ? ORDER BY chunk_number DESC LIMIT 1" (Only fileId)
|
|
pure $ case map fromOnly ns of
|
|
[]
|
|
| chunkNo == 1 ->
|
|
if chunkSize >= fileSize
|
|
then RcvChunkFinal
|
|
else RcvChunkOk
|
|
| otherwise -> RcvChunkError
|
|
n : _
|
|
| chunkNo == n -> RcvChunkDuplicate
|
|
| chunkNo == n + 1 ->
|
|
let prevSize = n * chunkSize
|
|
in if prevSize >= fileSize
|
|
then RcvChunkError
|
|
else
|
|
if prevSize + chunkSize >= fileSize
|
|
then RcvChunkFinal
|
|
else RcvChunkOk
|
|
| otherwise -> RcvChunkError
|
|
|
|
updatedRcvFileChunkStored :: MonadUnliftIO m => SQLiteStore -> RcvFileTransfer -> Integer -> m ()
|
|
updatedRcvFileChunkStored st RcvFileTransfer {fileId} chunkNo =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE rcv_file_chunks
|
|
SET chunk_stored = 1, updated_at = ?
|
|
WHERE file_id = ? AND chunk_number = ?
|
|
|]
|
|
(currentTs, fileId, chunkNo)
|
|
|
|
deleteRcvFileChunks :: MonadUnliftIO m => SQLiteStore -> RcvFileTransfer -> m ()
|
|
deleteRcvFileChunks st RcvFileTransfer {fileId} =
|
|
liftIO . withTransaction st $ \db ->
|
|
DB.execute db "DELETE FROM rcv_file_chunks WHERE file_id = ?" (Only fileId)
|
|
|
|
updateFileTransferChatItemId :: MonadUnliftIO m => SQLiteStore -> FileTransferId -> ChatItemId -> m ()
|
|
updateFileTransferChatItemId st fileId ciId =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute db "UPDATE files SET chat_item_id = ?, updated_at = ? WHERE file_id = ?" (ciId, currentTs, fileId)
|
|
|
|
getFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m FileTransfer
|
|
getFileTransfer st userId fileId =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
getFileTransfer_ db userId fileId
|
|
|
|
getFileTransferProgress :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m (FileTransfer, [Integer])
|
|
getFileTransferProgress st userId fileId =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
ft <- ExceptT $ getFileTransfer_ db userId fileId
|
|
liftIO $
|
|
(ft,) . map fromOnly <$> case ft of
|
|
FTSnd _ [] -> pure [Only 0]
|
|
FTSnd _ _ -> DB.query db "SELECT COUNT(*) FROM snd_file_chunks WHERE file_id = ? and chunk_sent = 1 GROUP BY connection_id" (Only fileId)
|
|
FTRcv _ -> DB.query db "SELECT COUNT(*) FROM rcv_file_chunks WHERE file_id = ? AND chunk_stored = 1" (Only fileId)
|
|
|
|
getFileTransfer_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError FileTransfer)
|
|
getFileTransfer_ db userId fileId =
|
|
fileTransfer
|
|
=<< DB.query
|
|
db
|
|
[sql|
|
|
SELECT s.file_id, r.file_id
|
|
FROM files f
|
|
LEFT JOIN snd_files s ON s.file_id = f.file_id
|
|
LEFT JOIN rcv_files r ON r.file_id = f.file_id
|
|
WHERE user_id = ? AND f.file_id = ?
|
|
|]
|
|
(userId, fileId)
|
|
where
|
|
fileTransfer :: [(Maybe Int64, Maybe Int64)] -> IO (Either StoreError FileTransfer)
|
|
fileTransfer [(Nothing, Nothing)] = runExceptT $ do
|
|
fileTransferMeta <- ExceptT $ getFileTransferMeta_ db userId fileId
|
|
pure FTSnd {fileTransferMeta, sndFileTransfers = []}
|
|
fileTransfer ((Just _, Nothing) : _) = runExceptT $ do
|
|
fileTransferMeta <- ExceptT $ getFileTransferMeta_ db userId fileId
|
|
sndFileTransfers <- ExceptT $ getSndFileTransfers_ db userId fileId
|
|
pure FTSnd {fileTransferMeta, sndFileTransfers}
|
|
fileTransfer [(Nothing, Just _)] = FTRcv <$$> getRcvFileTransfer_ db userId fileId
|
|
fileTransfer _ = pure . Left $ SEFileNotFound fileId
|
|
|
|
getSndFileTransfers_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError [SndFileTransfer])
|
|
getSndFileTransfers_ db userId fileId =
|
|
sndFileTransfers
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.connection_id, c.agent_conn_id,
|
|
cs.local_display_name, m.local_display_name
|
|
FROM snd_files s
|
|
JOIN files f USING (file_id)
|
|
JOIN connections c USING (connection_id)
|
|
LEFT JOIN contacts cs USING (contact_id)
|
|
LEFT JOIN group_members m USING (group_member_id)
|
|
WHERE f.user_id = ? AND f.file_id = ?
|
|
|]
|
|
(userId, fileId)
|
|
where
|
|
sndFileTransfers :: [(FileStatus, String, Integer, Integer, FilePath, Int64, AgentConnId, Maybe ContactName, Maybe ContactName)] -> Either StoreError [SndFileTransfer]
|
|
sndFileTransfers [] = Left $ SESndFileNotFound fileId
|
|
sndFileTransfers fts = mapM sndFileTransfer fts
|
|
sndFileTransfer (fileStatus, fileName, fileSize, chunkSize, filePath, connId, agentConnId, contactName_, memberName_) =
|
|
case contactName_ <|> memberName_ of
|
|
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId}
|
|
Nothing -> Left $ SESndFileInvalid fileId
|
|
|
|
getFileTransferMeta_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError FileTransferMeta)
|
|
getFileTransferMeta_ db userId fileId =
|
|
firstRow fileTransferMeta (SEFileNotFound fileId) $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT f.file_name, f.file_size, f.chunk_size, f.file_path, f.cancelled
|
|
FROM files f
|
|
WHERE f.user_id = ? AND f.file_id = ?
|
|
|]
|
|
(userId, fileId)
|
|
where
|
|
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe Bool) -> FileTransferMeta
|
|
fileTransferMeta (fileName, fileSize, chunkSize, filePath, cancelled_) =
|
|
FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, cancelled = fromMaybe False cancelled_}
|
|
|
|
createNewSndMessage :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage) -> m SndMessage
|
|
createNewSndMessage st gVar connOrGroupId mkMessage =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
createWithRandomId gVar $ \sharedMsgId -> do
|
|
let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId
|
|
createdAt <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO messages (
|
|
msg_sent, chat_msg_event, msg_body, connection_id, group_id,
|
|
shared_msg_id, shared_msg_id_user, created_at, updated_at
|
|
) VALUES (?,?,?,?,?,?,?,?,?)
|
|
|]
|
|
(MDSnd, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt)
|
|
msgId <- insertedRowId db
|
|
pure SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody}
|
|
where
|
|
(connId_, groupId_) = case connOrGroupId of
|
|
ConnectionId connId -> (Just connId, Nothing)
|
|
GroupId groupId -> (Nothing, Just groupId)
|
|
|
|
createSndMsgDelivery :: MonadUnliftIO m => SQLiteStore -> SndMsgDelivery -> MessageId -> m ()
|
|
createSndMsgDelivery st sndMsgDelivery messageId =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId currentTs
|
|
createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent currentTs
|
|
|
|
createNewMessageAndRcvMsgDelivery :: MonadUnliftIO m => SQLiteStore -> ConnOrGroupId -> NewMessage -> Maybe SharedMsgId -> RcvMsgDelivery -> m RcvMessage
|
|
createNewMessageAndRcvMsgDelivery st connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO messages (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id) VALUES (?,?,?,?,?,?,?,?)"
|
|
(MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_)
|
|
msgId <- insertedRowId db
|
|
DB.execute
|
|
db
|
|
"INSERT INTO msg_deliveries (message_id, connection_id, agent_msg_id, agent_msg_meta, chat_ts, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
|
|
(msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, snd $ broker agentMsgMeta, currentTs, currentTs)
|
|
msgDeliveryId <- insertedRowId db
|
|
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs
|
|
pure RcvMessage {msgId, chatMsgEvent, sharedMsgId_, msgBody}
|
|
where
|
|
(connId_, groupId_) = case connOrGroupId of
|
|
ConnectionId connId' -> (Just connId', Nothing)
|
|
GroupId groupId -> (Nothing, Just groupId)
|
|
|
|
createSndMsgDeliveryEvent :: StoreMonad m => SQLiteStore -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> m ()
|
|
createSndMsgDeliveryEvent st connId agentMsgId sndMsgDeliveryStatus =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
msgDeliveryId <- ExceptT $ getMsgDeliveryId_ db connId agentMsgId
|
|
liftIO $ do
|
|
currentTs <- getCurrentTime
|
|
createMsgDeliveryEvent_ db msgDeliveryId sndMsgDeliveryStatus currentTs
|
|
|
|
createRcvMsgDeliveryEvent :: StoreMonad m => SQLiteStore -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDRcv -> m ()
|
|
createRcvMsgDeliveryEvent st connId agentMsgId rcvMsgDeliveryStatus =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
msgDeliveryId <- ExceptT $ getMsgDeliveryId_ db connId agentMsgId
|
|
liftIO $ do
|
|
currentTs <- getCurrentTime
|
|
createMsgDeliveryEvent_ db msgDeliveryId rcvMsgDeliveryStatus currentTs
|
|
|
|
createSndMsgDelivery_ :: DB.Connection -> SndMsgDelivery -> MessageId -> UTCTime -> IO Int64
|
|
createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId createdAt = do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO msg_deliveries
|
|
(message_id, connection_id, agent_msg_id, agent_msg_meta, chat_ts, created_at, updated_at)
|
|
VALUES (?,?,?,NULL,?,?,?)
|
|
|]
|
|
(messageId, connId, agentMsgId, createdAt, createdAt, createdAt)
|
|
insertedRowId db
|
|
|
|
createMsgDeliveryEvent_ :: DB.Connection -> Int64 -> MsgDeliveryStatus d -> UTCTime -> IO ()
|
|
createMsgDeliveryEvent_ db msgDeliveryId msgDeliveryStatus createdAt = do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO msg_delivery_events
|
|
(msg_delivery_id, delivery_status, created_at, updated_at)
|
|
VALUES (?,?,?,?)
|
|
|]
|
|
(msgDeliveryId, msgDeliveryStatus, createdAt, createdAt)
|
|
|
|
getMsgDeliveryId_ :: DB.Connection -> Int64 -> AgentMsgId -> IO (Either StoreError Int64)
|
|
getMsgDeliveryId_ db connId agentMsgId =
|
|
firstRow fromOnly (SENoMsgDelivery connId agentMsgId) $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT msg_delivery_id
|
|
FROM msg_deliveries m
|
|
WHERE m.connection_id = ? AND m.agent_msg_id = ?
|
|
LIMIT 1
|
|
|]
|
|
(connId, agentMsgId)
|
|
|
|
createPendingGroupMessage :: MonadUnliftIO m => SQLiteStore -> Int64 -> MessageId -> Maybe Int64 -> m ()
|
|
createPendingGroupMessage st groupMemberId messageId introId_ =
|
|
liftIO . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO pending_group_messages
|
|
(group_member_id, message_id, group_member_intro_id, created_at, updated_at) VALUES (?,?,?,?,?)
|
|
|]
|
|
(groupMemberId, messageId, introId_, currentTs, currentTs)
|
|
|
|
getPendingGroupMessages :: MonadUnliftIO m => SQLiteStore -> Int64 -> m [PendingGroupMessage]
|
|
getPendingGroupMessages st groupMemberId =
|
|
liftIO . withTransaction st $ \db ->
|
|
map pendingGroupMessage
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT pgm.message_id, m.chat_msg_event, m.msg_body, pgm.group_member_intro_id
|
|
FROM pending_group_messages pgm
|
|
JOIN messages m USING (message_id)
|
|
WHERE pgm.group_member_id = ?
|
|
ORDER BY pgm.message_id ASC
|
|
|]
|
|
(Only groupMemberId)
|
|
where
|
|
pendingGroupMessage (msgId, cmEventTag, msgBody, introId_) =
|
|
PendingGroupMessage {msgId, cmEventTag, msgBody, introId_}
|
|
|
|
deletePendingGroupMessage :: MonadUnliftIO m => SQLiteStore -> Int64 -> MessageId -> m ()
|
|
deletePendingGroupMessage st groupMemberId messageId =
|
|
liftIO . withTransaction st $ \db ->
|
|
DB.execute db "DELETE FROM pending_group_messages WHERE group_member_id = ? AND message_id = ?" (groupMemberId, messageId)
|
|
|
|
type NewQuoteRow = (Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MemberId)
|
|
|
|
createNewSndChatItem :: MonadUnliftIO m => SQLiteStore -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> UTCTime -> m ChatItemId
|
|
createNewSndChatItem st user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem createdAt =
|
|
liftIO . withTransaction st $ \db ->
|
|
createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow createdAt createdAt
|
|
where
|
|
createdByMsgId = if msgId == 0 then Nothing else Just msgId
|
|
quoteRow :: NewQuoteRow
|
|
quoteRow = case quotedItem of
|
|
Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing)
|
|
Just CIQuote {chatDir, sharedMsgId = quotedSharedMsgId, sentAt, content} ->
|
|
uncurry (quotedSharedMsgId,Just sentAt,Just content,,) $ case chatDir of
|
|
CIQDirectSnd -> (Just True, Nothing)
|
|
CIQDirectRcv -> (Just False, Nothing)
|
|
CIQGroupSnd -> (Just True, Nothing)
|
|
CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId)
|
|
CIQGroupRcv Nothing -> (Just False, Nothing)
|
|
|
|
createNewRcvChatItem :: MonadUnliftIO m => SQLiteStore -> User -> ChatDirection c 'MDRcv -> RcvMessage -> CIContent 'MDRcv -> UTCTime -> UTCTime -> m (ChatItemId, Maybe (CIQuote c))
|
|
createNewRcvChatItem st user chatDirection RcvMessage {msgId, chatMsgEvent, sharedMsgId_} ciContent itemTs createdAt =
|
|
liftIO . withTransaction st $ \db -> do
|
|
ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow itemTs createdAt
|
|
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
|
|
pure (ciId, quotedItem)
|
|
where
|
|
quotedMsg = cmToQuotedMsg chatMsgEvent
|
|
quoteRow :: NewQuoteRow
|
|
quoteRow = case quotedMsg of
|
|
Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing)
|
|
Just QuotedMsg {msgRef = MsgRef {msgId = sharedMsgId, sentAt, sent, memberId}, content} ->
|
|
uncurry (sharedMsgId,Just sentAt,Just content,,) $ case chatDirection of
|
|
CDDirectRcv _ -> (Just $ not sent, Nothing)
|
|
CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ ->
|
|
(Just $ Just userMemberId == memberId, memberId)
|
|
|
|
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> UTCTime -> UTCTime -> IO ChatItemId
|
|
createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow itemTs createdAt = do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO chat_items (
|
|
-- user and IDs
|
|
user_id, created_by_msg_id, contact_id, group_id, group_member_id,
|
|
-- meta
|
|
item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, created_at, updated_at,
|
|
-- quote
|
|
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id
|
|
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
|
|]
|
|
((userId, msgId_) :. idsRow :. itemRow :. quoteRow)
|
|
ciId <- insertedRowId db
|
|
case msgId_ of
|
|
Just msgId -> insertChatItemMessage_ db ciId msgId createdAt
|
|
Nothing -> pure ()
|
|
pure ciId
|
|
where
|
|
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId, UTCTime, UTCTime)
|
|
itemRow = (msgDirection @d, itemTs, ciContent, ciContentToText ciContent, ciStatusNew @d, sharedMsgId, createdAt, createdAt)
|
|
idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64)
|
|
idsRow = case chatDirection of
|
|
CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing)
|
|
CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing)
|
|
CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId)
|
|
CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing)
|
|
|
|
insertChatItemMessage_ :: DB.Connection -> ChatItemId -> MessageId -> UTCTime -> IO ()
|
|
insertChatItemMessage_ db ciId msgId ts = DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (ciId, msgId, ts, ts)
|
|
|
|
getChatItemQuote_ :: DB.Connection -> User -> ChatDirection c 'MDRcv -> QuotedMsg -> IO (CIQuote c)
|
|
getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId}, content} =
|
|
case chatDirection of
|
|
CDDirectRcv Contact {contactId} -> getDirectChatItemQuote_ contactId (not sent)
|
|
CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} sender@GroupMember {memberId = senderMemberId} ->
|
|
case memberId of
|
|
Just mId
|
|
| mId == userMemberId -> (`ciQuote` CIQGroupSnd) <$> getUserGroupChatItemId_ groupId
|
|
| mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender)) <$> getGroupChatItemId_ groupId mId
|
|
| otherwise -> getGroupChatItemQuote_ groupId mId
|
|
_ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing
|
|
where
|
|
ciQuote :: Maybe ChatItemId -> CIQDirection c -> CIQuote c
|
|
ciQuote itemId dir = CIQuote dir itemId msgId sentAt content . parseMaybeMarkdownList $ msgContentText content
|
|
getDirectChatItemQuote_ :: Int64 -> Bool -> IO (CIQuote 'CTDirect)
|
|
getDirectChatItemQuote_ contactId userSent = do
|
|
ciQuoteDirect . listToMaybe . map fromOnly
|
|
<$> DB.query
|
|
db
|
|
"SELECT chat_item_id FROM chat_items WHERE user_id = ? AND contact_id = ? AND shared_msg_id = ? AND item_sent = ?"
|
|
(userId, contactId, msgId, userSent)
|
|
where
|
|
ciQuoteDirect :: Maybe ChatItemId -> CIQuote 'CTDirect
|
|
ciQuoteDirect = (`ciQuote` if userSent then CIQDirectSnd else CIQDirectRcv)
|
|
getUserGroupChatItemId_ :: Int64 -> IO (Maybe ChatItemId)
|
|
getUserGroupChatItemId_ groupId =
|
|
listToMaybe . map fromOnly
|
|
<$> DB.query
|
|
db
|
|
"SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? AND shared_msg_id = ? AND item_sent = ? AND group_member_id IS NULL"
|
|
(userId, groupId, msgId, MDSnd)
|
|
getGroupChatItemId_ :: Int64 -> MemberId -> IO (Maybe ChatItemId)
|
|
getGroupChatItemId_ groupId mId =
|
|
listToMaybe . map fromOnly
|
|
<$> DB.query
|
|
db
|
|
"SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? AND shared_msg_id = ? AND item_sent = ? AND group_member_id = ?"
|
|
(userId, groupId, msgId, MDRcv, mId)
|
|
getGroupChatItemQuote_ :: Int64 -> MemberId -> IO (CIQuote 'CTGroup)
|
|
getGroupChatItemQuote_ groupId mId = do
|
|
ciQuoteGroup
|
|
<$> DB.queryNamed
|
|
db
|
|
[sql|
|
|
SELECT i.chat_item_id,
|
|
-- GroupMember
|
|
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
|
m.member_status, m.invited_by, m.local_display_name, m.contact_id,
|
|
p.display_name, p.full_name, p.image
|
|
FROM group_members m
|
|
JOIN contact_profiles p ON m.contact_profile_id = p.contact_profile_id
|
|
LEFT JOIN contacts c ON m.contact_id = c.contact_id
|
|
LEFT JOIN chat_items i ON i.group_id = m.group_id
|
|
AND m.group_member_id = i.group_member_id
|
|
AND i.shared_msg_id = :msg_id
|
|
WHERE m.user_id = :user_id AND m.group_id = :group_id AND m.member_id = :member_id
|
|
|]
|
|
[":user_id" := userId, ":group_id" := groupId, ":member_id" := mId, ":msg_id" := msgId]
|
|
where
|
|
ciQuoteGroup :: [Only (Maybe ChatItemId) :. GroupMemberRow] -> CIQuote 'CTGroup
|
|
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing
|
|
ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow
|
|
|
|
getChatPreviews :: MonadUnliftIO m => SQLiteStore -> User -> m [AChat]
|
|
getChatPreviews st user =
|
|
liftIO . withTransaction st $ \db -> do
|
|
directChats <- getDirectChatPreviews_ db user
|
|
groupChats <- getGroupChatPreviews_ db user
|
|
cReqChats <- getContactRequestChatPreviews_ db user
|
|
pure $ sortOn (Down . ts) (directChats <> groupChats <> cReqChats)
|
|
where
|
|
ts :: AChat -> UTCTime
|
|
ts (AChat _ Chat {chatItems = ci : _}) = chatItemTs ci
|
|
ts (AChat _ Chat {chatInfo}) = case chatInfo of
|
|
DirectChat Contact {createdAt} -> createdAt
|
|
GroupChat GroupInfo {createdAt} -> createdAt
|
|
ContactRequest UserContactRequest {createdAt} -> createdAt
|
|
|
|
chatItemTs :: CChatItem d -> UTCTime
|
|
chatItemTs (CChatItem _ ChatItem {meta = CIMeta {itemTs}}) = itemTs
|
|
|
|
getDirectChatPreviews_ :: DB.Connection -> User -> IO [AChat]
|
|
getDirectChatPreviews_ db User {userId} = do
|
|
tz <- getCurrentTimeZone
|
|
currentTs <- getCurrentTime
|
|
map (toDirectChatPreview tz currentTs)
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- Contact
|
|
ct.contact_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, ct.created_at,
|
|
-- Connection
|
|
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.conn_status, c.conn_type,
|
|
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at,
|
|
-- ChatStats
|
|
COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0),
|
|
-- ChatItem
|
|
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
|
-- CIFile
|
|
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
|
-- DirectQuote
|
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
|
FROM contacts ct
|
|
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
|
|
JOIN connections c ON c.contact_id = ct.contact_id
|
|
LEFT JOIN (
|
|
SELECT contact_id, MAX(chat_item_id) AS MaxId
|
|
FROM chat_items
|
|
WHERE item_deleted != 1
|
|
GROUP BY contact_id
|
|
) MaxIds ON MaxIds.contact_id = ct.contact_id
|
|
LEFT JOIN chat_items i ON i.contact_id = MaxIds.contact_id
|
|
AND i.chat_item_id = MaxIds.MaxId
|
|
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
|
|
LEFT JOIN (
|
|
SELECT contact_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread
|
|
FROM chat_items
|
|
WHERE item_status = ?
|
|
GROUP BY contact_id
|
|
) ChatStats ON ChatStats.contact_id = ct.contact_id
|
|
LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id
|
|
WHERE ct.user_id = ?
|
|
AND c.connection_id = (
|
|
SELECT cc_connection_id FROM (
|
|
SELECT
|
|
cc.connection_id AS cc_connection_id,
|
|
(CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord
|
|
FROM connections cc
|
|
WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id
|
|
ORDER BY cc_conn_status_ord DESC, cc_connection_id DESC
|
|
LIMIT 1
|
|
)
|
|
)
|
|
ORDER BY i.item_ts DESC
|
|
|]
|
|
(CISRcvNew, userId, ConnReady, ConnSndReady)
|
|
where
|
|
toDirectChatPreview :: TimeZone -> UTCTime -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat
|
|
toDirectChatPreview tz currentTs (contactRow :. connRow :. statsRow :. ciRow_) =
|
|
let contact = toContact $ contactRow :. connRow
|
|
ci_ = toDirectChatItemList tz currentTs ciRow_
|
|
stats = toChatStats statsRow
|
|
in AChat SCTDirect $ Chat (DirectChat contact) ci_ stats
|
|
|
|
getGroupChatPreviews_ :: DB.Connection -> User -> IO [AChat]
|
|
getGroupChatPreviews_ db User {userId, userContactId} = do
|
|
tz <- getCurrentTimeZone
|
|
currentTs <- getCurrentTime
|
|
map (toGroupChatPreview tz currentTs)
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- GroupInfo
|
|
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at,
|
|
-- GroupMember - membership
|
|
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
|
|
mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id,
|
|
pu.display_name, pu.full_name, pu.image,
|
|
-- ChatStats
|
|
COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0),
|
|
-- ChatItem
|
|
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
|
-- CIFile
|
|
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
|
-- Maybe GroupMember - sender
|
|
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
|
m.member_status, m.invited_by, m.local_display_name, m.contact_id,
|
|
p.display_name, p.full_name, p.image,
|
|
-- quoted ChatItem
|
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent,
|
|
-- quoted GroupMember
|
|
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category,
|
|
rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id,
|
|
rp.display_name, rp.full_name, rp.image
|
|
FROM groups g
|
|
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
|
|
JOIN group_members mu ON mu.group_id = g.group_id
|
|
JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id
|
|
LEFT JOIN (
|
|
SELECT group_id, MAX(chat_item_id) AS MaxId
|
|
FROM chat_items
|
|
WHERE item_deleted != 1
|
|
GROUP BY group_id
|
|
) MaxIds ON MaxIds.group_id = g.group_id
|
|
LEFT JOIN chat_items i ON i.group_id = MaxIds.group_id
|
|
AND i.chat_item_id = MaxIds.MaxId
|
|
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
|
|
LEFT JOIN (
|
|
SELECT group_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread
|
|
FROM chat_items
|
|
WHERE item_status = ?
|
|
GROUP BY group_id
|
|
) ChatStats ON ChatStats.group_id = g.group_id
|
|
LEFT JOIN group_members m ON m.group_member_id = i.group_member_id
|
|
LEFT JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
|
LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id
|
|
LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id
|
|
LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id
|
|
WHERE g.user_id = ? AND mu.contact_id = ?
|
|
ORDER BY i.item_ts DESC
|
|
|]
|
|
(CISRcvNew, userId, userContactId)
|
|
where
|
|
toGroupChatPreview :: TimeZone -> UTCTime -> GroupInfoRow :. ChatStatsRow :. MaybeGroupChatItemRow -> AChat
|
|
toGroupChatPreview tz currentTs (groupInfoRow :. statsRow :. ciRow_) =
|
|
let groupInfo = toGroupInfo userContactId groupInfoRow
|
|
ci_ = toGroupChatItemList tz currentTs userContactId ciRow_
|
|
stats = toChatStats statsRow
|
|
in AChat SCTGroup $ Chat (GroupChat groupInfo) ci_ stats
|
|
|
|
getContactRequestChatPreviews_ :: DB.Connection -> User -> IO [AChat]
|
|
getContactRequestChatPreviews_ db User {userId} =
|
|
map toContactRequestChatPreview
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id,
|
|
c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, cr.created_at, cr.xcontact_id
|
|
FROM contact_requests cr
|
|
JOIN connections c USING (user_contact_link_id)
|
|
JOIN contact_profiles p USING (contact_profile_id)
|
|
WHERE cr.user_id = ?
|
|
|]
|
|
(Only userId)
|
|
where
|
|
toContactRequestChatPreview :: ContactRequestRow -> AChat
|
|
toContactRequestChatPreview cReqRow =
|
|
let cReq = toContactRequest cReqRow
|
|
stats = ChatStats {unreadCount = 0, minUnreadItemId = 0}
|
|
in AChat SCTContactRequest $ Chat (ContactRequest cReq) [] stats
|
|
|
|
getDirectChat :: StoreMonad m => SQLiteStore -> User -> Int64 -> ChatPagination -> m (Chat 'CTDirect)
|
|
getDirectChat st user contactId pagination =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
case pagination of
|
|
CPLast count -> getDirectChatLast_ db user contactId count
|
|
CPAfter afterId count -> getDirectChatAfter_ db user contactId afterId count
|
|
CPBefore beforeId count -> getDirectChatBefore_ db user contactId beforeId count
|
|
|
|
getDirectChatLast_ :: DB.Connection -> User -> Int64 -> Int -> ExceptT StoreError IO (Chat 'CTDirect)
|
|
getDirectChatLast_ db User {userId} contactId count = do
|
|
contact <- ExceptT $ getContact_ db userId contactId
|
|
stats <- liftIO $ getDirectChatStats_ db userId contactId
|
|
chatItems <- ExceptT getDirectChatItemsLast_
|
|
pure $ Chat (DirectChat contact) (reverse chatItems) stats
|
|
where
|
|
getDirectChatItemsLast_ :: IO (Either StoreError [CChatItem 'CTDirect])
|
|
getDirectChatItemsLast_ = do
|
|
tz <- getCurrentTimeZone
|
|
currentTs <- getCurrentTime
|
|
mapM (toDirectChatItem tz currentTs)
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- ChatItem
|
|
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
|
-- CIFile
|
|
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
|
-- DirectQuote
|
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
|
FROM chat_items i
|
|
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
|
|
LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id
|
|
WHERE i.user_id = ? AND i.contact_id = ? AND i.item_deleted != 1
|
|
ORDER BY i.chat_item_id DESC
|
|
LIMIT ?
|
|
|]
|
|
(userId, contactId, count)
|
|
|
|
getDirectChatAfter_ :: DB.Connection -> User -> Int64 -> ChatItemId -> Int -> ExceptT StoreError IO (Chat 'CTDirect)
|
|
getDirectChatAfter_ db User {userId} contactId afterChatItemId count = do
|
|
contact <- ExceptT $ getContact_ db userId contactId
|
|
stats <- liftIO $ getDirectChatStats_ db userId contactId
|
|
chatItems <- ExceptT getDirectChatItemsAfter_
|
|
pure $ Chat (DirectChat contact) chatItems stats
|
|
where
|
|
getDirectChatItemsAfter_ :: IO (Either StoreError [CChatItem 'CTDirect])
|
|
getDirectChatItemsAfter_ = do
|
|
tz <- getCurrentTimeZone
|
|
currentTs <- getCurrentTime
|
|
mapM (toDirectChatItem tz currentTs)
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- ChatItem
|
|
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
|
-- CIFile
|
|
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
|
-- DirectQuote
|
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
|
FROM chat_items i
|
|
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
|
|
LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id
|
|
WHERE i.user_id = ? AND i.contact_id = ? AND i.chat_item_id > ? AND i.item_deleted != 1
|
|
ORDER BY i.chat_item_id ASC
|
|
LIMIT ?
|
|
|]
|
|
(userId, contactId, afterChatItemId, count)
|
|
|
|
getDirectChatBefore_ :: DB.Connection -> User -> Int64 -> ChatItemId -> Int -> ExceptT StoreError IO (Chat 'CTDirect)
|
|
getDirectChatBefore_ db User {userId} contactId beforeChatItemId count = do
|
|
contact <- ExceptT $ getContact_ db userId contactId
|
|
stats <- liftIO $ getDirectChatStats_ db userId contactId
|
|
chatItems <- ExceptT getDirectChatItemsBefore_
|
|
pure $ Chat (DirectChat contact) (reverse chatItems) stats
|
|
where
|
|
getDirectChatItemsBefore_ :: IO (Either StoreError [CChatItem 'CTDirect])
|
|
getDirectChatItemsBefore_ = do
|
|
tz <- getCurrentTimeZone
|
|
currentTs <- getCurrentTime
|
|
mapM (toDirectChatItem tz currentTs)
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- ChatItem
|
|
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
|
-- CIFile
|
|
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
|
-- DirectQuote
|
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
|
FROM chat_items i
|
|
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
|
|
LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id
|
|
WHERE i.user_id = ? AND i.contact_id = ? AND i.chat_item_id < ? AND i.item_deleted != 1
|
|
ORDER BY i.chat_item_id DESC
|
|
LIMIT ?
|
|
|]
|
|
(userId, contactId, beforeChatItemId, count)
|
|
|
|
getDirectChatStats_ :: DB.Connection -> UserId -> Int64 -> IO ChatStats
|
|
getDirectChatStats_ db userId contactId =
|
|
toChatStats'
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT COUNT(1), MIN(chat_item_id)
|
|
FROM chat_items
|
|
WHERE user_id = ? AND contact_id = ? AND item_status = ? AND item_deleted != 1
|
|
GROUP BY contact_id
|
|
|]
|
|
(userId, contactId, CISRcvNew)
|
|
where
|
|
toChatStats' :: [ChatStatsRow] -> ChatStats
|
|
toChatStats' [statsRow] = toChatStats statsRow
|
|
toChatStats' _ = ChatStats {unreadCount = 0, minUnreadItemId = 0}
|
|
|
|
getContactIdByName :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m Int64
|
|
getContactIdByName st userId cName =
|
|
liftIOEither . withTransaction st $ \db -> getContactIdByName_ db userId cName
|
|
|
|
getContactIdByName_ :: DB.Connection -> UserId -> ContactName -> IO (Either StoreError Int64)
|
|
getContactIdByName_ db userId cName =
|
|
firstRow fromOnly (SEContactNotFoundByName cName) $
|
|
DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ?" (userId, cName)
|
|
|
|
getContact :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m Contact
|
|
getContact st userId contactId =
|
|
liftIOEither . withTransaction st $ \db -> getContact_ db userId contactId
|
|
|
|
getContact_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError Contact)
|
|
getContact_ db userId contactId =
|
|
join
|
|
<$> firstRow
|
|
toContactOrError
|
|
(SEContactNotFound contactId)
|
|
( DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- Contact
|
|
ct.contact_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, ct.created_at,
|
|
-- Connection
|
|
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.conn_status, c.conn_type,
|
|
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
|
FROM contacts ct
|
|
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
|
|
LEFT JOIN connections c ON c.contact_id = ct.contact_id
|
|
WHERE ct.user_id = ? AND ct.contact_id = ?
|
|
AND c.connection_id = (
|
|
SELECT cc_connection_id FROM (
|
|
SELECT
|
|
cc.connection_id AS cc_connection_id,
|
|
(CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord
|
|
FROM connections cc
|
|
WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id
|
|
ORDER BY cc_conn_status_ord DESC, cc_connection_id DESC
|
|
LIMIT 1
|
|
)
|
|
)
|
|
|]
|
|
(userId, contactId, ConnReady, ConnSndReady)
|
|
)
|
|
|
|
getGroupChat :: StoreMonad m => SQLiteStore -> User -> Int64 -> ChatPagination -> m (Chat 'CTGroup)
|
|
getGroupChat st user groupId pagination =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
case pagination of
|
|
CPLast count -> getGroupChatLast_ db user groupId count
|
|
CPAfter afterId count -> getGroupChatAfter_ db user groupId afterId count
|
|
CPBefore beforeId count -> getGroupChatBefore_ db user groupId beforeId count
|
|
|
|
getGroupChatLast_ :: DB.Connection -> User -> Int64 -> Int -> ExceptT StoreError IO (Chat 'CTGroup)
|
|
getGroupChatLast_ db user@User {userId, userContactId} groupId count = do
|
|
groupInfo <- ExceptT $ getGroupInfo_ db user groupId
|
|
stats <- liftIO $ getGroupChatStats_ db userId groupId
|
|
chatItems <- ExceptT getGroupChatItemsLast_
|
|
pure $ Chat (GroupChat groupInfo) (reverse chatItems) stats
|
|
where
|
|
getGroupChatItemsLast_ :: IO (Either StoreError [CChatItem 'CTGroup])
|
|
getGroupChatItemsLast_ = do
|
|
tz <- getCurrentTimeZone
|
|
currentTs <- getCurrentTime
|
|
mapM (toGroupChatItem tz currentTs userContactId)
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- ChatItem
|
|
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
|
-- CIFile
|
|
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
|
-- GroupMember
|
|
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
|
m.member_status, m.invited_by, m.local_display_name, m.contact_id,
|
|
p.display_name, p.full_name, p.image,
|
|
-- quoted ChatItem
|
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent,
|
|
-- quoted GroupMember
|
|
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category,
|
|
rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id,
|
|
rp.display_name, rp.full_name, rp.image
|
|
FROM chat_items i
|
|
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
|
|
LEFT JOIN group_members m ON m.group_member_id = i.group_member_id
|
|
LEFT JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
|
LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id
|
|
LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id
|
|
LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id
|
|
WHERE i.user_id = ? AND i.group_id = ? AND i.item_deleted != 1
|
|
ORDER BY i.item_ts DESC, i.chat_item_id DESC
|
|
LIMIT ?
|
|
|]
|
|
(userId, groupId, count)
|
|
|
|
getGroupChatAfter_ :: DB.Connection -> User -> Int64 -> ChatItemId -> Int -> ExceptT StoreError IO (Chat 'CTGroup)
|
|
getGroupChatAfter_ db user@User {userId, userContactId} groupId afterChatItemId count = do
|
|
groupInfo <- ExceptT $ getGroupInfo_ db user groupId
|
|
stats <- liftIO $ getGroupChatStats_ db userId groupId
|
|
chatItems <- ExceptT getGroupChatItemsAfter_
|
|
pure $ Chat (GroupChat groupInfo) chatItems stats
|
|
where
|
|
getGroupChatItemsAfter_ :: IO (Either StoreError [CChatItem 'CTGroup])
|
|
getGroupChatItemsAfter_ = do
|
|
tz <- getCurrentTimeZone
|
|
currentTs <- getCurrentTime
|
|
mapM (toGroupChatItem tz currentTs userContactId)
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- ChatItem
|
|
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
|
-- CIFile
|
|
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
|
-- GroupMember
|
|
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
|
m.member_status, m.invited_by, m.local_display_name, m.contact_id,
|
|
p.display_name, p.full_name, p.image,
|
|
-- quoted ChatItem
|
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent,
|
|
-- quoted GroupMember
|
|
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category,
|
|
rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id,
|
|
rp.display_name, rp.full_name, rp.image
|
|
FROM chat_items i
|
|
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
|
|
LEFT JOIN group_members m ON m.group_member_id = i.group_member_id
|
|
LEFT JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
|
LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id
|
|
LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id
|
|
LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id
|
|
WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id > ? AND i.item_deleted != 1
|
|
ORDER BY i.item_ts ASC, i.chat_item_id ASC
|
|
LIMIT ?
|
|
|]
|
|
(userId, groupId, afterChatItemId, count)
|
|
|
|
getGroupChatBefore_ :: DB.Connection -> User -> Int64 -> ChatItemId -> Int -> ExceptT StoreError IO (Chat 'CTGroup)
|
|
getGroupChatBefore_ db user@User {userId, userContactId} groupId beforeChatItemId count = do
|
|
groupInfo <- ExceptT $ getGroupInfo_ db user groupId
|
|
stats <- liftIO $ getGroupChatStats_ db userId groupId
|
|
chatItems <- ExceptT getGroupChatItemsBefore_
|
|
pure $ Chat (GroupChat groupInfo) (reverse chatItems) stats
|
|
where
|
|
getGroupChatItemsBefore_ :: IO (Either StoreError [CChatItem 'CTGroup])
|
|
getGroupChatItemsBefore_ = do
|
|
tz <- getCurrentTimeZone
|
|
currentTs <- getCurrentTime
|
|
mapM (toGroupChatItem tz currentTs userContactId)
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- ChatItem
|
|
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
|
-- CIFile
|
|
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
|
-- GroupMember
|
|
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
|
m.member_status, m.invited_by, m.local_display_name, m.contact_id,
|
|
p.display_name, p.full_name, p.image,
|
|
-- quoted ChatItem
|
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent,
|
|
-- quoted GroupMember
|
|
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category,
|
|
rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id,
|
|
rp.display_name, rp.full_name, rp.image
|
|
FROM chat_items i
|
|
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
|
|
LEFT JOIN group_members m ON m.group_member_id = i.group_member_id
|
|
LEFT JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
|
LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id
|
|
LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id
|
|
LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id
|
|
WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id < ? AND i.item_deleted != 1
|
|
ORDER BY i.item_ts DESC, i.chat_item_id DESC
|
|
LIMIT ?
|
|
|]
|
|
(userId, groupId, beforeChatItemId, count)
|
|
|
|
getGroupChatStats_ :: DB.Connection -> UserId -> Int64 -> IO ChatStats
|
|
getGroupChatStats_ db userId groupId =
|
|
toChatStats'
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT COUNT(1), MIN(chat_item_id)
|
|
FROM chat_items
|
|
WHERE user_id = ? AND group_id = ? AND item_status = ? AND item_deleted != 1
|
|
GROUP BY group_id
|
|
|]
|
|
(userId, groupId, CISRcvNew)
|
|
where
|
|
toChatStats' :: [ChatStatsRow] -> ChatStats
|
|
toChatStats' [statsRow] = toChatStats statsRow
|
|
toChatStats' _ = ChatStats {unreadCount = 0, minUnreadItemId = 0}
|
|
|
|
getGroupInfo :: StoreMonad m => SQLiteStore -> User -> Int64 -> m GroupInfo
|
|
getGroupInfo st user groupId =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
getGroupInfo_ db user groupId
|
|
|
|
getGroupInfo_ :: DB.Connection -> User -> Int64 -> IO (Either StoreError GroupInfo)
|
|
getGroupInfo_ db User {userId, userContactId} groupId =
|
|
firstRow (toGroupInfo userContactId) (SEGroupNotFound groupId) $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- GroupInfo
|
|
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at,
|
|
-- GroupMember - membership
|
|
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
|
|
mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id,
|
|
pu.display_name, pu.full_name, pu.image
|
|
FROM groups g
|
|
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
|
|
JOIN group_members mu ON mu.group_id = g.group_id
|
|
JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id
|
|
WHERE g.group_id = ? AND g.user_id = ? AND mu.contact_id = ?
|
|
|]
|
|
(groupId, userId, userContactId)
|
|
|
|
getGroupIdByName :: StoreMonad m => SQLiteStore -> User -> GroupName -> m Int64
|
|
getGroupIdByName st user gName =
|
|
liftIOEither . withTransaction st $ \db -> getGroupIdByName_ db user gName
|
|
|
|
getGroupIdByName_ :: DB.Connection -> User -> GroupName -> IO (Either StoreError Int64)
|
|
getGroupIdByName_ db User {userId} gName =
|
|
firstRow fromOnly (SEGroupNotFoundByName gName) $
|
|
DB.query db "SELECT group_id FROM groups WHERE user_id = ? AND local_display_name = ?" (userId, gName)
|
|
|
|
getChatItemIdByAgentMsgId :: StoreMonad m => SQLiteStore -> Int64 -> AgentMsgId -> m (Maybe ChatItemId)
|
|
getChatItemIdByAgentMsgId st connId msgId =
|
|
liftIO . withTransaction st $ \db ->
|
|
join . listToMaybe . map fromOnly
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT chat_item_id
|
|
FROM chat_item_messages
|
|
WHERE message_id = (
|
|
SELECT message_id
|
|
FROM msg_deliveries
|
|
WHERE connection_id = ? AND agent_msg_id = ?
|
|
LIMIT 1
|
|
)
|
|
|]
|
|
(connId, msgId)
|
|
|
|
updateDirectChatItemStatus :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> UserId -> Int64 -> ChatItemId -> CIStatus d -> m (ChatItem 'CTDirect d)
|
|
updateDirectChatItemStatus st userId contactId itemId itemStatus =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
ci <- ExceptT $ (correctDir =<<) <$> getDirectChatItem_ db userId contactId itemId
|
|
currentTs <- liftIO getCurrentTime
|
|
liftIO $ DB.execute db "UPDATE chat_items SET item_status = ?, updated_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?" (itemStatus, currentTs, userId, contactId, itemId)
|
|
pure ci {meta = (meta ci) {itemStatus}}
|
|
where
|
|
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
|
|
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
|
|
|
|
updateDirectChatItem :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> UserId -> Int64 -> ChatItemId -> CIContent d -> MessageId -> m (ChatItem 'CTDirect d)
|
|
updateDirectChatItem st userId contactId itemId newContent msgId =
|
|
liftIOEither . withTransaction st $ \db -> updateDirectChatItem_ db userId contactId itemId newContent msgId
|
|
|
|
updateDirectChatItem_ :: forall d. (MsgDirectionI d) => DB.Connection -> UserId -> Int64 -> ChatItemId -> CIContent d -> MessageId -> IO (Either StoreError (ChatItem 'CTDirect d))
|
|
updateDirectChatItem_ db userId contactId itemId newContent msgId = runExceptT $ do
|
|
ci <- ExceptT $ (correctDir =<<) <$> getDirectChatItem_ db userId contactId itemId
|
|
currentTs <- liftIO getCurrentTime
|
|
let newText = ciContentToText newContent
|
|
liftIO $ do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE chat_items
|
|
SET item_content = ?, item_text = ?, item_deleted = 0, item_edited = 1, updated_at = ?
|
|
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
|
|
|]
|
|
(newContent, newText, currentTs, userId, contactId, itemId)
|
|
insertChatItemMessage_ db itemId msgId currentTs
|
|
pure ci {content = newContent, meta = (meta ci) {itemText = newText, itemEdited = True}, formattedText = parseMaybeMarkdownList newText}
|
|
where
|
|
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
|
|
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
|
|
|
|
deleteDirectChatItemInternal :: StoreMonad m => SQLiteStore -> UserId -> Contact -> ChatItemId -> m AChatItem
|
|
deleteDirectChatItemInternal st userId ct itemId =
|
|
liftIOEither . withTransaction st $ \db -> do
|
|
currentTs <- liftIO getCurrentTime
|
|
ci <- deleteDirectChatItem_ db userId ct itemId CIDMInternal True currentTs
|
|
setChatItemMessagesDeleted_ db itemId
|
|
pure ci
|
|
|
|
setChatItemMessagesDeleted_ :: DB.Connection -> ChatItemId -> IO ()
|
|
setChatItemMessagesDeleted_ db itemId =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE messages
|
|
SET chat_msg_event = ?, msg_body = ?
|
|
WHERE message_id IN (
|
|
SELECT message_id
|
|
FROM chat_item_messages
|
|
WHERE chat_item_id = ?
|
|
)
|
|
|]
|
|
(XMsgDeleted_, xMsgDeletedBody, itemId)
|
|
where
|
|
xMsgDeletedBody = strEncode ChatMessage {msgId = Nothing, chatMsgEvent = XMsgDeleted}
|
|
|
|
deleteDirectChatItemRcvBroadcast :: StoreMonad m => SQLiteStore -> UserId -> Contact -> ChatItemId -> MessageId -> m AChatItem
|
|
deleteDirectChatItemRcvBroadcast st userId ct itemId msgId =
|
|
liftIOEither . withTransaction st $ \db -> deleteDirectChatItemBroadcast_ db userId ct itemId False msgId
|
|
|
|
deleteDirectChatItemSndBroadcast :: StoreMonad m => SQLiteStore -> UserId -> Contact -> ChatItemId -> MessageId -> m AChatItem
|
|
deleteDirectChatItemSndBroadcast st userId ct itemId msgId =
|
|
liftIOEither . withTransaction st $ \db -> do
|
|
ci <- deleteDirectChatItemBroadcast_ db userId ct itemId True msgId
|
|
setChatItemMessagesDeleted_ db itemId
|
|
pure ci
|
|
|
|
deleteDirectChatItemBroadcast_ :: DB.Connection -> UserId -> Contact -> ChatItemId -> Bool -> MessageId -> IO (Either StoreError AChatItem)
|
|
deleteDirectChatItemBroadcast_ db userId ct itemId itemDeleted msgId = do
|
|
currentTs <- liftIO getCurrentTime
|
|
insertChatItemMessage_ db itemId msgId currentTs
|
|
deleteDirectChatItem_ db userId ct itemId CIDMBroadcast itemDeleted currentTs
|
|
|
|
deleteDirectChatItem_ :: DB.Connection -> UserId -> Contact -> ChatItemId -> CIDeleteMode -> Bool -> UTCTime -> IO (Either StoreError AChatItem)
|
|
deleteDirectChatItem_ db userId ct@Contact {contactId} itemId mode itemDeleted currentTs = runExceptT $ do
|
|
(CChatItem msgDir ci) <- ExceptT $ getDirectChatItem_ db userId contactId itemId
|
|
let toContent = msgDirToDeletedContent_ msgDir mode
|
|
liftIO $ do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE chat_items
|
|
SET item_content = ?, item_text = ?, item_deleted = ?, updated_at = ?
|
|
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
|
|
|]
|
|
(toContent, toText, itemDeleted, currentTs, userId, contactId, itemId)
|
|
when itemDeleted $ deleteQuote_ db itemId
|
|
pure $ AChatItem SCTDirect msgDir (DirectChat ct) (ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted}, formattedText = Nothing})
|
|
where
|
|
toText = ciDeleteModeToText mode
|
|
|
|
deleteQuote_ :: DB.Connection -> ChatItemId -> IO ()
|
|
deleteQuote_ db itemId =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE chat_items
|
|
SET quoted_shared_msg_id = NULL, quoted_sent_at = NULL, quoted_content = NULL, quoted_sent = NULL, quoted_member_id = NULL
|
|
WHERE chat_item_id = ?
|
|
|]
|
|
(Only itemId)
|
|
|
|
getDirectChatItem :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> ChatItemId -> m (CChatItem 'CTDirect)
|
|
getDirectChatItem st userId contactId itemId =
|
|
liftIOEither . withTransaction st $ \db -> getDirectChatItem_ db userId contactId itemId
|
|
|
|
getDirectChatItemBySharedMsgId :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> SharedMsgId -> m (CChatItem 'CTDirect)
|
|
getDirectChatItemBySharedMsgId st userId contactId sharedMsgId =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
itemId <- ExceptT $ getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId
|
|
liftIOEither $ getDirectChatItem_ db userId contactId itemId
|
|
|
|
getDirectChatItemIdBySharedMsgId_ :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> IO (Either StoreError Int64)
|
|
getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId =
|
|
firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT chat_item_id
|
|
FROM chat_items
|
|
WHERE user_id = ? AND contact_id = ? AND shared_msg_id = ?
|
|
ORDER BY chat_item_id DESC
|
|
LIMIT 1
|
|
|]
|
|
(userId, contactId, sharedMsgId)
|
|
|
|
getDirectChatItem_ :: DB.Connection -> UserId -> Int64 -> ChatItemId -> IO (Either StoreError (CChatItem 'CTDirect))
|
|
getDirectChatItem_ db userId contactId itemId = do
|
|
tz <- getCurrentTimeZone
|
|
currentTs <- getCurrentTime
|
|
join <$> firstRow (toDirectChatItem tz currentTs) (SEChatItemNotFound itemId) getItem
|
|
where
|
|
getItem =
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- ChatItem
|
|
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
|
-- CIFile
|
|
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
|
-- DirectQuote
|
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
|
FROM chat_items i
|
|
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
|
|
LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id
|
|
WHERE i.user_id = ? AND i.contact_id = ? AND i.chat_item_id = ?
|
|
|]
|
|
(userId, contactId, itemId)
|
|
|
|
getDirectChatItemIdByText :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> SMsgDirection d -> Text -> m ChatItemId
|
|
getDirectChatItemIdByText st userId contactId msgDir quotedMsg =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
firstRow fromOnly SEQuotedChatItemNotFound $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT chat_item_id
|
|
FROM chat_items
|
|
WHERE user_id = ? AND contact_id = ? AND item_sent = ? AND item_text like ?
|
|
ORDER BY chat_item_id DESC
|
|
LIMIT 1
|
|
|]
|
|
(userId, contactId, msgDir, quotedMsg <> "%")
|
|
|
|
updateGroupChatItem :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> User -> Int64 -> ChatItemId -> CIContent d -> MessageId -> m (ChatItem 'CTGroup d)
|
|
updateGroupChatItem st user groupId itemId newContent msgId =
|
|
liftIOEither . withTransaction st $ \db -> updateGroupChatItem_ db user groupId itemId newContent msgId
|
|
|
|
updateGroupChatItem_ :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> MessageId -> IO (Either StoreError (ChatItem 'CTGroup d))
|
|
updateGroupChatItem_ db user@User {userId} groupId itemId newContent msgId = runExceptT $ do
|
|
ci <- ExceptT $ (correctDir =<<) <$> getGroupChatItem_ db user groupId itemId
|
|
currentTs <- liftIO getCurrentTime
|
|
let newText = ciContentToText newContent
|
|
liftIO $ do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE chat_items
|
|
SET item_content = ?, item_text = ?, item_deleted = 0, item_edited = 1, updated_at = ?
|
|
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|
|
|]
|
|
(newContent, newText, currentTs, userId, groupId, itemId)
|
|
insertChatItemMessage_ db itemId msgId currentTs
|
|
pure ci {content = newContent, meta = (meta ci) {itemText = newText, itemEdited = True}, formattedText = parseMaybeMarkdownList newText}
|
|
where
|
|
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
|
|
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
|
|
|
|
deleteGroupChatItemInternal :: StoreMonad m => SQLiteStore -> User -> GroupInfo -> ChatItemId -> m AChatItem
|
|
deleteGroupChatItemInternal st user gInfo itemId =
|
|
liftIOEither . withTransaction st $ \db -> do
|
|
currentTs <- liftIO getCurrentTime
|
|
ci <- deleteGroupChatItem_ db user gInfo itemId CIDMInternal True currentTs
|
|
setChatItemMessagesDeleted_ db itemId
|
|
pure ci
|
|
|
|
deleteGroupChatItemRcvBroadcast :: StoreMonad m => SQLiteStore -> User -> GroupInfo -> ChatItemId -> MessageId -> m AChatItem
|
|
deleteGroupChatItemRcvBroadcast st user gInfo itemId msgId =
|
|
liftIOEither . withTransaction st $ \db -> deleteGroupChatItemBroadcast_ db user gInfo itemId False msgId
|
|
|
|
deleteGroupChatItemSndBroadcast :: StoreMonad m => SQLiteStore -> User -> GroupInfo -> ChatItemId -> MessageId -> m AChatItem
|
|
deleteGroupChatItemSndBroadcast st user gInfo itemId msgId =
|
|
liftIOEither . withTransaction st $ \db -> do
|
|
ci <- deleteGroupChatItemBroadcast_ db user gInfo itemId True msgId
|
|
setChatItemMessagesDeleted_ db itemId
|
|
pure ci
|
|
|
|
deleteGroupChatItemBroadcast_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Bool -> MessageId -> IO (Either StoreError AChatItem)
|
|
deleteGroupChatItemBroadcast_ db user gInfo itemId itemDeleted msgId = do
|
|
currentTs <- liftIO getCurrentTime
|
|
insertChatItemMessage_ db itemId msgId currentTs
|
|
deleteGroupChatItem_ db user gInfo itemId CIDMBroadcast itemDeleted currentTs
|
|
|
|
deleteGroupChatItem_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> CIDeleteMode -> Bool -> UTCTime -> IO (Either StoreError AChatItem)
|
|
deleteGroupChatItem_ db user@User {userId} gInfo@GroupInfo {groupId} itemId mode itemDeleted currentTs = runExceptT $ do
|
|
(CChatItem msgDir ci) <- ExceptT $ getGroupChatItem_ db user groupId itemId
|
|
let toContent = msgDirToDeletedContent_ msgDir mode
|
|
liftIO $ do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE chat_items
|
|
SET item_content = ?, item_text = ?, item_deleted = ?, updated_at = ?
|
|
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|
|
|]
|
|
(toContent, toText, itemDeleted, currentTs, userId, groupId, itemId)
|
|
when itemDeleted $ deleteQuote_ db itemId
|
|
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted}, formattedText = Nothing})
|
|
where
|
|
toText = ciDeleteModeToText mode
|
|
|
|
getGroupChatItem :: StoreMonad m => SQLiteStore -> User -> Int64 -> ChatItemId -> m (CChatItem 'CTGroup)
|
|
getGroupChatItem st user groupId itemId =
|
|
liftIOEither . withTransaction st $ \db -> getGroupChatItem_ db user groupId itemId
|
|
|
|
getGroupChatItemBySharedMsgId :: StoreMonad m => SQLiteStore -> User -> Int64 -> SharedMsgId -> m (CChatItem 'CTGroup)
|
|
getGroupChatItemBySharedMsgId st user groupId sharedMsgId =
|
|
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
|
itemId <- ExceptT $ getGroupChatItemIdBySharedMsgId_ db user groupId sharedMsgId
|
|
liftIOEither $ getGroupChatItem_ db user groupId itemId
|
|
|
|
getGroupChatItemIdBySharedMsgId_ :: DB.Connection -> User -> Int64 -> SharedMsgId -> IO (Either StoreError Int64)
|
|
getGroupChatItemIdBySharedMsgId_ db User {userId} groupId sharedMsgId =
|
|
firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT chat_item_id
|
|
FROM chat_items
|
|
WHERE user_id = ? AND group_id = ? AND shared_msg_id = ?
|
|
ORDER BY chat_item_id DESC
|
|
LIMIT 1
|
|
|]
|
|
(userId, groupId, sharedMsgId)
|
|
|
|
getGroupChatItem_ :: DB.Connection -> User -> Int64 -> ChatItemId -> IO (Either StoreError (CChatItem 'CTGroup))
|
|
getGroupChatItem_ db User {userId, userContactId} groupId itemId = do
|
|
tz <- getCurrentTimeZone
|
|
currentTs <- liftIO getCurrentTime
|
|
join <$> firstRow (toGroupChatItem tz currentTs userContactId) (SEChatItemNotFound itemId) getItem
|
|
where
|
|
getItem =
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT
|
|
-- ChatItem
|
|
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at,
|
|
-- CIFile
|
|
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
|
-- GroupMember
|
|
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
|
|
m.member_status, m.invited_by, m.local_display_name, m.contact_id,
|
|
p.display_name, p.full_name, p.image,
|
|
-- quoted ChatItem
|
|
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent,
|
|
-- quoted GroupMember
|
|
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category,
|
|
rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id,
|
|
rp.display_name, rp.full_name, rp.image
|
|
FROM chat_items i
|
|
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
|
|
LEFT JOIN group_members m ON m.group_member_id = i.group_member_id
|
|
LEFT JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
|
LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id
|
|
LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id
|
|
LEFT JOIN contact_profiles rp ON rp.contact_profile_id = rm.contact_profile_id
|
|
WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id = ?
|
|
|]
|
|
(userId, groupId, itemId)
|
|
|
|
getGroupChatItemIdByText :: StoreMonad m => SQLiteStore -> User -> Int64 -> Maybe ContactName -> Text -> m ChatItemId
|
|
getGroupChatItemIdByText st User {userId, localDisplayName = userName} groupId contactName_ quotedMsg =
|
|
liftIOEither . withTransaction st $ \db ->
|
|
firstRow fromOnly SEQuotedChatItemNotFound $ case contactName_ of
|
|
Nothing -> anyMemberChatItem_ db
|
|
Just cName
|
|
| userName == cName -> userChatItem_ db
|
|
| otherwise -> memberChatItem_ db cName
|
|
where
|
|
anyMemberChatItem_ db =
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT chat_item_id
|
|
FROM chat_items
|
|
WHERE user_id = ? AND group_id = ? AND item_text like ?
|
|
ORDER BY chat_item_id DESC
|
|
LIMIT 1
|
|
|]
|
|
(userId, groupId, quotedMsg <> "%")
|
|
userChatItem_ db =
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT chat_item_id
|
|
FROM chat_items
|
|
WHERE user_id = ? AND group_id = ? AND group_member_id IS NULL AND item_text like ?
|
|
ORDER BY chat_item_id DESC
|
|
LIMIT 1
|
|
|]
|
|
(userId, groupId, quotedMsg <> "%")
|
|
memberChatItem_ db cName =
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT i.chat_item_id
|
|
FROM chat_items i
|
|
JOIN group_members m ON m.group_member_id = i.group_member_id
|
|
JOIN contacts c ON c.contact_id = m.contact_id
|
|
WHERE i.user_id = ? AND i.group_id = ? AND c.local_display_name = ? AND i.item_text like ?
|
|
ORDER BY i.chat_item_id DESC
|
|
LIMIT 1
|
|
|]
|
|
(userId, groupId, cName, quotedMsg <> "%")
|
|
|
|
updateDirectChatItemsRead :: (StoreMonad m) => SQLiteStore -> Int64 -> (ChatItemId, ChatItemId) -> m ()
|
|
updateDirectChatItemsRead st contactId (fromItemId, toItemId) = do
|
|
currentTs <- liftIO getCurrentTime
|
|
liftIO . withTransaction st $ \db ->
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE chat_items SET item_status = ?, updated_at = ?
|
|
WHERE contact_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ?
|
|
|]
|
|
(CISRcvRead, currentTs, contactId, fromItemId, toItemId, CISRcvNew)
|
|
|
|
updateGroupChatItemsRead :: (StoreMonad m) => SQLiteStore -> Int64 -> (ChatItemId, ChatItemId) -> m ()
|
|
updateGroupChatItemsRead st groupId (fromItemId, toItemId) = do
|
|
currentTs <- liftIO getCurrentTime
|
|
liftIO . withTransaction st $ \db ->
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE chat_items SET item_status = ?, updated_at = ?
|
|
WHERE group_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ?
|
|
|]
|
|
(CISRcvRead, currentTs, groupId, fromItemId, toItemId, CISRcvNew)
|
|
|
|
type ChatStatsRow = (Int, ChatItemId)
|
|
|
|
toChatStats :: ChatStatsRow -> ChatStats
|
|
toChatStats (unreadCount, minUnreadItemId) = ChatStats {unreadCount, minUnreadItemId}
|
|
|
|
type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe ACIFileStatus)
|
|
|
|
type ChatItemRow = (Int64, ChatItemTs, ACIContent, Text, ACIStatus, Maybe SharedMsgId, Bool, Maybe Bool, UTCTime) :. MaybeCIFIleRow
|
|
|
|
type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe ACIContent, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId, Maybe Bool, Maybe Bool, Maybe UTCTime) :. MaybeCIFIleRow
|
|
|
|
type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool)
|
|
|
|
toDirectQuote :: QuoteRow -> Maybe (CIQuote 'CTDirect)
|
|
toDirectQuote qr@(_, _, _, _, quotedSent) = toQuote qr $ direction <$> quotedSent
|
|
where
|
|
direction sent = if sent then CIQDirectSnd else CIQDirectRcv
|
|
|
|
toQuote :: QuoteRow -> Maybe (CIQDirection c) -> Maybe (CIQuote c)
|
|
toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir =
|
|
CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent)
|
|
|
|
toDirectChatItem :: TimeZone -> UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
|
|
toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. quoteRow) =
|
|
case (itemContent, itemStatus, fileStatus_) of
|
|
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Just (AFS SMDSnd fileStatus)) ->
|
|
Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent (maybeCIFile fileStatus)
|
|
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Nothing) ->
|
|
Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent Nothing
|
|
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just (AFS SMDRcv fileStatus)) ->
|
|
Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent (maybeCIFile fileStatus)
|
|
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Nothing) ->
|
|
Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent Nothing
|
|
_ -> badItem
|
|
where
|
|
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
|
|
maybeCIFile fileStatus =
|
|
case (fileId_, fileName_, fileSize_) of
|
|
(Just fileId, Just fileName, Just fileSize) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus}
|
|
_ -> Nothing
|
|
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect
|
|
cItem d chatDir ciStatus content file =
|
|
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, file}
|
|
badItem = Left $ SEBadChatItem itemId
|
|
ciMeta :: CIContent d -> CIStatus d -> CIMeta d
|
|
ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt
|
|
|
|
toDirectChatItemList :: TimeZone -> UTCTime -> MaybeChatItemRow :. QuoteRow -> [CChatItem 'CTDirect]
|
|
toDirectChatItemList tz currentTs (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt) :. fileRow) :. quoteRow) =
|
|
either (const []) (: []) $ toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt) :. fileRow) :. quoteRow)
|
|
toDirectChatItemList _ _ _ = []
|
|
|
|
type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow
|
|
|
|
type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow
|
|
|
|
toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup)
|
|
toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_
|
|
where
|
|
direction (Just True) _ = Just CIQGroupSnd
|
|
direction (Just False) (Just member) = Just . CIQGroupRcv $ Just member
|
|
direction (Just False) Nothing = Just $ CIQGroupRcv Nothing
|
|
direction _ _ = Nothing
|
|
|
|
toGroupChatItem :: TimeZone -> UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow -> Either StoreError (CChatItem 'CTGroup)
|
|
toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. memberRow_ :. quoteRow :. quotedMemberRow_) = do
|
|
let member_ = toMaybeGroupMember userContactId memberRow_
|
|
let quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_
|
|
case (itemContent, itemStatus, member_, fileStatus_) of
|
|
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Just (AFS SMDSnd fileStatus)) ->
|
|
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ (maybeCIFile fileStatus)
|
|
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Nothing) ->
|
|
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ Nothing
|
|
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Just (AFS SMDRcv fileStatus)) ->
|
|
Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent quotedMember_ (maybeCIFile fileStatus)
|
|
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Nothing) ->
|
|
Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent quotedMember_ Nothing
|
|
_ -> badItem
|
|
where
|
|
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
|
|
maybeCIFile fileStatus =
|
|
case (fileId_, fileName_, fileSize_) of
|
|
(Just fileId, Just fileName, Just fileSize) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus}
|
|
_ -> Nothing
|
|
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe GroupMember -> Maybe (CIFile d) -> CChatItem 'CTGroup
|
|
cItem d chatDir ciStatus content quotedMember_ file =
|
|
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, file}
|
|
badItem = Left $ SEBadChatItem itemId
|
|
ciMeta :: CIContent d -> CIStatus d -> CIMeta d
|
|
ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt
|
|
|
|
toGroupChatItemList :: TimeZone -> UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup]
|
|
toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_) =
|
|
either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_)
|
|
toGroupChatItemList _ _ _ _ = []
|
|
|
|
getSMPServers :: MonadUnliftIO m => SQLiteStore -> User -> m [SMPServer]
|
|
getSMPServers st User {userId} =
|
|
liftIO . withTransaction st $ \db ->
|
|
map toSmpServer
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT host, port, key_hash
|
|
FROM smp_servers
|
|
WHERE user_id = ?;
|
|
|]
|
|
(Only userId)
|
|
where
|
|
toSmpServer :: (String, String, C.KeyHash) -> SMPServer
|
|
toSmpServer (host, port, keyHash) = SMPServer host port keyHash
|
|
|
|
overwriteSMPServers :: StoreMonad m => SQLiteStore -> User -> [SMPServer] -> m ()
|
|
overwriteSMPServers st User {userId} smpServers = do
|
|
liftIOEither . checkConstraint SEUniqueID . withTransaction st $ \db -> do
|
|
currentTs <- getCurrentTime
|
|
DB.execute db "DELETE FROM smp_servers WHERE user_id = ?" (Only userId)
|
|
forM_ smpServers $ \SMPServer {host, port, keyHash} ->
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO smp_servers
|
|
(host, port, key_hash, user_id, created_at, updated_at)
|
|
VALUES (?,?,?,?,?,?)
|
|
|]
|
|
(host, port, keyHash, userId, currentTs, currentTs)
|
|
pure $ Right ()
|
|
|
|
-- | Saves unique local display name based on passed displayName, suffixed with _N if required.
|
|
-- This function should be called inside transaction.
|
|
withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO a) -> IO (Either StoreError a)
|
|
withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreateName` 20)
|
|
where
|
|
getLdnSuffix :: IO Int
|
|
getLdnSuffix =
|
|
maybe 0 ((+ 1) . fromOnly) . listToMaybe
|
|
<$> DB.queryNamed
|
|
db
|
|
[sql|
|
|
SELECT ldn_suffix FROM display_names
|
|
WHERE user_id = :user_id AND ldn_base = :display_name
|
|
ORDER BY ldn_suffix DESC
|
|
LIMIT 1
|
|
|]
|
|
[":user_id" := userId, ":display_name" := displayName]
|
|
tryCreateName :: Int -> Int -> IO (Either StoreError a)
|
|
tryCreateName _ 0 = pure $ Left SEDuplicateName
|
|
tryCreateName ldnSuffix attempts = do
|
|
currentTs <- getCurrentTime
|
|
let ldn = displayName <> (if ldnSuffix == 0 then "" else T.pack $ '_' : show ldnSuffix)
|
|
E.try (insertName ldn currentTs) >>= \case
|
|
Right () -> Right <$> action ldn
|
|
Left e
|
|
| DB.sqlError e == DB.ErrorConstraint -> tryCreateName (ldnSuffix + 1) (attempts - 1)
|
|
| otherwise -> E.throwIO e
|
|
where
|
|
insertName ldn ts =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO display_names
|
|
(local_display_name, ldn_base, ldn_suffix, user_id, created_at, updated_at)
|
|
VALUES (?,?,?,?,?,?)
|
|
|]
|
|
(ldn, displayName, ldnSuffix, userId, ts, ts)
|
|
|
|
createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> IO (Either StoreError a)
|
|
createWithRandomId = createWithRandomBytes 12
|
|
|
|
createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> IO (Either StoreError a)
|
|
createWithRandomBytes size gVar create = tryCreate 3
|
|
where
|
|
tryCreate :: Int -> IO (Either StoreError a)
|
|
tryCreate 0 = pure $ Left SEUniqueID
|
|
tryCreate n = do
|
|
id' <- randomBytes gVar size
|
|
E.try (create id') >>= \case
|
|
Right x -> pure $ Right x
|
|
Left e
|
|
| DB.sqlError e == DB.ErrorConstraint -> tryCreate (n - 1)
|
|
| otherwise -> pure . Left . SEInternalError $ show e
|
|
|
|
randomBytes :: TVar ChaChaDRG -> Int -> IO ByteString
|
|
randomBytes gVar n = B64.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)
|
|
|
|
-- These error type constructors must be added to mobile apps
|
|
data StoreError
|
|
= SEDuplicateName
|
|
| SEContactNotFound {contactId :: Int64}
|
|
| SEContactNotFoundByName {contactName :: ContactName}
|
|
| SEContactNotReady {contactName :: ContactName}
|
|
| SEDuplicateContactLink
|
|
| SEUserContactLinkNotFound
|
|
| SEContactRequestNotFound {contactRequestId :: Int64}
|
|
| SEContactRequestNotFoundByName {contactName :: ContactName}
|
|
| SEGroupNotFound {groupId :: Int64}
|
|
| SEGroupNotFoundByName {groupName :: GroupName}
|
|
| SEGroupWithoutUser
|
|
| SEDuplicateGroupMember
|
|
| SEGroupAlreadyJoined
|
|
| SEGroupInvitationNotFound
|
|
| SESndFileNotFound {fileId :: FileTransferId}
|
|
| SESndFileInvalid {fileId :: FileTransferId}
|
|
| SERcvFileNotFound {fileId :: FileTransferId}
|
|
| SEFileNotFound {fileId :: FileTransferId}
|
|
| SERcvFileInvalid {fileId :: FileTransferId}
|
|
| SESharedMsgIdNotFoundByFileId {fileId :: FileTransferId}
|
|
| SEFileIdNotFoundBySharedMsgId {sharedMsgId :: SharedMsgId}
|
|
| SEConnectionNotFound {agentConnId :: AgentConnId}
|
|
| SEIntroNotFound
|
|
| SEUniqueID
|
|
| SEInternalError {message :: String}
|
|
| SENoMsgDelivery {connId :: Int64, agentMsgId :: AgentMsgId}
|
|
| SEBadChatItem {itemId :: ChatItemId}
|
|
| SEChatItemNotFound {itemId :: ChatItemId}
|
|
| SEQuotedChatItemNotFound
|
|
| SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId}
|
|
deriving (Show, Exception, Generic)
|
|
|
|
instance ToJSON StoreError where
|
|
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SE"
|
|
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SE"
|