diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index a10917a61..7c8ee4cbf 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -361,6 +361,9 @@ instance ToJSON XFTPErrorType where toJSON = J.genericToJSON $ sumTypeJSON id toEncoding = J.genericToEncoding $ sumTypeJSON id +instance FromJSON XFTPErrorType where + parseJSON = J.genericParseJSON $ sumTypeJSON id + instance StrEncoding XFTPErrorType where strEncode = \case CMD e -> "CMD " <> bshow e diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 89849d246..dc7ea44fb 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -114,7 +115,7 @@ import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader import Crypto.Random (getRandomBytes) -import Data.Aeson (ToJSON) +import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J import Data.Bifunctor (bimap, first, second) import Data.ByteString.Base64 @@ -277,7 +278,7 @@ data AgentState = ASForeground | ASSuspending | ASSuspended deriving (Eq, Show) data AgentLocks = AgentLocks {connLocks :: Map String String, srvLocks :: Map String String, delLock :: Maybe String} - deriving (Show, Generic) + deriving (Show, Generic, FromJSON) instance ToJSON AgentLocks where toEncoding = J.genericToEncoding J.defaultOptions @@ -728,16 +729,17 @@ instance ToJSON ProtocolTestStep where toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "TS" toJSON = J.genericToJSON . enumJSON $ dropPrefix "TS" +instance FromJSON ProtocolTestStep where + parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "TS" + data ProtocolTestFailure = ProtocolTestFailure { testStep :: ProtocolTestStep, testError :: AgentErrorType } - deriving (Eq, Show, Generic) - -instance ToJSON ProtocolTestFailure where - toEncoding = J.genericToEncoding J.defaultOptions - toJSON = J.genericToJSON J.defaultOptions + deriving (Eq, Show, Generic, FromJSON) +instance ToJSON ProtocolTestFailure where toEncoding = J.genericToEncoding J.defaultOptions + runSMPServerTest :: AgentMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe ProtocolTestFailure) runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do cfg <- getClientConfig c smpCfg @@ -1355,6 +1357,8 @@ data SubInfo = SubInfo {userId :: UserId, server :: Text, rcvId :: Text, subErro instance ToJSON SubInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} +instance FromJSON SubInfo where parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True} + data SubscriptionsInfo = SubscriptionsInfo { activeSubscriptions :: [SubInfo], pendingSubscriptions :: [SubInfo], @@ -1364,6 +1368,8 @@ data SubscriptionsInfo = SubscriptionsInfo instance ToJSON SubscriptionsInfo where toEncoding = J.genericToEncoding J.defaultOptions +instance FromJSON SubscriptionsInfo where parseJSON = J.genericParseJSON J.defaultOptions + getAgentSubscriptions :: MonadIO m => AgentClient -> m SubscriptionsInfo getAgentSubscriptions c = do activeSubscriptions <- getSubs activeSubs diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 3053132b9..2912537df 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -616,6 +616,8 @@ data RcvQueueInfo = RcvQueueInfo instance ToJSON RcvQueueInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} +instance FromJSON RcvQueueInfo where parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True} + instance StrEncoding RcvQueueInfo where strEncode RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch} = "srv=" <> strEncode rcvServer @@ -635,6 +637,8 @@ data SndQueueInfo = SndQueueInfo instance ToJSON SndQueueInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} +instance FromJSON SndQueueInfo where parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True} + instance StrEncoding SndQueueInfo where strEncode SndQueueInfo {sndServer, sndSwitchStatus} = "srv=" <> strEncode sndServer <> maybe "" (\switch -> ";switch=" <> strEncode switch) sndSwitchStatus @@ -650,7 +654,9 @@ data ConnectionStats = ConnectionStats ratchetSyncState :: RatchetSyncState, ratchetSyncSupported :: Bool } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON ConnectionStats where toEncoding = J.genericToEncoding J.defaultOptions instance StrEncoding ConnectionStats where strEncode ConnectionStats {connAgentVersion, rcvQueuesInfo, sndQueuesInfo, ratchetSyncState, ratchetSyncSupported} = @@ -667,8 +673,6 @@ instance StrEncoding ConnectionStats where ratchetSyncSupported <- " sync_supported=" *> strP pure ConnectionStats {connAgentVersion, rcvQueuesInfo, sndQueuesInfo, ratchetSyncState, ratchetSyncSupported} -instance ToJSON ConnectionStats where toEncoding = J.genericToEncoding J.defaultOptions - data NotificationsMode = NMPeriodic | NMInstant deriving (Eq, Show) @@ -686,6 +690,9 @@ instance ToJSON NotificationsMode where toEncoding = strToJEncoding toJSON = strToJSON +instance FromJSON NotificationsMode where + parseJSON = strParseJSON "NotificationsMode" + instance ToField NotificationsMode where toField = toField . strEncode instance FromField NotificationsMode where fromField = blobFieldDecoder $ parseAll strP @@ -1048,6 +1055,9 @@ instance ToJSON MsgReceiptStatus where toJSON = strToJSON toEncoding = strToJEncoding +instance FromJSON MsgReceiptStatus where + parseJSON = strParseJSON "MsgReceiptStatus" + type MsgReceiptInfo = ByteString type SndQAddr = (SMPServer, SMP.SenderId) @@ -1447,6 +1457,9 @@ instance ToJSON AgentErrorType where toJSON = J.genericToJSON $ sumTypeJSON id toEncoding = J.genericToEncoding $ sumTypeJSON id +instance FromJSON AgentErrorType where + parseJSON = J.genericParseJSON $ sumTypeJSON id + -- | SMP agent protocol command or response error. data CommandErrorType = -- | command is prohibited in this context @@ -1465,6 +1478,9 @@ instance ToJSON CommandErrorType where toJSON = J.genericToJSON $ sumTypeJSON id toEncoding = J.genericToEncoding $ sumTypeJSON id +instance FromJSON CommandErrorType where + parseJSON = J.genericParseJSON $ sumTypeJSON id + -- | Connection error. data ConnectionErrorType = -- | connection is not in the database @@ -1483,6 +1499,9 @@ instance ToJSON ConnectionErrorType where toJSON = J.genericToJSON $ sumTypeJSON id toEncoding = J.genericToEncoding $ sumTypeJSON id +instance FromJSON ConnectionErrorType where + parseJSON = J.genericParseJSON $ sumTypeJSON id + -- | SMP server errors. data BrokerErrorType = -- | invalid server response (failed to parse) @@ -1503,6 +1522,9 @@ instance ToJSON BrokerErrorType where toJSON = J.genericToJSON $ sumTypeJSON id toEncoding = J.genericToEncoding $ sumTypeJSON id +instance FromJSON BrokerErrorType where + parseJSON = J.genericParseJSON $ sumTypeJSON id + -- | Errors of another SMP agent. data SMPAgentError = -- | client or agent message that failed to parse @@ -1537,6 +1559,9 @@ instance ToJSON AgentCryptoError where toJSON = J.genericToJSON $ sumTypeJSON id toEncoding = J.genericToEncoding $ sumTypeJSON id +instance FromJSON AgentCryptoError where + parseJSON = J.genericParseJSON $ sumTypeJSON id + instance StrEncoding AgentCryptoError where strP = "DECRYPT_AES" $> DECRYPT_AES @@ -1555,6 +1580,9 @@ instance ToJSON SMPAgentError where toJSON = J.genericToJSON $ sumTypeJSON id toEncoding = J.genericToEncoding $ sumTypeJSON id +instance FromJSON SMPAgentError where + parseJSON = J.genericParseJSON $ sumTypeJSON id + instance StrEncoding AgentErrorType where strP = "CMD " *> (CMD <$> parseRead1) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index e44049f3a..57804091a 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -215,7 +216,7 @@ where import Control.Concurrent.STM (stateTVar) import Control.Monad.Except import Crypto.Random (ChaChaDRG, randomBytesGenerate) -import Data.Aeson (ToJSON) +import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (second) @@ -297,14 +298,12 @@ instance ToJSON MigrationError where toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "ME" data UpMigration = UpMigration {upName :: String, withDown :: Bool} - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, FromJSON) upMigration :: Migration -> UpMigration upMigration Migration {name, down} = UpMigration name $ isJust down -instance ToJSON UpMigration where - toJSON = J.genericToJSON J.defaultOptions - toEncoding = J.genericToEncoding J.defaultOptions +instance ToJSON UpMigration where toEncoding = J.genericToEncoding J.defaultOptions data MigrationConfirmation = MCYesUp | MCYesUpDown | MCConsole | MCError deriving (Eq, Show) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs index 651f3fbd1..789f7214e 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StrictData #-} @@ -19,7 +20,7 @@ where import Control.Concurrent.STM import Control.Monad (when) -import Data.Aeson (ToJSON (..)) +import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J import Data.Int (Int64) import Data.Time (diffUTCTime, getCurrentTime) @@ -40,7 +41,7 @@ data SlowQueryStats = SlowQueryStats timeMax :: Int64, timeAvg :: Int64 } - deriving (Show, Generic) + deriving (Show, Generic, FromJSON) instance ToJSON SlowQueryStats where toEncoding = J.genericToEncoding J.defaultOptions diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 60b5b5c2a..9f1e28103 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -294,10 +294,10 @@ deriving instance Eq (PrivateKey a) deriving instance Show (PrivateKey a) --- XXX: Do not enable, may acidentally leak key data +-- Do not enable, to avoid leaking key data -- instance StrEncoding (PrivateKey Ed25519) where --- XXX: used in notification store log +-- Used in notification store log instance StrEncoding (PrivateKey X25519) where strEncode = strEncode . encodePrivKey {-# INLINE strEncode #-} @@ -834,6 +834,9 @@ instance ToJSON KeyHash where toEncoding = strToJEncoding toJSON = strToJSON +instance FromJSON KeyHash where + parseJSON = strParseJSON "KeyHash" + instance IsString KeyHash where fromString = parseString $ parseAll strP diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 34f93d8a7..3594a17c2 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -11,7 +11,7 @@ module Simplex.Messaging.Notifications.Protocol where -import Data.Aeson (FromJSON (..), ToJSON (..), (.=)) +import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE import qualified Data.Attoparsec.ByteString.Char8 as A @@ -408,6 +408,12 @@ instance ToJSON DeviceToken where toEncoding (DeviceToken pp t) = J.pairs $ "pushProvider" .= decodeLatin1 (strEncode pp) <> "token" .= decodeLatin1 t toJSON (DeviceToken pp t) = J.object ["pushProvider" .= decodeLatin1 (strEncode pp), "token" .= decodeLatin1 t] +instance FromJSON DeviceToken where + parseJSON = J.withObject "DeviceToken" $ \o -> do + pp <- strDecode . encodeUtf8 <$?> o .: "pushProvider" + t <- encodeUtf8 <$> o .: "token" + pure $ DeviceToken pp t + type NtfEntityId = ByteString type NtfSubscriptionId = NtfEntityId @@ -510,6 +516,9 @@ instance ToJSON NtfTknStatus where toEncoding = JE.text . decodeLatin1 . smpEncode toJSON = J.String . decodeLatin1 . smpEncode +instance FromJSON NtfTknStatus where + parseJSON = J.withText "NtfTknStatus" $ either fail pure . smpDecode . encodeUtf8 + checkEntity :: forall t e e'. (NtfEntityI e, NtfEntityI e') => t e' -> Either String (t e) checkEntity c = case testEquality (sNtfEntity @e) (sNtfEntity @e') of Just Refl -> Right c diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index cd3c4ad64..a3c014d61 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -471,7 +472,7 @@ instance Encoding NMsgMeta where -- it must be data for correct JSON encoding data MsgFlags = MsgFlags {notification :: Bool} - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, FromJSON) instance ToJSON MsgFlags where toEncoding = J.genericToEncoding J.defaultOptions @@ -737,10 +738,16 @@ instance ProtocolTypeI p => ToJSON (SProtocolType p) where toEncoding = strToJEncoding toJSON = strToJSON +instance ProtocolTypeI p => FromJSON (SProtocolType p) where + parseJSON = strParseJSON "SProtocolType" + instance ToJSON AProtocolType where toEncoding = strToJEncoding toJSON = strToJSON +instance FromJSON AProtocolType where + parseJSON = strParseJSON "AProtocolType" + checkProtocolType :: forall t p p'. (ProtocolTypeI p, ProtocolTypeI p') => t p' -> Either String (t p) checkProtocolType p = case testEquality (protocolTypeI @p) (protocolTypeI @p') of Just Refl -> Right p @@ -917,6 +924,9 @@ instance ToJSON CorrId where toJSON = strToJSON toEncoding = strToJEncoding +instance FromJSON CorrId where + parseJSON = strParseJSON "CorrId" + -- | Queue IDs and keys data QueueIdsKeys = QIK { rcvId :: RecipientId, @@ -993,6 +1003,9 @@ instance ToJSON ErrorType where toJSON = J.genericToJSON $ sumTypeJSON id toEncoding = J.genericToEncoding $ sumTypeJSON id +instance FromJSON ErrorType where + parseJSON = J.genericParseJSON $ sumTypeJSON id + instance StrEncoding ErrorType where strEncode = \case CMD e -> "CMD " <> bshow e @@ -1019,6 +1032,9 @@ instance ToJSON CommandError where toJSON = J.genericToJSON $ sumTypeJSON id toEncoding = J.genericToEncoding $ sumTypeJSON id +instance FromJSON CommandError where + parseJSON = J.genericParseJSON $ 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 4572a861e..de49da35a 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -63,7 +63,7 @@ where import Control.Applicative ((<|>)) import Control.Monad.Except import Control.Monad.Trans.Except (throwE) -import Data.Aeson (ToJSON) +import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J import Data.Attoparsec.ByteString.Char8 (Parser) import Data.Bifunctor (first) @@ -219,7 +219,7 @@ instance Transport TLS where cGet :: TLS -> Int -> IO ByteString cGet TLS {tlsContext, tlsBuffer, tlsTransportConfig = TransportConfig {transportTimeout = t_}} n = getBuffered tlsBuffer n t_ (T.recvData tlsContext) - + cPut :: TLS -> ByteString -> IO () cPut TLS {tlsContext, tlsTransportConfig = TransportConfig {transportTimeout = t_}} s = withTimedErr t_ . T.sendData tlsContext $ BL.fromStrict s @@ -290,6 +290,9 @@ instance ToJSON TransportError where toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "TE" toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "TE" +instance FromJSON TransportError where + parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "TE" + -- | Transport handshake error. data HandshakeError = -- | parsing error @@ -304,6 +307,9 @@ instance ToJSON HandshakeError where toJSON = J.genericToJSON $ sumTypeJSON id toEncoding = J.genericToEncoding $ sumTypeJSON id +instance FromJSON HandshakeError where + parseJSON = J.genericParseJSON $ sumTypeJSON id + instance Arbitrary TransportError where arbitrary = genericArbitraryU instance Arbitrary HandshakeError where arbitrary = genericArbitraryU diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index 1f7fd44a8..95dca5616 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -89,6 +89,9 @@ instance ToJSON TransportHost where toEncoding = strToJEncoding toJSON = strToJSON +instance FromJSON TransportHost where + parseJSON = strParseJSON "TransportHost" + newtype TransportHosts = TransportHosts {thList :: NonEmpty TransportHost} instance StrEncoding TransportHosts where