{-# 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"