From f6bb105536103d10a4d1e8ec8ed043a1b9e1345c Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Thu, 23 May 2024 14:47:30 +0300 Subject: [PATCH 1/2] utils: remove MonadError usage (#1168) --- src/Simplex/Messaging/Util.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index b42d5b378..ef2cc6933 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -97,15 +97,15 @@ catchAll_ :: IO a -> IO a -> IO a catchAll_ a = catchAll a . const {-# INLINE catchAll_ #-} -tryAllErrors :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m (Either e a) -tryAllErrors err action = tryError action `UE.catch` (pure . Left . err) +tryAllErrors :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> ExceptT e m (Either e a) +tryAllErrors err action = ExceptT $ Right <$> runExceptT action `UE.catch` (pure . Left . err) {-# INLINE tryAllErrors #-} tryAllErrors' :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> m (Either e a) tryAllErrors' err action = runExceptT action `UE.catch` (pure . Left . err) {-# INLINE tryAllErrors' #-} -catchAllErrors :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> (e -> m a) -> m a +catchAllErrors :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a catchAllErrors err action handler = tryAllErrors err action >>= either handler pure {-# INLINE catchAllErrors #-} @@ -113,11 +113,11 @@ catchAllErrors' :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> catchAllErrors' err action handler = tryAllErrors' err action >>= either handler pure {-# INLINE catchAllErrors' #-} -catchThrow :: (MonadUnliftIO m, MonadError e m) => m a -> (E.SomeException -> e) -> m a +catchThrow :: MonadUnliftIO m => ExceptT e m a -> (E.SomeException -> e) -> ExceptT e m a catchThrow action err = catchAllErrors err action throwError {-# INLINE catchThrow #-} -allFinally :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m b -> m a +allFinally :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> ExceptT e m b -> ExceptT e m a allFinally err action final = tryAllErrors err action >>= \r -> final >> either throwError pure r {-# INLINE allFinally #-} From 984394d90630731dcbc26ba0ffa13bf9fa98a251 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Thu, 23 May 2024 18:44:00 +0300 Subject: [PATCH 2/2] core: remove MonadUnliftIO ExceptT orphans (#1169) --- src/Simplex/FileTransfer/Client.hs | 1 - src/Simplex/FileTransfer/Client/Agent.hs | 1 - src/Simplex/Messaging/Agent/Client.hs | 1 - src/Simplex/Messaging/Agent/Env/SQLite.hs | 1 - .../Messaging/Agent/NtfSubSupervisor.hs | 1 - src/Simplex/Messaging/Client/Agent.hs | 29 ------------------- src/Simplex/Messaging/Crypto/File.hs | 1 - tests/AgentTests/FunctionalAPITests.hs | 18 +++++++++++- tests/CoreTests/UtilTests.hs | 2 +- 9 files changed, 18 insertions(+), 37 deletions(-) diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 468df6157..e407279ce 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -39,7 +39,6 @@ import Simplex.Messaging.Client proxyUsername, transportClientConfig, ) -import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding (smpDecode, smpEncode) diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs index 1dafc8108..c17790c2d 100644 --- a/src/Simplex/FileTransfer/Client/Agent.hs +++ b/src/Simplex/FileTransfer/Client/Agent.hs @@ -18,7 +18,6 @@ import Data.Text.Encoding (decodeUtf8) import Simplex.FileTransfer.Client import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError) -import Simplex.Messaging.Client.Agent () import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer) import Simplex.Messaging.TMap (TMap) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 30e1f0aa8..e59dee7a1 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -185,7 +185,6 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import Simplex.Messaging.Agent.TRcvQueues (TRcvQueues (getRcvQueues)) import qualified Simplex.Messaging.Agent.TRcvQueues as RQ import Simplex.Messaging.Client -import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index b753a4226..cd32d4e8a 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -54,7 +54,6 @@ import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Client -import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange) import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index 4aaa5f278..1e2c7cb00 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -33,7 +33,6 @@ import Simplex.Messaging.Agent.Protocol (ACommand (..), APartyCmd (..), AgentErr import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite -import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..)) import Simplex.Messaging.Notifications.Types diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index 4b925c6f6..2ade2d24f 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -8,7 +8,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Simplex.Messaging.Client.Agent where @@ -19,7 +18,6 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Trans.Except -import Control.Monad.Trans.Reader import Crypto.Random (ChaChaDRG) import Data.Bifunctor (bimap, first) import Data.ByteString.Char8 (ByteString) @@ -47,8 +45,6 @@ import Simplex.Messaging.Transport import Simplex.Messaging.Util (catchAll_, toChunks, ($>>=)) import System.Timeout (timeout) import UnliftIO (async) -import UnliftIO.Exception (Exception) -import qualified UnliftIO.Exception as E import UnliftIO.STM type SMPClientVar = SessionVar (Either SMPClientError SMPClient) @@ -105,31 +101,6 @@ data SMPClientAgent = SMPClientAgent workerSeq :: TVar Int } -newtype InternalException e = InternalException {unInternalException :: e} - deriving (Eq, Show) - -instance Exception e => Exception (InternalException e) - -instance Exception e => MonadUnliftIO (ExceptT e IO) where - {-# INLINE withRunInIO #-} - withRunInIO :: ((forall a. ExceptT e IO a -> IO a) -> IO b) -> ExceptT e IO b - withRunInIO inner = - ExceptT . fmap (first unInternalException) . E.try $ - withRunInIO $ \run -> - inner $ run . (either (E.throwIO . InternalException) pure <=< runExceptT) - --- as MonadUnliftIO instance for IO is `withRunInIO inner = inner id`, --- the last two lines could be replaced with: --- inner $ either (E.throwIO . InternalException) pure <=< runExceptT - -instance Exception e => MonadUnliftIO (ExceptT e (ReaderT r IO)) where - {-# INLINE withRunInIO #-} - withRunInIO :: ((forall a. ExceptT e (ReaderT r IO) a -> IO a) -> IO b) -> ExceptT e (ReaderT r IO) b - withRunInIO inner = - withExceptT unInternalException . ExceptT . E.try $ - withRunInIO $ \run -> - inner $ run . (either (E.throwIO . InternalException) pure <=< runExceptT) - newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> STM SMPClientAgent newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do msgQ <- newTBQueue msgQSize diff --git a/src/Simplex/Messaging/Crypto/File.hs b/src/Simplex/Messaging/Crypto/File.hs index 2787df58e..9608d21b7 100644 --- a/src/Simplex/Messaging/Crypto/File.hs +++ b/src/Simplex/Messaging/Crypto/File.hs @@ -31,7 +31,6 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust) -import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Lazy (LazyByteString) import qualified Simplex.Messaging.Crypto.Lazy as LC diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index bb1d34b10..72a62cbbf 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} @@ -54,6 +56,7 @@ import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Monad import Control.Monad.Except import Control.Monad.Reader +import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Either (isRight) @@ -65,7 +68,7 @@ import Data.Maybe (isJust, isNothing) import qualified Data.Set as S import Data.Time.Clock (diffUTCTime, getCurrentTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) -import Data.Type.Equality +import Data.Type.Equality (testEquality, (:~:) (Refl)) import Data.Word (Word16) import qualified Database.SQLite.Simple as SQL import GHC.Stack (withFrozenCallStack) @@ -2809,3 +2812,16 @@ exchangeGreetingsMsgIds alice bobId aliceMsgId bob aliceId bobMsgId = do get bob ##> ("", aliceId, SENT bobMsgId') get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False ackMessage alice bobId aliceMsgId' Nothing + +newtype InternalException e = InternalException {unInternalException :: e} + deriving (Eq, Show) + +instance Exception e => Exception (InternalException e) + +instance Exception e => MonadUnliftIO (ExceptT e IO) where + {-# INLINE withRunInIO #-} + withRunInIO :: ((forall a. ExceptT e IO a -> IO a) -> IO b) -> ExceptT e IO b + withRunInIO inner = + ExceptT . fmap (first unInternalException) . try $ + withRunInIO $ \run -> + inner $ run . (either (throwIO . InternalException) pure <=< runExceptT) diff --git a/tests/CoreTests/UtilTests.hs b/tests/CoreTests/UtilTests.hs index 9e413e838..2254ecafd 100644 --- a/tests/CoreTests/UtilTests.hs +++ b/tests/CoreTests/UtilTests.hs @@ -2,11 +2,11 @@ module CoreTests.UtilTests where +import AgentTests.FunctionalAPITests () import Control.Exception (Exception, SomeException, throwIO) import Control.Monad.Except import Control.Monad.IO.Class import Data.IORef -import Simplex.Messaging.Client.Agent () import Simplex.Messaging.Util import Test.Hspec import qualified UnliftIO.Exception as UE