catch IOErrors in getRelay

src/Simplex/Messaging/Agent/Client.hs

@@ -1142,6 +1142,8 @@ temporaryAgentError :: AgentErrorType -> Bool
 temporaryAgentError = \case
   BROKER _ NETWORK -> True
   BROKER _ TIMEOUT -> True
+  SMP (SMP.PROXY SMP.TIMEOUT) -> True
+  NTF (SMP.PROXY SMP.TIMEOUT) -> True
   INACTIVE -> True
   _ -> False
 {-# INLINE temporaryAgentError #-}

src/Simplex/Messaging/Client.hs

@@ -484,16 +484,15 @@ temporaryClientError = \case
   _ -> False
 {-# INLINE temporaryClientError #-}
 
--- TODO keep error params
 smpProxyError :: SMPClientError -> ErrorType
 smpProxyError = \case
-  PCEProtocolError _ -> PROXY PROTOCOL
+  PCEProtocolError et -> PROXY (PROTOCOL et)
-  PCEResponseError _ -> PROXY RESPONSE
+  PCEResponseError et -> PROXY (RESPONSE et)
-  PCEUnexpectedResponse _ -> PROXY UNEXPECTED
+  PCEUnexpectedResponse bs -> PROXY (UNEXPECTED $ B.unpack $ B.take 32 bs)
   PCEResponseTimeout -> PROXY TIMEOUT
   PCENetworkError -> PROXY NETWORK
   PCEIncompatibleHost -> PROXY BAD_HOST
-  PCETransportError _ -> PROXY TRANSPORT
+  PCETransportError t -> PROXY (TRANSPORT t)
   PCECryptoError _ -> INTERNAL
   PCEIOError _ -> INTERNAL
 

src/Simplex/Messaging/Encoding/String.hs

@@ -75,6 +75,8 @@ instance StrEncoding Str where
   strEncode = unStr
   strP = Str <$> A.takeTill (== ' ') <* optional A.space
 
+-- inherited from ByteString, the parser only allows non-empty strings
+-- only Char8 elements may round-trip as B.pack truncates unicode
 instance StrEncoding String where
   strEncode = strEncode . B.pack
   strP = B.unpack <$> strP

src/Simplex/Messaging/Protocol.hs

@@ -195,6 +195,8 @@ import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (isJust, isNothing)
 import Data.String
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock.System (SystemTime (..))
 import Data.Type.Equality
 import Data.Word (Word16)
@@ -210,7 +212,7 @@ import Simplex.Messaging.Parsers
 import Simplex.Messaging.ServiceScheme
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
-import Simplex.Messaging.Util (bshow, eitherToMaybe, (<$?>))
+import Simplex.Messaging.Util (bshow, eitherToMaybe, safeDecodeUtf8, (<$?>))
 import Simplex.Messaging.Version
 import Simplex.Messaging.Version.Internal
 
@@ -1167,11 +1169,11 @@ data ErrorType
 instance StrEncoding ErrorType where
   strEncode = \case
     CMD e -> "CMD " <> bshow e
-    PROXY e -> "PROXY " <> bshow e
+    PROXY e -> "PROXY " <> strEncode e
     e -> bshow e
   strP =
     "CMD " *> (CMD <$> parseRead1)
-      <|> "PROXY " *> (PROXY <$> parseRead1)
+      <|> "PROXY " *> (PROXY <$> strP)
       <|> parseRead1
 
 -- | SMP command error type.
@@ -1190,20 +1192,19 @@ data CommandError
     NO_ENTITY
   deriving (Eq, Read, Show)
 
--- TODO keep error params
 data ProxyError
   = -- | Correctly parsed SMP server ERR response.
     -- This error is forwarded to the agent client as `ERR SMP err`.
-    PROTOCOL -- {protocolErr :: String}
+    PROTOCOL {protocolErr :: ErrorType}
   | -- | Invalid server response that failed to parse.
     -- Forwarded to the agent client as `ERR BROKER RESPONSE`.
-    RESPONSE -- {responseErr :: String}
+    RESPONSE {responseErr :: ErrorType}
-  | UNEXPECTED
+  | UNEXPECTED {unexpectedResponse :: String} -- 'String' for using derived JSON and Arbitrary instances
   | TIMEOUT
   | NETWORK
   | BAD_HOST
   | NO_SESSION
-  | TRANSPORT -- {transportErr :: TransportError}
+  | TRANSPORT {transportErr :: TransportError}
   deriving (Eq, Read, Show)
 
 -- | SMP transmission parser.
@@ -1473,26 +1474,42 @@ instance Encoding CommandError where
 
 instance Encoding ProxyError where
   smpEncode e = case e of
-    PROTOCOL -> "PROTOCOL"
+    PROTOCOL et -> "PROTOCOL " <> smpEncode et
-    RESPONSE -> "RESPONSE"
+    RESPONSE et -> "RESPONSE " <> smpEncode et
-    UNEXPECTED -> "UNEXPECTED"
+    UNEXPECTED s -> "UNEXPECTED " <> smpEncode (encodeUtf8 $ T.pack s)
     TIMEOUT -> "TIMEOUT"
     NETWORK -> "NETWORK"
     BAD_HOST -> "BAD_HOST"
     NO_SESSION -> "NO_SESSION"
-    TRANSPORT -> "TRANSPORT"
+    TRANSPORT t -> "TRANSPORT " <> serializeTransportError t
   smpP =
     A.takeTill (== ' ') >>= \case
-      "PROTOCOL" -> pure PROTOCOL
+      "PROTOCOL" -> PROTOCOL <$> _smpP
-      "RESPONSE" -> pure RESPONSE
+      "RESPONSE" -> RESPONSE <$> _smpP
-      "UNEXPECTED" -> pure UNEXPECTED
+      "UNEXPECTED" -> UNEXPECTED . (T.unpack . safeDecodeUtf8) <$> _smpP
       "TIMEOUT" -> pure TIMEOUT
       "NETWORK" -> pure NETWORK
       "BAD_HOST" -> pure BAD_HOST
       "NO_SESSION" -> pure NO_SESSION
-      "TRANSPORT" -> pure TRANSPORT
+      "TRANSPORT" -> TRANSPORT <$> (A.space *> transportErrorP)
       _ -> fail "bad command error type"
 
+instance StrEncoding ProxyError where
+  strEncode = \case
+    PROTOCOL et -> "PROTOCOL " <> strEncode et
+    RESPONSE et -> "RESPONSE " <> strEncode et
+    UNEXPECTED "" -> "UNEXPECTED" -- Arbitrary instance generates empty strings which String instance can't handle
+    UNEXPECTED s -> "UNEXPECTED " <> strEncode s
+    TRANSPORT t -> "TRANSPORT " <> serializeTransportError t
+    e -> bshow e
+  strP =
+    "PROTOCOL " *> (PROTOCOL <$> strP)
+      <|> "RESPONSE " *> (RESPONSE <$> strP)
+      <|> "UNEXPECTED " *> (UNEXPECTED <$> strP)
+      <|> "UNEXPECTED" $> UNEXPECTED ""
+      <|> "TRANSPORT " *> (TRANSPORT <$> transportErrorP)
+      <|> parseRead1
+
 -- | Send signed SMP transmission to TCP transport.
 tPut :: Transport c => THandle v c p -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
 tPut th@THandle {params} = fmap concat . mapM tPutBatch . batchTransmissions (batch params) (blockSize params)
@@ -1630,6 +1647,5 @@ $(J.deriveJSON defaultJSON ''MsgFlags)
 
 $(J.deriveJSON (sumTypeJSON id) ''CommandError)
 
-$(J.deriveJSON (sumTypeJSON id) ''ProxyError)
+-- run deriveJSON in one TH splice to allow mutual instance
-
+$(concat <$> mapM @[] (J.deriveJSON (sumTypeJSON id)) [''ProxyError, ''ErrorType])
-$(J.deriveJSON (sumTypeJSON id) ''ErrorType)

src/Simplex/Messaging/Server.hs

@@ -68,7 +68,7 @@ import GHC.Stats (getRTSStats)
 import GHC.TypeLits (KnownNat)
 import Network.Socket (ServiceName, Socket, socketToHandle)
 import Simplex.Messaging.Agent.Lock
-import Simplex.Messaging.Client (ProtocolClient (thParams), forwardSMPMessage, smpProxyError)
+import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (PCEIOError), forwardSMPMessage, smpProxyError)
 import Simplex.Messaging.Client.Agent (SMPClientAgent (..), SMPClientAgentEvent (..), getSMPServerClient', lookupSMPServerClient)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -623,8 +623,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
             pure $ allowSMPProxy && maybe True ((== auth) . Just) newQueueBasicAuth
           getRelay = do
             ProxyAgent {smpAgent} <- asks proxyAgent
-            -- TODO catch IO errors too
+            liftIO $ proxyResp <$> runExceptT (getSMPServerClient' smpAgent srv) `catch` (pure . Left . PCEIOError)
-            liftIO $ proxyResp <$> runExceptT (getSMPServerClient' smpAgent srv)
             where
               proxyResp = \case
                 Right smp ->
@@ -632,7 +631,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
                       vr = supportedServerSMPRelayVRange
                    in case thAuth of
                         Just THAuthClient {serverCertKey} -> PKEY srvSessId vr serverCertKey
-                        Nothing -> ERR $ PROXY TRANSPORT -- TODO different error?
+                        Nothing -> ERR $ PROXY (TRANSPORT TENoServerAuth)
                 Left err -> ERR $ smpProxyError err
       PFWD pubKey encBlock -> do
         ProxyAgent {smpAgent} <- asks proxyAgent

tests/CoreTests/ProtocolErrorTests.hs

@@ -17,6 +17,7 @@ import qualified Simplex.Messaging.Agent.Protocol as Agent
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (CommandError (..), ErrorType (..), ProxyError (..))
+import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport (HandshakeError (..), TransportError (..))
 import Simplex.RemoteControl.Types (RCErrorType (..))
 import Test.Hspec
@@ -28,15 +29,19 @@ protocolErrorTests = modifyMaxSuccess (const 1000) $ do
   describe "errors parsing / serializing" $ do
     it "should parse SMP protocol errors" . property $ \(err :: ErrorType) ->
       smpDecode (smpEncode err) == Right err
-    it "should parse SMP agent errors" . property $ \(err :: AgentErrorType) ->
+    it "should parse SMP agent errors" . property . forAll possible $ \err ->
-      errHasSpaces err
+      strDecode (strEncode err) == Right err
-        || strDecode (strEncode err) == Right err
   where
-    errHasSpaces = \case
+    possible :: Gen AgentErrorType
-      BROKER srv (Agent.RESPONSE e) -> hasSpaces srv || hasSpaces e
+    possible =
-      BROKER srv _ -> hasSpaces srv
+      arbitrary >>= \case
-      _ -> False
+        BROKER srv (Agent.RESPONSE e) | hasSpaces srv || hasSpaces e -> discard
+        BROKER srv _ | hasSpaces srv -> discard
+        SMP (PROXY (SMP.UNEXPECTED s)) | hasUnicode s -> discard
+        NTF (PROXY (SMP.UNEXPECTED s)) | hasUnicode s -> discard
+        ok -> pure ok
     hasSpaces s = ' ' `B.elem` encodeUtf8 (T.pack s)
+    hasUnicode = any (>= '\255')
 
 deriving instance Generic AgentErrorType