Merge branch 'master' into master-ghc8107

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

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

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)

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)

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
 

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
 

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

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

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

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