IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' into master-ghc8107

Browse Source
This commit is contained in:
Evgeny Poberezkin 2023-10-01 11:19:27 +01:00
commit 0312fde818
2 changed files with 43 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
src/Simplex/Chat.hs
View File

@ -16,7 +16,6 @@ module Simplex.Chat where
import Control.Applicative (optional, (<|>))
import Control.Concurrent.STM (retry, stateTVar)
import qualified Control.Exception as E
import Control.Logger.Simple
import Control.Monad.Except
import Control.Monad.IO.Unlift
@ -352,11 +351,6 @@ execChatCommand_ u cmd = either (CRChatCmdError u) id <$> runExceptT (processCha
parseChatCommand :: ByteString -> Either String ChatCommand
parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace
toView :: ChatMonad' m => ChatResponse -> m ()
toView event = do
q <- asks outputQ
atomically $ writeTBQueue q (Nothing, event)
processChatCommand :: forall m. ChatMonad m => ChatCommand -> m ChatResponse
processChatCommand = \case
ShowActiveUser -> withUser' $ pure . CRActiveUser
@ -5337,33 +5331,6 @@ withAgent action =
>>= runExceptT . action
>>= liftEither . first (`ChatErrorAgent` Nothing)
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) `E.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) `E.catch` handleInternal ""
where
handleInternal :: String -> E.SomeException -> IO (Either StoreError a)
handleInternal ctxStr e = pure . Left . SEInternalError $ show e <> ctxStr
chatCommandP :: Parser ChatCommand
chatCommandP =
choice

53
src/Simplex/Chat/Controller.hs
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