diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 4fb18c27a..e4a64c0c9 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -41,7 +41,6 @@ import Simplex.Messaging.Client transportClientConfig, unexpectedResponse, ) -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 a2d7b5f59..32297713a 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -197,7 +197,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 30b2b566a..63aa652ac 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 f27de3667..bd878ada7 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -9,7 +9,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Simplex.Messaging.Client.Agent where @@ -21,7 +20,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) @@ -50,7 +48,6 @@ import Simplex.Messaging.Transport import Simplex.Messaging.Util (catchAll_, ifM, toChunks, whenM, ($>>=)) import System.Timeout (timeout) import UnliftIO (async) -import UnliftIO.Exception (Exception) import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -114,31 +111,6 @@ data SMPClientAgent = SMPClientAgent type OwnServer = Bool -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 active <- newTVar True 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/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 #-} diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 2ece3e7b9..6e5e09fc3 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 #-} @@ -55,6 +57,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) @@ -66,7 +69,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) @@ -2806,3 +2809,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