JSON encoding of types used in simplex-chat (#311)
* JSON encoding of types used in simplex-chat * add field names for JSON encodings, encode all error sum-types as objects (to allow extension)
This commit is contained in:
parent
2b857876b4
commit
6fe3bfa980
|
@ -83,16 +83,10 @@ module Simplex.Messaging.Agent.Protocol
|
|||
|
||||
-- * Encode/decode
|
||||
serializeCommand,
|
||||
serializeMsgIntegrity,
|
||||
connMode,
|
||||
connMode',
|
||||
serializeAgentError,
|
||||
serializeSmpErrorType,
|
||||
commandP,
|
||||
connModeT,
|
||||
msgIntegrityP,
|
||||
agentErrorTypeP,
|
||||
smpErrorTypeP,
|
||||
serializeQueueStatus,
|
||||
queueStatusT,
|
||||
aMessageType,
|
||||
|
@ -108,6 +102,7 @@ where
|
|||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Base64
|
||||
|
@ -131,7 +126,7 @@ import qualified Simplex.Messaging.Crypto as C
|
|||
import Simplex.Messaging.Crypto.Ratchet (E2ERatchetParams, E2ERatchetParamsUri)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (base64P, parse, parseRead, parseRead1, parseRead2, tsISO8601P)
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol
|
||||
( ErrorType,
|
||||
MsgBody,
|
||||
|
@ -305,7 +300,7 @@ data AgentMsgEnvelope
|
|||
}
|
||||
| AgentInvitation -- the connInfo in contactInvite is only encrypted with per-queue E2E, not with double ratchet,
|
||||
{ agentVersion :: Version,
|
||||
connReq :: (ConnectionRequestUri 'CMInvitation),
|
||||
connReq :: ConnectionRequestUri 'CMInvitation,
|
||||
connInfo :: ByteString -- this message is only encrypted with per-queue E2E, not with double ratchet,
|
||||
}
|
||||
deriving (Show)
|
||||
|
@ -618,29 +613,70 @@ queueStatusT = \case
|
|||
type AgentMsgId = Int64
|
||||
|
||||
-- | Result of received message integrity validation.
|
||||
data MsgIntegrity = MsgOk | MsgError MsgErrorType
|
||||
deriving (Eq, Show)
|
||||
data MsgIntegrity = MsgOk | MsgError {errorInfo :: MsgErrorType}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance StrEncoding MsgIntegrity where
|
||||
strP = "OK" $> MsgOk <|> "ERR " *> (MsgError <$> strP)
|
||||
strEncode = \case
|
||||
MsgOk -> "OK"
|
||||
MsgError e -> "ERR" <> strEncode e
|
||||
|
||||
instance ToJSON MsgIntegrity where
|
||||
toJSON = J.genericToJSON $ sumTypeJSON fstToLower
|
||||
toEncoding = J.genericToEncoding $ sumTypeJSON fstToLower
|
||||
|
||||
instance FromJSON MsgIntegrity where
|
||||
parseJSON = J.genericParseJSON $ sumTypeJSON fstToLower
|
||||
|
||||
-- | Error of message integrity validation.
|
||||
data MsgErrorType = MsgSkipped AgentMsgId AgentMsgId | MsgBadId AgentMsgId | MsgBadHash | MsgDuplicate
|
||||
deriving (Eq, Show)
|
||||
data MsgErrorType
|
||||
= MsgSkipped {fromMsgId :: AgentMsgId, toMsgId :: AgentMsgId}
|
||||
| MsgBadId {msgId :: AgentMsgId}
|
||||
| MsgBadHash
|
||||
| MsgDuplicate
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance StrEncoding MsgErrorType where
|
||||
strP =
|
||||
"ID " *> (MsgBadId <$> A.decimal)
|
||||
<|> "IDS " *> (MsgSkipped <$> A.decimal <* A.space <*> A.decimal)
|
||||
<|> "HASH" $> MsgBadHash
|
||||
<|> "DUPLICATE" $> MsgDuplicate
|
||||
strEncode = \case
|
||||
MsgSkipped fromMsgId toMsgId ->
|
||||
B.unwords ["NO_ID", bshow fromMsgId, bshow toMsgId]
|
||||
MsgBadId aMsgId -> "ID " <> bshow aMsgId
|
||||
MsgBadHash -> "HASH"
|
||||
MsgDuplicate -> "DUPLICATE"
|
||||
|
||||
instance ToJSON MsgErrorType where
|
||||
toJSON = J.genericToJSON $ sumTypeJSON fstToLower
|
||||
toEncoding = J.genericToEncoding $ sumTypeJSON fstToLower
|
||||
|
||||
instance FromJSON MsgErrorType where
|
||||
parseJSON = J.genericParseJSON $ sumTypeJSON fstToLower
|
||||
|
||||
-- | Error type used in errors sent to agent clients.
|
||||
data AgentErrorType
|
||||
= -- | command or response error
|
||||
CMD CommandErrorType
|
||||
CMD {cmdErr :: CommandErrorType}
|
||||
| -- | connection errors
|
||||
CONN ConnectionErrorType
|
||||
CONN {connErr :: ConnectionErrorType}
|
||||
| -- | SMP protocol errors forwarded to agent clients
|
||||
SMP ErrorType
|
||||
SMP {smpErr :: ErrorType}
|
||||
| -- | SMP server errors
|
||||
BROKER BrokerErrorType
|
||||
BROKER {brokerErr :: BrokerErrorType}
|
||||
| -- | errors of other agents
|
||||
AGENT SMPAgentError
|
||||
AGENT {agentErr :: SMPAgentError}
|
||||
| -- | agent implementation or dependency errors
|
||||
INTERNAL String
|
||||
INTERNAL {internalErr :: String}
|
||||
deriving (Eq, Generic, Read, Show, Exception)
|
||||
|
||||
instance ToJSON AgentErrorType where
|
||||
toJSON = J.genericToJSON $ sumTypeJSON id
|
||||
toEncoding = J.genericToEncoding $ sumTypeJSON id
|
||||
|
||||
-- | SMP agent protocol command or response error.
|
||||
data CommandErrorType
|
||||
= -- | command is prohibited in this context
|
||||
|
@ -655,6 +691,10 @@ data CommandErrorType
|
|||
LARGE
|
||||
deriving (Eq, Generic, Read, Show, Exception)
|
||||
|
||||
instance ToJSON CommandErrorType where
|
||||
toJSON = J.genericToJSON $ sumTypeJSON id
|
||||
toEncoding = J.genericToEncoding $ sumTypeJSON id
|
||||
|
||||
-- | Connection error.
|
||||
data ConnectionErrorType
|
||||
= -- | connection is not in the database
|
||||
|
@ -669,20 +709,28 @@ data ConnectionErrorType
|
|||
NOT_AVAILABLE
|
||||
deriving (Eq, Generic, Read, Show, Exception)
|
||||
|
||||
instance ToJSON ConnectionErrorType where
|
||||
toJSON = J.genericToJSON $ sumTypeJSON id
|
||||
toEncoding = J.genericToEncoding $ sumTypeJSON id
|
||||
|
||||
-- | SMP server errors.
|
||||
data BrokerErrorType
|
||||
= -- | invalid server response (failed to parse)
|
||||
RESPONSE ErrorType
|
||||
RESPONSE {smpErr :: ErrorType}
|
||||
| -- | unexpected response
|
||||
UNEXPECTED
|
||||
| -- | network error
|
||||
NETWORK
|
||||
| -- | handshake or other transport error
|
||||
TRANSPORT TransportError
|
||||
TRANSPORT {transportErr :: TransportError}
|
||||
| -- | command response timeout
|
||||
TIMEOUT
|
||||
deriving (Eq, Generic, Read, Show, Exception)
|
||||
|
||||
instance ToJSON BrokerErrorType where
|
||||
toJSON = J.genericToJSON $ sumTypeJSON id
|
||||
toEncoding = J.genericToEncoding $ sumTypeJSON id
|
||||
|
||||
-- | Errors of another SMP agent.
|
||||
-- TODO encode/decode without A prefix
|
||||
data SMPAgentError
|
||||
|
@ -696,6 +744,30 @@ data SMPAgentError
|
|||
A_ENCRYPTION
|
||||
deriving (Eq, Generic, Read, Show, Exception)
|
||||
|
||||
instance ToJSON SMPAgentError where
|
||||
toJSON = J.genericToJSON $ sumTypeJSON id
|
||||
toEncoding = J.genericToEncoding $ sumTypeJSON id
|
||||
|
||||
instance StrEncoding AgentErrorType where
|
||||
strP =
|
||||
"CMD " *> (CMD <$> parseRead1)
|
||||
<|> "CONN " *> (CONN <$> parseRead1)
|
||||
<|> "SMP " *> (SMP <$> strP)
|
||||
<|> "BROKER RESPONSE " *> (BROKER . RESPONSE <$> strP)
|
||||
<|> "BROKER TRANSPORT " *> (BROKER . TRANSPORT <$> transportErrorP)
|
||||
<|> "BROKER " *> (BROKER <$> parseRead1)
|
||||
<|> "AGENT " *> (AGENT <$> parseRead1)
|
||||
<|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString)
|
||||
strEncode = \case
|
||||
CMD e -> "CMD " <> bshow e
|
||||
CONN e -> "CONN " <> bshow e
|
||||
SMP e -> "SMP " <> strEncode e
|
||||
BROKER (RESPONSE e) -> "BROKER RESPONSE " <> strEncode e
|
||||
BROKER (TRANSPORT e) -> "BROKER TRANSPORT " <> serializeTransportError e
|
||||
BROKER e -> "BROKER " <> bshow e
|
||||
AGENT e -> "AGENT " <> bshow e
|
||||
INTERNAL e -> "INTERNAL " <> bshow e
|
||||
|
||||
instance Arbitrary AgentErrorType where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary CommandErrorType where arbitrary = genericArbitraryU
|
||||
|
@ -746,27 +818,17 @@ commandP =
|
|||
sendCmd = ACmd SClient . SEND <$> A.takeByteString
|
||||
msgIdResp = ACmd SAgent . MID <$> A.decimal
|
||||
sentResp = ACmd SAgent . SENT <$> A.decimal
|
||||
msgErrResp = ACmd SAgent .: MERR <$> A.decimal <* A.space <*> agentErrorTypeP
|
||||
msgErrResp = ACmd SAgent .: MERR <$> A.decimal <* A.space <*> strP
|
||||
message = ACmd SAgent .: MSG <$> msgMetaP <* A.space <*> A.takeByteString
|
||||
ackCmd = ACmd SClient . ACK <$> A.decimal
|
||||
msgMetaP = do
|
||||
integrity <- msgIntegrityP
|
||||
integrity <- strP
|
||||
recipient <- " R=" *> partyMeta A.decimal
|
||||
broker <- " B=" *> partyMeta base64P
|
||||
sndMsgId <- " S=" *> A.decimal
|
||||
pure MsgMeta {integrity, recipient, broker, sndMsgId}
|
||||
partyMeta idParser = (,) <$> idParser <* A.char ',' <*> tsISO8601P
|
||||
agentError = ACmd SAgent . ERR <$> agentErrorTypeP
|
||||
|
||||
-- | Message integrity validation result parser.
|
||||
msgIntegrityP :: Parser MsgIntegrity
|
||||
msgIntegrityP = "OK" $> MsgOk <|> "ERR " *> (MsgError <$> msgErrorType)
|
||||
where
|
||||
msgErrorType =
|
||||
"ID " *> (MsgBadId <$> A.decimal)
|
||||
<|> "IDS " *> (MsgSkipped <$> A.decimal <* A.space <*> A.decimal)
|
||||
<|> "HASH" $> MsgBadHash
|
||||
<|> "DUPLICATE" $> MsgDuplicate
|
||||
agentError = ACmd SAgent . ERR <$> strP
|
||||
|
||||
parseCommand :: ByteString -> Either AgentErrorType ACmd
|
||||
parseCommand = parse commandP $ CMD SYNTAX
|
||||
|
@ -790,13 +852,13 @@ serializeCommand = \case
|
|||
SEND msgBody -> "SEND " <> serializeBinary msgBody
|
||||
MID mId -> "MID " <> bshow mId
|
||||
SENT mId -> "SENT " <> bshow mId
|
||||
MERR mId e -> B.unwords ["MERR", bshow mId, serializeAgentError e]
|
||||
MERR mId e -> B.unwords ["MERR", bshow mId, strEncode e]
|
||||
MSG msgMeta msgBody -> B.unwords ["MSG", serializeMsgMeta msgMeta, serializeBinary msgBody]
|
||||
ACK mId -> "ACK " <> bshow mId
|
||||
OFF -> "OFF"
|
||||
DEL -> "DEL"
|
||||
CON -> "CON"
|
||||
ERR e -> "ERR " <> serializeAgentError e
|
||||
ERR e -> "ERR " <> strEncode e
|
||||
OK -> "OK"
|
||||
where
|
||||
showTs :: UTCTime -> ByteString
|
||||
|
@ -804,49 +866,12 @@ serializeCommand = \case
|
|||
serializeMsgMeta :: MsgMeta -> ByteString
|
||||
serializeMsgMeta MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId} =
|
||||
B.unwords
|
||||
[ serializeMsgIntegrity integrity,
|
||||
[ strEncode integrity,
|
||||
"R=" <> bshow rmId <> "," <> showTs rTs,
|
||||
"B=" <> encode bmId <> "," <> showTs bTs,
|
||||
"S=" <> bshow sndMsgId
|
||||
]
|
||||
|
||||
-- | Serialize message integrity validation result.
|
||||
serializeMsgIntegrity :: MsgIntegrity -> ByteString
|
||||
serializeMsgIntegrity = \case
|
||||
MsgOk -> "OK"
|
||||
MsgError e ->
|
||||
"ERR " <> case e of
|
||||
MsgSkipped fromMsgId toMsgId ->
|
||||
B.unwords ["NO_ID", bshow fromMsgId, bshow toMsgId]
|
||||
MsgBadId aMsgId -> "ID " <> bshow aMsgId
|
||||
MsgBadHash -> "HASH"
|
||||
MsgDuplicate -> "DUPLICATE"
|
||||
|
||||
-- | SMP agent protocol error parser.
|
||||
agentErrorTypeP :: Parser AgentErrorType
|
||||
agentErrorTypeP =
|
||||
"SMP " *> (SMP <$> smpErrorTypeP)
|
||||
<|> "BROKER RESPONSE " *> (BROKER . RESPONSE <$> smpErrorTypeP)
|
||||
<|> "BROKER TRANSPORT " *> (BROKER . TRANSPORT <$> transportErrorP)
|
||||
<|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString)
|
||||
<|> parseRead2
|
||||
|
||||
-- | Serialize SMP agent protocol error.
|
||||
serializeAgentError :: AgentErrorType -> ByteString
|
||||
serializeAgentError = \case
|
||||
SMP e -> "SMP " <> serializeSmpErrorType e
|
||||
BROKER (RESPONSE e) -> "BROKER RESPONSE " <> serializeSmpErrorType e
|
||||
BROKER (TRANSPORT e) -> "BROKER TRANSPORT " <> serializeTransportError e
|
||||
e -> bshow e
|
||||
|
||||
-- | SMP error parser.
|
||||
smpErrorTypeP :: Parser ErrorType
|
||||
smpErrorTypeP = "CMD " *> (SMP.CMD <$> parseRead1) <|> parseRead1
|
||||
|
||||
-- | Serialize SMP error.
|
||||
serializeSmpErrorType :: ErrorType -> ByteString
|
||||
serializeSmpErrorType = bshow
|
||||
|
||||
serializeBinary :: ByteString -> ByteString
|
||||
serializeBinary body = bshow (B.length body) <> "\n" <> body
|
||||
|
||||
|
|
|
@ -569,9 +569,9 @@ instance ToField AMsgType where toField = toField . smpEncode
|
|||
|
||||
instance FromField AMsgType where fromField = blobFieldParser smpP
|
||||
|
||||
instance ToField MsgIntegrity where toField = toField . serializeMsgIntegrity
|
||||
instance ToField MsgIntegrity where toField = toField . strEncode
|
||||
|
||||
instance FromField MsgIntegrity where fromField = blobFieldParser msgIntegrityP
|
||||
instance FromField MsgIntegrity where fromField = blobFieldParser strP
|
||||
|
||||
instance ToField SMPQueueUri where toField = toField . strEncode
|
||||
|
||||
|
|
|
@ -4,13 +4,14 @@
|
|||
module Simplex.Messaging.Parsers where
|
||||
|
||||
import Control.Monad.Trans.Except
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString.Base64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (isAlphaNum)
|
||||
import Data.Char (isAlphaNum, toLower)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Time.ISO8601 (parseISO8601)
|
||||
import Data.Typeable (Typeable)
|
||||
|
@ -78,3 +79,20 @@ blobFieldDecoder dec = \case
|
|||
Right k -> Ok k
|
||||
Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
|
||||
f -> returnError ConversionFailed f "expecting SQLBlob column type"
|
||||
|
||||
fstToLower :: String -> String
|
||||
fstToLower "" = ""
|
||||
fstToLower (h : t) = toLower h : t
|
||||
|
||||
dropPrefix :: String -> String -> String
|
||||
dropPrefix pfx s =
|
||||
let (p, rest) = splitAt (length pfx) s
|
||||
in fstToLower $ if p == pfx then rest else s
|
||||
|
||||
sumTypeJSON :: (String -> String) -> J.Options
|
||||
sumTypeJSON tagModifier =
|
||||
J.defaultOptions
|
||||
{ J.sumEncoding = J.TaggedObject "type" "data",
|
||||
J.constructorTagModifier = tagModifier,
|
||||
J.omitNothingFields = True
|
||||
}
|
||||
|
|
|
@ -90,6 +90,8 @@ where
|
|||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Monad.Except
|
||||
import Data.Aeson (ToJSON (..))
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
|
@ -107,7 +109,7 @@ import Simplex.Messaging.Encoding
|
|||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Transport (THandle (..), Transport, TransportError (..), tGetBlock, tPutBlock)
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
import Simplex.Messaging.Util (bshow, (<$?>))
|
||||
import Simplex.Messaging.Version
|
||||
import Test.QuickCheck (Arbitrary (..))
|
||||
|
||||
|
@ -413,6 +415,15 @@ newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)
|
|||
instance IsString CorrId where
|
||||
fromString = CorrId . fromString
|
||||
|
||||
instance StrEncoding CorrId where
|
||||
strEncode (CorrId cId) = strEncode cId
|
||||
strDecode s = CorrId <$> strDecode s
|
||||
strP = CorrId <$> strP
|
||||
|
||||
instance ToJSON CorrId where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
-- | Queue IDs and keys
|
||||
data QueueIdsKeys = QIK
|
||||
{ rcvId :: RecipientId,
|
||||
|
@ -462,7 +473,7 @@ data ErrorType
|
|||
| -- | incorrect SMP session ID (TLS Finished message / tls-unique binding RFC5929)
|
||||
SESSION
|
||||
| -- | SMP command is unknown or has invalid syntax
|
||||
CMD CommandError
|
||||
CMD {cmdErr :: CommandError}
|
||||
| -- | command authorization error - bad signature or non-existing SMP queue
|
||||
AUTH
|
||||
| -- | SMP queue capacity is exceeded on the server
|
||||
|
@ -477,6 +488,16 @@ data ErrorType
|
|||
DUPLICATE_ -- TODO remove, not part of SMP protocol
|
||||
deriving (Eq, Generic, Read, Show)
|
||||
|
||||
instance ToJSON ErrorType where
|
||||
toJSON = J.genericToJSON $ sumTypeJSON id
|
||||
toEncoding = J.genericToEncoding $ sumTypeJSON id
|
||||
|
||||
instance StrEncoding ErrorType where
|
||||
strEncode = \case
|
||||
CMD e -> "CMD " <> bshow e
|
||||
e -> bshow e
|
||||
strP = "CMD " *> (CMD <$> parseRead1) <|> parseRead1
|
||||
|
||||
-- | SMP command error type.
|
||||
data CommandError
|
||||
= -- | unknown command
|
||||
|
@ -491,6 +512,10 @@ data CommandError
|
|||
NO_QUEUE
|
||||
deriving (Eq, Generic, Read, Show)
|
||||
|
||||
instance ToJSON CommandError where
|
||||
toJSON = J.genericToJSON $ sumTypeJSON id
|
||||
toEncoding = J.genericToEncoding $ sumTypeJSON id
|
||||
|
||||
instance Arbitrary ErrorType where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary CommandError where arbitrary = genericArbitraryU
|
||||
|
|
|
@ -61,6 +61,8 @@ where
|
|||
import Control.Applicative ((<|>))
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Data.Aeson (ToJSON)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Bitraversable (bimapM)
|
||||
|
@ -77,7 +79,7 @@ import qualified Network.TLS as T
|
|||
import qualified Network.TLS.Extra as TE
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Parsers (parse, parseRead1)
|
||||
import Simplex.Messaging.Parsers (dropPrefix, parse, parseRead1, sumTypeJSON)
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
import Simplex.Messaging.Version
|
||||
import Test.QuickCheck (Arbitrary (..))
|
||||
|
@ -287,9 +289,13 @@ data TransportError
|
|||
| -- | incorrect session ID
|
||||
TEBadSession
|
||||
| -- | transport handshake error
|
||||
TEHandshake HandshakeError
|
||||
TEHandshake {handshakeErr :: HandshakeError}
|
||||
deriving (Eq, Generic, Read, Show, Exception)
|
||||
|
||||
instance ToJSON TransportError where
|
||||
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "TE"
|
||||
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "TE"
|
||||
|
||||
-- | Transport handshake error.
|
||||
data HandshakeError
|
||||
= -- | parsing error
|
||||
|
@ -300,6 +306,10 @@ data HandshakeError
|
|||
IDENTITY
|
||||
deriving (Eq, Generic, Read, Show, Exception)
|
||||
|
||||
instance ToJSON HandshakeError where
|
||||
toJSON = J.genericToJSON $ sumTypeJSON id
|
||||
toEncoding = J.genericToEncoding $ sumTypeJSON id
|
||||
|
||||
instance Arbitrary TransportError where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary HandshakeError where arbitrary = genericArbitraryU
|
||||
|
|
|
@ -1,6 +1,5 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Messaging.Transport.Server
|
||||
|
|
|
@ -391,10 +391,10 @@ sendMessage (h1, name1) (h2, name2) msg = do
|
|||
("m1", name2', Right (MID mId)) <- h1 #: ("m1", name2, "SEND :" <> msg)
|
||||
name2' `shouldBe` name2
|
||||
h1 <#= \case ("", n, SENT m) -> n == name2 && m == mId; _ -> False
|
||||
("", name1', Right (MSG MsgMeta {recipient = (msgId, _)} msg')) <- (h2 <#:)
|
||||
("", name1', Right (MSG MsgMeta {recipient = (msgId', _)} msg')) <- (h2 <#:)
|
||||
name1' `shouldBe` name1
|
||||
msg' `shouldBe` msg
|
||||
h2 #: ("m2", name1, "ACK " <> bshow msgId) =#> \case ("m2", n, OK) -> n == name1; _ -> False
|
||||
h2 #: ("m2", name1, "ACK " <> bshow msgId') =#> \case ("m2", n, OK) -> n == name1; _ -> False
|
||||
|
||||
-- connect' :: forall c. Transport c => c -> c -> IO (ByteString, ByteString)
|
||||
-- connect' h1 h2 = do
|
||||
|
|
|
@ -1,8 +1,9 @@
|
|||
module CoreTests.ProtocolErrorTests where
|
||||
|
||||
import Simplex.Messaging.Agent.Protocol (AgentErrorType, agentErrorTypeP, serializeAgentError, serializeSmpErrorType, smpErrorTypeP)
|
||||
import Simplex.Messaging.Agent.Protocol (AgentErrorType)
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Protocol (ErrorType)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck (modifyMaxSuccess)
|
||||
import Test.QuickCheck
|
||||
|
@ -11,8 +12,8 @@ protocolErrorTests :: Spec
|
|||
protocolErrorTests = modifyMaxSuccess (const 1000) $ do
|
||||
describe "errors parsing / serializing" $ do
|
||||
it "should parse SMP protocol errors" . property $ \err ->
|
||||
parseAll smpErrorTypeP (serializeSmpErrorType err)
|
||||
parseAll strP (strEncode err)
|
||||
== Right (err :: ErrorType)
|
||||
it "should parse SMP agent errors" . property $ \err ->
|
||||
parseAll agentErrorTypeP (serializeAgentError err)
|
||||
parseAll strP (strEncode err)
|
||||
== Right (err :: AgentErrorType)
|
||||
|
|
Reference in New Issue