dandri/simplex-chat
1
0 Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-10-22 13:11:55 +00:00
Code Issues Packages Projects Releases Wiki Activity

Move toView and withStore* to a common module (#3147)

Browse Source
This commit is contained in:
Alexander Bondarenko authored and GitHub committed 2023-09-29 15:50:20 +01:00
1 parent 70a65e8969
commit 5ce388522e
2 files changed
+43 -43
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

src/Simplex/Chat/Controller.hs
+43 -10
View File
@@ -46,7 +46,7 @@ import Simplex.Chat.Markdown (MarkdownList)
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol
import Simplex.Chat.Store (AutoAccept, StoreError, UserContactLink, UserMsgReceiptSettings)
import Simplex.Chat.Store (AutoAccept, StoreError (..), UserContactLink, UserMsgReceiptSettings)
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo)
@@ -54,8 +54,9 @@ import Simplex.Messaging.Agent.Client (AgentLocks, ProtocolTestFailure)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration)
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration, withTransaction)
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import qualified Simplex.Messaging.Crypto.File as CF
@@ -66,7 +67,7 @@ import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType, CorrId,
import Simplex.Messaging.TMap (TMap)
import Simplex.Messaging.Transport (simplexMQVersion)
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (allFinally, catchAllErrors, tryAllErrors, (<$$>))
import Simplex.Messaging.Util (allFinally, catchAllErrors, liftEitherError, tryAllErrors, (<$$>))
import Simplex.Messaging.Version
import System.IO (Handle)
import System.Mem.Weak (Weak)
@@ -969,6 +970,15 @@ instance ToJSON SQLiteError where
throwDBError :: ChatMonad m => DatabaseError -> m ()
throwDBError = throwError . ChatErrorDatabase
data ArchiveError
= AEImport {chatError :: ChatError}
| AEImportFile {file :: String, chatError :: ChatError}
deriving (Show, Exception, Generic)
instance ToJSON ArchiveError where
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "AE"
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "AE"
type ChatMonad' m = (MonadUnliftIO m, MonadReader ChatController m)
type ChatMonad m = (ChatMonad' m, MonadError ChatError m)
@@ -1008,11 +1018,34 @@ unsetActive a = asks activeTo >>= atomically . (`modifyTVar` unset)
where
unset a' = if a == a' then ActiveNone else a'
data ArchiveError
= AEImport {chatError :: ChatError}
| AEImportFile {file :: String, chatError :: ChatError}
deriving (Show, Exception, Generic)
toView :: ChatMonad' m => ChatResponse -> m ()
toView event = do
q <- asks outputQ
atomically $ writeTBQueue q (Nothing, event)
instance ToJSON ArchiveError where
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "AE"
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "AE"
withStore' :: ChatMonad m => (DB.Connection -> IO a) -> m a
withStore' action = withStore $ liftIO . action
withStore :: ChatMonad m => (DB.Connection -> ExceptT StoreError IO a) -> m a
withStore = withStoreCtx Nothing
withStoreCtx' :: ChatMonad m => Maybe String -> (DB.Connection -> IO a) -> m a
withStoreCtx' ctx_ action = withStoreCtx ctx_ $ liftIO . action
withStoreCtx :: ChatMonad m => Maybe String -> (DB.Connection -> ExceptT StoreError IO a) -> m a
withStoreCtx ctx_ action = do
ChatController {chatStore} <- ask
liftEitherError ChatErrorStore $ case ctx_ of
Nothing -> withTransaction chatStore (runExceptT . action) `catch` handleInternal ""
-- uncomment to debug store performance
-- Just ctx -> do
-- t1 <- liftIO getCurrentTime
-- putStrLn $ "withStoreCtx start :: " <> show t1 <> " :: " <> ctx
-- r <- withTransactionCtx ctx_ chatStore (runExceptT . action) `E.catch` handleInternal (" (" <> ctx <> ")")
-- t2 <- liftIO getCurrentTime
-- putStrLn $ "withStoreCtx end :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
-- pure r
Just _ -> withTransaction chatStore (runExceptT . action) `catch` handleInternal ""
where
handleInternal :: String -> SomeException -> IO (Either StoreError a)
handleInternal ctxStr e = pure . Left . SEInternalError $ show e <> ctxStr