diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 88afea56b..11243b4e0 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/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 - PCEResponseError _ -> PROXY RESPONSE - PCEUnexpectedResponse _ -> PROXY UNEXPECTED + PCEProtocolError et -> PROXY (PROTOCOL et) + PCEResponseError et -> PROXY (RESPONSE et) + 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 diff --git a/src/Simplex/Messaging/Encoding/String.hs b/src/Simplex/Messaging/Encoding/String.hs index fcefdc73d..6b9fb5624 100644 --- a/src/Simplex/Messaging/Encoding/String.hs +++ b/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 diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 3ad510481..fafd8a340 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/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} - | UNEXPECTED + RESPONSE {responseErr :: ErrorType} + | 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" - RESPONSE -> "RESPONSE" - UNEXPECTED -> "UNEXPECTED" + PROTOCOL et -> "PROTOCOL " <> smpEncode et + RESPONSE et -> "RESPONSE " <> smpEncode et + 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 - "RESPONSE" -> pure RESPONSE - "UNEXPECTED" -> pure UNEXPECTED + "PROTOCOL" -> PROTOCOL <$> _smpP + "RESPONSE" -> RESPONSE <$> _smpP + "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) - -$(J.deriveJSON (sumTypeJSON id) ''ErrorType) +-- run deriveJSON in one TH splice to allow mutual instance +$(concat <$> mapM @[] (J.deriveJSON (sumTypeJSON id)) [''ProxyError, ''ErrorType]) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 959339fad..b4c9722f7 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -632,7 +632,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 diff --git a/tests/CoreTests/ProtocolErrorTests.hs b/tests/CoreTests/ProtocolErrorTests.hs index a486e6549..8f5ad70e7 100644 --- a/tests/CoreTests/ProtocolErrorTests.hs +++ b/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) -> - errHasSpaces err - || strDecode (strEncode err) == Right err + it "should parse SMP agent errors" . property . forAll possible $ \err -> + strDecode (strEncode err) == Right err where - errHasSpaces = \case - BROKER srv (Agent.RESPONSE e) -> hasSpaces srv || hasSpaces e - BROKER srv _ -> hasSpaces srv - _ -> False + possible :: Gen AgentErrorType + possible = + arbitrary >>= \case + 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