diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 24fc0fa50..ab3931a1f 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index f215bbb75..597eb3148 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -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 diff --git a/src/Simplex/Messaging/Parsers.hs b/src/Simplex/Messaging/Parsers.hs index b73f0aff0..1d4e1c3a4 100644 --- a/src/Simplex/Messaging/Parsers.hs +++ b/src/Simplex/Messaging/Parsers.hs @@ -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 + } diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index c1e688001..0705ad697 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -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 diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 8cc1b7e57..398bf0a62 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -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 diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index 8057b4967..d91c596b9 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} module Simplex.Messaging.Transport.Server diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 2bdc2e2a4..e214aafc4 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -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 diff --git a/tests/CoreTests/ProtocolErrorTests.hs b/tests/CoreTests/ProtocolErrorTests.hs index 2a673714a..bb57529f5 100644 --- a/tests/CoreTests/ProtocolErrorTests.hs +++ b/tests/CoreTests/ProtocolErrorTests.hs @@ -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)