From 3ad0bffaabcf297de2dc2354edce14b0e67be79b Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Wed, 13 Jan 2021 19:49:45 +0000
Subject: [PATCH] SMPClient returns errors via ExceptT (#13)

---
 package.yaml                    |  1 +
 src/Simplex/Messaging/Agent.hs  | 29 ++++++++++++-----------------
 src/Simplex/Messaging/Client.hs | 22 ++++++++++++----------
 3 files changed, 25 insertions(+), 27 deletions(-)

diff --git a/package.yaml b/package.yaml
index 41f50a010..58270289d 100644
--- a/package.yaml
+++ b/package.yaml
@@ -27,6 +27,7 @@ dependencies:
   - template-haskell == 2.15.*
   - text == 1.2.*
   - time == 1.9.*
+  - transformers == 0.5.*
   - unliftio == 0.2.*
   - unliftio-core == 0.1.*
 
diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs
index 2fd8dbeaf..b703ed6c4 100644
--- a/src/Simplex/Messaging/Agent.hs
+++ b/src/Simplex/Messaging/Agent.hs
@@ -14,6 +14,7 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
+import Data.Bifunctor (first)
 import qualified Data.Map as M
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Store
@@ -79,6 +80,15 @@ withStore action = do
     handleInternal :: (MonadError StoreError m') => SomeException -> m' a
     handleInternal _ = throwError SEInternal
 
+liftSMP :: (MonadUnliftIO m, MonadError ErrorType m) => ExceptT SMPClientError IO a -> m a
+liftSMP action =
+  liftIO (first smpClientError <$> runExceptT action) >>= liftEither
+  where
+    smpClientError :: SMPClientError -> ErrorType
+    smpClientError = \case
+      SMPServerError e -> SMP e
+      _ -> INTERNAL -- TODO handle other errors
+
 processCommand ::
   forall m.
   (MonadUnliftIO m, MonadReader Env m, MonadError ErrorType m) =>
@@ -97,10 +107,7 @@ processCommand AgentClient {sndQ, smpClients} (corrId, connAlias, cmd) =
       g <- asks idsDrg
       recipientKey <- atomically $ randomBytes 16 g -- TODO replace with cryptographic key pair
       let rcvPrivateKey = recipientKey
-      (recipientId, senderId) <-
-        liftIO (createSMPQueue c recipientKey)
-          `E.catch` smpClientError
-          `E.catch` replyError INTERNAL
+      (recipientId, senderId) <- liftSMP $ createSMPQueue c recipientKey
       encryptKey <- atomically $ randomBytes 16 g -- TODO replace with cryptographic key pair
       let decryptKey = encryptKey
       withStore $ \st ->
@@ -140,22 +147,10 @@ processCommand AgentClient {sndQ, smpClients} (corrId, connAlias, cmd) =
               status = New,
               ackMode = AckMode On
             }
-      liftIO (sendSMPMessage c "" senderId msg)
-        `E.catch` smpClientError
-      -- `E.catch` replyError INTERNAL
-      -- TODO the problem here is that while the intention of the 2nd catch was to catch
-      -- all other exceptions, because smpClientError "throwError" via left channel
-      -- and of how ExceptT instance of UnliftIO is implemented, the second `catch` catches
-      -- Left channel... The only solution is to use runtime exceptions and not ExceptT
+      liftSMP $ sendSMPMessage c "" senderId msg
       withStore $ \st -> updateQueueStatus st connAlias SND Confirmed
       respond OK
 
-    smpClientError :: SMPClientError -> m a
-    smpClientError = \case
-      SMPServerError e -> throwError $ SMP e
-      _ -> throwError INTERNAL
-    -- TODO
-
     replyError :: ErrorType -> SomeException -> m a
     replyError err e = do
       liftIO . putStrLn $ "Exception: " ++ show e -- TODO remove
diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs
index 9948c31a1..f13d33bad 100644
--- a/src/Simplex/Messaging/Client.hs
+++ b/src/Simplex/Messaging/Client.hs
@@ -21,6 +21,7 @@ import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
+import Control.Monad.Trans.Except
 import qualified Data.ByteString.Char8 as B
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
@@ -84,7 +85,10 @@ getSMPClient SMPServer {host, port} SMPClientConfig {qSize, defaultPort} = do
           modifyTVar sentCommands $ M.delete corrId
           putTMVar responseVar $
             if queueId == qId
-              then either (Left . SMPResponseError) Right respOrErr
+              then case respOrErr of
+                Left e -> Left $ SMPResponseError e
+                Right (Cmd _ (ERR e)) -> Left $ SMPServerError e
+                Right r -> Right r
               else Left SMPQueueIdError
 
 data SMPClientError
@@ -96,25 +100,23 @@ data SMPClientError
   | SMPClientError
   deriving (Eq, Show, Exception)
 
-createSMPQueue :: SMPClient -> RecipientKey -> IO (RecipientId, SenderId)
+createSMPQueue :: SMPClient -> RecipientKey -> ExceptT SMPClientError IO (RecipientId, SenderId)
 createSMPQueue c rKey = do
   sendSMPCommand c "" "" (Cmd SRecipient $ NEW rKey) >>= \case
     Cmd _ (IDS rId sId) -> return (rId, sId)
-    Cmd _ (ERR e) -> throwIO $ SMPServerError e
-    _ -> throwIO SMPUnexpectedResponse
+    _ -> throwE SMPUnexpectedResponse
 
-sendSMPMessage :: SMPClient -> SenderKey -> QueueId -> MsgBody -> IO ()
+sendSMPMessage :: SMPClient -> SenderKey -> QueueId -> MsgBody -> ExceptT SMPClientError IO ()
 sendSMPMessage c sKey qId msg = do
   sendSMPCommand c sKey qId (Cmd SSender $ SEND msg) >>= \case
     Cmd _ OK -> return ()
-    Cmd _ (ERR e) -> throwIO $ SMPServerError e
-    _ -> throwIO SMPUnexpectedResponse
+    _ -> throwE SMPUnexpectedResponse
 
-sendSMPCommand :: SMPClient -> PrivateKey -> QueueId -> Cmd -> IO Cmd
-sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId} pKey qId cmd = do
+sendSMPCommand :: SMPClient -> PrivateKey -> QueueId -> Cmd -> ExceptT SMPClientError IO Cmd
+sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId} pKey qId cmd = ExceptT $ do
   corrId <- atomically getNextCorrId
   t <- signTransmission (corrId, qId, cmd)
-  atomically (send corrId t) >>= atomically . takeTMVar >>= either throwIO return
+  atomically (send corrId t) >>= atomically . takeTMVar
   where
     getNextCorrId :: STM CorrId
     getNextCorrId = do