core: correctly handle errors in createWithRandomId/Bytes for postgres (reuse withSavepoint from simplexmq) (#6578)

src/Simplex/Chat/Store/Groups.hs

@@ -1133,7 +1133,7 @@ getGroupInvitation db vr user groupId =
 createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupInfo -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> SubscriptionMode -> ExceptT StoreError IO GroupMember
 createNewContactMember _ _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ _ _ = throwError $ SEContactNotReady localDisplayName
 createNewContactMember db gVar User {userId, userContactId} GroupInfo {groupId, membership} Contact {contactId, localDisplayName, profile, activeConn = Just Connection {connChatVersion, peerChatVRange}} memberRole agentConnId connRequest subMode =
-  createWithRandomId' gVar $ \memId -> runExceptT $ do
+  createWithRandomId' db gVar $ \memId -> runExceptT $ do
     createdAt <- liftIO getCurrentTime
     member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt
     void $ liftIO $ createMemberConnection_ db userId groupMemberId agentConnId connChatVersion peerChatVRange Nothing 0 createdAt subMode
@@ -1188,7 +1188,7 @@ createNewContactMember db gVar User {userId, userContactId} GroupInfo {groupId,
 
 createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupInfo -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> VersionChat -> VersionRangeChat -> SubscriptionMode -> ExceptT StoreError IO ()
 createNewContactMemberAsync db gVar user@User {userId, userContactId} GroupInfo {groupId, membership} Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) chatV peerChatVRange subMode =
-  createWithRandomId' gVar $ \memId -> runExceptT $ do
+  createWithRandomId' db gVar $ \memId -> runExceptT $ do
     createdAt <- liftIO getCurrentTime
     insertMember_ (MemberId memId) createdAt
     groupMemberId <- liftIO $ insertedRowId db
@@ -1233,7 +1233,7 @@ createJoiningMember
           "INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
           (displayName, fullName, shortDescr, image, contactLink, userId, preferences, currentTs, currentTs)
       profileId <- liftIO $ insertedRowId db
-      createWithRandomId' gVar $ \memId -> runExceptT $ do
+      createWithRandomId' db gVar $ \memId -> runExceptT $ do
         insertMember_ ldn profileId (MemberId memId) currentTs
         groupMemberId <- liftIO $ insertedRowId db
         pure (groupMemberId, MemberId memId)
@@ -1318,7 +1318,7 @@ createBusinessRequestGroup
       VersionRange minV maxV = cReqChatVRange
       insertClientMember_ currentTs groupId membership =
         ExceptT . withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do
-          createWithRandomId' gVar $ \memId -> runExceptT $ do
+          createWithRandomId' db gVar $ \memId -> runExceptT $ do
             indexInGroup <- getUpdateNextIndexInGroup_ db groupId
             liftIO $
               DB.execute
@@ -1950,7 +1950,7 @@ getMatchingMemberContacts db vr user@User {userId} GroupMember {memberProfile =
 
 createSentProbe :: DB.Connection -> TVar ChaChaDRG -> UserId -> ContactOrMember -> ExceptT StoreError IO (Probe, Int64)
 createSentProbe db gVar userId to =
-  createWithRandomBytes 32 gVar $ \probe -> do
+  createWithRandomBytes db 32 gVar $ \probe -> do
     currentTs <- getCurrentTime
     let (ctId, gmId) = contactOrMemberIds to
     DB.execute

src/Simplex/Chat/Store/Messages.hs

@@ -174,6 +174,7 @@ import Simplex.Chat.Types
 import Simplex.Chat.Types.Shared
 import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserId)
 import Simplex.Messaging.Agent.Store.AgentStore (firstRow, firstRow', maybeFirstRow)
+import Simplex.Messaging.Agent.Store.Common (withSavepoint)
 import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
@@ -219,7 +220,7 @@ deleteGroupChatItemsMessages db User {userId} GroupInfo {groupId} = do
 
 createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> ChatMsgEvent e -> (SharedMsgId -> EncodedChatMessage) -> ExceptT StoreError IO SndMessage
 createNewSndMessage db gVar connOrGroupId chatMsgEvent encodeMessage =
-  createWithRandomId' gVar $ \sharedMsgId ->
+  createWithRandomId' db gVar $ \sharedMsgId ->
     case encodeMessage (SharedMsgId sharedMsgId) of
       ECMLarge -> pure $ Left SELargeMsg
       ECMEncoded msgBody -> do
@@ -2700,12 +2701,14 @@ updateGroupCIMentions :: DB.Connection -> GroupInfo -> ChatItem 'CTGroup d -> Ma
 updateGroupCIMentions db g ci@ChatItem {mentions} mentions'
   | mentions' == mentions = pure ci
   | otherwise = do
-      unless (null mentions) $ deleteMentions
+      unless (null mentions) deleteMentions
       if null mentions'
         then pure ci
         else -- This is a fallback for the error that should not happen in practice.
         -- In theory, it may happen in item mentions in database are different from item record.
-          createMentions `E.catch` \e -> if constraintError e then deleteMentions >> createMentions else E.throwIO e
+          withSavepoint db "create_mentions" createMentions >>= \case
+            Right r -> pure r
+            Left e -> if constraintError e then deleteMentions >> createMentions else E.throwIO e
   where
     deleteMentions = DB.execute db "DELETE FROM chat_item_mentions WHERE chat_item_id = ?" (Only $ chatItemId' ci)
     createMentions = createGroupCIMentions db g ci mentions'

src/Simplex/Chat/Store/Shared.hs

@@ -40,6 +40,7 @@ import Simplex.Chat.Types.UITheme
 import Simplex.Messaging.Agent.Protocol (AConnShortLink (..), AConnectionRequestUri (..), ACreatedConnLink (..), ConnId, ConnShortLink, ConnectionRequestUri, CreatedConnLink (..), UserId, connMode)
 import Simplex.Messaging.Agent.Store (AnyStoreError (..))
 import Simplex.Messaging.Agent.Store.AgentStore (firstRow, maybeFirstRow)
+import Simplex.Messaging.Agent.Store.Common (withSavepoint)
 import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
@@ -597,42 +598,23 @@ withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreate
             |]
             (ldn, displayName, ldnSuffix, userId, ts, ts)
 
--- Execute an action within a savepoint (PostgreSQL only).
--- On success, releases the savepoint. On error, rolls back to the savepoint
--- to restore the transaction to a usable state before returning the error.
-withSavepoint :: DB.Connection -> Query -> IO a -> IO (Either SQLError a)
-withSavepoint db name action =
-#if defined(dbPostgres)
-  do
-    DB.execute_ db $ "SAVEPOINT " <> name
-    E.try action >>= \case
-      Right r -> do
-        DB.execute_ db $ "RELEASE SAVEPOINT " <> name
-        pure $ Right r
-      Left e -> do
-        DB.execute_ db $ "ROLLBACK TO SAVEPOINT " <> name
-        pure $ Left e
-#else
-  E.try action
-#endif
+createWithRandomId :: forall a. DB.Connection -> TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
+createWithRandomId db = createWithRandomBytes db 12
 
-createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
-createWithRandomId = createWithRandomBytes 12
+createWithRandomId' :: forall a. DB.Connection -> TVar ChaChaDRG -> (ByteString -> IO (Either StoreError a)) -> ExceptT StoreError IO a
+createWithRandomId' db = createWithRandomBytes' db 12
 
-createWithRandomId' :: forall a. TVar ChaChaDRG -> (ByteString -> IO (Either StoreError a)) -> ExceptT StoreError IO a
-createWithRandomId' = createWithRandomBytes' 12
+createWithRandomBytes :: forall a. DB.Connection -> Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
+createWithRandomBytes db size gVar create = createWithRandomBytes' db size gVar (fmap Right . create)
 
-createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
-createWithRandomBytes size gVar create = createWithRandomBytes' size gVar (fmap Right . create)
-
-createWithRandomBytes' :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO (Either StoreError a)) -> ExceptT StoreError IO a
-createWithRandomBytes' size gVar create = tryCreate 3
+createWithRandomBytes' :: forall a. DB.Connection -> Int -> TVar ChaChaDRG -> (ByteString -> IO (Either StoreError a)) -> ExceptT StoreError IO a
+createWithRandomBytes' db size gVar create = tryCreate 3
   where
     tryCreate :: Int -> ExceptT StoreError IO a
     tryCreate 0 = throwError SEUniqueID
     tryCreate n = do
       id' <- liftIO $ encodedRandomBytes gVar size
-      liftIO (E.try $ create id') >>= \case
+      liftIO (withSavepoint db "create_random_id" (create id')) >>= \case
         Right x -> liftEither x
         Left e
           | constraintError e -> tryCreate (n - 1)