From 96a38505d63ec9a12096991e7725b250e397af72 Mon Sep 17 00:00:00 2001
From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com>
Date: Thu, 5 Oct 2023 17:57:53 +0300
Subject: [PATCH] add FromJSON instances (#856)

* Add FromJSON instances

* add missing FromJSON instances

* more JSON instances

* update comments

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
---
 src/Simplex/FileTransfer/Protocol.hs          |  3 ++
 src/Simplex/Messaging/Agent/Client.hs         | 20 +++++++----
 src/Simplex/Messaging/Agent/Protocol.hs       | 34 +++++++++++++++++--
 src/Simplex/Messaging/Agent/Store/SQLite.hs   |  9 +++--
 .../Messaging/Agent/Store/SQLite/DB.hs        |  5 +--
 src/Simplex/Messaging/Crypto.hs               |  7 ++--
 .../Messaging/Notifications/Protocol.hs       | 11 +++++-
 src/Simplex/Messaging/Protocol.hs             | 18 +++++++++-
 src/Simplex/Messaging/Transport.hs            | 10 ++++--
 src/Simplex/Messaging/Transport/Client.hs     |  3 ++
 10 files changed, 97 insertions(+), 23 deletions(-)

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 fd48e0ef7..586749606 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 #-}
@@ -116,7 +117,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
@@ -279,7 +280,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
 
@@ -730,16 +731,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
@@ -1357,6 +1359,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],
@@ -1366,6 +1370,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 fce6271a5..7b6362407 100644
--- a/src/Simplex/Messaging/Agent/Protocol.hs
+++ b/src/Simplex/Messaging/Agent/Protocol.hs
@@ -618,6 +618,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
@@ -637,6 +639,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
@@ -652,7 +656,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} =
@@ -669,8 +675,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)
 
@@ -688,6 +692,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
@@ -1050,6 +1057,9 @@ instance ToJSON MsgReceiptStatus where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
+instance FromJSON MsgReceiptStatus where
+  parseJSON = strParseJSON "MsgReceiptStatus"
+
 type MsgReceiptInfo = ByteString
 
 type SndQAddr = (SMPServer, SMP.SenderId)
@@ -1450,6 +1460,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
@@ -1468,6 +1481,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
@@ -1486,6 +1502,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)
@@ -1506,6 +1525,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
@@ -1540,6 +1562,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
@@ -1558,6 +1583,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 45a2389ea..e14e68e75 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 #-}
@@ -219,7 +220,7 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
 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)
@@ -301,14 +302,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 b1b8644f7..503138132 100644
--- a/src/Simplex/Messaging/Crypto.hs
+++ b/src/Simplex/Messaging/Crypto.hs
@@ -295,10 +295,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 #-}
@@ -835,6 +835,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 39439f9b0..a8ccdd9c9 100644
--- a/src/Simplex/Messaging/Transport/Client.hs
+++ b/src/Simplex/Messaging/Transport/Client.hs
@@ -88,6 +88,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