From 4bf5125c5167be175a175293d855c31aed56a743 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 18 Jun 2022 20:06:13 +0100 Subject: [PATCH] core: support combining store functions in one transaction (#740) * refactor store functions (WIP - does not compile yet) * update chat * update simplexmq --- cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- src/Simplex/Chat.hs | 499 +++--- src/Simplex/Chat/Mobile.hs | 2 +- src/Simplex/Chat/Store.hs | 3113 +++++++++++++++++------------------- stack.yaml | 2 +- tests/ChatClient.hs | 4 +- tests/MobileTests.hs | 2 +- 8 files changed, 1712 insertions(+), 1914 deletions(-) diff --git a/cabal.project b/cabal.project index 2b006bd93..c13077743 100644 --- a/cabal.project +++ b/cabal.project @@ -5,7 +5,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: b58523d4a29235c29c56a461edb686ed93bc1e89 + tag: d1db7d6f79b527a689af1807e7d91a92076d2d8c source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 4002a3b2f..5388d80e6 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."b58523d4a29235c29c56a461edb686ed93bc1e89" = "0k8kmk5dil8dny4xzw6k0c97g0m9ql105x870bvy4sdd2ix23var"; + "https://github.com/simplex-chat/simplexmq.git"."d1db7d6f79b527a689af1807e7d91a92076d2d8c" = "1zlp925qq8akv8v846g03czn0yb293vdsgd7vs6g0axs4yx6c9ap"; "https://github.com/simplex-chat/aeson.git"."3eb66f9a68f103b5f1489382aad89f5712a64db7" = "0kilkx59fl6c3qy3kjczqvm8c3f4n3p0bdk9biyflf51ljnzp4yp"; "https://github.com/simplex-chat/haskell-terminal.git"."f708b00009b54890172068f168bf98508ffcd495" = "0zmq7lmfsk8m340g47g5963yba7i88n4afa6z93sg9px5jv1mijj"; "https://github.com/zw3rk/android-support.git"."3c3a5ab0b8b137a072c98d3d0937cbdc96918ddb" = "1r6jyxbim3dsvrmakqfyxbd6ms6miaghpbwyl0sr6dzwpgaprz97"; diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 232e60057..4a6213f90 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -41,6 +41,7 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds) import Data.Time.LocalTime (getCurrentTimeZone, getZonedTime) import Data.Word (Word32) +import qualified Database.SQLite.Simple as DB import Simplex.Chat.Archive import Simplex.Chat.Call import Simplex.Chat.Controller @@ -63,7 +64,7 @@ import Simplex.Messaging.Parsers (base64P, parseAll) import Simplex.Messaging.Protocol (ErrorType (..), MsgBody, MsgFlags (..)) import qualified Simplex.Messaging.Protocol as SMP import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (ifM, tryError, unlessM, whenM, (<$?>)) +import Simplex.Messaging.Util (ifM, liftEitherError, tryError, unlessM, whenM, (<$?>)) import System.Exit (exitFailure, exitSuccess) import System.FilePath (combine, splitExtensions, takeFileName) import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout) @@ -141,7 +142,7 @@ newChatController chatStore user cfg@ChatConfig {agentConfig = aCfg, tbqSize, de Just smpServers' -> pure ss {smp = smpServers'} _ -> case user of Just usr -> do - userSmpServers <- getSMPServers chatStore usr + userSmpServers <- withTransaction chatStore (`getSMPServers` usr) pure ss {smp = fromMaybe defaultSMPServers $ nonEmpty userSmpServers} _ -> pure ss @@ -189,7 +190,7 @@ processChatCommand = \case CreateActiveUser p -> do u <- asks currentUser whenM (isJust <$> readTVarIO u) $ throwChatError CEActiveUserExists - user <- withStore $ \st -> createUser st p True + user <- withStore $ \db -> createUser db p True atomically . writeTVar u $ Just user pure $ CRActiveUser user StartChat -> withUser' $ \user -> @@ -212,16 +213,16 @@ processChatCommand = \case APIExportArchive cfg -> checkChatStopped $ exportArchive cfg $> CRCmdOk APIImportArchive cfg -> checkChatStopped $ importArchive cfg >> setStoreChanged $> CRCmdOk APIDeleteStorage -> checkChatStopped $ deleteStorage >> setStoreChanged $> CRCmdOk - APIGetChats withPCC -> CRApiChats <$> withUser (\user -> withStore $ \st -> getChatPreviews st user withPCC) + APIGetChats withPCC -> CRApiChats <$> withUser (\user -> withStore' $ \db -> getChatPreviews db user withPCC) APIGetChat (ChatRef cType cId) pagination -> withUser $ \user -> case cType of - CTDirect -> CRApiChat . AChat SCTDirect <$> withStore (\st -> getDirectChat st user cId pagination) - CTGroup -> CRApiChat . AChat SCTGroup <$> withStore (\st -> getGroupChat st user cId pagination) + CTDirect -> CRApiChat . AChat SCTDirect <$> withStore (\db -> getDirectChat db user cId pagination) + CTGroup -> CRApiChat . AChat SCTGroup <$> withStore (\db -> getGroupChat db user cId pagination) CTContactRequest -> pure $ chatCmdError "not implemented" CTContactConnection -> pure $ chatCmdError "not supported" APIGetChatItems _pagination -> pure $ chatCmdError "not implemented" APISendMessage (ChatRef cType chatId) (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock $ case cType of CTDirect -> do - ct@Contact {localDisplayName = c} <- withStore $ \st -> getContact st userId chatId + ct@Contact {localDisplayName = c} <- withStore $ \db -> getContact db userId chatId (fileInvitation_, ciFile_) <- unzipMaybe <$> setupSndFileTransfer ct (msgContainer, quotedItem_) <- prepareMsg fileInvitation_ msg <- sendDirectContactMessage ct (XMsgNew msgContainer) @@ -237,7 +238,7 @@ processChatCommand = \case (agentConnId, fileConnReq) <- withAgent (`createConnection` SCMInvitation) let fileName = takeFileName file fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Just fileConnReq} - fileId <- withStore $ \st -> createSndFileTransfer st userId ct file fileInvitation agentConnId chSize + fileId <- withStore' $ \db -> createSndFileTransfer db userId ct file fileInvitation agentConnId chSize let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored} pure $ Just (fileInvitation, ciFile) prepareMsg :: Maybe FileInvitation -> m (MsgContainer, Maybe (CIQuote 'CTDirect)) @@ -245,7 +246,7 @@ processChatCommand = \case Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_), Nothing) Just quotedItemId -> do CChatItem _ ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, content = ciContent, formattedText, file} <- - withStore $ \st -> getDirectChatItem st userId chatId quotedItemId + withStore $ \db -> getDirectChatItem db userId chatId quotedItemId (origQmc, qd, sent) <- quoteData ciContent let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} qmc = quoteContent origQmc file @@ -257,7 +258,7 @@ processChatCommand = \case quoteData (CIRcvMsgContent qmc) = pure (qmc, CIQDirectRcv, False) quoteData _ = throwChatError CEInvalidQuote CTGroup -> do - Group gInfo@GroupInfo {membership, localDisplayName = gName} ms <- withStore $ \st -> getGroup st user chatId + Group gInfo@GroupInfo {membership, localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved (fileInvitation_, ciFile_) <- unzipMaybe <$> setupSndFileTransfer gInfo (msgContainer, quotedItem_) <- prepareMsg fileInvitation_ membership @@ -273,7 +274,7 @@ processChatCommand = \case (fileSize, chSize) <- checkSndFile file let fileName = takeFileName file fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Nothing} - fileId <- withStore $ \st -> createSndGroupFileTransfer st userId gInfo file fileInvitation chSize + fileId <- withStore' $ \db -> createSndGroupFileTransfer db userId gInfo file fileInvitation chSize let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored} pure $ Just (fileInvitation, ciFile) prepareMsg :: Maybe FileInvitation -> GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup)) @@ -281,7 +282,7 @@ processChatCommand = \case Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_), Nothing) Just quotedItemId -> do CChatItem _ ChatItem {chatDir, meta = CIMeta {itemTs, itemSharedMsgId}, content = ciContent, formattedText, file} <- - withStore $ \st -> getGroupChatItem st user chatId quotedItemId + withStore $ \db -> getGroupChatItem db user chatId quotedItemId (origQmc, qd, sent, GroupMember {memberId}) <- quoteData ciContent chatDir membership let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId} qmc = quoteContent origQmc file @@ -318,27 +319,27 @@ processChatCommand = \case unzipMaybe t = (fst <$> t, snd <$> t) APIUpdateChatItem (ChatRef cType chatId) itemId mc -> withUser $ \user@User {userId} -> withChatLock $ case cType of CTDirect -> do - (ct@Contact {contactId, localDisplayName = c}, ci) <- withStore $ \st -> (,) <$> getContact st userId chatId <*> getDirectChatItem st userId chatId itemId + (ct@Contact {contactId, localDisplayName = c}, ci) <- withStore $ \db -> (,) <$> getContact db userId chatId <*> getDirectChatItem db userId chatId itemId case ci of CChatItem SMDSnd ChatItem {meta = CIMeta {itemSharedMsgId}, content = ciContent} -> do case (ciContent, itemSharedMsgId) of (CISndMsgContent _, Just itemSharedMId) -> do SndMessage {msgId} <- sendDirectContactMessage ct (XMsgUpdate itemSharedMId mc) - updCi <- withStore $ \st -> updateDirectChatItem st userId contactId itemId (CISndMsgContent mc) $ Just msgId + updCi <- withStore $ \db -> updateDirectChatItem db userId contactId itemId (CISndMsgContent mc) $ Just msgId setActive $ ActiveC c pure . CRChatItemUpdated $ AChatItem SCTDirect SMDSnd (DirectChat ct) updCi _ -> throwChatError CEInvalidChatItemUpdate CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate CTGroup -> do - Group gInfo@GroupInfo {groupId, localDisplayName = gName, membership} ms <- withStore $ \st -> getGroup st user chatId + Group gInfo@GroupInfo {groupId, localDisplayName = gName, membership} ms <- withStore $ \db -> getGroup db user chatId unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved - ci <- withStore $ \st -> getGroupChatItem st user chatId itemId + ci <- withStore $ \db -> getGroupChatItem db user chatId itemId case ci of CChatItem SMDSnd ChatItem {meta = CIMeta {itemSharedMsgId}, content = ciContent} -> do case (ciContent, itemSharedMsgId) of (CISndMsgContent _, Just itemSharedMId) -> do SndMessage {msgId} <- sendGroupMessage gInfo ms (XMsgUpdate itemSharedMId mc) - updCi <- withStore $ \st -> updateGroupChatItem st user groupId itemId (CISndMsgContent mc) msgId + updCi <- withStore $ \db -> updateGroupChatItem db user groupId itemId (CISndMsgContent mc) msgId setActive $ ActiveG gName pure . CRChatItemUpdated $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) updCi _ -> throwChatError CEInvalidChatItemUpdate @@ -347,33 +348,33 @@ processChatCommand = \case CTContactConnection -> pure $ chatCmdError "not supported" APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user@User {userId} -> withChatLock $ case cType of CTDirect -> do - (ct@Contact {localDisplayName = c}, CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}, file}) <- withStore $ \st -> (,) <$> getContact st userId chatId <*> getDirectChatItem st userId chatId itemId + (ct@Contact {localDisplayName = c}, CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}, file}) <- withStore $ \db -> (,) <$> getContact db userId chatId <*> getDirectChatItem db userId chatId itemId case (mode, msgDir, itemSharedMsgId) of (CIDMInternal, _, _) -> do deleteCIFile user file - toCi <- withStore $ \st -> deleteDirectChatItemLocal st userId ct itemId CIDMInternal + toCi <- withStore $ \db -> deleteDirectChatItemLocal db userId ct itemId CIDMInternal pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do void $ sendDirectContactMessage ct (XMsgDel itemSharedMId) deleteCIFile user file - toCi <- withStore $ \st -> deleteDirectChatItemLocal st userId ct itemId CIDMBroadcast + toCi <- withStore $ \db -> deleteDirectChatItemLocal db userId ct itemId CIDMBroadcast setActive $ ActiveC c pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi (CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete -- TODO for group integrity and pending messages, group items and messages are set to "deleted"; maybe a different workaround is needed CTGroup -> do - Group gInfo@GroupInfo {localDisplayName = gName, membership} ms <- withStore $ \st -> getGroup st user chatId + Group gInfo@GroupInfo {localDisplayName = gName, membership} ms <- withStore $ \db -> getGroup db user chatId unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved - CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}, file} <- withStore $ \st -> getGroupChatItem st user chatId itemId + CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}, file} <- withStore $ \db -> getGroupChatItem db user chatId itemId case (mode, msgDir, itemSharedMsgId) of (CIDMInternal, _, _) -> do deleteCIFile user file - toCi <- withStore $ \st -> deleteGroupChatItemInternal st user gInfo itemId + toCi <- withStore $ \db -> deleteGroupChatItemInternal db user gInfo itemId pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do SndMessage {msgId} <- sendGroupMessage gInfo ms (XMsgDel itemSharedMId) deleteCIFile user file - toCi <- withStore $ \st -> deleteGroupChatItemSndBroadcast st user gInfo itemId msgId + toCi <- withStore $ \db -> deleteGroupChatItemSndBroadcast db user gInfo itemId msgId setActive $ ActiveG gName pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi (CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete @@ -387,81 +388,84 @@ processChatCommand = \case cancelFile user fileInfo withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo APIChatRead (ChatRef cType chatId) fromToIds -> withChatLock $ case cType of - CTDirect -> withStore (\st -> updateDirectChatItemsRead st chatId fromToIds) $> CRCmdOk - CTGroup -> withStore (\st -> updateGroupChatItemsRead st chatId fromToIds) $> CRCmdOk + CTDirect -> withStore' (\db -> updateDirectChatItemsRead db chatId fromToIds) $> CRCmdOk + CTGroup -> withStore' (\db -> updateGroupChatItemsRead db chatId fromToIds) $> CRCmdOk CTContactRequest -> pure $ chatCmdError "not supported" CTContactConnection -> pure $ chatCmdError "not supported" APIDeleteChat (ChatRef cType chatId) -> withUser $ \user@User {userId} -> case cType of CTDirect -> do - ct@Contact {localDisplayName} <- withStore $ \st -> getContact st userId chatId - withStore (\st -> getContactGroupNames st userId ct) >>= \case + ct@Contact {localDisplayName} <- withStore $ \db -> getContact db userId chatId + withStore' (\db -> getContactGroupNames db userId ct) >>= \case [] -> do - filesInfo <- withStore $ \st -> getContactFileInfo st userId ct - conns <- withStore $ \st -> getContactConnections st userId ct + filesInfo <- withStore' $ \db -> getContactFileInfo db userId ct + conns <- withStore $ \db -> getContactConnections db userId ct withChatLock . procCmd $ do forM_ filesInfo $ \fileInfo -> do cancelFile user fileInfo withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo withAgent $ \a -> forM_ conns $ \conn -> deleteConnection a (aConnId conn) `catchError` \(_ :: AgentErrorType) -> pure () - withStore $ \st -> deleteContact st userId ct + -- two functions below are called in separate transactions to prevent crashes on android + -- (possibly, race condition on integrity check?) + withStore' $ \db -> deleteContactConnectionsAndFiles db userId ct + withStore' $ \db -> deleteContact db userId ct unsetActive $ ActiveC localDisplayName pure $ CRContactDeleted ct gs -> throwChatError $ CEContactGroups ct gs CTContactConnection -> withChatLock . procCmd $ do - conn <- withStore $ \st -> getPendingContactConnection st userId chatId + conn <- withStore $ \db -> getPendingContactConnection db userId chatId withAgent $ \a -> deleteConnection a $ aConnId' conn - withStore $ \st -> deletePendingContactConnection st userId chatId + withStore' $ \db -> deletePendingContactConnection db userId chatId pure $ CRContactConnectionDeleted conn CTGroup -> pure $ chatCmdError "not implemented" CTContactRequest -> pure $ chatCmdError "not supported" APIClearChat (ChatRef cType chatId) -> withUser $ \user@User {userId} -> case cType of CTDirect -> do - ct <- withStore $ \st -> getContact st userId chatId - ciIdsAndFileInfo <- withStore $ \st -> getContactChatItemIdsAndFileInfo st user chatId + ct <- withStore $ \db -> getContact db userId chatId + ciIdsAndFileInfo <- withStore' $ \db -> getContactChatItemIdsAndFileInfo db user chatId forM_ ciIdsAndFileInfo $ \(itemId, _, fileInfo_) -> do forM_ fileInfo_ $ \fileInfo -> do cancelFile user fileInfo withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo - void $ withStore $ \st -> deleteDirectChatItemLocal st userId ct itemId CIDMInternal + void $ withStore $ \db -> deleteDirectChatItemLocal db userId ct itemId CIDMInternal ct' <- case ciIdsAndFileInfo of [] -> pure ct _ -> do let (_, lastItemTs, _) = last ciIdsAndFileInfo - withStore (\st -> updateContactTs st user ct lastItemTs) + withStore' $ \db -> updateContactTs db user ct lastItemTs pure (ct :: Contact) {updatedAt = lastItemTs} pure $ CRChatCleared (AChatInfo SCTDirect (DirectChat ct')) CTGroup -> do - gInfo <- withStore $ \st -> getGroupInfo st user chatId - ciIdsAndFileInfo <- withStore $ \st -> getGroupChatItemIdsAndFileInfo st user chatId + gInfo <- withStore $ \db -> getGroupInfo db user chatId + ciIdsAndFileInfo <- withStore' $ \db -> getGroupChatItemIdsAndFileInfo db user chatId forM_ ciIdsAndFileInfo $ \(itemId, _, itemDeleted, fileInfo_) -> unless itemDeleted $ do forM_ fileInfo_ $ \fileInfo -> do cancelFile user fileInfo withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo - void $ withStore $ \st -> deleteGroupChatItemInternal st user gInfo itemId + void $ withStore $ \db -> deleteGroupChatItemInternal db user gInfo itemId gInfo' <- case ciIdsAndFileInfo of [] -> pure gInfo _ -> do let (_, lastItemTs, _, _) = last ciIdsAndFileInfo - withStore (\st -> updateGroupTs st user gInfo lastItemTs) + withStore' $ \db -> updateGroupTs db user gInfo lastItemTs pure (gInfo :: GroupInfo) {updatedAt = lastItemTs} pure $ CRChatCleared (AChatInfo SCTGroup (GroupChat gInfo')) CTContactConnection -> pure $ chatCmdError "not supported" CTContactRequest -> pure $ chatCmdError "not supported" APIAcceptContact connReqId -> withUser $ \user@User {userId} -> withChatLock $ do - cReq <- withStore $ \st -> getContactRequest st userId connReqId + cReq <- withStore $ \db -> getContactRequest db userId connReqId procCmd $ CRAcceptingContactRequest <$> acceptContactRequest user cReq APIRejectContact connReqId -> withUser $ \User {userId} -> withChatLock $ do cReq@UserContactRequest {agentContactConnId = AgentConnId connId, agentInvitationId = AgentInvId invId} <- - withStore $ \st -> - getContactRequest st userId connReqId - `E.finally` deleteContactRequest st userId connReqId + withStore $ \db -> + getContactRequest db userId connReqId + `E.finally` liftIO (deleteContactRequest db userId connReqId) withAgent $ \a -> rejectContact a connId invId pure $ CRContactRequestRejected cReq APISendCallInvitation contactId callType -> withUser $ \user@User {userId} -> do -- party initiating call - ct <- withStore $ \st -> getContact st userId contactId + ct <- withStore $ \db -> getContact db userId contactId calls <- asks currentCalls withChatLock $ do callId <- CallId <$> (asks idsDrg >>= liftIO . (`randomBytes` 16)) @@ -476,14 +480,14 @@ processChatCommand = \case toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci pure CRCmdOk SendCallInvitation cName callType -> withUser $ \User {userId} -> do - contactId <- withStore $ \st -> getContactIdByName st userId cName + contactId <- withStore $ \db -> getContactIdByName db userId cName processChatCommand $ APISendCallInvitation contactId callType APIRejectCall contactId -> -- party accepting call withCurrentCall contactId $ \userId ct Call {chatItemId, callState} -> case callState of CallInvitationReceived {} -> do let aciContent = ACIContent SMDRcv $ CIRcvCall CISCallRejected 0 - withStore $ \st -> updateDirectChatItemsRead st contactId $ Just (chatItemId, chatItemId) + withStore' $ \db -> updateDirectChatItemsRead db contactId $ Just (chatItemId, chatItemId) updateDirectChatItemView userId ct chatItemId aciContent Nothing $> Nothing _ -> throwChatError . CECallState $ callStateTag callState APISendCallOffer contactId WebRTCCallOffer {callType, rtcSession} -> @@ -495,7 +499,7 @@ processChatCommand = \case callState' = CallOfferSent {localCallType = callType, peerCallType, localCallSession = rtcSession, sharedKey} aciContent = ACIContent SMDRcv $ CIRcvCall CISCallAccepted 0 SndMessage {msgId} <- sendDirectContactMessage ct (XCallOffer callId offer) - withStore $ \st -> updateDirectChatItemsRead st contactId $ Just (chatItemId, chatItemId) + withStore' $ \db -> updateDirectChatItemsRead db contactId $ Just (chatItemId, chatItemId) updateDirectChatItemView userId ct chatItemId aciContent $ Just msgId pure $ Just call {callState = callState'} _ -> throwChatError . CECallState $ callStateTag callState @@ -538,9 +542,9 @@ processChatCommand = \case APIVerifyToken token code nonce -> withUser $ \_ -> withAgent (\a -> verifyNtfToken a token code nonce) $> CRCmdOk APIIntervalNofication token interval -> withUser $ \_ -> withAgent (\a -> enableNtfCron a token interval) $> CRCmdOk APIDeleteToken token -> withUser $ \_ -> withAgent (`deleteNtfToken` token) $> CRCmdOk - GetUserSMPServers -> CRUserSMPServers <$> withUser (\user -> withStore (`getSMPServers` user)) + GetUserSMPServers -> CRUserSMPServers <$> withUser (\user -> withStore' (`getSMPServers` user)) SetUserSMPServers smpServers -> withUser $ \user -> withChatLock $ do - withStore $ \st -> overwriteSMPServers st user smpServers + withStore $ \db -> overwriteSMPServers db user smpServers ChatConfig {defaultServers = InitialAgentServers {smp = defaultSMPServers}} <- asks config withAgent $ \a -> setSMPServers a (fromMaybe defaultSMPServers (nonEmpty smpServers)) pure CRCmdOk @@ -548,12 +552,12 @@ processChatCommand = \case Welcome -> withUser $ pure . CRWelcome AddContact -> withUser $ \User {userId} -> withChatLock . procCmd $ do (connId, cReq) <- withAgent (`createConnection` SCMInvitation) - conn <- withStore $ \st -> createDirectConnection st userId connId ConnNew + conn <- withStore' $ \db -> createDirectConnection db userId connId ConnNew toView $ CRNewContactConnection conn pure $ CRInvitation cReq Connect (Just (ACR SCMInvitation cReq)) -> withUser $ \User {userId, profile} -> withChatLock . procCmd $ do connId <- withAgent $ \a -> joinConnection a cReq . directMessage $ XInfo profile - conn <- withStore $ \st -> createDirectConnection st userId connId ConnJoined + conn <- withStore' $ \db -> createDirectConnection db userId connId ConnJoined toView $ CRNewContactConnection conn pure CRSentConfirmation Connect (Just (ACR SCMContact cReq)) -> withUser $ \User {userId, profile} -> @@ -562,39 +566,39 @@ processChatCommand = \case ConnectSimplex -> withUser $ \User {userId, profile} -> connectViaContact userId adminContactReq profile DeleteContact cName -> withUser $ \User {userId} -> do - contactId <- withStore $ \st -> getContactIdByName st userId cName + contactId <- withStore $ \db -> getContactIdByName db userId cName processChatCommand $ APIDeleteChat (ChatRef CTDirect contactId) ClearContact cName -> withUser $ \User {userId} -> do - contactId <- withStore $ \st -> getContactIdByName st userId cName + contactId <- withStore $ \db -> getContactIdByName db userId cName processChatCommand $ APIClearChat (ChatRef CTDirect contactId) - ListContacts -> withUser $ \user -> CRContactsList <$> withStore (`getUserContacts` user) + ListContacts -> withUser $ \user -> CRContactsList <$> withStore' (`getUserContacts` user) CreateMyAddress -> withUser $ \User {userId} -> withChatLock . procCmd $ do (connId, cReq) <- withAgent (`createConnection` SCMContact) - withStore $ \st -> createUserContactLink st userId connId cReq + withStore $ \db -> createUserContactLink db userId connId cReq pure $ CRUserContactLinkCreated cReq DeleteMyAddress -> withUser $ \User {userId} -> withChatLock $ do - conns <- withStore $ \st -> getUserContactLinkConnections st userId + conns <- withStore (`getUserContactLinkConnections` userId) procCmd $ do withAgent $ \a -> forM_ conns $ \conn -> deleteConnection a (aConnId conn) `catchError` \(_ :: AgentErrorType) -> pure () - withStore $ \st -> deleteUserContactLink st userId + withStore' (`deleteUserContactLink` userId) pure CRUserContactLinkDeleted ShowMyAddress -> withUser $ \User {userId} -> uncurry CRUserContactLink <$> withStore (`getUserContactLink` userId) AddressAutoAccept onOff -> withUser $ \User {userId} -> do - uncurry CRUserContactLinkUpdated <$> withStore (\st -> updateUserContactLinkAutoAccept st userId onOff) + uncurry CRUserContactLinkUpdated <$> withStore (\db -> updateUserContactLinkAutoAccept db userId onOff) AcceptContact cName -> withUser $ \User {userId} -> do - connReqId <- withStore $ \st -> getContactRequestIdByName st userId cName + connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName processChatCommand $ APIAcceptContact connReqId RejectContact cName -> withUser $ \User {userId} -> do - connReqId <- withStore $ \st -> getContactRequestIdByName st userId cName + connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName processChatCommand $ APIRejectContact connReqId SendMessage chatName msg -> withUser $ \user -> do chatRef <- getChatRef user chatName let mc = MCText $ safeDecodeUtf8 msg processChatCommand . APISendMessage chatRef $ ComposedMessage Nothing Nothing mc SendMessageBroadcast msg -> withUser $ \user -> do - contacts <- withStore (`getUserContacts` user) + contacts <- withStore' (`getUserContacts` user) withChatLock . procCmd $ do let mc = MCText $ safeDecodeUtf8 msg cts = filter isReady contacts @@ -607,8 +611,8 @@ processChatCommand = \case `catchError` (toView . CRChatError) CRBroadcastSent mc (length cts) <$> liftIO getZonedTime SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \User {userId} -> do - contactId <- withStore $ \st -> getContactIdByName st userId cName - quotedItemId <- withStore $ \st -> getDirectChatItemIdByText st userId contactId msgDir (safeDecodeUtf8 quotedMsg) + contactId <- withStore $ \db -> getContactIdByName db userId cName + quotedItemId <- withStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir (safeDecodeUtf8 quotedMsg) let mc = MCText $ safeDecodeUtf8 msg processChatCommand . APISendMessage (ChatRef CTDirect contactId) $ ComposedMessage Nothing (Just quotedItemId) mc DeleteMessage chatName deletedMsg -> withUser $ \user -> do @@ -622,10 +626,10 @@ processChatCommand = \case processChatCommand $ APIUpdateChatItem chatRef editedItemId mc NewGroup gProfile -> withUser $ \user -> do gVar <- asks idsDrg - CRGroupCreated <$> withStore (\st -> createNewGroup st gVar user gProfile) + CRGroupCreated <$> withStore (\db -> createNewGroup db gVar user gProfile) AddMember gName cName memRole -> withUser $ \user@User {userId} -> withChatLock $ do -- TODO for large groups: no need to load all members to determine if contact is a member - (group, contact) <- withStore $ \st -> (,) <$> getGroupByName st user gName <*> getContactByName st userId cName + (group, contact) <- withStore $ \db -> (,) <$> getGroupByName db user gName <*> getContactByName db userId cName let Group gInfo@GroupInfo {groupId, groupProfile, membership} members = group GroupMember {memberRole = userRole, memberId = userMemberId} = membership when (userRole < GRAdmin || userRole < memRole) $ throwChatError CEGroupUserRole @@ -640,26 +644,26 @@ processChatCommand = \case Nothing -> do gVar <- asks idsDrg (agentConnId, cReq) <- withAgent (`createConnection` SCMInvitation) - GroupMember {memberId} <- withStore $ \st -> createContactMember st gVar user groupId contact memRole agentConnId cReq + GroupMember {memberId} <- withStore $ \db -> createContactMember db gVar user groupId contact memRole agentConnId cReq sendInvitation memberId cReq Just GroupMember {groupMemberId, memberId, memberStatus} | memberStatus == GSMemInvited -> - withStore (\st -> getMemberInvitation st user groupMemberId) >>= \case + withStore' (\db -> getMemberInvitation db user groupMemberId) >>= \case Just cReq -> sendInvitation memberId cReq Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName | otherwise -> throwChatError $ CEGroupDuplicateMember cName JoinGroup gName -> withUser $ \user@User {userId} -> do - ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g} <- withStore $ \st -> getGroupInvitation st user gName + ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g} <- withStore $ \db -> getGroupInvitation db user gName withChatLock . procCmd $ do agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage . XGrpAcpt $ memberId (membership g :: GroupMember) - withStore $ \st -> do - createMemberConnection st userId fromMember agentConnId - updateGroupMemberStatus st userId fromMember GSMemAccepted - updateGroupMemberStatus st userId (membership g) GSMemAccepted + withStore' $ \db -> do + createMemberConnection db userId fromMember agentConnId + updateGroupMemberStatus db userId fromMember GSMemAccepted + updateGroupMemberStatus db userId (membership g) GSMemAccepted pure $ CRUserAcceptedGroupSent g MemberRole _gName _cName _mRole -> throwChatError $ CECommandError "unsupported" RemoveMember gName cName -> withUser $ \user@User {userId} -> do - Group gInfo@GroupInfo {membership} members <- withStore $ \st -> getGroupByName st user gName + Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroupByName db user gName case find ((== cName) . (localDisplayName :: GroupMember -> ContactName)) members of Nothing -> throwChatError $ CEGroupMemberNotFound cName Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus} -> do @@ -668,17 +672,17 @@ processChatCommand = \case withChatLock . procCmd $ do when (mStatus /= GSMemInvited) . void . sendGroupMessage gInfo members $ XGrpMemDel mId deleteMemberConnection m - withStore $ \st -> updateGroupMemberStatus st userId m GSMemRemoved + withStore' $ \db -> updateGroupMemberStatus db userId m GSMemRemoved pure $ CRUserDeletedMember gInfo m LeaveGroup gName -> withUser $ \user@User {userId} -> do - Group gInfo@GroupInfo {membership} members <- withStore $ \st -> getGroupByName st user gName + Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroupByName db user gName withChatLock . procCmd $ do void $ sendGroupMessage gInfo members XGrpLeave mapM_ deleteMemberConnection members - withStore $ \st -> updateGroupMemberStatus st userId membership GSMemLeft + withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft pure $ CRLeftMemberUser gInfo DeleteGroup gName -> withUser $ \user -> do - g@(Group gInfo@GroupInfo {membership} members) <- withStore $ \st -> getGroupByName st user gName + g@(Group gInfo@GroupInfo {membership} members) <- withStore $ \db -> getGroupByName db user gName let s = memberStatus membership canDelete = memberRole (membership :: GroupMember) == GROwner @@ -687,23 +691,23 @@ processChatCommand = \case withChatLock . procCmd $ do when (memberActive membership) . void $ sendGroupMessage gInfo members XGrpDel mapM_ deleteMemberConnection members - withStore $ \st -> deleteGroup st user g + withStore' $ \db -> deleteGroup db user g pure $ CRGroupDeletedUser gInfo ClearGroup gName -> withUser $ \user -> do - groupId <- withStore $ \st -> getGroupIdByName st user gName + groupId <- withStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIClearChat (ChatRef CTGroup groupId) - ListMembers gName -> CRGroupMembers <$> withUser (\user -> withStore (\st -> getGroupByName st user gName)) - ListGroups -> CRGroupsList <$> withUser (\user -> withStore (`getUserGroupDetails` user)) + ListMembers gName -> CRGroupMembers <$> withUser (\user -> withStore (\db -> getGroupByName db user gName)) + ListGroups -> CRGroupsList <$> withUser (\user -> withStore' (`getUserGroupDetails` user)) SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do - groupId <- withStore $ \st -> getGroupIdByName st user gName - quotedItemId <- withStore $ \st -> getGroupChatItemIdByText st user groupId cName (safeDecodeUtf8 quotedMsg) + groupId <- withStore $ \db -> getGroupIdByName db user gName + quotedItemId <- withStore $ \db -> getGroupChatItemIdByText db user groupId cName (safeDecodeUtf8 quotedMsg) let mc = MCText $ safeDecodeUtf8 msg processChatCommand . APISendMessage (ChatRef CTGroup groupId) $ ComposedMessage Nothing (Just quotedItemId) mc LastMessages (Just chatName) count -> withUser $ \user -> do chatRef <- getChatRef user chatName CRLastMessages . aChatItems . chat <$> (processChatCommand . APIGetChat chatRef $ CPLast count) - LastMessages Nothing count -> withUser $ \user -> withStore $ \st -> - CRLastMessages <$> getAllChatItems st user (CPLast count) + LastMessages Nothing count -> withUser $ \user -> withStore $ \db -> + CRLastMessages <$> getAllChatItems db user (CPLast count) SendFile chatName f -> withUser $ \user -> do chatRef <- getChatRef user chatName processChatCommand . APISendMessage chatRef $ ComposedMessage (Just f) Nothing (MCFile "") @@ -718,7 +722,7 @@ processChatCommand = \case ForwardImage chatName fileId -> forwardFile chatName fileId SendImage ReceiveFile fileId filePath_ -> withUser $ \user -> withChatLock . procCmd $ do - ft <- withStore $ \st -> getRcvFileTransfer st user fileId + ft <- withStore $ \db -> getRcvFileTransfer db user fileId (CRRcvFileAccepted <$> acceptFileReceive user ft filePath_) `catchError` processError ft where processError ft = \case @@ -728,27 +732,27 @@ processChatCommand = \case e -> throwError e CancelFile fileId -> withUser $ \user@User {userId} -> withChatLock . procCmd $ - withStore (\st -> getFileTransfer st user fileId) >>= \case + withStore (\db -> getFileTransfer db user fileId) >>= \case FTSnd ftm@FileTransferMeta {cancelled} fts -> do unless cancelled $ do cancelSndFile user ftm fts - sharedMsgId <- withStore $ \st -> getSharedMsgIdByFileId st userId fileId + sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId void $ - withStore (\st -> getChatRefByFileId st user fileId) >>= \case + withStore (\db -> getChatRefByFileId db user fileId) >>= \case ChatRef CTDirect contactId -> do - contact <- withStore $ \st -> getContact st userId contactId + contact <- withStore $ \db -> getContact db userId contactId sendDirectContactMessage contact $ XFileCancel sharedMsgId ChatRef CTGroup groupId -> do - Group gInfo ms <- withStore $ \st -> getGroup st user groupId + Group gInfo ms <- withStore $ \db -> getGroup db user groupId sendGroupMessage gInfo ms $ XFileCancel sharedMsgId _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" - ci <- withStore $ \st -> getChatItemByFileId st user fileId + ci <- withStore $ \db -> getChatItemByFileId db user fileId pure $ CRSndGroupFileCancelled ci ftm fts FTRcv ftr@RcvFileTransfer {cancelled} -> do unless cancelled $ cancelRcvFileTransfer user ftr pure $ CRRcvFileCancelled ftr FileStatus fileId -> - CRFileTransferStatus <$> withUser (\user -> withStore $ \st -> getFileTransferProgress st user fileId) + CRFileTransferStatus <$> withUser (\user -> withStore $ \db -> getFileTransferProgress db user fileId) ShowProfile -> withUser $ \User {profile} -> pure $ CRUserProfile profile UpdateProfile displayName fullName -> withUser $ \user@User {profile} -> do let p = (profile :: Profile) {displayName = displayName, fullName = fullName} @@ -778,8 +782,8 @@ processChatCommand = \case getChatRef :: User -> ChatName -> m ChatRef getChatRef user@User {userId} (ChatName cType name) = ChatRef cType <$> case cType of - CTDirect -> withStore $ \st -> getContactIdByName st userId name - CTGroup -> withStore $ \st -> getGroupIdByName st user name + CTDirect -> withStore $ \db -> getContactIdByName db userId name + CTGroup -> withStore $ \db -> getGroupIdByName db user name _ -> throwChatError $ CECommandError "not supported" checkChatStopped :: m ChatResponse -> m ChatResponse checkChatStopped a = asks agentAsync >>= readTVarIO >>= maybe a (const $ throwChatError CEChatNotStopped) @@ -787,19 +791,19 @@ processChatCommand = \case setStoreChanged = asks chatStoreChanged >>= atomically . (`writeTVar` True) getSentChatItemIdByText :: User -> ChatRef -> ByteString -> m Int64 getSentChatItemIdByText user@User {userId, localDisplayName} (ChatRef cType cId) msg = case cType of - CTDirect -> withStore $ \st -> getDirectChatItemIdByText st userId cId SMDSnd (safeDecodeUtf8 msg) - CTGroup -> withStore $ \st -> getGroupChatItemIdByText st user cId (Just localDisplayName) (safeDecodeUtf8 msg) + CTDirect -> withStore $ \db -> getDirectChatItemIdByText db userId cId SMDSnd (safeDecodeUtf8 msg) + CTGroup -> withStore $ \db -> getGroupChatItemIdByText db user cId (Just localDisplayName) (safeDecodeUtf8 msg) _ -> throwChatError $ CECommandError "not supported" connectViaContact :: UserId -> ConnectionRequestUri 'CMContact -> Profile -> m ChatResponse connectViaContact userId cReq profile = withChatLock $ do let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq - withStore (\st -> getConnReqContactXContactId st userId cReqHash) >>= \case + withStore' (\db -> getConnReqContactXContactId db userId cReqHash) >>= \case (Just contact, _) -> pure $ CRContactAlreadyExists contact (_, xContactId_) -> procCmd $ do let randomXContactId = XContactId <$> (asks idsDrg >>= liftIO . (`randomBytes` 16)) xContactId <- maybe randomXContactId pure xContactId_ connId <- withAgent $ \a -> joinConnection a cReq $ directMessage (XContact profile $ Just xContactId) - conn <- withStore $ \st -> createConnReqConnection st userId connId cReqHash xContactId + conn <- withStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId toView $ CRNewContactConnection conn pure CRSentInvitation contactMember :: Contact -> [GroupMember] -> Maybe GroupMember @@ -815,10 +819,10 @@ processChatCommand = \case updateProfile user@User {profile = p} p'@Profile {displayName} | p' == p = pure CRUserProfileNoChange | otherwise = do - withStore $ \st -> updateUserProfile st user p' + withStore $ \db -> updateUserProfile db user p' let user' = (user :: User) {localDisplayName = displayName, profile = p'} asks currentUser >>= atomically . (`writeTVar` Just user') - contacts <- filter isReady <$> withStore (`getUserContacts` user) + contacts <- filter isReady <$> withStore' (`getUserContacts` user) withChatLock . procCmd $ do forM_ contacts $ \ct -> void (sendDirectContactMessage ct $ XInfo p') `catchError` (toView . CRChatError) @@ -841,14 +845,14 @@ processChatCommand = \case unless (ciFileEnded status) $ case dir of SMDSnd -> do - (ftm@FileTransferMeta {cancelled}, fts) <- withStore (\st -> getSndFileTransfer st user fileId) + (ftm@FileTransferMeta {cancelled}, fts) <- withStore (\db -> getSndFileTransfer db user fileId) unless cancelled $ cancelSndFile user ftm fts SMDRcv -> do - ft@RcvFileTransfer {cancelled} <- withStore (\st -> getRcvFileTransfer st user fileId) + ft@RcvFileTransfer {cancelled} <- withStore (\db -> getRcvFileTransfer db user fileId) unless cancelled $ cancelRcvFileTransfer user ft withCurrentCall :: ContactId -> (UserId -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse withCurrentCall ctId action = withUser $ \User {userId} -> do - ct <- withStore $ \st -> getContact st userId ctId + ct <- withStore $ \db -> getContact db userId ctId calls <- asks currentCalls withChatLock $ atomically (TM.lookup ctId calls) >>= \case @@ -863,7 +867,7 @@ processChatCommand = \case | otherwise -> throwChatError $ CECallContact contactId forwardFile :: ChatName -> FileTransferId -> (ChatName -> FilePath -> ChatCommand) -> m ChatResponse forwardFile chatName fileId sendCommand = withUser $ \user -> do - withStore (\st -> getFileTransfer st user fileId) >>= \case + withStore (\db -> getFileTransfer db user fileId) >>= \case FTRcv RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}} -> forward filePath FTSnd {fileTransferMeta = FileTransferMeta {filePath}} -> forward filePath _ -> throwChatError CEFileNotReceived {fileId} @@ -877,13 +881,13 @@ updateCallItemStatus userId ct Call {chatItemId} receivedStatus msgId_ = do updateDirectChatItemView :: ChatMonad m => UserId -> Contact -> ChatItemId -> ACIContent -> Maybe MessageId -> m () updateDirectChatItemView userId ct@Contact {contactId} chatItemId (ACIContent msgDir ciContent) msgId_ = do - updCi <- withStore $ \st -> updateDirectChatItem st userId contactId chatItemId ciContent msgId_ + updCi <- withStore $ \db -> updateDirectChatItem db userId contactId chatItemId ciContent msgId_ toView . CRChatItemUpdated $ AChatItem SCTDirect msgDir (DirectChat ct) updCi callStatusItemContent :: ChatMonad m => UserId -> Contact -> ChatItemId -> WebRTCCallStatus -> m (Maybe ACIContent) callStatusItemContent userId Contact {contactId} chatItemId receivedStatus = do CChatItem msgDir ChatItem {meta = CIMeta {updatedAt}, content} <- - withStore $ \st -> getDirectChatItem st userId contactId chatItemId + withStore $ \db -> getDirectChatItem db userId contactId chatItemId ts <- liftIO getCurrentTime let callDuration :: Int = nominalDiffTimeToSeconds (ts `diffUTCTime` updatedAt) `div'` 1 callStatus = case content of @@ -927,20 +931,20 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = F tryError (withAgent $ \a -> joinConnection a connReq . directMessage $ XFileAcpt fName) >>= \case Right agentConnId -> do filePath <- getRcvFilePath filePath_ fName - withStore $ \st -> acceptRcvFileTransfer st user fileId agentConnId ConnJoined filePath + withStore $ \db -> acceptRcvFileTransfer db user fileId agentConnId ConnJoined filePath Left e -> throwError e -- group file protocol Nothing -> case grpMemberId of Nothing -> throwChatError $ CEFileInternal "group member not found for file transfer" Just memId -> do - (GroupInfo {groupId}, GroupMember {activeConn}) <- withStore $ \st -> getGroupAndMember st user memId + (GroupInfo {groupId}, GroupMember {activeConn}) <- withStore $ \db -> getGroupAndMember db user memId case activeConn of Just conn -> do - sharedMsgId <- withStore $ \st -> getSharedMsgIdByFileId st userId fileId + sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId (agentConnId, fileInvConnReq) <- withAgent (`createConnection` SCMInvitation) filePath <- getRcvFilePath filePath_ fName - ci <- withStore $ \st -> acceptRcvFileTransfer st user fileId agentConnId ConnNew filePath + ci <- withStore $ \db -> acceptRcvFileTransfer db user fileId agentConnId ConnNew filePath void $ sendDirectMessage conn (XFileAcptInv sharedMsgId fileInvConnReq fName) (GroupId groupId) pure ci _ -> throwChatError $ CEFileInternal "member connection not active" @@ -986,7 +990,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = F acceptContactRequest :: ChatMonad m => User -> UserContactRequest -> m Contact acceptContactRequest User {userId, profile} UserContactRequest {agentInvitationId = AgentInvId invId, localDisplayName = cName, profileId, profile = p, xContactId} = do connId <- withAgent $ \a -> acceptContact a invId . directMessage $ XInfo profile - withStore $ \st -> createAcceptedContact st userId connId cName profileId p xContactId + withStore' $ \db -> createAcceptedContact db userId connId cName profileId p xContactId agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => User -> m () agentSubscriber user = do @@ -1016,13 +1020,13 @@ subscribeUserConnections agentSubscribe user@User {userId} = do where catchErr a = a `catchError` \_ -> pure () subscribeContacts n ce = do - contacts <- withStore (`getUserContacts` user) + contacts <- withStore' (`getUserContacts` user) toView . CRContactSubSummary =<< pooledForConcurrentlyN n contacts (\ct -> ContactSubStatus ct <$> subscribeContact ce ct) subscribeContact ce ct = (subscribe (contactConnId ct) $> Nothing) `catchError` (\e -> when ce (toView $ CRContactSubError ct e) $> Just e) subscribeGroups n ce = do - groups <- withStore (`getUserGroups` user) + groups <- withStore' (`getUserGroups` user) toView . CRMemberSubErrors . mconcat =<< forM groups (subscribeGroup n ce) subscribeGroup n ce (Group g@GroupInfo {membership} members) = do let connectedMembers = mapMaybe (\m -> (m,) <$> memberConnId m) members @@ -1043,9 +1047,9 @@ subscribeUserConnections agentSubscribe user@User {userId} = do toView $ CRGroupSubscribed g pure $ mapMaybe (\(m, e) -> (Just . MemberSubError m) =<< e) ms subscribeFiles n = do - sndFileTransfers <- withStore (`getLiveSndFileTransfers` user) + sndFileTransfers <- withStore' (`getLiveSndFileTransfers` user) pooledForConcurrentlyN_ n sndFileTransfers $ \sft -> subscribeSndFile sft - rcvFileTransfers <- withStore (`getLiveRcvFileTransfers` user) + rcvFileTransfers <- withStore' (`getLiveRcvFileTransfers` user) pooledForConcurrentlyN_ n rcvFileTransfers $ \rft -> subscribeRcvFile rft where subscribeSndFile ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId cId} = do @@ -1066,7 +1070,7 @@ subscribeUserConnections agentSubscribe user@User {userId} = do resume RcvFileInfo {agentConnId = AgentConnId cId} = subscribe cId `catchError` (toView . CRRcvFileSubError ft) subscribePendingConnections n = do - cs <- withStore (`getPendingConnections` user) + cs <- withStore' (`getPendingConnections` user) summary <- pooledForConcurrentlyN n cs $ \Connection {agentConnId = acId@(AgentConnId cId)} -> PendingSubStatus acId <$> ((subscribe cId $> Nothing) `catchError` (pure . Just)) toView $ CRPendingSubSummary summary @@ -1087,11 +1091,11 @@ processAgentMessage (Just User {userId}) "" agentMessage = case agentMessage of _ -> pure () where serverEvent srv@SMP.ProtocolServer {host, port} conns event str = do - cs <- withStore $ \st -> getConnectionsContacts st userId conns + cs <- withStore' $ \db -> getConnectionsContacts db userId conns toView $ event srv cs showToast ("server " <> str) (safeDecodeUtf8 . strEncode $ SrvLoc host port) processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage = - (withStore (\st -> getConnectionEntity st user agentConnId) >>= updateConnStatus) >>= \case + (withStore (\db -> getConnectionEntity db user agentConnId) >>= updateConnStatus) >>= \case RcvDirectMsgConnection conn contact_ -> processDirectMessage agentMessage conn contact_ RcvGroupMsgConnection conn gInfo m -> @@ -1107,7 +1111,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage updateConnStatus acEntity = case agentMsgConnStatus agentMessage of Just connStatus -> do let conn = (entityConnection acEntity) {connStatus} - withStore $ \st -> updateConnectionStatus st conn connStatus + withStore' $ \db -> updateConnectionStatus db conn connStatus pure $ updateEntityConnStatus acEntity connStatus Nothing -> pure acEntity @@ -1187,7 +1191,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage XOk -> pure () _ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok" CON -> - withStore (\st -> getViaGroupMember st user ct) >>= \case + withStore' (\db -> getViaGroupMember db user ct) >>= \case Nothing -> do toView $ CRContactConnected ct setActive $ ActiveC c @@ -1198,9 +1202,9 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage when (memberCategory m == GCPreMember) $ probeMatchingContacts ct SENT msgId -> do sentMsgDeliveryEvent conn msgId - withStore (\st -> getDirectChatItemByAgentMsgId st userId contactId connId msgId) >>= \case + withStore' (\db -> getDirectChatItemByAgentMsgId db userId contactId connId msgId) >>= \case Just (CChatItem SMDSnd ci) -> do - chatItem <- withStore $ \st -> updateDirectChatItemStatus st userId contactId (chatItemId' ci) CISSndSent + chatItem <- withStore $ \db -> updateDirectChatItemStatus db userId contactId (chatItemId' ci) CISSndSent toView $ CRChatItemStatusUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem) _ -> pure () END -> do @@ -1209,11 +1213,11 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage unsetActive $ ActiveC c -- TODO print errors MERR msgId err -> do - chatItemId_ <- withStore $ \st -> getChatItemIdByAgentMsgId st connId msgId + chatItemId_ <- withStore' $ \db -> getChatItemIdByAgentMsgId db connId msgId case chatItemId_ of Nothing -> pure () Just chatItemId -> do - chatItem <- withStore $ \st -> updateDirectChatItemStatus st userId contactId chatItemId (agentErrToItemStatus err) + chatItem <- withStore $ \db -> updateDirectChatItemStatus db userId contactId chatItemId (agentErrToItemStatus err) toView $ CRChatItemStatusUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem) ERR _ -> pure () -- TODO add debugging output @@ -1228,7 +1232,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage case chatMsgEvent of XGrpAcpt memId | sameMemberId memId m -> do - withStore $ \st -> updateGroupMemberStatus st userId m GSMemAccepted + withStore' $ \db -> updateGroupMemberStatus db userId m GSMemAccepted allowAgentConnection conn confId XOk | otherwise -> messageError "x.grp.acpt: memberId is different from expected" _ -> messageError "CONF from invited member must have x.grp.acpt" @@ -1252,11 +1256,11 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage _ -> messageError "INFO from member must have x.grp.mem.info" pure () CON -> do - members <- withStore $ \st -> getGroupMembers st user gInfo - withStore $ \st -> do - updateGroupMemberStatus st userId m GSMemConnected + members <- withStore' $ \db -> getGroupMembers db user gInfo + withStore' $ \db -> do + updateGroupMemberStatus db userId m GSMemConnected unless (memberActive membership) $ - updateGroupMemberStatus st userId membership GSMemConnected + updateGroupMemberStatus db userId membership GSMemConnected sendPendingGroupMessages m conn case memberCategory m of GCHostMember -> do @@ -1267,15 +1271,15 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage toView $ CRJoinedGroupMember gInfo m setActive $ ActiveG gName showToast ("#" <> gName) $ "member " <> localDisplayName (m :: GroupMember) <> " is connected" - intros <- withStore $ \st -> createIntroductions st members m + intros <- withStore' $ \db -> createIntroductions db members m void . sendGroupMessage gInfo members . XGrpMemNew $ memberInfo m forM_ intros $ \intro@GroupMemberIntro {introId} -> do void $ sendDirectMessage conn (XGrpMemIntro . memberInfo $ reMember intro) (GroupId groupId) - withStore $ \st -> updateIntroStatus st introId GMIntroSent + withStore' $ \db -> updateIntroStatus db introId GMIntroSent _ -> do -- TODO send probe and decide whether to use existing contact connection or the new contact connection -- TODO notify member who forwarded introduction - question - where it is stored? There is via_contact but probably there should be via_member in group_members table - withStore (\st -> getViaGroupContact st user m) >>= \case + withStore' (\db -> getViaGroupContact db user m) >>= \case Nothing -> do notifyMemberConnected gInfo m messageError "implementation error: connected member does not have contact" @@ -1322,24 +1326,24 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage -- TODO save XFileAcpt message XFileAcpt name | name == fileName -> do - withStore $ \st -> updateSndFileStatus st ft FSAccepted + withStore' $ \db -> updateSndFileStatus db ft FSAccepted allowAgentConnection conn confId XOk | otherwise -> messageError "x.file.acpt: fileName is different from expected" _ -> messageError "CONF from file connection must have x.file.acpt" CON -> do - ci <- withStore $ \st -> do - updateSndFileStatus st ft FSConnected - updateDirectCIFileStatus st user fileId CIFSSndTransfer + ci <- withStore $ \db -> do + liftIO $ updateSndFileStatus db ft FSConnected + updateDirectCIFileStatus db user fileId CIFSSndTransfer toView $ CRSndFileStart ci ft sendFileChunk user ft SENT msgId -> do - withStore $ \st -> updateSndFileChunkSent st ft msgId + withStore' $ \db -> updateSndFileChunkSent db ft msgId unless (fileStatus == FSCancelled) $ sendFileChunk user ft MERR _ err -> do cancelSndFileTransfer ft case err of SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ do - ci <- withStore $ \st -> getChatItemByFileId st user fileId + ci <- withStore $ \db -> getChatItemByFileId db user fileId toView $ CRSndFileRcvCancelled ci ft _ -> throwChatError $ CEFileSend fileId err MSG meta _ _ -> @@ -1361,10 +1365,10 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage XOk -> allowAgentConnection conn confId XOk _ -> pure () CON -> do - ci <- withStore $ \st -> do - updateRcvFileStatus st ft FSConnected - updateCIFileStatus st user fileId CIFSRcvTransfer - getChatItemByFileId st user fileId + ci <- withStore $ \db -> do + liftIO $ updateRcvFileStatus db ft FSConnected + liftIO $ updateCIFileStatus db user fileId CIFSRcvTransfer + getChatItemByFileId db user fileId toView $ CRRcvFileStart ci MSG meta@MsgMeta {recipient = (msgId, _), integrity} _ msgBody -> withAckMessage agentConnId meta $ do parseFileChunk msgBody >>= \case @@ -1378,7 +1382,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage MsgError MsgDuplicate -> pure () -- TODO remove once agent removes duplicates MsgError e -> badRcvFileChunk ft $ "invalid file chunk number " <> show chunkNo <> ": " <> show e - withStore (\st -> createRcvFileChunk st ft chunkNo msgId) >>= \case + withStore' (\db -> createRcvFileChunk db ft chunkNo msgId) >>= \case RcvChunkOk -> if B.length chunk /= fromInteger chunkSize then badRcvFileChunk ft "incorrect chunk size" @@ -1388,11 +1392,12 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage then badRcvFileChunk ft "incorrect chunk size" else do appendFileChunk ft chunkNo chunk - ci <- withStore $ \st -> do - updateRcvFileStatus st ft FSComplete - updateCIFileStatus st user fileId CIFSRcvComplete - deleteRcvFileChunks st ft - getChatItemByFileId st user fileId + ci <- withStore $ \db -> do + liftIO $ do + updateRcvFileStatus db ft FSComplete + updateCIFileStatus db user fileId CIFSRcvComplete + deleteRcvFileChunks db ft + getChatItemByFileId db user fileId toView $ CRRcvFileComplete ci closeFileHandle fileId rcvFiles withAgent (`deleteConnection` agentConnId) @@ -1421,10 +1426,10 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage where profileContactRequest :: InvitationId -> Profile -> Maybe XContactId -> m () profileContactRequest invId p xContactId_ = do - withStore (\st -> createOrUpdateContactRequest st userId userContactLinkId invId p xContactId_) >>= \case + withStore (\db -> createOrUpdateContactRequest db userId userContactLinkId invId p xContactId_) >>= \case CORContact contact -> toView $ CRContactRequestAlreadyAccepted contact CORRequest cReq@UserContactRequest {localDisplayName} -> do - (_, autoAccept) <- withStore $ \st -> getUserContactLink st userId + (_, autoAccept) <- withStore $ \db -> getUserContactLink db userId if autoAccept then acceptContactRequest user cReq >>= toView . CRAcceptingContactRequest else do @@ -1437,11 +1442,11 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage ackMsgDeliveryEvent :: Connection -> MsgMeta -> m () ackMsgDeliveryEvent Connection {connId} MsgMeta {recipient = (msgId, _)} = - withStore $ \st -> createRcvMsgDeliveryEvent st connId msgId MDSRcvAcknowledged + withStore $ \db -> createRcvMsgDeliveryEvent db connId msgId MDSRcvAcknowledged sentMsgDeliveryEvent :: Connection -> AgentMsgId -> m () sentMsgDeliveryEvent Connection {connId} msgId = - withStore $ \st -> createSndMsgDeliveryEvent st connId msgId MDSSndSent + withStore $ \db -> createSndMsgDeliveryEvent db connId msgId MDSSndSent agentErrToItemStatus :: AgentErrorType -> CIStatus 'MDSnd agentErrToItemStatus (SMP AUTH) = CISSndErrorAuth @@ -1463,16 +1468,16 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage probeMatchingContacts :: Contact -> m () probeMatchingContacts ct = do gVar <- asks idsDrg - (probe, probeId) <- withStore $ \st -> createSentProbe st gVar userId ct + (probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId ct void . sendDirectContactMessage ct $ XInfoProbe probe - cs <- withStore (\st -> getMatchingContacts st userId ct) + cs <- withStore' $ \db -> getMatchingContacts db userId ct let probeHash = ProbeHash $ C.sha256Hash (unProbe probe) forM_ cs $ \c -> sendProbeHash c probeHash probeId `catchError` const (pure ()) where sendProbeHash :: Contact -> ProbeHash -> Int64 -> m () sendProbeHash c probeHash probeId = do void . sendDirectContactMessage c $ XInfoProbeCheck probeHash - withStore $ \st -> createSentProbeHash st userId probeId c + withStore' $ \db -> createSentProbeHash db userId probeId c messageWarning :: Text -> m () messageWarning = toView . CRMessageError "warning" @@ -1485,7 +1490,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage checkIntegrityCreateItem (CDDirectRcv ct) msgMeta let (ExtMsgContent content fileInvitation_) = mcExtMsgContent mc ciFile_ <- processFileInvitation fileInvitation_ $ - \fi chSize -> withStore $ \st -> createRcvFileTransfer st userId ct fi chSize + \fi chSize -> withStore' $ \db -> createRcvFileTransfer db userId ct fi chSize ci@ChatItem {formattedText} <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvMsgContent content) ciFile_ toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci showMsgToast (c <> "> ") content formattedText @@ -1516,7 +1521,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage _ -> throwError e where updateRcvChatItem = do - CChatItem msgDir ChatItem {meta = CIMeta {itemId}} <- withStore $ \st -> getDirectChatItemBySharedMsgId st userId contactId sharedMsgId + CChatItem msgDir ChatItem {meta = CIMeta {itemId}} <- withStore $ \db -> getDirectChatItemBySharedMsgId db userId contactId sharedMsgId case msgDir of SMDRcv -> updateDirectChatItemView userId ct itemId (ACIContent SMDRcv $ CIRcvMsgContent mc) $ Just msgId SMDSnd -> messageError "x.msg.update: contact attempted invalid message update" @@ -1530,10 +1535,10 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage _ -> throwError e where deleteRcvChatItem = do - CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemId}} <- withStore $ \st -> getDirectChatItemBySharedMsgId st userId contactId sharedMsgId + CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemId}} <- withStore $ \db -> getDirectChatItemBySharedMsgId db userId contactId sharedMsgId case msgDir of SMDRcv -> do - toCi <- withStore $ \st -> deleteDirectChatItemRcvBroadcast st userId ct itemId msgId + toCi <- withStore $ \db -> deleteDirectChatItemRcvBroadcast db userId ct itemId msgId toView $ CRChatItemDeleted (AChatItem SCTDirect SMDRcv (DirectChat ct) deletedItem) toCi SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete" @@ -1541,7 +1546,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage newGroupContentMessage gInfo m@GroupMember {localDisplayName = c} mc msg msgMeta = do let (ExtMsgContent content fileInvitation_) = mcExtMsgContent mc ciFile_ <- processFileInvitation fileInvitation_ $ - \fi chSize -> withStore $ \st -> createRcvGroupFileTransfer st userId m fi chSize + \fi chSize -> withStore' $ \db -> createRcvGroupFileTransfer db userId m fi chSize ci@ChatItem {formattedText} <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvMsgContent content) ciFile_ groupMsgToView gInfo m ci msgMeta let g = groupName' gInfo @@ -1550,24 +1555,24 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> m () groupMessageUpdate gInfo@GroupInfo {groupId} GroupMember {memberId} sharedMsgId mc RcvMessage {msgId} = do - CChatItem msgDir ChatItem {chatDir, meta = CIMeta {itemId}} <- withStore $ \st -> getGroupChatItemBySharedMsgId st user groupId sharedMsgId + CChatItem msgDir ChatItem {chatDir, meta = CIMeta {itemId}} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId sharedMsgId case (msgDir, chatDir) of (SMDRcv, CIGroupRcv m) -> if sameMemberId memberId m then do - updCi <- withStore $ \st -> updateGroupChatItem st user groupId itemId (CIRcvMsgContent mc) msgId + updCi <- withStore $ \db -> updateGroupChatItem db user groupId itemId (CIRcvMsgContent mc) msgId toView . CRChatItemUpdated $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) updCi else messageError "x.msg.update: group member attempted to update a message of another member" (SMDSnd, _) -> messageError "x.msg.update: group member attempted invalid message update" groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> RcvMessage -> m () groupMessageDelete gInfo@GroupInfo {groupId} GroupMember {memberId} sharedMsgId RcvMessage {msgId} = do - CChatItem msgDir deletedItem@ChatItem {chatDir, meta = CIMeta {itemId}} <- withStore $ \st -> getGroupChatItemBySharedMsgId st user groupId sharedMsgId + CChatItem msgDir deletedItem@ChatItem {chatDir, meta = CIMeta {itemId}} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId sharedMsgId case (msgDir, chatDir) of (SMDRcv, CIGroupRcv m) -> if sameMemberId memberId m then do - toCi <- withStore $ \st -> deleteGroupChatItemRcvBroadcast st user gInfo itemId msgId + toCi <- withStore $ \db -> deleteGroupChatItemRcvBroadcast db user gInfo itemId msgId toView $ CRChatItemDeleted (AChatItem SCTGroup SMDRcv (GroupChat gInfo) deletedItem) toCi else messageError "x.msg.del: group member attempted to delete a message of another member" (SMDSnd, _) -> messageError "x.msg.del: group member attempted invalid message delete" @@ -1577,7 +1582,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage processFileInvitation' ct@Contact {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg msgMeta = do checkIntegrityCreateItem (CDDirectRcv ct) msgMeta chSize <- asks $ fileChunkSize . config - RcvFileTransfer {fileId} <- withStore $ \st -> createRcvFileTransfer st userId ct fInv chSize + RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvFileTransfer db userId ct fInv chSize let ciFile = Just $ CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation} ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvMsgContent $ MCFile "") ciFile toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci @@ -1588,7 +1593,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> MsgMeta -> m () processGroupFileInvitation' gInfo m@GroupMember {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg msgMeta = do chSize <- asks $ fileChunkSize . config - RcvFileTransfer {fileId} <- withStore $ \st -> createRcvGroupFileTransfer st userId m fInv chSize + RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvGroupFileTransfer db userId m fInv chSize let ciFile = Just $ CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation} ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvMsgContent $ MCFile "") ciFile groupMsgToView gInfo m ci msgMeta @@ -1599,8 +1604,8 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage xFileCancel :: Contact -> SharedMsgId -> MsgMeta -> m () xFileCancel ct@Contact {contactId} sharedMsgId msgMeta = do checkIntegrityCreateItem (CDDirectRcv ct) msgMeta - fileId <- withStore $ \st -> getFileIdBySharedMsgId st userId contactId sharedMsgId - ft@RcvFileTransfer {cancelled} <- withStore (\st -> getRcvFileTransfer st user fileId) + fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId + ft@RcvFileTransfer {cancelled} <- withStore (\db -> getRcvFileTransfer db user fileId) unless cancelled $ do cancelRcvFileTransfer user ft toView $ CRRcvFileSndCancelled ft @@ -1608,13 +1613,13 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> MsgMeta -> m () xFileCancelGroup g@GroupInfo {groupId} mem@GroupMember {memberId} sharedMsgId msgMeta = do checkIntegrityCreateItem (CDGroupRcv g mem) msgMeta - fileId <- withStore $ \st -> getGroupFileIdBySharedMsgId st userId groupId sharedMsgId - CChatItem msgDir ChatItem {chatDir} <- withStore $ \st -> getGroupChatItemBySharedMsgId st user groupId sharedMsgId + fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId + CChatItem msgDir ChatItem {chatDir} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId sharedMsgId case (msgDir, chatDir) of (SMDRcv, CIGroupRcv m) -> do if sameMemberId memberId m then do - ft@RcvFileTransfer {cancelled} <- withStore (\st -> getRcvFileTransfer st user fileId) + ft@RcvFileTransfer {cancelled} <- withStore (\db -> getRcvFileTransfer db user fileId) unless cancelled $ do cancelRcvFileTransfer user ft toView $ CRRcvFileSndCancelled ft @@ -1624,14 +1629,14 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> ConnReqInvitation -> String -> MsgMeta -> m () xFileAcptInvGroup g@GroupInfo {groupId} m sharedMsgId fileConnReq fName msgMeta = do checkIntegrityCreateItem (CDGroupRcv g m) msgMeta - fileId <- withStore $ \st -> getGroupFileIdBySharedMsgId st userId groupId sharedMsgId - (FileTransferMeta {fileName, cancelled}, _) <- withStore (\st -> getSndFileTransfer st user fileId) + fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId + (FileTransferMeta {fileName, cancelled}, _) <- withStore (\db -> getSndFileTransfer db user fileId) unless cancelled $ if fName == fileName then tryError (withAgent $ \a -> joinConnection a fileConnReq . directMessage $ XOk) >>= \case Right acId -> - withStore $ \st -> createSndGroupFileTransferConnection st userId fileId acId m + withStore' $ \db -> createSndGroupFileTransferConnection db userId fileId acId m Left e -> throwError e else messageError "x.file.acpt.inv: fileName is different from expected" @@ -1644,7 +1649,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage processGroupInvitation ct@Contact {localDisplayName = c} inv@(GroupInvitation (MemberIdRole fromMemId fromRole) (MemberIdRole memId memRole) _ _) = do when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c) when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId - gInfo@GroupInfo {localDisplayName = gName} <- withStore $ \st -> createGroupInvitation st user ct inv + gInfo@GroupInfo {localDisplayName = gName} <- withStore $ \db -> createGroupInvitation db user ct inv toView $ CRReceivedGroupInvitation gInfo ct memRole showToast ("#" <> gName <> " " <> c <> "> ") "invited you to join the group" @@ -1658,23 +1663,23 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage createIntegrityErrorItem e = do createdAt <- liftIO getCurrentTime let content = CIRcvIntegrityError e - ciId <- withStore $ \st -> createNewChatItemNoMsg st user cd content brokerTs createdAt + ciId <- withStore' $ \db -> createNewChatItemNoMsg db user cd content brokerTs createdAt ci <- liftIO $ mkChatItem cd ciId content Nothing Nothing Nothing brokerTs createdAt toView $ CRNewChatItem $ AChatItem (chatTypeI @c) SMDRcv (toChatInfo cd) ci xInfo :: Contact -> Profile -> m () xInfo c@Contact {profile = p} p' = unless (p == p') $ do - c' <- withStore $ \st -> updateContactProfile st userId c p' + c' <- withStore $ \db -> updateContactProfile db userId c p' toView $ CRContactUpdated c c' xInfoProbe :: Contact -> Probe -> m () xInfoProbe c2 probe = do - r <- withStore $ \st -> matchReceivedProbe st userId c2 probe + r <- withStore' $ \db -> matchReceivedProbe db userId c2 probe forM_ r $ \c1 -> probeMatch c1 c2 probe xInfoProbeCheck :: Contact -> ProbeHash -> m () xInfoProbeCheck c1 probeHash = do - r <- withStore $ \st -> matchReceivedProbeHash st userId c1 probeHash + r <- withStore' $ \db -> matchReceivedProbeHash db userId c1 probeHash forM_ r . uncurry $ probeMatch c1 probeMatch :: Contact -> Contact -> Probe -> m () @@ -1685,7 +1690,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage xInfoProbeOk :: Contact -> Probe -> m () xInfoProbeOk c1 probe = do - r <- withStore $ \st -> matchSentProbe st userId c1 probe + r <- withStore' $ \db -> matchSentProbe db userId c1 probe forM_ r $ \c2 -> mergeContacts c1 c2 -- to party accepting call @@ -1784,7 +1789,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage mergeContacts :: Contact -> Contact -> m () mergeContacts to from = do - withStore $ \st -> mergeContactRecords st userId to from + withStore' $ \db -> mergeContactRecords db userId to from toView $ CRContactsMerged to from saveConnInfo :: Connection -> ConnInfo -> m () @@ -1792,72 +1797,72 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo case chatMsgEvent of XInfo p -> do - ct <- withStore $ \st -> createDirectContact st userId activeConn p + ct <- withStore $ \db -> createDirectContact db userId activeConn p toView $ CRContactConnecting ct -- TODO show/log error, other events in SMP confirmation _ -> pure () xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> m () xGrpMemNew gInfo m memInfo@(MemberInfo memId _ _) = do - members <- withStore $ \st -> getGroupMembers st user gInfo + members <- withStore' $ \db -> getGroupMembers db user gInfo unless (sameMemberId memId $ membership gInfo) $ if isMember memId gInfo members then messageError "x.grp.mem.new error: member already exists" else do - newMember <- withStore $ \st -> createNewGroupMember st user gInfo memInfo GCPostMember GSMemAnnounced + newMember <- withStore $ \db -> createNewGroupMember db user gInfo memInfo GCPostMember GSMemAnnounced toView $ CRJoinedGroupMemberConnecting gInfo m newMember xGrpMemIntro :: Connection -> GroupInfo -> GroupMember -> MemberInfo -> m () xGrpMemIntro conn gInfo@GroupInfo {groupId} m memInfo@(MemberInfo memId _ _) = do case memberCategory m of GCHostMember -> do - members <- withStore $ \st -> getGroupMembers st user gInfo + members <- withStore' $ \db -> getGroupMembers db user gInfo if isMember memId gInfo members then messageWarning "x.grp.mem.intro ignored: member already exists" else do (groupConnId, groupConnReq) <- withAgent (`createConnection` SCMInvitation) (directConnId, directConnReq) <- withAgent (`createConnection` SCMInvitation) - newMember <- withStore $ \st -> createIntroReMember st user gInfo m memInfo groupConnId directConnId + newMember <- withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnId directConnId let msg = XGrpMemInv memId IntroInvitation {groupConnReq, directConnReq} void $ sendDirectMessage conn msg (GroupId groupId) - withStore $ \st -> updateGroupMemberStatus st userId newMember GSMemIntroInvited + withStore' $ \db -> updateGroupMemberStatus db userId newMember GSMemIntroInvited _ -> messageError "x.grp.mem.intro can be only sent by host member" xGrpMemInv :: GroupInfo -> GroupMember -> MemberId -> IntroInvitation -> m () xGrpMemInv gInfo m memId introInv = do case memberCategory m of GCInviteeMember -> do - members <- withStore $ \st -> getGroupMembers st user gInfo + members <- withStore' $ \db -> getGroupMembers db user gInfo case find (sameMemberId memId) members of Nothing -> messageError "x.grp.mem.inv error: referenced member does not exist" Just reMember -> do - GroupMemberIntro {introId} <- withStore $ \st -> saveIntroInvitation st reMember m introInv + GroupMemberIntro {introId} <- withStore $ \db -> saveIntroInvitation db reMember m introInv void $ sendXGrpMemInv gInfo reMember (XGrpMemFwd (memberInfo m) introInv) introId _ -> messageError "x.grp.mem.inv can be only sent by invitee member" xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m () xGrpMemFwd gInfo@GroupInfo {membership} m memInfo@(MemberInfo memId _ _) introInv@IntroInvitation {groupConnReq, directConnReq} = do - members <- withStore $ \st -> getGroupMembers st user gInfo + members <- withStore' $ \db -> getGroupMembers db user gInfo toMember <- case find (sameMemberId memId) members of -- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent -- the situation when member does not exist is an error -- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that. -- For now, this branch compensates for the lack of delayed message delivery. - Nothing -> withStore $ \st -> createNewGroupMember st user gInfo memInfo GCPostMember GSMemAnnounced + Nothing -> withStore $ \db -> createNewGroupMember db user gInfo memInfo GCPostMember GSMemAnnounced Just m' -> pure m' - withStore $ \st -> saveMemberInvitation st toMember introInv + withStore' $ \db -> saveMemberInvitation db toMember introInv let msg = XGrpMemInfo (memberId (membership :: GroupMember)) profile groupConnId <- withAgent $ \a -> joinConnection a groupConnReq $ directMessage msg directConnId <- withAgent $ \a -> joinConnection a directConnReq $ directMessage msg - withStore $ \st -> createIntroToMemberContact st userId m toMember groupConnId directConnId + withStore' $ \db -> createIntroToMemberContact db userId m toMember groupConnId directConnId xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> m () xGrpMemDel gInfo@GroupInfo {membership} m memId = do - members <- withStore $ \st -> getGroupMembers st user gInfo + members <- withStore' $ \db -> getGroupMembers db user gInfo if memberId (membership :: GroupMember) == memId then do mapM_ deleteMemberConnection members - withStore $ \st -> updateGroupMemberStatus st userId membership GSMemRemoved + withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved toView $ CRDeletedMemberUser gInfo m else case find (sameMemberId memId) members of Nothing -> messageError "x.grp.mem.del with unknown member ID" @@ -1867,7 +1872,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage then messageError "x.grp.mem.del with insufficient member permissions" else do deleteMemberConnection member - withStore $ \st -> updateGroupMemberStatus st userId member GSMemRemoved + withStore' $ \db -> updateGroupMemberStatus db userId member GSMemRemoved toView $ CRDeletedMember gInfo m member sameMemberId :: MemberId -> GroupMember -> Bool @@ -1876,15 +1881,15 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage xGrpLeave :: GroupInfo -> GroupMember -> m () xGrpLeave gInfo m = do deleteMemberConnection m - withStore $ \st -> updateGroupMemberStatus st userId m GSMemLeft + withStore' $ \db -> updateGroupMemberStatus db userId m GSMemLeft toView $ CRLeftMember gInfo m xGrpDel :: GroupInfo -> GroupMember -> m () xGrpDel gInfo m@GroupMember {memberRole} = do when (memberRole /= GROwner) $ throwChatError CEGroupUserRole - ms <- withStore $ \st -> do - members <- getGroupMembers st user gInfo - updateGroupMemberStatus st userId (membership gInfo) GSMemGroupDeleted + ms <- withStore' $ \db -> do + members <- getGroupMembers db user gInfo + updateGroupMemberStatus db userId (membership gInfo) GSMemGroupDeleted pure members mapM_ deleteMemberConnection ms toView $ CRGroupDeleted gInfo m @@ -1895,13 +1900,13 @@ parseChatMessage = first (ChatError . CEInvalidChatMessage) . strDecode sendFileChunk :: ChatMonad m => User -> SndFileTransfer -> m () sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId acId} = unless (fileStatus == FSComplete || fileStatus == FSCancelled) $ - withStore (`createSndFileChunk` ft) >>= \case + withStore' (`createSndFileChunk` ft) >>= \case Just chunkNo -> sendFileChunkNo ft chunkNo Nothing -> do - ci <- withStore $ \st -> do - updateSndFileStatus st ft FSComplete - deleteSndFileChunks st ft - updateDirectCIFileStatus st user fileId CIFSSndComplete + ci <- withStore $ \db -> do + liftIO $ updateSndFileStatus db ft FSComplete + liftIO $ deleteSndFileChunks db ft + updateDirectCIFileStatus db user fileId CIFSSndComplete toView $ CRSndFileComplete ci ft closeFileHandle fileId sndFiles withAgent (`deleteConnection` acId) @@ -1910,7 +1915,7 @@ sendFileChunkNo :: ChatMonad m => SndFileTransfer -> Integer -> m () sendFileChunkNo ft@SndFileTransfer {agentConnId = AgentConnId acId} chunkNo = do chunkBytes <- readFileChunk ft chunkNo msgId <- withAgent $ \a -> sendMessage a acId SMP.noMsgFlags $ smpEncode FileChunk {chunkNo, chunkBytes} - withStore $ \st -> updateSndFileChunkMsg st ft chunkNo msgId + withStore' $ \db -> updateSndFileChunkMsg db ft chunkNo msgId readFileChunk :: ChatMonad m => SndFileTransfer -> Integer -> m ByteString readFileChunk SndFileTransfer {fileId, filePath, chunkSize} chunkNo = do @@ -1958,7 +1963,7 @@ appendFileChunk ft@RcvFileTransfer {fileId, fileStatus} chunkNo chunk = h <- getFileHandle fileId fsFilePath rcvFiles AppendMode E.try (liftIO $ B.hPut h chunk >> hFlush h) >>= \case Left (e :: E.SomeException) -> throwChatError . CEFileWrite fsFilePath $ show e - Right () -> withStore $ \st -> updatedRcvFileChunkStored st ft chunkNo + Right () -> withStore' $ \db -> updatedRcvFileChunkStored db ft chunkNo getFileHandle :: ChatMonad m => Int64 -> FilePath -> (ChatController -> TVar (Map Int64 Handle)) -> IOMode -> m Handle getFileHandle fileId filePath files ioMode = do @@ -1980,10 +1985,10 @@ isFileActive fileId files = do cancelRcvFileTransfer :: ChatMonad m => User -> RcvFileTransfer -> m () cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, fileStatus} = do closeFileHandle fileId rcvFiles - withStore $ \st -> do - updateFileCancelled st user fileId CIFSRcvCancelled - updateRcvFileStatus st ft FSCancelled - deleteRcvFileChunks st ft + withStore' $ \db -> do + updateFileCancelled db user fileId CIFSRcvCancelled + updateRcvFileStatus db ft FSCancelled + deleteRcvFileChunks db ft case fileStatus of RFSAccepted RcvFileInfo {agentConnId = AgentConnId acId} -> withAgent (`deleteConnection` acId) @@ -1993,15 +1998,15 @@ cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, fileStatus} = do cancelSndFile :: ChatMonad m => User -> FileTransferMeta -> [SndFileTransfer] -> m () cancelSndFile user FileTransferMeta {fileId} fts = do - withStore $ \st -> updateFileCancelled st user fileId CIFSSndCancelled + withStore' $ \db -> updateFileCancelled db user fileId CIFSSndCancelled forM_ fts $ \ft' -> cancelSndFileTransfer ft' cancelSndFileTransfer :: ChatMonad m => SndFileTransfer -> m () cancelSndFileTransfer ft@SndFileTransfer {agentConnId = AgentConnId acId, fileStatus} = unless (fileStatus == FSCancelled || fileStatus == FSComplete) $ do - withStore $ \st -> do - updateSndFileStatus st ft FSCancelled - deleteSndFileChunks st ft + withStore' $ \db -> do + updateSndFileStatus db ft FSCancelled + deleteSndFileChunks db ft withAgent $ \a -> do void (sendMessage a acId SMP.noMsgFlags $ smpEncode FileChunkCancel) `catchError` \_ -> pure () deleteConnection a acId @@ -2019,8 +2024,8 @@ deleteMemberConnection :: ChatMonad m => GroupMember -> m () deleteMemberConnection m@GroupMember {activeConn} = do -- User {userId} <- asks currentUser withAgent (forM_ (memberConnId m) . deleteConnection) `catchError` const (pure ()) - -- withStore $ \st -> deleteGroupMemberConnection st userId m - forM_ activeConn $ \conn -> withStore $ \st -> updateConnectionStatus st conn ConnDeleted + -- withStore $ \db -> deleteGroupMemberConnection db userId m + forM_ activeConn $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted sendDirectContactMessage :: ChatMonad m => Contact -> ChatMsgEvent -> m SndMessage sendDirectContactMessage ct@Contact {activeConn = conn@Connection {connId, connStatus}} chatMsgEvent = do @@ -2037,7 +2042,7 @@ sendDirectMessage conn chatMsgEvent connOrGroupId = do createSndMessage :: ChatMonad m => ChatMsgEvent -> ConnOrGroupId -> m SndMessage createSndMessage chatMsgEvent connOrGroupId = do gVar <- asks idsDrg - withStore $ \st -> createNewSndMessage st gVar connOrGroupId $ \sharedMsgId -> + withStore $ \db -> createNewSndMessage db gVar connOrGroupId $ \sharedMsgId -> let msgBody = strEncode ChatMessage {msgId = Just sharedMsgId, chatMsgEvent} in NewMessage {chatMsgEvent, msgBody} @@ -2049,7 +2054,7 @@ deliverMessage conn@Connection {connId} cmEventTag msgBody msgId = do let msgFlags = MsgFlags {notification = hasNotification cmEventTag} agentMsgId <- withAgent $ \a -> sendMessage a (aConnId conn) msgFlags msgBody let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId} - withStore $ \st -> createSndMsgDelivery st sndMsgDelivery msgId + withStore' $ \db -> createSndMsgDelivery db sndMsgDelivery msgId sendGroupMessage :: ChatMonad m => GroupInfo -> [GroupMember] -> ChatMsgEvent -> m SndMessage sendGroupMessage GroupInfo {groupId} members chatMsgEvent = @@ -2058,7 +2063,7 @@ sendGroupMessage GroupInfo {groupId} members chatMsgEvent = sendXGrpMemInv :: ChatMonad m => GroupInfo -> GroupMember -> ChatMsgEvent -> Int64 -> m SndMessage sendXGrpMemInv GroupInfo {groupId} reMember chatMsgEvent introId = sendGroupMessage' [reMember] chatMsgEvent groupId (Just introId) $ - withStore (\st -> updateIntroStatus st introId GMIntroInvForwarded) + withStore' $ \db -> updateIntroStatus db introId GMIntroInvForwarded sendGroupMessage' :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> Int64 -> Maybe Int64 -> m () -> m SndMessage sendGroupMessage' members chatMsgEvent groupId introId_ postDeliver = do @@ -2066,25 +2071,25 @@ sendGroupMessage' members chatMsgEvent groupId introId_ postDeliver = do -- TODO collect failed deliveries into a single error forM_ (filter memberCurrent members) $ \m@GroupMember {groupMemberId} -> case memberConn m of - Nothing -> withStore $ \st -> createPendingGroupMessage st groupMemberId msgId introId_ + Nothing -> withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_ Just conn@Connection {connStatus} | connStatus == ConnSndReady || connStatus == ConnReady -> do let tag = toCMEventTag chatMsgEvent (deliverMessage conn tag msgBody msgId >> postDeliver) `catchError` const (pure ()) | connStatus == ConnDeleted -> pure () - | otherwise -> withStore (\st -> createPendingGroupMessage st groupMemberId msgId introId_) + | otherwise -> withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_ pure msg sendPendingGroupMessages :: ChatMonad m => GroupMember -> Connection -> m () sendPendingGroupMessages GroupMember {groupMemberId, localDisplayName} conn = do - pendingMessages <- withStore $ \st -> getPendingGroupMessages st groupMemberId + pendingMessages <- withStore' $ \db -> getPendingGroupMessages db groupMemberId -- TODO ensure order - pending messages interleave with user input messages forM_ pendingMessages $ \PendingGroupMessage {msgId, cmEventTag, msgBody, introId_} -> do deliverMessage conn cmEventTag msgBody msgId - withStore (\st -> deletePendingGroupMessage st groupMemberId msgId) + withStore' $ \db -> deletePendingGroupMessage db groupMemberId msgId when (cmEventTag == XGrpMemFwd_) $ case introId_ of Nothing -> throwChatError $ CEGroupMemberIntroNotFound localDisplayName - Just introId -> withStore (\st -> updateIntroStatus st introId GMIntroInvForwarded) + Just introId -> withStore' $ \db -> updateIntroStatus db introId GMIntroInvForwarded saveRcvMSG :: ChatMonad m => Connection -> ConnOrGroupId -> MsgMeta -> MsgBody -> m RcvMessage saveRcvMSG Connection {connId} connOrGroupId agentMsgMeta msgBody = do @@ -2092,13 +2097,13 @@ saveRcvMSG Connection {connId} connOrGroupId agentMsgMeta msgBody = do let agentMsgId = fst $ recipient agentMsgMeta newMsg = NewMessage {chatMsgEvent, msgBody} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} - withStore $ \st -> createNewMessageAndRcvMsgDelivery st connOrGroupId newMsg sharedMsgId_ rcvMsgDelivery + withStore' $ \db -> createNewMessageAndRcvMsgDelivery db connOrGroupId newMsg sharedMsgId_ rcvMsgDelivery saveSndChatItem :: ChatMonad m => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> m (ChatItem c 'MDSnd) saveSndChatItem user cd msg@SndMessage {sharedMsgId} content ciFile quotedItem = do createdAt <- liftIO getCurrentTime - ciId <- withStore $ \st -> createNewSndChatItem st user cd msg content quotedItem createdAt - forM_ ciFile $ \CIFile {fileId} -> withStore $ \st -> updateFileTransferChatItemId st fileId ciId + ciId <- withStore' $ \db -> createNewSndChatItem db user cd msg content quotedItem createdAt + forM_ ciFile $ \CIFile {fileId} -> withStore' $ \db -> updateFileTransferChatItemId db fileId ciId liftIO $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) createdAt createdAt saveRcvChatItem :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> MsgMeta -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> m (ChatItem c 'MDRcv) @@ -2107,8 +2112,8 @@ saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} = saveRcvChatItem' user cd saveRcvChatItem' :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> MsgMeta -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> m (ChatItem c 'MDRcv) saveRcvChatItem' user cd msg sharedMsgId_ MsgMeta {broker = (_, brokerTs)} content ciFile = do createdAt <- liftIO getCurrentTime - (ciId, quotedItem) <- withStore $ \st -> createNewRcvChatItem st user cd msg sharedMsgId_ content brokerTs createdAt - forM_ ciFile $ \CIFile {fileId} -> withStore $ \st -> updateFileTransferChatItemId st fileId ciId + (ciId, quotedItem) <- withStore' $ \db -> createNewRcvChatItem db user cd msg sharedMsgId_ content brokerTs createdAt + forM_ ciFile $ \CIFile {fileId} -> withStore' $ \db -> updateFileTransferChatItemId db fileId ciId liftIO $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ brokerTs createdAt mkChatItem :: MsgDirectionI d => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> ChatItemTs -> UTCTime -> IO (ChatItem c d) @@ -2121,12 +2126,12 @@ mkChatItem cd ciId content file quotedItem sharedMsgId itemTs currentTs = do allowAgentConnection :: ChatMonad m => Connection -> ConfirmationId -> ChatMsgEvent -> m () allowAgentConnection conn confId msg = do withAgent $ \a -> allowConnection a (aConnId conn) confId $ directMessage msg - withStore $ \st -> updateConnectionStatus st conn ConnAccepted + withStore' $ \db -> updateConnectionStatus db conn ConnAccepted getCreateActiveUser :: SQLiteStore -> IO User getCreateActiveUser st = do user <- - getUsers st >>= \case + withTransaction st getUsers >>= \case [] -> newUser users -> maybe (selectUser users) pure (find activeUser users) putStrLn $ "Current user: " <> userStr user @@ -2144,7 +2149,7 @@ getCreateActiveUser st = do loop = do displayName <- getContactName fullName <- T.pack <$> getWithPrompt "full name (optional)" - liftIO (runExceptT $ createUser st Profile {displayName, fullName, image = Nothing} True) >>= \case + withTransaction st (\db -> runExceptT $ createUser db Profile {displayName, fullName, image = Nothing} True) >>= \case Left SEDuplicateName -> do putStrLn "chosen display name is already used by another profile on this device, choose another one" loop @@ -2152,7 +2157,7 @@ getCreateActiveUser st = do Right user -> pure user selectUser :: [User] -> IO User selectUser [user] = do - liftIO $ setActiveUser st (userId user) + withTransaction st (`setActiveUser` userId user) pure user selectUser users = do putStrLn "Select user profile:" @@ -2167,7 +2172,7 @@ getCreateActiveUser st = do | n <= 0 || n > length users -> putStrLn "invalid user number" >> loop | otherwise -> do let user = users !! (n - 1) - liftIO $ setActiveUser st (userId user) + withTransaction st (`setActiveUser` userId user) pure user userStr :: User -> String userStr User {localDisplayName, profile = Profile {fullName}} = @@ -2214,16 +2219,20 @@ withAgent action = >>= runExceptT . action >>= liftEither . first ChatErrorAgent +withStore' :: ChatMonad m => (DB.Connection -> IO a) -> m a +withStore' action = withStore $ liftIO . action + withStore :: ChatMonad m => - (forall m'. (MonadUnliftIO m', MonadError StoreError m') => SQLiteStore -> m' a) -> + (DB.Connection -> ExceptT StoreError IO a) -> m a -withStore action = - asks chatStore - >>= runExceptT . action - -- use this line instead of above to log query errors - -- >>= (\st -> runExceptT $ action st `E.catch` \(e :: E.SomeException) -> liftIO (print e) >> E.throwIO e) - >>= liftEither . first ChatErrorStore +withStore action = do + st <- asks chatStore + liftEitherError ChatErrorStore $ + withTransaction st (runExceptT . action) `E.catch` handleInternal + where + handleInternal :: DB.SQLError -> IO (Either StoreError a) + handleInternal = pure . Left . SEInternalError . show chatCommandP :: Parser ChatCommand chatCommandP = diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index c8f05c4be..4cd85330d 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -85,7 +85,7 @@ defaultMobileConfig = type CJSONString = CString getActiveUser_ :: SQLiteStore -> IO (Maybe User) -getActiveUser_ st = find activeUser <$> getUsers st +getActiveUser_ st = find activeUser <$> withTransaction st getUsers chatInit :: String -> IO ChatController chatInit dbFilePrefix = do diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 14a4ab61b..46da813a4 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -30,6 +30,7 @@ module Simplex.Chat.Store getConnReqContactXContactId, createDirectContact, getContactGroupNames, + deleteContactConnectionsAndFiles, deleteContact, getContactByName, getContact, @@ -160,6 +161,7 @@ module Simplex.Chat.Store overwriteSMPServers, getPendingContactConnection, deletePendingContactConnection, + withTransaction, ) where @@ -168,14 +170,13 @@ 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 (isRight, rights) +import Data.Either (rights) import Data.Function (on) import Data.Functor (($>)) import Data.Int (Int64) @@ -207,13 +208,13 @@ import Simplex.Chat.Migrations.M20220514_profiles_user_id import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, InvitationId, MsgMeta (..)) -import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, firstRow, withTransaction) +import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, firstRow, firstRow', maybeFirstRow, 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.Protocol (ProtocolServer (..), SMPServer, pattern SMPServer) -import Simplex.Messaging.Util (eitherToMaybe, liftIOEither, (<$$>)) +import Simplex.Messaging.Util (eitherToMaybe) import UnliftIO.STM schemaMigrations :: [(String, Query)] @@ -243,8 +244,8 @@ createStore dbFilePath = createSQLiteStore dbFilePath 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) +checkConstraint :: StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a +checkConstraint err action = ExceptT $ runExceptT action `E.catch` (pure . Left . handleSQLError err) handleSQLError :: StoreError -> SQLError -> StoreError handleSQLError err e @@ -254,11 +255,9 @@ handleSQLError err 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 +createUser :: DB.Connection -> Profile -> Bool -> ExceptT StoreError IO User +createUser db Profile {displayName, fullName, image} activeUser = + checkConstraint SEDuplicateName . liftIO $ do currentTs <- getCurrentTime DB.execute db @@ -280,60 +279,56 @@ createUser st Profile {displayName, fullName, image} activeUser = (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) + pure $ 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 - |] +getUsers :: DB.Connection -> IO [User] +getUsers 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) +setActiveUser :: DB.Connection -> UserId -> IO () +setActiveUser db userId = 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 PendingContactConnection -createConnReqConnection st userId acId cReqHash xContactId = do - liftIO . withTransaction st $ \db -> do - createdAt <- getCurrentTime - let pccConnStatus = ConnJoined - 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, pccConnStatus, ConnContact, createdAt, createdAt, cReqHash, xContactId) - pccConnId <- insertedRowId db - pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, createdAt, updatedAt = createdAt} +createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> IO PendingContactConnection +createConnReqConnection db userId acId cReqHash xContactId = do + createdAt <- getCurrentTime + let pccConnStatus = ConnJoined + 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, pccConnStatus, ConnContact, createdAt, createdAt, cReqHash, xContactId) + pccConnId <- insertedRowId db + pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, createdAt, updatedAt = createdAt} -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 +getConnReqContactXContactId :: DB.Connection -> UserId -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId) +getConnReqContactXContactId db userId cReqHash = do + getContact' >>= \case + c@(Just _) -> pure (c, Nothing) + Nothing -> (Nothing,) <$> getXContactId where - getContact' :: DB.Connection -> IO (Maybe Contact) - getContact' db = - fmap toContact . listToMaybe - <$> DB.query + getContact' :: IO (Maybe Contact) + getContact' = + maybeFirstRow toContact $ + DB.query db [sql| SELECT @@ -350,27 +345,26 @@ getConnReqContactXContactId st userId cReqHash = do LIMIT 1 |] (userId, cReqHash) - getXContactId :: DB.Connection -> IO (Maybe XContactId) - getXContactId db = - fmap fromOnly . listToMaybe - <$> DB.query + getXContactId :: IO (Maybe XContactId) + getXContactId = + maybeFirstRow fromOnly $ + 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 -> ConnStatus -> m PendingContactConnection -createDirectConnection st userId acId pccConnStatus = - liftIO . withTransaction st $ \db -> do - createdAt <- getCurrentTime - DB.execute - db - [sql| - INSERT INTO connections - (user_id, agent_conn_id, conn_status, conn_type, created_at, updated_at) VALUES (?,?,?,?,?,?) - |] - (userId, acId, pccConnStatus, ConnContact, createdAt, createdAt) - pccConnId <- insertedRowId db - pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = False, createdAt, updatedAt = createdAt} +createDirectConnection :: DB.Connection -> UserId -> ConnId -> ConnStatus -> IO PendingContactConnection +createDirectConnection db userId acId pccConnStatus = do + createdAt <- getCurrentTime + DB.execute + db + [sql| + INSERT INTO connections + (user_id, agent_conn_id, conn_status, conn_type, created_at, updated_at) VALUES (?,?,?,?,?,?) + |] + (userId, acId, pccConnStatus, ConnContact, createdAt, createdAt) + pccConnId <- insertedRowId db + pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = False, createdAt, updatedAt = createdAt} createContactConnection_ :: DB.Connection -> UserId -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection createContactConnection_ db userId = createConnection_ db userId ConnContact Nothing @@ -393,16 +387,15 @@ createConnection_ db userId connType entityId acId viaContact connLevel currentT 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, updatedAt = createdAt} +createDirectContact :: DB.Connection -> UserId -> Connection -> Profile -> ExceptT StoreError IO Contact +createDirectContact db userId activeConn@Connection {connId} profile = do + createdAt <- liftIO getCurrentTime + (localDisplayName, contactId, _) <- createContact_ db userId connId profile Nothing createdAt + pure $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup = Nothing, createdAt, updatedAt = createdAt} -createContact_ :: DB.Connection -> UserId -> Int64 -> Profile -> Maybe Int64 -> UTCTime -> IO (Either StoreError (Text, Int64, Int64)) +createContact_ :: DB.Connection -> UserId -> Int64 -> Profile -> Maybe Int64 -> UTCTime -> ExceptT StoreError IO (Text, Int64, Int64) createContact_ db userId connId Profile {displayName, fullName, image} viaGroup currentTs = - withLocalDisplayName db userId displayName $ \ldn -> do + ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do DB.execute db "INSERT INTO contact_profiles (display_name, full_name, image, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" @@ -416,41 +409,40 @@ createContact_ db userId connId Profile {displayName, fullName, image} viaGroup 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} = do - liftIO . withTransaction st $ \db -> do - DB.execute +getContactGroupNames :: DB.Connection -> UserId -> Contact -> IO [GroupName] +getContactGroupNames db userId Contact {contactId} = + map fromOnly + <$> DB.query 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 = ? - ) + 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) - DB.execute db "DELETE FROM files WHERE user_id = ? AND contact_id = ?" (userId, contactId) - -- in separate transaction to prevent crashes on android (race condition on integrity check?) - liftIO . withTransaction st $ \db -> do - DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) - deleteContactProfile_ db 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) + +deleteContactConnectionsAndFiles :: DB.Connection -> UserId -> Contact -> IO () +deleteContactConnectionsAndFiles db userId Contact {contactId} = 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 files WHERE user_id = ? AND contact_id = ?" (userId, contactId) + +deleteContact :: DB.Connection -> UserId -> Contact -> IO () +deleteContact db userId Contact {contactId, localDisplayName} = do + DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) + deleteContactProfile_ db 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) deleteContactProfile_ :: DB.Connection -> UserId -> ContactId -> IO () deleteContactProfile_ db userId contactId = @@ -466,13 +458,12 @@ deleteContactProfile_ db userId contactId = |] (userId, contactId) -updateUserProfile :: StoreMonad m => SQLiteStore -> User -> Profile -> m () -updateUserProfile st User {userId, userContactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName} +updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO () +updateUserProfile db User {userId, userContactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName} | displayName == newName = - liftIO . withTransaction st $ \db -> - updateContactProfile_ db userId userContactId p' + liftIO $ updateContactProfile_ db userId userContactId p' | otherwise = - liftIOEither . checkConstraint SEDuplicateName . withTransaction st $ \db -> do + checkConstraint SEDuplicateName . liftIO $ do currentTs <- getCurrentTime DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId) DB.execute @@ -481,20 +472,17 @@ updateUserProfile st User {userId, userContactId, localDisplayName, profile = Pr (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} +updateContactProfile :: DB.Connection -> UserId -> Contact -> Profile -> ExceptT StoreError IO Contact +updateContactProfile db 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'} + liftIO $ 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'} + ExceptT . 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 @@ -556,34 +544,33 @@ toContactOrError ((contactId, localDisplayName, viaGroup, displayName, fullName, -- 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 +getContactByName :: DB.Connection -> UserId -> ContactName -> ExceptT StoreError IO Contact +getContactByName db userId localDisplayName = do + cId <- getContactIdByName db userId localDisplayName + 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 +getUserContacts :: DB.Connection -> User -> IO [Contact] +getUserContacts db User {userId} = do + contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ?" (Only userId) + rights <$> mapM (runExceptT . getContact db userId) contactIds -createUserContactLink :: StoreMonad m => SQLiteStore -> UserId -> ConnId -> ConnReqContact -> m () -createUserContactLink st userId agentConnId cReq = - liftIOEither . checkConstraint SEDuplicateContactLink . withTransaction st $ \db -> do +createUserContactLink :: DB.Connection -> UserId -> ConnId -> ConnReqContact -> ExceptT StoreError IO () +createUserContactLink db userId agentConnId cReq = + checkConstraint SEDuplicateContactLink . liftIO $ 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 + void $ 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 +getUserContactLinkConnections :: DB.Connection -> UserId -> ExceptT StoreError IO [Connection] +getUserContactLinkConnections db userId = + connections =<< liftIO getConnections + where + getConnections = + DB.queryNamed db [sql| SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, @@ -595,61 +582,54 @@ getUserContactLinkConnections st userId = AND uc.local_display_name = '' |] [":user_id" := userId] - where - connections [] = Left SEUserContactLinkNotFound - connections rows = Right $ map toConnection rows + connections [] = throwError SEUserContactLinkNotFound + connections rows = pure $ 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 +deleteUserContactLink :: DB.Connection -> UserId -> IO () +deleteUserContactLink db userId = 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.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = ''" (Only userId) + |] + [":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 $ +getUserContactLink :: DB.Connection -> UserId -> ExceptT StoreError IO (ConnReqContact, Bool) +getUserContactLink db userId = + ExceptT . firstRow id SEUserContactLinkNotFound $ DB.query db [sql| @@ -660,15 +640,14 @@ getUserContactLink_ db userId = |] (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) +updateUserContactLinkAutoAccept :: DB.Connection -> UserId -> Bool -> ExceptT StoreError IO (ConnReqContact, Bool) +updateUserContactLinkAutoAccept db userId autoAccept = do + (cReqUri, _) <- getUserContactLink db userId + liftIO updateUserContactLinkAutoAccept_ + pure (cReqUri, autoAccept) where - updateUserContactLinkAutoAccept_ :: DB.Connection -> IO () - updateUserContactLinkAutoAccept_ db = + updateUserContactLinkAutoAccept_ :: IO () + updateUserContactLinkAutoAccept_ = DB.execute db [sql| @@ -679,26 +658,21 @@ updateUserContactLinkAutoAccept st userId autoAccept = do |] (autoAccept, userId) -createOrUpdateContactRequest :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> m ContactOrRequest -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 ContactOrRequest) -createOrUpdateContactRequest_ db userId userContactLinkId invId Profile {displayName, fullName, image} xContactId_ = - maybeM getContact' xContactId_ >>= \case - Just contact -> pure . Right $ CORContact contact - Nothing -> CORRequest <$$> createOrUpdate_ +createOrUpdateContactRequest :: DB.Connection -> UserId -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest +createOrUpdateContactRequest db userId userContactLinkId invId Profile {displayName, fullName, image} xContactId_ = + liftIO (maybeM getContact' xContactId_) >>= \case + Just contact -> pure $ CORContact contact + Nothing -> CORRequest <$> createOrUpdate_ where maybeM = maybe (pure Nothing) - createOrUpdate_ :: IO (Either StoreError UserContactRequest) - createOrUpdate_ = runExceptT $ do + createOrUpdate_ :: ExceptT StoreError IO UserContactRequest + createOrUpdate_ = do cReqId <- ExceptT $ maybeM getContactRequest' xContactId_ >>= \case Nothing -> createContactRequest Just cr -> updateContactRequest cr $> Right (contactRequestId (cr :: UserContactRequest)) - ExceptT $ getContactRequest_ db userId cReqId + getContactRequest db userId cReqId createContactRequest :: IO (Either StoreError Int64) createContactRequest = do currentTs <- getCurrentTime @@ -721,8 +695,8 @@ createOrUpdateContactRequest_ db userId userContactLinkId invId Profile {display insertedRowId db getContact' :: XContactId -> IO (Maybe Contact) getContact' xContactId = - fmap toContact . listToMaybe - <$> DB.query + maybeFirstRow toContact $ + DB.query db [sql| SELECT @@ -741,8 +715,8 @@ createOrUpdateContactRequest_ db userId userContactLinkId invId Profile {display (userId, xContactId) getContactRequest' :: XContactId -> IO (Maybe UserContactRequest) getContactRequest' xContactId = - fmap toContactRequest . listToMaybe - <$> DB.query + maybeFirstRow toContactRequest $ + DB.query db [sql| SELECT @@ -784,14 +758,9 @@ createOrUpdateContactRequest_ db userId userContactLinkId invId Profile {display |] (displayName, fullName, image, currentTs, 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) $ +getContactRequest :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO UserContactRequest +getContactRequest db userId contactRequestId = + ExceptT . firstRow toContactRequest (SEContactRequestNotFound contactRequestId) $ DB.query db [sql| @@ -813,121 +782,115 @@ toContactRequest (contactRequestId, localDisplayName, agentInvitationId, userCon let profile = Profile {displayName, fullName, image} in UserContactRequest {contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, localDisplayName, profileId, profile, xContactId, createdAt, updatedAt} -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) +getContactRequestIdByName :: DB.Connection -> UserId -> ContactName -> ExceptT StoreError IO Int64 +getContactRequestIdByName db userId cName = + ExceptT . 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 contact_profiles - WHERE contact_profile_id in ( - SELECT contact_profile_id - FROM contact_requests - WHERE user_id = ? AND contact_request_id = ? - ) - |] - (userId, contactRequestId) - 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) +deleteContactRequest :: DB.Connection -> UserId -> Int64 -> IO () +deleteContactRequest db userId contactRequestId = do + DB.execute + db + [sql| + DELETE FROM contact_profiles + WHERE contact_profile_id in ( + SELECT contact_profile_id + FROM contact_requests + WHERE user_id = ? AND contact_request_id = ? + ) + |] + (userId, contactRequestId) + 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, updatedAt = currentTs} +createAcceptedContact :: DB.Connection -> UserId -> ConnId -> ContactName -> Int64 -> Profile -> Maybe XContactId -> IO Contact +createAcceptedContact db userId agentConnId localDisplayName profileId profile xContactId = 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, updatedAt = 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 -> +getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer] +getLiveSndFileTransfers db User {userId} = do + fileIds :: [Int64] <- 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 + SELECT DISTINCT f.file_id + FROM files f + JOIN snd_files s + WHERE f.user_id = ? AND s.file_status IN (?, ?, ?) |] - (fileId, connId) + (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] -getPendingConnections :: MonadUnliftIO m => SQLiteStore -> User -> m [Connection] -getPendingConnections st User {userId} = - liftIO . withTransaction st $ \db -> - map toConnection - <$> DB.queryNamed +getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer] +getLiveRcvFileTransfers db user@User {userId} = do + fileIds :: [Int64] <- + map fromOnly + <$> 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 = :user_id - AND conn_type = :conn_type - AND contact_id IS NULL + SELECT f.file_id + FROM files f + JOIN rcv_files r + WHERE f.user_id = ? AND r.file_status IN (?, ?) |] - [":user_id" := userId, ":conn_type" := ConnContact] + (userId, FSAccepted, FSConnected) + rights <$> mapM (runExceptT . getRcvFileTransfer db user) fileIds -getContactConnections :: StoreMonad m => SQLiteStore -> UserId -> Contact -> m [Connection] -getContactConnections st userId Contact {contactId} = - liftIOEither . withTransaction st $ \db -> - connections - <$> DB.query +getPendingSndChunks :: DB.Connection -> Int64 -> Int64 -> IO [Integer] +getPendingSndChunks db fileId connId = + 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 :: DB.Connection -> User -> IO [Connection] +getPendingConnections db User {userId} = + 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 :: DB.Connection -> UserId -> Contact -> ExceptT StoreError IO [Connection] +getContactConnections db userId Contact {contactId} = + connections =<< liftIO getConnections_ + where + getConnections_ = + DB.query db [sql| SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, @@ -937,9 +900,8 @@ getContactConnections st userId Contact {contactId} = 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 + connections [] = throwError $ SEContactNotFound contactId + connections rows = pure $ map toConnection rows type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, UTCTime) @@ -962,171 +924,163 @@ toMaybeConnection (Just connId, Just agentConnId, Just connLevel, viaContact, Ju 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 +getMatchingContacts :: DB.Connection -> UserId -> Contact -> IO [Contact] +getMatchingContacts db userId Contact {contactId, profile = Profile {displayName, fullName, image}} = do + contactIds <- + map fromOnly + <$> DB.queryNamed db [sql| - SELECT c.contact_id, r.probe + 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 (runExceptT . getContact db userId) contactIds + +createSentProbe :: DB.Connection -> TVar ChaChaDRG -> UserId -> Contact -> ExceptT StoreError IO (Probe, Int64) +createSentProbe db gVar userId _to@Contact {contactId} = + 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 :: DB.Connection -> UserId -> Int64 -> Contact -> IO () +createSentProbeHash db userId probeId _to@Contact {contactId} = 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 :: DB.Connection -> UserId -> Contact -> Probe -> IO (Maybe Contact) +matchReceivedProbe db userId _from@Contact {contactId} (Probe probe) = 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 NOT NULL + 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_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 + 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 <$> runExceptT (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 +matchReceivedProbeHash :: DB.Connection -> UserId -> Contact -> ProbeHash -> IO (Maybe (Contact, Probe)) +matchReceivedProbeHash db userId _from@Contact {contactId} (ProbeHash probeHash) = do + namesAndProbes <- + DB.query 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 + 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 |] - [ ":to_contact_id" := toContactId, - ":from_contact_id" := fromContactId, - ":user_id" := userId, - ":updated_at" := currentTs - ] - deleteContactProfile_ db userId fromContactId - 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) + (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)) + <$> runExceptT (getContact db userId cId) -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 +matchSentProbe :: DB.Connection -> UserId -> Contact -> Probe -> IO (Maybe Contact) +matchSentProbe db userId _from@Contact {contactId} (Probe probe) = 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 <$> runExceptT (getContact db userId cId) + +mergeContactRecords :: DB.Connection -> UserId -> Contact -> Contact -> IO () +mergeContactRecords db userId Contact {contactId = toContactId} Contact {contactId = fromContactId, localDisplayName} = 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 + ] + deleteContactProfile_ db userId fromContactId + 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 :: DB.Connection -> User -> ConnId -> ExceptT StoreError IO ConnectionEntity +getConnectionEntity db user@User {userId, userContactId} agentConnId = do + c@Connection {connType, entityId} <- getConnection_ + 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_ entId c + ConnContact -> RcvDirectMsgConnection c . Just <$> getContactRec_ entId c + ConnSndFile -> SndFileConnection c <$> getConnSndFileTransfer_ entId c + ConnRcvFile -> RcvFileConnection c <$> getRcvFileTransfer db user entId + ConnUserContact -> UserContactConnection c <$> getUserContact_ entId where - getConnection_ :: DB.Connection -> ExceptT StoreError IO Connection - getConnection_ db = ExceptT $ do + getConnection_ :: ExceptT StoreError IO Connection + getConnection_ = ExceptT $ do connection <$> DB.query db @@ -1140,8 +1094,8 @@ getConnectionEntity st User {userId, userContactId} 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 + getContactRec_ :: Int64 -> Connection -> ExceptT StoreError IO Contact + getContactRec_ contactId c = ExceptT $ do toContact' contactId c <$> DB.query db @@ -1157,8 +1111,8 @@ getConnectionEntity st User {userId, userContactId} agentConnId = let profile = Profile {displayName, fullName, image} in Right $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup, createdAt, updatedAt} toContact' _ _ _ = Left $ SEInternalError "referenced contact not found" - getGroupAndMember_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember) - getGroupAndMember_ db groupMemberId c = ExceptT $ do + getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember) + getGroupAndMember_ groupMemberId c = ExceptT $ do firstRow (toGroupAndMember c) (SEInternalError "referenced group member not found") $ DB.query db @@ -1188,8 +1142,8 @@ getConnectionEntity st User {userId, userContactId} agentConnId = 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} = + getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer + getConnSndFileTransfer_ fileId Connection {connId} = ExceptT $ sndFileTransfer_ fileId connId <$> DB.query @@ -1209,8 +1163,8 @@ getConnectionEntity st User {userId, userContactId} agentConnId = 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 + getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact + getUserContact_ userContactLinkId = ExceptT $ do userContact_ <$> DB.query db @@ -1225,62 +1179,60 @@ getConnectionEntity st User {userId, userContactId} agentConnId = userContact_ [Only cReq] = Right UserContact {userContactLinkId, connReqContact = cReq} userContact_ _ = Left SEUserContactLinkNotFound -getConnectionsContacts :: MonadUnliftIO m => SQLiteStore -> UserId -> [ConnId] -> m [ContactRef] -getConnectionsContacts st userId agentConnIds = - liftIO . withTransaction st $ \db -> do - DB.execute_ db "DROP TABLE IF EXISTS temp.conn_ids" - DB.execute_ db "CREATE TABLE temp.conn_ids (conn_id BLOB)" - DB.executeMany db "INSERT INTO temp.conn_ids (conn_id) VALUES (?)" $ map Only agentConnIds - conns <- - map (uncurry ContactRef) - <$> DB.query - db - [sql| - SELECT ct.contact_id, ct.local_display_name - FROM contacts ct - JOIN connections c ON c.contact_id = ct.contact_id - WHERE ct.user_id = ? - AND c.agent_conn_id IN (SELECT conn_id FROM temp.conn_ids) - AND c.conn_type = ? - |] - (userId, ConnContact) - DB.execute_ db "DROP TABLE temp.conn_ids" - pure conns - -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 +getConnectionsContacts :: DB.Connection -> UserId -> [ConnId] -> IO [ContactRef] +getConnectionsContacts db userId agentConnIds = do + DB.execute_ db "DROP TABLE IF EXISTS temp.conn_ids" + DB.execute_ db "CREATE TABLE temp.conn_ids (conn_id BLOB)" + DB.executeMany db "INSERT INTO temp.conn_ids (conn_id) VALUES (?)" $ map Only agentConnIds + conns <- + map (uncurry ContactRef) + <$> DB.query db [sql| - SELECT - -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at, g.updated_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 = ? + SELECT ct.contact_id, ct.local_display_name + FROM contacts ct + JOIN connections c ON c.contact_id = ct.contact_id + WHERE ct.user_id = ? + AND c.agent_conn_id IN (SELECT conn_id FROM temp.conn_ids) + AND c.conn_type = ? |] - (groupMemberId, userId, userContactId) + (userId, ConnContact) + DB.execute_ db "DROP TABLE temp.conn_ids" + pure conns + +getGroupAndMember :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (GroupInfo, GroupMember) +getGroupAndMember db User {userId, userContactId} groupMemberId = + ExceptT . 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, g.updated_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) = @@ -1288,16 +1240,15 @@ getGroupAndMember st User {userId, userContactId} groupMemberId = 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) +updateConnectionStatus :: DB.Connection -> Connection -> ConnStatus -> IO () +updateConnectionStatus db Connection {connId} connStatus = 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 +createNewGroup :: DB.Connection -> TVar ChaChaDRG -> User -> GroupProfile -> ExceptT StoreError IO GroupInfo +createNewGroup db gVar user groupProfile = + checkConstraint SEDuplicateName . liftIO $ do let GroupProfile {displayName, fullName, image} = groupProfile uId = userId user currentTs <- getCurrentTime @@ -1317,24 +1268,22 @@ createNewGroup st gVar user groupProfile = groupId <- insertedRowId db memberId <- encodedRandomBytes 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, updatedAt = currentTs} + pure GroupInfo {groupId, localDisplayName = displayName, groupProfile, membership, createdAt = currentTs, updatedAt = 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 +createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> ExceptT StoreError IO GroupInfo +createGroupInvitation db user@User {userId} contact@Contact {contactId} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} = + liftIO getInvitationGroupId_ >>= \case + Nothing -> ExceptT createGroupInvitation_ + -- 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 + getInvitationGroupId_ :: IO (Maybe Int64) + getInvitationGroupId_ = + maybeFirstRow fromOnly $ + DB.query db "SELECT group_id FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMIT 1" (connRequest, userId) + createGroupInvitation_ :: IO (Either StoreError GroupInfo) + createGroupInvitation_ = do let GroupProfile {displayName, fullName, image} = groupProfile withLocalDisplayName db userId displayName $ \localDisplayName -> do currentTs <- getCurrentTime @@ -1354,70 +1303,61 @@ createGroupInvitation st user@User {userId} contact@Contact {contactId} GroupInv -- 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 +getGroupByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO Group +getGroupByName db user gName = do + groupId <- getGroupIdByName db user gName + 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 +getGroup :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Group +getGroup db user groupId = do + gInfo <- 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 +deleteGroup :: DB.Connection -> User -> Group -> IO () +deleteGroup db User {userId} (Group GroupInfo {groupId, localDisplayName} members) = 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 + [sql| + DELETE FROM group_profiles + WHERE group_profile_id in ( + SELECT group_profile_id + FROM groups + WHERE user_id = ? AND group_id = ? + ) + |] + (userId, groupId) + DB.execute db "DELETE FROM groups WHERE user_id = ? AND group_id = ?" (userId, groupId) + DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + +getUserGroups :: DB.Connection -> User -> IO [Group] +getUserGroups db user@User {userId} = do + groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId) + rights <$> mapM (runExceptT . getGroup db user) groupIds + +getUserGroupDetails :: DB.Connection -> User -> IO [GroupInfo] +getUserGroupDetails db User {userId, userContactId} = + map (toGroupInfo userContactId) + <$> DB.query db [sql| - DELETE FROM group_profiles - WHERE group_profile_id in ( - SELECT group_profile_id - FROM groups - WHERE user_id = ? AND group_id = ? - ) + SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at, g.updated_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, groupId) - DB.execute db "DELETE FROM groups WHERE user_id = ? AND group_id = ?" (userId, groupId) - DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + (userId, userContactId) -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, g.updated_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 +getGroupInfoByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupInfo +getGroupInfoByName db user gName = do + gId <- getGroupIdByName db user gName + getGroupInfo db user gId type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe ImageData, UTCTime, UTCTime) :. GroupMemberRow @@ -1426,11 +1366,8 @@ toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, im let membership = toGroupMember userContactId userMemberRow in GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName, fullName, image}, membership, createdAt, updatedAt} -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 +getGroupMembers :: DB.Connection -> User -> GroupInfo -> IO [GroupMember] +getGroupMembers db User {userId, userContactId} GroupInfo {groupId} = do map toContactMember <$> DB.query db @@ -1457,20 +1394,19 @@ getGroupMembers_ db User {userId, userContactId} GroupInfo {groupId} = do -- 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 +getGroupInvitation :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO ReceivedGroupInvitation +getGroupInvitation db user localDisplayName = do + cReq <- getConnRec_ user + groupId <- getGroupIdByName db user localDisplayName + Group groupInfo@GroupInfo {membership} members <- 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 + getConnRec_ :: User -> ExceptT StoreError IO (Maybe ConnReqInvitation) + getConnRec_ 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 @@ -1493,66 +1429,61 @@ toMaybeGroupMember userContactId (Just groupMemberId, Just groupId, Just memberI 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 +createContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> Int64 -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> ExceptT StoreError IO GroupMember +createContactMember db gVar user groupId contact memberRole agentConnId connRequest = + createWithRandomId gVar $ \memId -> do currentTs <- getCurrentTime - void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs + 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 -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 - ] +getMemberInvitation :: DB.Connection -> User -> Int64 -> IO (Maybe ConnReqInvitation) +getMemberInvitation db User {userId} groupMemberId = + fmap join . maybeFirstRow fromOnly $ + DB.query db "SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? AND user_id = ?" (groupMemberId, userId) + +createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> IO () +createMemberConnection db userId GroupMember {groupMemberId} agentConnId = do + currentTs <- getCurrentTime + void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs + +updateGroupMemberStatus :: DB.Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO () +updateGroupMemberStatus db userId GroupMember {groupMemberId} memStatus = 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, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (displayName, fullName, image, userId, currentTs, currentTs) - memProfileId <- insertedRowId db - let newMember = - NewGroupMember - { memInfo, - memCategory, - memStatus, - memInvitedBy = IBUnknown, - localDisplayName, - memContactId = Nothing, - memProfileId - } - createNewMember_ db user gInfo newMember currentTs +createNewGroupMember :: DB.Connection -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember +createNewGroupMember db user@User {userId} gInfo memInfo@(MemberInfo _ _ Profile {displayName, fullName, image}) memCategory memStatus = + ExceptT . withLocalDisplayName db userId displayName $ \localDisplayName -> do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO contact_profiles (display_name, full_name, image, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (displayName, fullName, image, userId, 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_ @@ -1583,25 +1514,21 @@ createNewMember_ 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} = +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 +createIntroductions :: DB.Connection -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro] +createIntroductions db 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 + else do currentTs <- getCurrentTime - mapM (insertIntro_ db currentTs) reMembers + mapM (insertIntro_ currentTs) reMembers where - insertIntro_ :: DB.Connection -> UTCTime -> GroupMember -> IO GroupMemberIntro - insertIntro_ db ts reMember = do + insertIntro_ :: UTCTime -> GroupMember -> IO GroupMemberIntro + insertIntro_ ts reMember = do DB.execute db [sql| @@ -1613,63 +1540,60 @@ createIntroductions st members toMember = do 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 +updateIntroStatus :: DB.Connection -> Int64 -> GroupMemberIntroStatus -> IO () +updateIntroStatus db introId introStatus = 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 :: DB.Connection -> GroupMember -> GroupMember -> IntroInvitation -> ExceptT StoreError IO GroupMemberIntro +saveIntroInvitation db reMember toMember introInv = do + intro <- getIntroduction_ db reMember toMember + liftIO $ 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, + SET intro_status = :intro_status, group_queue_info = :group_queue_info, direct_queue_info = :direct_queue_info, updated_at = :updated_at - WHERE group_member_id = :group_member_id + WHERE group_member_intro_id = :intro_id |] - [ ":member_status" := GSMemIntroInvited, - ":group_queue_info" := groupConnReq, - ":direct_queue_info" := directConnReq, + [ ":intro_status" := GMIntroInvReceived, + ":group_queue_info" := groupConnReq introInv, + ":direct_queue_info" := directConnReq introInv, ":updated_at" := currentTs, - ":group_member_id" := groupMemberId + ":intro_id" := introId intro ] + pure intro {introInvitation = Just introInv, introStatus = GMIntroInvReceived} + +saveMemberInvitation :: DB.Connection -> GroupMember -> IntroInvitation -> IO () +saveMemberInvitation db GroupMember {groupMemberId} IntroInvitation {groupConnReq, directConnReq} = 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 @@ -1689,40 +1613,38 @@ getIntroduction_ db reMember toMember = ExceptT $ do 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} +createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> ConnId -> ConnId -> ExceptT StoreError IO GroupMember +createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) groupAgentConnId directAgentConnId = 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) <- 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 +createIntroToMemberContact :: DB.Connection -> UserId -> GroupMember -> GroupMember -> ConnId -> ConnId -> IO () +createIntroToMemberContact db userId GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} groupAgentConnId directAgentConnId = 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_ directConnId currentTs + updateMember_ contactId currentTs where - createMemberContact_ :: DB.Connection -> Int64 -> UTCTime -> IO Int64 - createMemberContact_ db connId ts = do + createMemberContact_ :: Int64 -> UTCTime -> IO Int64 + createMemberContact_ connId ts = do DB.execute db [sql| @@ -1735,8 +1657,8 @@ createIntroToMemberContact st userId GroupMember {memberContactId = viaContactId 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 = + updateMember_ :: Int64 -> UTCTime -> IO () + updateMember_ contactId ts = DB.executeNamed db [sql| @@ -1790,215 +1712,199 @@ createContactMemberInv_ db User {userId, userContactId} groupId userOrContact Me ":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, g.updated_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, ct.updated_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, UTCTime) :. ConnectionRow] -> Maybe Contact - toContact' [(contactId, localDisplayName, displayName, fullName, image, viaGroup, createdAt, updatedAt) :. connRow] = - let profile = Profile {displayName, fullName, image} - activeConn = toConnection connRow - in Just Contact {contactId, localDisplayName, profile, activeConn, viaGroup, createdAt, updatedAt} - 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 - -createSndGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> m Int64 -createSndGroupFileTransfer 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 - -createSndGroupFileTransferConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> ConnId -> GroupMember -> m () -createSndGroupFileTransferConnection 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 :: MsgDirectionI d => MonadUnliftIO m => SQLiteStore -> User -> Int64 -> CIFileStatus d -> m () -updateFileCancelled st User {userId} fileId ciFileStatus = - liftIO . withTransaction st $ \db -> do - currentTs <- getCurrentTime - DB.execute db "UPDATE files SET cancelled = 1, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId) - -updateCIFileStatus :: (MsgDirectionI d, MonadUnliftIO m) => SQLiteStore -> User -> Int64 -> CIFileStatus d -> m () -updateCIFileStatus st user fileId ciFileStatus = - liftIO . withTransaction st $ \db -> updateCIFileStatus_ db user fileId ciFileStatus - -updateCIFileStatus_ :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO () -updateCIFileStatus_ db User {userId} fileId ciFileStatus = 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 -> UserId -> Int64 -> 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 -> UserId -> Int64 -> 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) - -getChatRefByFileId :: StoreMonad m => SQLiteStore -> User -> Int64 -> m ChatRef -getChatRefByFileId st User {userId} fileId = do - r <- liftIO . withTransaction st $ \db -> do +getViaGroupMember :: DB.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember)) +getViaGroupMember db User {userId, userContactId} Contact {contactId} = + maybeFirstRow toGroupAndMember $ DB.query db [sql| - SELECT contact_id, group_id - FROM files - WHERE user_id = ? AND file_id = ? - LIMIT 1 + SELECT + -- GroupInfo + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at, g.updated_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) -> (GroupInfo, GroupMember) + toGroupAndMember (groupInfoRow :. memberRow :. connRow) = + let groupInfo = toGroupInfo userContactId groupInfoRow + member = toGroupMember userContactId memberRow + in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) + +getViaGroupContact :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact) +getViaGroupContact db User {userId} GroupMember {groupMemberId} = + maybeFirstRow 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, ct.updated_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, UTCTime) :. ConnectionRow -> Contact + toContact' ((contactId, localDisplayName, displayName, fullName, image, viaGroup, createdAt, updatedAt) :. connRow) = + let profile = Profile {displayName, fullName, image} + activeConn = toConnection connRow + in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, createdAt, updatedAt} + +createSndFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> ConnId -> Integer -> IO Int64 +createSndFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize} acId chunkSize = 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 + +createSndGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> IO Int64 +createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize} chunkSize = 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 + +createSndGroupFileTransferConnection :: DB.Connection -> UserId -> Int64 -> ConnId -> GroupMember -> IO () +createSndGroupFileTransferConnection db userId fileId acId GroupMember {groupMemberId} = 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 :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO () +updateFileCancelled db User {userId} fileId ciFileStatus = do + currentTs <- getCurrentTime + DB.execute db "UPDATE files SET cancelled = 1, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId) + +updateCIFileStatus :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO () +updateCIFileStatus db User {userId} fileId ciFileStatus = 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 :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO SharedMsgId +getSharedMsgIdByFileId db userId fileId = + ExceptT . 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) - case r of + +getFileIdBySharedMsgId :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64 +getFileIdBySharedMsgId db userId contactId sharedMsgId = + ExceptT . 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 :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64 +getGroupFileIdBySharedMsgId db userId groupId sharedMsgId = + ExceptT . 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) + +getChatRefByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO ChatRef +getChatRefByFileId db User {userId} fileId = + liftIO getChatRef >>= \case [(Just contactId, Nothing)] -> pure $ ChatRef CTDirect contactId [(Nothing, Just groupId)] -> pure $ ChatRef CTGroup groupId _ -> throwError $ SEInternalError "could not retrieve chat ref by file id" + where + getChatRef = + DB.query + db + [sql| + SELECT contact_id, group_id + FROM files + WHERE user_id = ? AND file_id = ? + LIMIT 1 + |] + (userId, fileId) 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) +updateSndFileStatus :: DB.Connection -> SndFileTransfer -> FileStatus -> IO () +updateSndFileStatus db SndFileTransfer {fileId, connId} status = 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 +createSndFileChunk :: DB.Connection -> SndFileTransfer -> IO (Maybe Integer) +createSndFileChunk db SndFileTransfer {fileId, connId, fileSize, chunkSize} = do + chunkNo <- getLastChunkNo + insertChunk chunkNo + pure chunkNo where - getLastChunkNo db = do + getLastChunkNo = 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 + insertChunk = \case Just chunkNo -> do currentTs <- getCurrentTime DB.execute @@ -2007,76 +1913,66 @@ createSndFileChunk st SndFileTransfer {fileId, connId, fileSize, chunkSize} = (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) +updateSndFileChunkMsg :: DB.Connection -> SndFileTransfer -> Integer -> AgentMsgId -> IO () +updateSndFileChunkMsg db SndFileTransfer {fileId, connId} chunkNo msgId = 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) +updateSndFileChunkSent :: DB.Connection -> SndFileTransfer -> AgentMsgId -> IO () +updateSndFileChunkSent db SndFileTransfer {fileId, connId} msgId = 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) +deleteSndFileChunks :: DB.Connection -> SndFileTransfer -> IO () +deleteSndFileChunks db SndFileTransfer {fileId, connId} = + 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} +createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Integer -> IO RcvFileTransfer +createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq} chunkSize = 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, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (userId, groupId, fileName, fileSize, chunkSize, CIFSRcvInvitation, 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} +createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Integer -> IO RcvFileTransfer +createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq} chunkSize = do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (userId, groupId, fileName, fileSize, chunkSize, CIFSRcvInvitation, 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 -> User -> Int64 -> m RcvFileTransfer -getRcvFileTransfer st User {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 +getRcvFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO RcvFileTransfer +getRcvFileTransfer db User {userId} fileId = + ExceptT . firstRow' rcvFileTransfer (SERcvFileNotFound fileId) $ + DB.query db [sql| SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name, @@ -2092,9 +1988,9 @@ getRcvFileTransfer_ db userId fileId = (userId, fileId) where rcvFileTransfer :: - [(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe AgentConnId)] -> + (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_)] = + 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 @@ -2114,45 +2010,41 @@ getRcvFileTransfer_ db userId fileId = (Just filePath, Just connId, Just agentConnId) -> Just RcvFileInfo {filePath, connId, agentConnId} _ -> Nothing cancelled = fromMaybe False cancelled_ - rcvFileTransfer _ = Left $ SERcvFileNotFound fileId -acceptRcvFileTransfer :: StoreMonad m => SQLiteStore -> User -> Int64 -> ConnId -> ConnStatus -> FilePath -> m AChatItem -acceptRcvFileTransfer st user@User {userId} fileId agentConnId connStatus filePath = - liftIOEither . withTransaction st $ \db -> do +acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> ConnId -> ConnStatus -> FilePath -> ExceptT StoreError IO AChatItem +acceptRcvFileTransfer db user@User {userId} fileId agentConnId connStatus filePath = ExceptT $ do + currentTs <- getCurrentTime + DB.execute + db + "UPDATE files SET file_path = ?, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" + (filePath, CIFSRcvAccepted, 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, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs) + runExceptT $ getChatItemByFileId db user fileId + +updateRcvFileStatus :: DB.Connection -> RcvFileTransfer -> FileStatus -> IO () +updateRcvFileStatus db RcvFileTransfer {fileId} status = do + currentTs <- getCurrentTime + DB.execute db "UPDATE rcv_files SET file_status = ?, updated_at = ? WHERE file_id = ?" (status, currentTs, fileId) + +createRcvFileChunk :: DB.Connection -> RcvFileTransfer -> Integer -> AgentMsgId -> IO RcvChunkStatus +createRcvFileChunk db RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, chunkSize} chunkNo msgId = do + status <- getLastChunkNo + unless (status == RcvChunkError) $ do currentTs <- getCurrentTime DB.execute db - "UPDATE files SET file_path = ?, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" - (filePath, CIFSRcvAccepted, 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, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs) - getChatItemByFileId_ db user fileId - -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 + "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 + getLastChunkNo = 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 [] @@ -2173,71 +2065,60 @@ createRcvFileChunk st RcvFileTransfer {fileId, fileInvitation = FileInvitation { 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) +updatedRcvFileChunkStored :: DB.Connection -> RcvFileTransfer -> Integer -> IO () +updatedRcvFileChunkStored db RcvFileTransfer {fileId} chunkNo = 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) +deleteRcvFileChunks :: DB.Connection -> RcvFileTransfer -> IO () +deleteRcvFileChunks db RcvFileTransfer {fileId} = + 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) +updateFileTransferChatItemId :: DB.Connection -> FileTransferId -> ChatItemId -> IO () +updateFileTransferChatItemId db fileId ciId = do + currentTs <- getCurrentTime + DB.execute db "UPDATE files SET chat_item_id = ?, updated_at = ? WHERE file_id = ?" (ciId, currentTs, fileId) -getFileTransfer :: StoreMonad m => SQLiteStore -> User -> Int64 -> m FileTransfer -getFileTransfer st User {userId} fileId = - liftIOEither . withTransaction st $ \db -> - getFileTransfer_ db userId fileId +getFileTransferProgress :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransfer, [Integer]) +getFileTransferProgress db user fileId = do + ft <- getFileTransfer db user 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) -getFileTransferProgress :: StoreMonad m => SQLiteStore -> User -> Int64 -> m (FileTransfer, [Integer]) -getFileTransferProgress st User {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) +getFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransfer +getFileTransfer db user@User {userId} fileId = + fileTransfer =<< liftIO getFileTransferRow where - fileTransfer :: [(Maybe Int64, Maybe Int64)] -> IO (Either StoreError FileTransfer) - fileTransfer [(Nothing, Just _)] = FTRcv <$$> getRcvFileTransfer_ db userId fileId - fileTransfer _ = runExceptT $ do - (ftm, fts) <- ExceptT $ getSndFileTransfer_ db userId fileId + fileTransfer :: [(Maybe Int64, Maybe Int64)] -> ExceptT StoreError IO FileTransfer + fileTransfer [(Nothing, Just _)] = FTRcv <$> getRcvFileTransfer db user fileId + fileTransfer _ = do + (ftm, fts) <- getSndFileTransfer db user fileId pure $ FTSnd {fileTransferMeta = ftm, sndFileTransfers = fts} + getFileTransferRow :: IO [(Maybe Int64, Maybe Int64)] + getFileTransferRow = + 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) -getSndFileTransfer :: StoreMonad m => SQLiteStore -> User -> Int64 -> m (FileTransferMeta, [SndFileTransfer]) -getSndFileTransfer st User {userId} fileId = - liftIOEither . withTransaction st $ \db -> getSndFileTransfer_ db userId fileId - -getSndFileTransfer_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError (FileTransferMeta, [SndFileTransfer])) -getSndFileTransfer_ db userId fileId = runExceptT $ do +getSndFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer]) +getSndFileTransfer db User {userId} fileId = do fileTransferMeta <- ExceptT $ getFileTransferMeta_ db userId fileId sndFileTransfers <- ExceptT $ getSndFileTransfers_ db userId fileId pure (fileTransferMeta, sndFileTransfers) @@ -2283,37 +2164,35 @@ getFileTransferMeta_ db userId fileId = fileTransferMeta (fileName, fileSize, chunkSize, filePath, cancelled_) = FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, cancelled = fromMaybe False cancelled_} -getContactFileInfo :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> m [CIFileInfo] -getContactFileInfo st userId Contact {contactId} = - liftIO . withTransaction st $ \db -> - map toFileInfo - <$> DB.query - db - [sql| +getContactFileInfo :: DB.Connection -> UserId -> Contact -> IO [CIFileInfo] +getContactFileInfo db userId Contact {contactId} = + map toFileInfo + <$> DB.query + db + [sql| SELECT f.file_id, f.ci_file_status, f.file_path FROM chat_items i JOIN files f ON f.chat_item_id = i.chat_item_id WHERE i.user_id = ? AND i.contact_id = ? |] - (userId, contactId) + (userId, contactId) toFileInfo :: (Int64, ACIFileStatus, Maybe FilePath) -> CIFileInfo toFileInfo (fileId, fileStatus, filePath) = CIFileInfo {fileId, fileStatus, filePath} -getContactChatItemIdsAndFileInfo :: MonadUnliftIO m => SQLiteStore -> User -> ContactId -> m [(ChatItemId, UTCTime, Maybe CIFileInfo)] -getContactChatItemIdsAndFileInfo st User {userId} contactId = - liftIO . withTransaction st $ \db -> - map toItemIdAndFileInfo - <$> DB.query - db - [sql| - SELECT i.chat_item_id, i.item_ts, f.file_id, f.ci_file_status, f.file_path - FROM chat_items i - LEFT JOIN files f ON f.chat_item_id = i.chat_item_id - WHERE i.user_id = ? AND i.contact_id = ? - ORDER BY i.item_ts ASC - |] - (userId, contactId) +getContactChatItemIdsAndFileInfo :: DB.Connection -> User -> ContactId -> IO [(ChatItemId, UTCTime, Maybe CIFileInfo)] +getContactChatItemIdsAndFileInfo db User {userId} contactId = + map toItemIdAndFileInfo + <$> DB.query + db + [sql| + SELECT i.chat_item_id, i.item_ts, f.file_id, f.ci_file_status, f.file_path + FROM chat_items i + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + WHERE i.user_id = ? AND i.contact_id = ? + ORDER BY i.item_ts ASC + |] + (userId, contactId) toItemIdAndFileInfo :: (ChatItemId, UTCTime, Maybe Int64, Maybe ACIFileStatus, Maybe FilePath) -> (ChatItemId, UTCTime, Maybe CIFileInfo) toItemIdAndFileInfo (chatItemId, itemTs, fileId_, fileStatus_, filePath) = @@ -2321,28 +2200,26 @@ toItemIdAndFileInfo (chatItemId, itemTs, fileId_, fileStatus_, filePath) = (Just fileId, Just fileStatus) -> (chatItemId, itemTs, Just CIFileInfo {fileId, fileStatus, filePath}) _ -> (chatItemId, itemTs, Nothing) -updateContactTs :: MonadUnliftIO m => SQLiteStore -> User -> Contact -> UTCTime -> m () -updateContactTs st User {userId} Contact {contactId} updatedAt = - liftIO . withTransaction st $ \db -> - DB.execute - db - "UPDATE contacts SET updated_at = ? WHERE user_id = ? AND contact_id = ?" - (updatedAt, userId, contactId) +updateContactTs :: DB.Connection -> User -> Contact -> UTCTime -> IO () +updateContactTs db User {userId} Contact {contactId} updatedAt = + DB.execute + db + "UPDATE contacts SET updated_at = ? WHERE user_id = ? AND contact_id = ?" + (updatedAt, userId, contactId) -getGroupChatItemIdsAndFileInfo :: MonadUnliftIO m => SQLiteStore -> User -> Int64 -> m [(ChatItemId, UTCTime, Bool, Maybe CIFileInfo)] -getGroupChatItemIdsAndFileInfo st User {userId} groupId = - liftIO . withTransaction st $ \db -> - map toItemIdDeletedAndFileInfo - <$> DB.query - db - [sql| - SELECT i.chat_item_id, i.item_ts, i.item_deleted, f.file_id, f.ci_file_status, f.file_path - FROM chat_items i - LEFT JOIN files f ON f.chat_item_id = i.chat_item_id - WHERE i.user_id = ? AND i.group_id = ? - ORDER BY i.item_ts ASC - |] - (userId, groupId) +getGroupChatItemIdsAndFileInfo :: DB.Connection -> User -> Int64 -> IO [(ChatItemId, UTCTime, Bool, Maybe CIFileInfo)] +getGroupChatItemIdsAndFileInfo db User {userId} groupId = + map toItemIdDeletedAndFileInfo + <$> DB.query + db + [sql| + SELECT i.chat_item_id, i.item_ts, i.item_deleted, f.file_id, f.ci_file_status, f.file_path + FROM chat_items i + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + WHERE i.user_id = ? AND i.group_id = ? + ORDER BY i.item_ts ASC + |] + (userId, groupId) toItemIdDeletedAndFileInfo :: (ChatItemId, UTCTime, Bool, Maybe Int64, Maybe ACIFileStatus, Maybe FilePath) -> (ChatItemId, UTCTime, Bool, Maybe CIFileInfo) toItemIdDeletedAndFileInfo (chatItemId, itemTs, itemDeleted, fileId_, fileStatus_, filePath) = @@ -2350,79 +2227,73 @@ toItemIdDeletedAndFileInfo (chatItemId, itemTs, itemDeleted, fileId_, fileStatus (Just fileId, Just fileStatus) -> (chatItemId, itemTs, itemDeleted, Just CIFileInfo {fileId, fileStatus, filePath}) _ -> (chatItemId, itemTs, itemDeleted, Nothing) -updateGroupTs :: MonadUnliftIO m => SQLiteStore -> User -> GroupInfo -> UTCTime -> m () -updateGroupTs st User {userId} GroupInfo {groupId} updatedAt = - liftIO . withTransaction st $ \db -> +updateGroupTs :: DB.Connection -> User -> GroupInfo -> UTCTime -> IO () +updateGroupTs db User {userId} GroupInfo {groupId} updatedAt = + DB.execute + db + "UPDATE groups SET updated_at = ? WHERE user_id = ? AND group_id = ?" + (updatedAt, userId, groupId) + +createNewSndMessage :: DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage) -> ExceptT StoreError IO SndMessage +createNewSndMessage db gVar connOrGroupId mkMessage = + createWithRandomId gVar $ \sharedMsgId -> do + let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId + createdAt <- getCurrentTime DB.execute db - "UPDATE groups SET updated_at = ? WHERE user_id = ? AND group_id = ?" - (updatedAt, userId, groupId) - -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} + [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 +createSndMsgDelivery :: DB.Connection -> SndMsgDelivery -> MessageId -> IO () +createSndMsgDelivery db sndMsgDelivery messageId = 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} +createNewMessageAndRcvMsgDelivery :: DB.Connection -> ConnOrGroupId -> NewMessage -> Maybe SharedMsgId -> RcvMsgDelivery -> IO RcvMessage +createNewMessageAndRcvMsgDelivery db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} = 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 +createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO () +createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do + msgDeliveryId <- 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 +createRcvMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDRcv -> ExceptT StoreError IO () +createRcvMsgDeliveryEvent db connId agentMsgId rcvMsgDeliveryStatus = do + msgDeliveryId <- 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 @@ -2447,9 +2318,9 @@ createMsgDeliveryEvent_ db msgDeliveryId msgDeliveryStatus createdAt = do |] (msgDeliveryId, msgDeliveryStatus, createdAt, createdAt) -getMsgDeliveryId_ :: DB.Connection -> Int64 -> AgentMsgId -> IO (Either StoreError Int64) +getMsgDeliveryId_ :: DB.Connection -> Int64 -> AgentMsgId -> ExceptT StoreError IO Int64 getMsgDeliveryId_ db connId agentMsgId = - firstRow fromOnly (SENoMsgDelivery connId agentMsgId) $ + ExceptT . firstRow fromOnly (SENoMsgDelivery connId agentMsgId) $ DB.query db [sql| @@ -2460,47 +2331,43 @@ getMsgDeliveryId_ db connId agentMsgId = |] (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 +createPendingGroupMessage :: DB.Connection -> Int64 -> MessageId -> Maybe Int64 -> IO () +createPendingGroupMessage db groupMemberId messageId introId_ = 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 :: DB.Connection -> Int64 -> IO [PendingGroupMessage] +getPendingGroupMessages db groupMemberId = + map pendingGroupMessage + <$> DB.query db [sql| - INSERT INTO pending_group_messages - (group_member_id, message_id, group_member_intro_id, created_at, updated_at) VALUES (?,?,?,?,?) + 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 |] - (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) + (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) +deletePendingGroupMessage :: DB.Connection -> Int64 -> MessageId -> IO () +deletePendingGroupMessage db groupMemberId messageId = + 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 +createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> UTCTime -> IO ChatItemId +createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem createdAt = + createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow createdAt createdAt where createdByMsgId = if msgId == 0 then Nothing else Just msgId quoteRow :: NewQuoteRow @@ -2514,12 +2381,11 @@ createNewSndChatItem st user chatDirection SndMessage {msgId, sharedMsgId} ciCon CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId) CIQGroupRcv Nothing -> (Just False, Nothing) -createNewRcvChatItem :: MonadUnliftIO m => SQLiteStore -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> 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) +createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c)) +createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} sharedMsgId_ ciContent itemTs createdAt = 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 @@ -2531,10 +2397,9 @@ createNewRcvChatItem st user chatDirection RcvMessage {msgId, chatMsgEvent} shar CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ -> (Just $ Just userMemberId == memberId, memberId) -createNewChatItemNoMsg :: forall c d m. (MsgDirectionI d, MonadUnliftIO m) => SQLiteStore -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> m ChatItemId -createNewChatItemNoMsg st user chatDirection ciContent itemTs createdAt = - liftIO . withTransaction st $ \db -> - createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow itemTs createdAt +createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId +createNewChatItemNoMsg db user chatDirection ciContent itemTs createdAt = + createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow itemTs createdAt where quoteRow :: NewQuoteRow quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing) @@ -2588,8 +2453,8 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe 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 + fmap ciQuoteDirect . maybeFirstRow 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) @@ -2598,15 +2463,15 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe ciQuoteDirect = (`ciQuote` if userSent then CIQDirectSnd else CIQDirectRcv) getUserGroupChatItemId_ :: Int64 -> IO (Maybe ChatItemId) getUserGroupChatItemId_ groupId = - listToMaybe . map fromOnly - <$> DB.query + maybeFirstRow 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 + maybeFirstRow 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) @@ -2635,14 +2500,13 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow -getChatPreviews :: MonadUnliftIO m => SQLiteStore -> User -> Bool -> m [AChat] -getChatPreviews st user withPCC = - liftIO . withTransaction st $ \db -> do - directChats <- getDirectChatPreviews_ db user - groupChats <- getGroupChatPreviews_ db user - cReqChats <- getContactRequestChatPreviews_ db user - connChats <- getContactConnectionChatPreviews_ db user withPCC - pure $ sortOn (Down . ts) (directChats <> groupChats <> cReqChats <> connChats) +getChatPreviews :: DB.Connection -> User -> Bool -> IO [AChat] +getChatPreviews db user withPCC = do + directChats <- getDirectChatPreviews_ db user + groupChats <- getGroupChatPreviews_ db user + cReqChats <- getContactRequestChatPreviews_ db user + connChats <- getContactConnectionChatPreviews_ db user withPCC + pure $ sortOn (Down . ts) (directChats <> groupChats <> cReqChats <> connChats) where ts :: AChat -> UTCTime ts (AChat _ Chat {chatInfo, chatItems = ci : _}) = max (chatItemTs ci) (chatInfoUpdatedAt chatInfo) @@ -2820,55 +2684,52 @@ getContactConnectionChatPreviews_ db User {userId} _ = stats = ChatStats {unreadCount = 0, minUnreadItemId = 0} in AChat SCTContactConnection $ Chat (ContactConnection conn) [] stats -getPendingContactConnection :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m PendingContactConnection -getPendingContactConnection st userId connId = - liftIOEither . withTransaction st $ \db -> do - firstRow toPendingContactConnection (SEPendingConnectionNotFound connId) $ - DB.query - db - [sql| - SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, created_at, updated_at - FROM connections - WHERE user_id = ? - AND connection_id = ? - AND conn_type = ? - AND contact_id IS NULL - AND conn_level = 0 - AND via_contact IS NULL - |] - (userId, connId, ConnContact) - -deletePendingContactConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> m () -deletePendingContactConnection st userId connId = - liftIO . withTransaction st $ \db -> - DB.execute +getPendingContactConnection :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO PendingContactConnection +getPendingContactConnection db userId connId = do + ExceptT . firstRow toPendingContactConnection (SEPendingConnectionNotFound connId) $ + DB.query db [sql| - DELETE FROM connections - WHERE user_id = ? - AND connection_id = ? - AND conn_type = ? - AND contact_id IS NULL - AND conn_level = 0 - AND via_contact IS NULL + SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, created_at, updated_at + FROM connections + WHERE user_id = ? + AND connection_id = ? + AND conn_type = ? + AND contact_id IS NULL + AND conn_level = 0 + AND via_contact IS NULL |] (userId, connId, ConnContact) +deletePendingContactConnection :: DB.Connection -> UserId -> Int64 -> IO () +deletePendingContactConnection db userId connId = + DB.execute + db + [sql| + DELETE FROM connections + WHERE user_id = ? + AND connection_id = ? + AND conn_type = ? + AND contact_id IS NULL + AND conn_level = 0 + AND via_contact IS NULL + |] + (userId, connId, ConnContact) + toPendingContactConnection :: (Int64, ConnId, ConnStatus, Maybe ByteString, UTCTime, UTCTime) -> PendingContactConnection toPendingContactConnection (pccConnId, acId, pccConnStatus, connReqHash, createdAt, updatedAt) = PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = isJust connReqHash, createdAt, updatedAt} -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 +getDirectChat :: DB.Connection -> User -> Int64 -> ChatPagination -> ExceptT StoreError IO (Chat 'CTDirect) +getDirectChat db user contactId pagination = 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 + contact <- getContact db userId contactId stats <- liftIO $ getDirectChatStats_ db userId contactId chatItems <- ExceptT getDirectChatItemsLast_ pure $ Chat (DirectChat contact) (reverse chatItems) stats @@ -2899,7 +2760,7 @@ getDirectChatLast_ db User {userId} contactId count = do 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 + contact <- getContact db userId contactId stats <- liftIO $ getDirectChatStats_ db userId contactId chatItems <- ExceptT getDirectChatItemsAfter_ pure $ Chat (DirectChat contact) chatItems stats @@ -2930,7 +2791,7 @@ getDirectChatAfter_ db User {userId} contactId afterChatItemId count = do 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 + contact <- getContact db userId contactId stats <- liftIO $ getDirectChatStats_ db userId contactId chatItems <- ExceptT getDirectChatItemsBefore_ pure $ Chat (DirectChat contact) (reverse chatItems) stats @@ -2976,64 +2837,51 @@ getDirectChatStats_ db userId contactId = 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) $ +getContactIdByName :: DB.Connection -> UserId -> ContactName -> ExceptT StoreError IO Int64 +getContactIdByName db userId cName = + ExceptT . 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 -> ExceptT StoreError IO Contact +getContact db userId contactId = + ExceptT . fmap 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, ct.updated_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) -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, ct.updated_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 +getGroupChat :: DB.Connection -> User -> Int64 -> ChatPagination -> ExceptT StoreError IO (Chat 'CTGroup) +getGroupChat db user groupId pagination = 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 + groupInfo <- getGroupInfo db user groupId stats <- liftIO $ getGroupChatStats_ db userId groupId chatItems <- ExceptT getGroupChatItemsLast_ pure $ Chat (GroupChat groupInfo) (reverse chatItems) stats @@ -3076,7 +2924,7 @@ getGroupChatLast_ db user@User {userId, userContactId} groupId count = do 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 + groupInfo <- getGroupInfo db user groupId stats <- liftIO $ getGroupChatStats_ db userId groupId chatItems <- ExceptT getGroupChatItemsAfter_ pure $ Chat (GroupChat groupInfo) chatItems stats @@ -3119,7 +2967,7 @@ getGroupChatAfter_ db user@User {userId, userContactId} groupId afterChatItemId 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 + groupInfo <- getGroupInfo db user groupId stats <- liftIO $ getGroupChatStats_ db userId groupId chatItems <- ExceptT getGroupChatItemsBefore_ pure $ Chat (GroupChat groupInfo) (reverse chatItems) stats @@ -3177,14 +3025,9 @@ getGroupChatStats_ db userId groupId = 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) $ +getGroupInfo :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO GroupInfo +getGroupInfo db User {userId, userContactId} groupId = + ExceptT . firstRow (toGroupInfo userContactId) (SEGroupNotFound groupId) $ DB.query db [sql| @@ -3203,13 +3046,12 @@ getGroupInfo_ db User {userId, userContactId} groupId = |] (groupId, userId, userContactId) -getAllChatItems :: StoreMonad m => SQLiteStore -> User -> ChatPagination -> m [AChatItem] -getAllChatItems st user pagination = - liftIOEither . withTransaction st $ \db -> runExceptT $ do - case pagination of - CPLast count -> getAllChatItemsLast_ db user count - CPAfter _afterId _count -> throwError $ SEInternalError "not implemented" - CPBefore _beforeId _count -> throwError $ SEInternalError "not implemented" +getAllChatItems :: DB.Connection -> User -> ChatPagination -> ExceptT StoreError IO [AChatItem] +getAllChatItems db user pagination = do + case pagination of + CPLast count -> getAllChatItemsLast_ db user count + CPAfter _afterId _count -> throwError $ SEInternalError "not implemented" + CPBefore _beforeId _count -> throwError $ SEInternalError "not implemented" getAllChatItemsLast_ :: DB.Connection -> User -> Int -> ExceptT StoreError IO [AChatItem] getAllChatItemsLast_ db user@User {userId} count = do @@ -3228,23 +3070,15 @@ getAllChatItemsLast_ db user@User {userId} count = do (userId, count) mapM (uncurry $ getAChatItem_ db user) itemRefs -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) $ +getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO Int64 +getGroupIdByName db User {userId} gName = + ExceptT . 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 -> getChatItemIdByAgentMsgId_ db connId msgId - -getChatItemIdByAgentMsgId_ :: DB.Connection -> Int64 -> AgentMsgId -> IO (Maybe ChatItemId) -getChatItemIdByAgentMsgId_ db connId msgId = - join . listToMaybe . map fromOnly - <$> DB.query +getChatItemIdByAgentMsgId :: DB.Connection -> Int64 -> AgentMsgId -> IO (Maybe ChatItemId) +getChatItemIdByAgentMsgId db connId msgId = + fmap join . maybeFirstRow fromOnly $ + DB.query db [sql| SELECT chat_item_id @@ -3258,28 +3092,26 @@ getChatItemIdByAgentMsgId_ db connId msgId = |] (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 = do - 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}} +updateDirectChatItemStatus :: forall d. MsgDirectionI d => DB.Connection -> UserId -> Int64 -> ChatItemId -> CIStatus d -> ExceptT StoreError IO (ChatItem 'CTDirect d) +updateDirectChatItemStatus db userId contactId itemId itemStatus = do + ci <- liftEither . 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 -> Maybe MessageId -> m (ChatItem 'CTDirect d) -updateDirectChatItem st userId contactId itemId newContent msgId_ = - liftIOEither . withTransaction st $ \db -> do - currentTs <- liftIO getCurrentTime - ci <- updateDirectChatItem_ db userId contactId itemId newContent currentTs - when (isRight ci) . forM_ msgId_ $ \msgId -> liftIO $ insertChatItemMessage_ db itemId msgId currentTs - pure ci +updateDirectChatItem :: forall d. MsgDirectionI d => DB.Connection -> UserId -> Int64 -> ChatItemId -> CIContent d -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTDirect d) +updateDirectChatItem db userId contactId itemId newContent msgId_ = do + currentTs <- liftIO getCurrentTime + ci <- updateDirectChatItem_ db userId contactId itemId newContent currentTs + forM_ msgId_ $ \msgId -> liftIO $ insertChatItemMessage_ db itemId msgId currentTs + pure ci -updateDirectChatItem_ :: forall d. (MsgDirectionI d) => DB.Connection -> UserId -> Int64 -> ChatItemId -> CIContent d -> UTCTime -> IO (Either StoreError (ChatItem 'CTDirect d)) -updateDirectChatItem_ db userId contactId itemId newContent currentTs = runExceptT $ do - ci <- ExceptT $ (correctDir =<<) <$> getDirectChatItem_ db userId contactId itemId +updateDirectChatItem_ :: forall d. (MsgDirectionI d) => DB.Connection -> UserId -> Int64 -> ChatItemId -> CIContent d -> UTCTime -> ExceptT StoreError IO (ChatItem 'CTDirect d) +updateDirectChatItem_ db userId contactId itemId newContent currentTs = do + ci <- liftEither . correctDir =<< getDirectChatItem db userId contactId itemId let newText = ciContentToText newContent liftIO $ do DB.execute @@ -3295,15 +3127,14 @@ updateDirectChatItem_ db userId contactId itemId newContent currentTs = runExcep correctDir :: CChatItem c -> Either StoreError (ChatItem c d) correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci -deleteDirectChatItemLocal :: StoreMonad m => SQLiteStore -> UserId -> Contact -> ChatItemId -> CIDeleteMode -> m AChatItem -deleteDirectChatItemLocal st userId ct itemId mode = - liftIOEither . withTransaction st $ \db -> do - deleteChatItemMessages_ db itemId - deleteDirectChatItem_ db userId ct itemId mode +deleteDirectChatItemLocal :: DB.Connection -> UserId -> Contact -> ChatItemId -> CIDeleteMode -> ExceptT StoreError IO AChatItem +deleteDirectChatItemLocal db userId ct itemId mode = do + liftIO $ deleteChatItemMessages_ db itemId + deleteDirectChatItem_ db userId ct itemId mode -deleteDirectChatItem_ :: DB.Connection -> UserId -> Contact -> ChatItemId -> CIDeleteMode -> IO (Either StoreError AChatItem) -deleteDirectChatItem_ db userId ct@Contact {contactId} itemId mode = runExceptT $ do - (CChatItem msgDir ci) <- ExceptT $ getDirectChatItem_ db userId contactId itemId +deleteDirectChatItem_ :: DB.Connection -> UserId -> Contact -> ChatItemId -> CIDeleteMode -> ExceptT StoreError IO AChatItem +deleteDirectChatItem_ db userId ct@Contact {contactId} itemId mode = do + (CChatItem msgDir ci) <- getDirectChatItem db userId contactId itemId let toContent = msgDirToDeletedContent_ msgDir mode liftIO $ do DB.execute @@ -3346,16 +3177,15 @@ setChatItemMessagesDeleted_ db 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 -> do - currentTs <- liftIO getCurrentTime - insertChatItemMessage_ db itemId msgId currentTs - updateDirectChatItemRcvDeleted_ db userId ct itemId currentTs +deleteDirectChatItemRcvBroadcast :: DB.Connection -> UserId -> Contact -> ChatItemId -> MessageId -> ExceptT StoreError IO AChatItem +deleteDirectChatItemRcvBroadcast db userId ct itemId msgId = do + currentTs <- liftIO getCurrentTime + liftIO $ insertChatItemMessage_ db itemId msgId currentTs + updateDirectChatItemRcvDeleted_ db userId ct itemId currentTs -updateDirectChatItemRcvDeleted_ :: DB.Connection -> UserId -> Contact -> ChatItemId -> UTCTime -> IO (Either StoreError AChatItem) -updateDirectChatItemRcvDeleted_ db userId ct@Contact {contactId} itemId currentTs = runExceptT $ do - (CChatItem msgDir ci) <- ExceptT $ getDirectChatItem_ db userId contactId itemId +updateDirectChatItemRcvDeleted_ :: DB.Connection -> UserId -> Contact -> ChatItemId -> UTCTime -> ExceptT StoreError IO AChatItem +updateDirectChatItemRcvDeleted_ db userId ct@Contact {contactId} itemId currentTs = do + (CChatItem msgDir ci) <- getDirectChatItem db userId contactId itemId let toContent = msgDirToDeletedContent_ msgDir CIDMBroadcast toText = ciDeleteModeToText CIDMBroadcast liftIO $ do @@ -3380,25 +3210,19 @@ deleteQuote_ db itemId = |] (Only itemId) -getDirectChatItem :: StoreMonad m => SQLiteStore -> UserId -> ContactId -> ChatItemId -> m (CChatItem 'CTDirect) -getDirectChatItem st userId contactId itemId = - liftIOEither . withTransaction st $ \db -> getDirectChatItem_ db userId contactId itemId +getDirectChatItemBySharedMsgId :: DB.Connection -> UserId -> ContactId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTDirect) +getDirectChatItemBySharedMsgId db userId contactId sharedMsgId = do + itemId <- getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId + getDirectChatItem db userId contactId itemId -getDirectChatItemBySharedMsgId :: StoreMonad m => SQLiteStore -> UserId -> ContactId -> 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 +getDirectChatItemByAgentMsgId :: DB.Connection -> UserId -> ContactId -> Int64 -> AgentMsgId -> IO (Maybe (CChatItem 'CTDirect)) +getDirectChatItemByAgentMsgId db userId contactId connId msgId = do + itemId_ <- getChatItemIdByAgentMsgId db connId msgId + maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getDirectChatItem db userId contactId) itemId_ -getDirectChatItemByAgentMsgId :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactId -> Int64 -> AgentMsgId -> m (Maybe (CChatItem 'CTDirect)) -getDirectChatItemByAgentMsgId st userId contactId connId msgId = - liftIO . withTransaction st $ \db -> do - itemId_ <- getChatItemIdByAgentMsgId_ db connId msgId - maybe (pure Nothing) (fmap eitherToMaybe . getDirectChatItem_ db userId contactId) itemId_ - -getDirectChatItemIdBySharedMsgId_ :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> IO (Either StoreError Int64) +getDirectChatItemIdBySharedMsgId_ :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64 getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId = - firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $ + ExceptT . firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $ DB.query db [sql| @@ -3410,8 +3234,8 @@ getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId = |] (userId, contactId, sharedMsgId) -getDirectChatItem_ :: DB.Connection -> UserId -> Int64 -> ChatItemId -> IO (Either StoreError (CChatItem 'CTDirect)) -getDirectChatItem_ db userId contactId itemId = do +getDirectChatItem :: DB.Connection -> UserId -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTDirect) +getDirectChatItem db userId contactId itemId = ExceptT $ do tz <- getCurrentTimeZone currentTs <- getCurrentTime join <$> firstRow (toDirectChatItem tz currentTs) (SEChatItemNotFound itemId) getItem @@ -3434,28 +3258,23 @@ getDirectChatItem_ db userId contactId itemId = do |] (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 <> "%") +getDirectChatItemIdByText :: DB.Connection -> UserId -> Int64 -> SMsgDirection d -> Text -> ExceptT StoreError IO ChatItemId +getDirectChatItemIdByText db userId contactId msgDir quotedMsg = + ExceptT . 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 +updateGroupChatItem :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> MessageId -> ExceptT StoreError IO (ChatItem 'CTGroup d) +updateGroupChatItem db user@User {userId} groupId itemId newContent msgId = do + ci <- liftEither . correctDir =<< getGroupChatItem db user groupId itemId currentTs <- liftIO getCurrentTime let newText = ciContentToText newContent liftIO $ do @@ -3473,36 +3292,34 @@ updateGroupChatItem_ db user@User {userId} groupId itemId newContent msgId = run 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 - DB.execute db "DELETE FROM files WHERE chat_item_id = ?" (Only itemId) - pure ci +deleteGroupChatItemInternal :: DB.Connection -> User -> GroupInfo -> ChatItemId -> ExceptT StoreError IO AChatItem +deleteGroupChatItemInternal db user gInfo itemId = do + currentTs <- liftIO getCurrentTime + ci <- deleteGroupChatItem_ db user gInfo itemId CIDMInternal True currentTs + liftIO $ setChatItemMessagesDeleted_ db itemId + liftIO $ DB.execute db "DELETE FROM files WHERE chat_item_id = ?" (Only 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 +deleteGroupChatItemRcvBroadcast :: DB.Connection -> User -> GroupInfo -> ChatItemId -> MessageId -> ExceptT StoreError IO AChatItem +deleteGroupChatItemRcvBroadcast db user gInfo itemId msgId = + 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 - DB.execute db "DELETE FROM files WHERE chat_item_id = ?" (Only itemId) - pure ci +deleteGroupChatItemSndBroadcast :: DB.Connection -> User -> GroupInfo -> ChatItemId -> MessageId -> ExceptT StoreError IO AChatItem +deleteGroupChatItemSndBroadcast db user gInfo itemId msgId = do + ci <- deleteGroupChatItemBroadcast_ db user gInfo itemId True msgId + liftIO $ setChatItemMessagesDeleted_ db itemId + liftIO $ DB.execute db "DELETE FROM files WHERE chat_item_id = ?" (Only itemId) + pure ci -deleteGroupChatItemBroadcast_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Bool -> MessageId -> IO (Either StoreError AChatItem) +deleteGroupChatItemBroadcast_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Bool -> MessageId -> ExceptT StoreError IO AChatItem deleteGroupChatItemBroadcast_ db user gInfo itemId itemDeleted msgId = do currentTs <- liftIO getCurrentTime - insertChatItemMessage_ db itemId msgId currentTs + liftIO $ 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 +deleteGroupChatItem_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> CIDeleteMode -> Bool -> UTCTime -> ExceptT StoreError IO AChatItem +deleteGroupChatItem_ db user@User {userId} gInfo@GroupInfo {groupId} itemId mode itemDeleted currentTs = do + (CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId let toContent = msgDirToDeletedContent_ msgDir mode liftIO $ do DB.execute @@ -3518,34 +3335,26 @@ deleteGroupChatItem_ db user@User {userId} gInfo@GroupInfo {groupId} itemId mode 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 :: DB.Connection -> User -> Int64 -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) +getGroupChatItemBySharedMsgId db user@User {userId} groupId sharedMsgId = do + itemId <- + ExceptT . 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 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 +getGroupChatItem :: DB.Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTGroup) +getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do tz <- getCurrentTimeZone - currentTs <- liftIO getCurrentTime + currentTs <- getCurrentTime join <$> firstRow (toGroupChatItem tz currentTs userContactId) (SEChatItemNotFound itemId) getItem where getItem = @@ -3578,16 +3387,15 @@ getGroupChatItem_ db User {userId, userContactId} groupId itemId = do |] (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 +getGroupChatItemIdByText :: DB.Connection -> User -> Int64 -> Maybe ContactName -> Text -> ExceptT StoreError IO ChatItemId +getGroupChatItemIdByText db User {userId, localDisplayName = userName} groupId contactName_ quotedMsg = + ExceptT . firstRow fromOnly SEQuotedChatItemNotFound $ case contactName_ of + Nothing -> anyMemberChatItem_ + Just cName + | userName == cName -> userChatItem_ + | otherwise -> memberChatItem_ cName where - anyMemberChatItem_ db = + anyMemberChatItem_ = DB.query db [sql| @@ -3598,7 +3406,7 @@ getGroupChatItemIdByText st User {userId, localDisplayName = userName} groupId c LIMIT 1 |] (userId, groupId, quotedMsg <> "%") - userChatItem_ db = + userChatItem_ = DB.query db [sql| @@ -3609,7 +3417,7 @@ getGroupChatItemIdByText st User {userId, localDisplayName = userName} groupId c LIMIT 1 |] (userId, groupId, quotedMsg <> "%") - memberChatItem_ db cName = + memberChatItem_ cName = DB.query db [sql| @@ -3623,51 +3431,42 @@ getGroupChatItemIdByText st User {userId, localDisplayName = userName} groupId c |] (userId, groupId, cName, quotedMsg <> "%") -getChatItemByFileId :: StoreMonad m => SQLiteStore -> User -> Int64 -> m AChatItem -getChatItemByFileId st user fileId = - liftIOEither . withTransaction st $ \db -> - getChatItemByFileId_ db user fileId - -getChatItemByFileId_ :: DB.Connection -> User -> Int64 -> IO (Either StoreError AChatItem) -getChatItemByFileId_ db user@User {userId} fileId = runExceptT $ do - (itemId, chatRef) <- ExceptT $ getChatItemIdByFileId_ db userId fileId +getChatItemByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO AChatItem +getChatItemByFileId db user@User {userId} fileId = do + (itemId, chatRef) <- + ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $ + DB.query + db + [sql| + SELECT i.chat_item_id, i.contact_id, i.group_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 = ? + LIMIT 1 + |] + (userId, fileId) getAChatItem_ db user itemId chatRef getAChatItem_ :: DB.Connection -> User -> ChatItemId -> ChatRef -> ExceptT StoreError IO AChatItem getAChatItem_ db user@User {userId} itemId = \case ChatRef CTDirect contactId -> do - ct <- ExceptT $ getContact_ db userId contactId - (CChatItem msgDir ci) <- ExceptT $ getDirectChatItem_ db userId contactId itemId + ct <- getContact db userId contactId + (CChatItem msgDir ci) <- getDirectChatItem db userId contactId itemId pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci ChatRef CTGroup groupId -> do - gInfo <- ExceptT $ getGroupInfo_ db user groupId - (CChatItem msgDir ci) <- ExceptT $ getGroupChatItem_ db user groupId itemId + gInfo <- getGroupInfo db user groupId + (CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci _ -> throwError $ SEChatItemNotFound itemId -getChatItemIdByFileId_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError (ChatItemId, ChatRef)) -getChatItemIdByFileId_ db userId fileId = - firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $ - DB.query - db - [sql| - SELECT i.chat_item_id, i.contact_id, i.group_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 = ? - LIMIT 1 - |] - (userId, fileId) - -updateDirectCIFileStatus :: forall d m. (MsgDirectionI d, StoreMonad m) => SQLiteStore -> User -> Int64 -> CIFileStatus d -> m AChatItem -updateDirectCIFileStatus st user fileId fileStatus = - liftIOEither . withTransaction st $ \db -> runExceptT $ do - aci@(AChatItem cType d cInfo ci) <- ExceptT $ getChatItemByFileId_ db user fileId - case (cType, testEquality d $ msgDirection @d) of - (SCTDirect, Just Refl) -> do - liftIO $ updateCIFileStatus_ db user fileId fileStatus - pure $ AChatItem SCTDirect d cInfo $ updateFileStatus ci fileStatus - _ -> pure aci +updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem +updateDirectCIFileStatus db user fileId fileStatus = do + aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId + case (cType, testEquality d $ msgDirection @d) of + (SCTDirect, Just Refl) -> do + liftIO $ updateCIFileStatus db user fileId fileStatus + pure $ AChatItem SCTDirect d cInfo $ updateFileStatus ci fileStatus + _ -> pure aci toChatItemRef :: (ChatItemId, Maybe Int64, Maybe Int64) -> Either StoreError (ChatItemId, ChatRef) toChatItemRef = \case @@ -3675,49 +3474,47 @@ toChatItemRef = \case (itemId, Nothing, Just groupId) -> Right (itemId, ChatRef CTGroup groupId) (itemId, _, _) -> Left $ SEBadChatItem itemId -updateDirectChatItemsRead :: (StoreMonad m) => SQLiteStore -> Int64 -> Maybe (ChatItemId, ChatItemId) -> m () -updateDirectChatItemsRead st contactId itemsRange_ = do - currentTs <- liftIO getCurrentTime - liftIO . withTransaction st $ \db -> - case itemsRange_ of - Just (fromItemId, toItemId) -> - 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) - _ -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE contact_id = ? AND item_status = ? - |] - (CISRcvRead, currentTs, contactId, CISRcvNew) +updateDirectChatItemsRead :: DB.Connection -> Int64 -> Maybe (ChatItemId, ChatItemId) -> IO () +updateDirectChatItemsRead db contactId itemsRange_ = do + currentTs <- getCurrentTime + case itemsRange_ of + Just (fromItemId, toItemId) -> + 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) + _ -> + DB.execute + db + [sql| + UPDATE chat_items SET item_status = ?, updated_at = ? + WHERE contact_id = ? AND item_status = ? + |] + (CISRcvRead, currentTs, contactId, CISRcvNew) -updateGroupChatItemsRead :: (StoreMonad m) => SQLiteStore -> Int64 -> Maybe (ChatItemId, ChatItemId) -> m () -updateGroupChatItemsRead st groupId itemsRange_ = do - currentTs <- liftIO getCurrentTime - liftIO . withTransaction st $ \db -> - case itemsRange_ of - Just (fromItemId, toItemId) -> - 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) - _ -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE group_id = ? AND item_status = ? - |] - (CISRcvRead, currentTs, groupId, CISRcvNew) +updateGroupChatItemsRead :: DB.Connection -> Int64 -> Maybe (ChatItemId, ChatItemId) -> IO () +updateGroupChatItemsRead db groupId itemsRange_ = do + currentTs <- getCurrentTime + case itemsRange_ of + Just (fromItemId, toItemId) -> + 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) + _ -> + DB.execute + db + [sql| + UPDATE chat_items SET item_status = ?, updated_at = ? + WHERE group_id = ? AND item_status = ? + |] + (CISRcvRead, currentTs, groupId, CISRcvNew) type ChatStatsRow = (Int, ChatItemId) @@ -3815,25 +3612,24 @@ toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. 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) +getSMPServers :: DB.Connection -> User -> IO [SMPServer] +getSMPServers db User {userId} = + 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 +overwriteSMPServers :: DB.Connection -> User -> [SMPServer] -> ExceptT StoreError IO () +overwriteSMPServers db User {userId} smpServers = + checkConstraint SEUniqueID . ExceptT $ do currentTs <- getCurrentTime DB.execute db "DELETE FROM smp_servers WHERE user_id = ?" (Only userId) forM_ smpServers $ \ProtocolServer {host, port, keyHash} -> @@ -3885,21 +3681,21 @@ withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreate |] (ldn, displayName, ldnSuffix, userId, ts, ts) -createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> IO (Either StoreError a) +createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a createWithRandomId = createWithRandomBytes 12 -createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> IO (Either StoreError a) +createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a createWithRandomBytes size gVar create = tryCreate 3 where - tryCreate :: Int -> IO (Either StoreError a) - tryCreate 0 = pure $ Left SEUniqueID + tryCreate :: Int -> ExceptT StoreError IO a + tryCreate 0 = throwError SEUniqueID tryCreate n = do - id' <- encodedRandomBytes gVar size - E.try (create id') >>= \case - Right x -> pure $ Right x + id' <- liftIO $ encodedRandomBytes gVar size + liftIO (E.try $ create id') >>= \case + Right x -> pure x Left e | DB.sqlError e == DB.ErrorConstraint -> tryCreate (n - 1) - | otherwise -> pure . Left . SEInternalError $ show e + | otherwise -> throwError . SEInternalError $ show e encodedRandomBytes :: TVar ChaChaDRG -> Int -> IO ByteString encodedRandomBytes gVar = fmap B64.encode . randomBytes gVar @@ -3907,13 +3703,6 @@ encodedRandomBytes gVar = fmap B64.encode . randomBytes gVar randomBytes :: TVar ChaChaDRG -> Int -> IO ByteString randomBytes gVar = atomically . stateTVar gVar . randomBytesGenerate -listToEither :: e -> [a] -> Either e a -listToEither _ (x : _) = Right x -listToEither e _ = Left e - -firstRow' :: (a -> Either e b) -> e -> IO [a] -> IO (Either e b) -firstRow' f e a = (f <=< listToEither e) <$> a - -- These error type constructors must be added to mobile apps data StoreError = SEDuplicateName diff --git a/stack.yaml b/stack.yaml index fec37b2e5..3f3f2e42b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -49,7 +49,7 @@ extra-deps: # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561 # - ../simplexmq - github: simplex-chat/simplexmq - commit: b58523d4a29235c29c56a461edb686ed93bc1e89 + commit: d1db7d6f79b527a689af1807e7d91a92076d2d8c # - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977 - github: simplex-chat/aeson commit: 3eb66f9a68f103b5f1489382aad89f5712a64db7 diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index fc98aff18..ad284c4b9 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -100,14 +100,14 @@ createTestChat :: ChatConfig -> ChatOpts -> String -> Profile -> IO TestCC createTestChat cfg opts dbPrefix profile = do let dbFilePrefix = testDBPrefix <> dbPrefix st <- createStore (dbFilePrefix <> "_chat.db") False - Right user <- runExceptT $ createUser st profile True + Right user <- withTransaction st $ \db -> runExceptT $ createUser db profile True startTestChat_ st cfg opts dbFilePrefix user startTestChat :: ChatConfig -> ChatOpts -> String -> IO TestCC startTestChat cfg opts dbPrefix = do let dbFilePrefix = testDBPrefix <> dbPrefix st <- createStore (dbFilePrefix <> "_chat.db") False - Just user <- find activeUser <$> getUsers st + Just user <- find activeUser <$> withTransaction st getUsers startTestChat_ st cfg opts dbFilePrefix user startTestChat_ :: SQLiteStore -> ChatConfig -> ChatOpts -> FilePath -> User -> IO TestCC diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index 8573d0049..ee6eae98c 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -83,7 +83,7 @@ testChatApi :: IO () testChatApi = withTmpFiles $ do let f = chatStoreFile $ testDBPrefix <> "1" st <- createStore f True - Right _ <- runExceptT $ createUser st aliceProfile True + Right _ <- withTransaction st $ \db -> runExceptT $ createUser db aliceProfile True cc <- chatInit $ testDBPrefix <> "1" chatSendCmd cc "/u" `shouldReturn` activeUser chatSendCmd cc "/u alice Alice" `shouldReturn` activeUserExists