From 753a6c7542c3764fda9ce3f4c4cdc9f2329816d3 Mon Sep 17 00:00:00 2001
From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com>
Date: Tue, 3 Oct 2023 15:43:21 +0300
Subject: [PATCH 1/4] add X509 cert and TLS credentials generator (#857)

* Add X509 cert and TLS credentials generator

* Expand Crypto toolkit and rewrite tls credentials with it

* Exclude X keys from SignatureAlgorithmX509 and TLS.PrivKey

* Add helpers for DB marshalling and fingerprints

* Derive public key from private

* remove module name from selectors

* Remove StrEncoding (PrivateKey Ed25519)

* remove comment

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
---
 package.yaml                                  |  1 +
 simplexmq.cabal                               |  8 ++
 src/Simplex/Messaging/Crypto.hs               | 80 ++++++++++++++++++-
 .../Messaging/Transport/Credentials.hs        | 73 +++++++++++++++++
 4 files changed, 161 insertions(+), 1 deletion(-)
 create mode 100644 src/Simplex/Messaging/Transport/Credentials.hs

diff --git a/package.yaml b/package.yaml
index c1e726683..dc18c5b4e 100644
--- a/package.yaml
+++ b/package.yaml
@@ -41,6 +41,7 @@ dependencies:
   - direct-sqlcipher == 2.3.*
   - directory == 1.3.*
   - filepath == 1.4.*
+  - hourglass == 0.2.*
   - http-types == 0.12.*
   - http2 == 4.1.*
   - generic-random == 1.5.*
diff --git a/simplexmq.cabal b/simplexmq.cabal
index cb304b4b0..62a59b0fe 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -130,6 +130,7 @@ library
       Simplex.Messaging.Transport
       Simplex.Messaging.Transport.Buffer
       Simplex.Messaging.Transport.Client
+      Simplex.Messaging.Transport.Credentials
       Simplex.Messaging.Transport.HTTP2
       Simplex.Messaging.Transport.HTTP2.Client
       Simplex.Messaging.Transport.HTTP2.Server
@@ -165,6 +166,7 @@ library
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random ==1.5.*
+    , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 ==4.1.*
     , ini ==0.4.1
@@ -229,6 +231,7 @@ executable ntf-server
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random ==1.5.*
+    , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 ==4.1.*
     , ini ==0.4.1
@@ -294,6 +297,7 @@ executable smp-agent
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random ==1.5.*
+    , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 ==4.1.*
     , ini ==0.4.1
@@ -359,6 +363,7 @@ executable smp-server
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random ==1.5.*
+    , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 ==4.1.*
     , ini ==0.4.1
@@ -424,6 +429,7 @@ executable xftp
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random ==1.5.*
+    , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 ==4.1.*
     , ini ==0.4.1
@@ -489,6 +495,7 @@ executable xftp-server
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random ==1.5.*
+    , hourglass ==0.2.*
     , http-types ==0.12.*
     , http2 ==4.1.*
     , ini ==0.4.1
@@ -584,6 +591,7 @@ test-suite simplexmq-test
     , directory ==1.3.*
     , filepath ==1.4.*
     , generic-random ==1.5.*
+    , hourglass ==0.2.*
     , hspec ==2.11.*
     , hspec-core ==2.11.*
     , http-types ==0.12.*
diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs
index 439612c0e..b1b8644f7 100644
--- a/src/Simplex/Messaging/Crypto.hs
+++ b/src/Simplex/Messaging/Crypto.hs
@@ -40,6 +40,8 @@ module Simplex.Messaging.Crypto
     DhAlgorithm,
     PrivateKey (..),
     PublicKey (..),
+    PrivateKeyEd25519,
+    PublicKeyEd25519,
     PrivateKeyX25519,
     PublicKeyX25519,
     PrivateKeyX448,
@@ -64,6 +66,8 @@ module Simplex.Messaging.Crypto
     generateDhKeyPair,
     privateToX509,
     publicKey,
+    signatureKeyPair,
+    publicToX509,
 
     -- * key encoding/decoding
     encodePubKey,
@@ -135,6 +139,16 @@ module Simplex.Messaging.Crypto
     pad,
     unPad,
 
+    -- * X509 Certificates
+    SignedCertificate,
+    Certificate,
+    signCertificate,
+    signX509,
+    certificateFingerprint,
+    signedFingerprint,
+    SignatureAlgorithmX509 (..),
+    SignedObject (..),
+
     -- * Cryptography error type
     CryptoError (..),
 
@@ -156,7 +170,7 @@ import Crypto.Cipher.AES (AES256)
 import qualified Crypto.Cipher.Types as AES
 import qualified Crypto.Cipher.XSalsa as XSalsa
 import qualified Crypto.Error as CE
-import Crypto.Hash (Digest, SHA256, SHA512, hash)
+import Crypto.Hash (Digest, SHA256 (..), SHA512, hash)
 import qualified Crypto.MAC.Poly1305 as Poly1305
 import qualified Crypto.PubKey.Curve25519 as X25519
 import qualified Crypto.PubKey.Curve448 as X448
@@ -183,6 +197,7 @@ import Data.Type.Equality
 import Data.Typeable (Proxy (Proxy), Typeable)
 import Data.Word (Word32)
 import Data.X509
+import Data.X509.Validation (Fingerprint (..), getFingerprint)
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
 import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+))
@@ -263,6 +278,8 @@ instance Eq APublicKey where
 
 deriving instance Show APublicKey
 
+type PublicKeyEd25519 = PublicKey Ed25519
+
 type PublicKeyX25519 = PublicKey X25519
 
 type PublicKeyX448 = PublicKey X448
@@ -278,6 +295,10 @@ deriving instance Eq (PrivateKey a)
 
 deriving instance Show (PrivateKey a)
 
+-- XXX: Do not enable, may acidentally leak key data
+-- instance StrEncoding (PrivateKey Ed25519) where
+
+-- XXX: used in notification store log
 instance StrEncoding (PrivateKey X25519) where
   strEncode = strEncode . encodePrivKey
   {-# INLINE strEncode #-}
@@ -296,6 +317,8 @@ instance Eq APrivateKey where
 
 deriving instance Show APrivateKey
 
+type PrivateKeyEd25519 = PrivateKey Ed25519
+
 type PrivateKeyX25519 = PrivateKey X25519
 
 type PrivateKeyX448 = PrivateKey X448
@@ -538,6 +561,10 @@ publicKey = \case
   PrivateKeyX25519 _ k -> PublicKeyX25519 k
   PrivateKeyX448 _ k -> PublicKeyX448 k
 
+-- | Expand signature private key to a key pair.
+signatureKeyPair :: APrivateSignKey -> ASignatureKeyPair
+signatureKeyPair ak@(APrivateSignKey a k) = (APublicVerifyKey a (publicKey k), ak)
+
 encodePrivKey :: CryptoPrivateKey pk => pk -> ByteString
 encodePrivKey = toPrivKey $ encodeASNObj . privateToX509
 
@@ -804,6 +831,10 @@ instance StrEncoding KeyHash where
   strEncode = strEncode . unKeyHash
   strP = KeyHash <$> strP
 
+instance ToJSON KeyHash where
+  toEncoding = strToJEncoding
+  toJSON = strToJSON
+
 instance IsString KeyHash where
   fromString = parseString $ parseAll strP
 
@@ -967,6 +998,53 @@ sign' (PrivateKeyEd448 pk k) msg = SignatureEd448 $ Ed448.sign pk k msg
 sign :: APrivateSignKey -> ByteString -> ASignature
 sign (APrivateSignKey a k) = ASignature a . sign' k
 
+signCertificate :: APrivateSignKey -> Certificate -> SignedCertificate
+signCertificate = signX509
+
+signX509 :: (ASN1Object o, Eq o, Show o) => APrivateSignKey -> o -> SignedExact o
+signX509 key = fst . objectToSignedExact f
+  where
+    f bytes =
+      ( signatureBytes $ sign key bytes,
+        signatureAlgorithmX509 key,
+        ()
+      )
+
+certificateFingerprint :: SignedCertificate -> KeyHash
+certificateFingerprint = signedFingerprint
+
+signedFingerprint :: (ASN1Object o, Eq o, Show o) => SignedExact o -> KeyHash
+signedFingerprint o = KeyHash fp
+  where
+    Fingerprint fp = getFingerprint o HashSHA256
+
+class SignatureAlgorithmX509 a where
+  signatureAlgorithmX509 :: a -> SignatureALG
+
+instance SignatureAlgorithm a => SignatureAlgorithmX509 (SAlgorithm a) where
+  signatureAlgorithmX509 = \case
+    SEd25519 -> SignatureALG_IntrinsicHash PubKeyALG_Ed25519
+    SEd448 -> SignatureALG_IntrinsicHash PubKeyALG_Ed448
+
+instance SignatureAlgorithmX509 APrivateSignKey where
+  signatureAlgorithmX509 (APrivateSignKey a _) = signatureAlgorithmX509 a
+
+instance SignatureAlgorithmX509 APublicVerifyKey where
+  signatureAlgorithmX509 (APublicVerifyKey a _) = signatureAlgorithmX509 a
+
+-- | An instance for 'ASignatureKeyPair' / ('PublicKeyType' pk, pk), without touching its type family.
+instance SignatureAlgorithmX509 pk => SignatureAlgorithmX509 (a, pk) where
+  signatureAlgorithmX509 = signatureAlgorithmX509 . snd
+
+-- | A wrapper to marshall signed ASN1 objects, like certificates.
+newtype SignedObject a = SignedObject (SignedExact a)
+
+instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a) where
+  fromField = fmap SignedObject . blobFieldDecoder decodeSignedObject
+
+instance (Eq a, Show a, ASN1Object a) => ToField (SignedObject a) where
+  toField (SignedObject s) = toField $ encodeSignedObject s
+
 -- | Signature verification.
 --
 -- Used by SMP servers to authorize SMP commands and by SMP agents to verify messages.
diff --git a/src/Simplex/Messaging/Transport/Credentials.hs b/src/Simplex/Messaging/Transport/Credentials.hs
new file mode 100644
index 000000000..a44dd9ead
--- /dev/null
+++ b/src/Simplex/Messaging/Transport/Credentials.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Messaging.Transport.Credentials
+  ( tlsCredentials,
+    Credentials,
+    genCredentials,
+    C.signCertificate,
+  )
+where
+
+import Data.ASN1.Types (getObjectID)
+import Data.ASN1.Types.String (ASN1StringEncoding (UTF8))
+import Data.Hourglass (Hours (..), timeAdd)
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as NE
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
+import qualified Data.X509 as X509
+import Data.X509.Validation (Fingerprint (..), getFingerprint)
+import qualified Network.TLS as TLS
+import qualified Simplex.Messaging.Crypto as C
+import qualified Time.System as Hourglass
+
+-- | Generate a certificate chain to be used with TLS fingerprint-pinning
+--
+-- @
+-- genTlsCredentials = do
+--   ca <- genCredentials Nothing (-25, 365 * 24) "Root" -- long-lived root cert
+--   leaf <- genCredentials (Just ca) (0, 1) "Entity" -- session-signing cert
+--   pure $ tlsCredentials (leaf :| [ca])
+-- @
+tlsCredentials :: NonEmpty Credentials -> (C.KeyHash, TLS.Credentials)
+tlsCredentials credentials = (C.KeyHash rootFP, TLS.Credentials [(X509.CertificateChain certs, privateToTls $ snd leafKey)])
+  where
+    Fingerprint rootFP = getFingerprint root X509.HashSHA256
+    leafKey = fst $ NE.head credentials
+    root = snd $ NE.last credentials
+    certs = map snd $ NE.toList credentials
+
+privateToTls :: C.APrivateSignKey -> TLS.PrivKey
+privateToTls (C.APrivateSignKey _ k) = case k of
+  C.PrivateKeyEd25519 secret _ -> TLS.PrivKeyEd25519 secret
+  C.PrivateKeyEd448 secret _ -> TLS.PrivKeyEd448 secret
+
+type Credentials = (C.ASignatureKeyPair, X509.SignedCertificate)
+
+genCredentials :: Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials
+genCredentials parent (before, after) subjectName = do
+  subjectKeys <- C.generateSignatureKeyPair C.SEd25519
+  let (issuerKeys, issuer) = case parent of
+        Nothing -> (subjectKeys, subject) -- self-signed
+        Just (keys, cert) -> (keys, X509.certSubjectDN . X509.signedObject $ X509.getSigned cert)
+  today <- Hourglass.dateCurrent
+  let signed =
+        C.signCertificate
+          (snd issuerKeys)
+          X509.Certificate
+            { certVersion = 2,
+              certSerial = 1,
+              certSignatureAlg = C.signatureAlgorithmX509 issuerKeys,
+              certIssuerDN = issuer,
+              certValidity = (timeAdd today (-before), timeAdd today after),
+              certSubjectDN = subject,
+              certPubKey = C.toPubKey C.publicToX509 $ fst subjectKeys,
+              certExtensions = X509.Extensions Nothing
+            }
+  pure (subjectKeys, signed)
+  where
+    subject = dn $ X509.ASN1CharacterString {characterEncoding = UTF8, getCharacterStringRawData = encodeUtf8 subjectName}
+    dn dnCommonName = X509.DistinguishedName [(getObjectID X509.DnCommonName, dnCommonName)]

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 2/4] 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

From 919550948501d315aa8845cbed1781d4298d4ced Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 7 Oct 2023 12:30:26 +0100
Subject: [PATCH 3/4] update aeson to add tag to platform-specific single field
 JSON encoding (#859)

* update aeson to add tag to platform-specific single field JSON encoding

* refactor
---
 cabal.project                    |  2 +-
 src/Simplex/Messaging/Parsers.hs | 14 +++++++++++---
 stack.yaml                       |  2 +-
 3 files changed, 13 insertions(+), 5 deletions(-)

diff --git a/cabal.project b/cabal.project
index 193c1816b..301ca7d56 100644
--- a/cabal.project
+++ b/cabal.project
@@ -9,7 +9,7 @@ with-compiler: ghc-9.6.2
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/aeson.git
-    tag: 68330dce8208173c6acf5f62b23acb500ab5d873
+    tag: aab7b5a14d6c5ea64c64dcaee418de1bb00dcc2b
 
 source-repository-package
     type: git
diff --git a/src/Simplex/Messaging/Parsers.hs b/src/Simplex/Messaging/Parsers.hs
index a54503c46..cbc1d84bf 100644
--- a/src/Simplex/Messaging/Parsers.hs
+++ b/src/Simplex/Messaging/Parsers.hs
@@ -107,13 +107,17 @@ enumJSON tagModifier =
       J.allNullaryToStringTag = True
     }
 
+-- used in platform-specific encoding, includes tag for single-field encoding of sum types to allow conversion to tagged objects
 sumTypeJSON :: (String -> String) -> J.Options
 #if defined(darwin_HOST_OS) && defined(swiftJSON)
-sumTypeJSON = singleFieldJSON
+sumTypeJSON = singleFieldJSON_ $ Just singleFieldJSONTag
 #else
 sumTypeJSON = taggedObjectJSON
 #endif
 
+singleFieldJSONTag :: String
+singleFieldJSONTag = "_owsf"
+
 taggedObjectJSON :: (String -> String) -> J.Options
 taggedObjectJSON tagModifier =
   J.defaultOptions
@@ -125,10 +129,14 @@ taggedObjectJSON tagModifier =
       J.omitNothingFields = True
     }
 
+-- used in platform independent encoding, doesn't include tag for single-field encoding of sum types
 singleFieldJSON :: (String -> String) -> J.Options
-singleFieldJSON tagModifier =
+singleFieldJSON = singleFieldJSON_ Nothing
+
+singleFieldJSON_ :: Maybe String -> (String -> String) -> J.Options
+singleFieldJSON_ objectTag tagModifier =
   J.defaultOptions
-    { J.sumEncoding = J.ObjectWithSingleField,
+    { J.sumEncoding = J.ObjectWithSingleField objectTag,
       J.tagSingleConstructors = True,
       J.constructorTagModifier = tagModifier,
       J.allNullaryToStringTag = False,
diff --git a/stack.yaml b/stack.yaml
index 077ee23df..58f50b42f 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -47,7 +47,7 @@ extra-deps:
   - text-short-0.1.5@sha256:962c6228555debdc46f758d0317dea16e5240d01419b42966674b08a5c3d8fa6,3498
   - time-compat-1.9.6.1@sha256:42d8f2e08e965e1718917d54ad69e1d06bd4b87d66c41dc7410f59313dba4ed1,5033
   - github: simplex-chat/aeson
-    commit: 68330dce8208173c6acf5f62b23acb500ab5d873
+    commit: aab7b5a14d6c5ea64c64dcaee418de1bb00dcc2b
   - github: kazu-yamamoto/http2
     commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
   # - ../direct-sqlcipher

From 6b0da8ac50b1582c9f5187c316b93fc8f12c9365 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 7 Oct 2023 14:21:15 +0100
Subject: [PATCH 4/4] export JSON tags as patterns

---
 src/Simplex/Messaging/Parsers.hs | 16 ++++++++++++----
 1 file changed, 12 insertions(+), 4 deletions(-)

diff --git a/src/Simplex/Messaging/Parsers.hs b/src/Simplex/Messaging/Parsers.hs
index cbc1d84bf..3363cbcc9 100644
--- a/src/Simplex/Messaging/Parsers.hs
+++ b/src/Simplex/Messaging/Parsers.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 module Simplex.Messaging.Parsers where
 
@@ -13,6 +14,7 @@ import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlphaNum, toLower)
+import Data.String
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime)
@@ -110,18 +112,18 @@ enumJSON tagModifier =
 -- used in platform-specific encoding, includes tag for single-field encoding of sum types to allow conversion to tagged objects
 sumTypeJSON :: (String -> String) -> J.Options
 #if defined(darwin_HOST_OS) && defined(swiftJSON)
-sumTypeJSON = singleFieldJSON_ $ Just singleFieldJSONTag
+sumTypeJSON = singleFieldJSON_ $ Just SingleFieldJSONTag
 #else
 sumTypeJSON = taggedObjectJSON
 #endif
 
-singleFieldJSONTag :: String
-singleFieldJSONTag = "_owsf"
+pattern SingleFieldJSONTag :: (Eq a, IsString a) => a
+pattern SingleFieldJSONTag = "_owsf"
 
 taggedObjectJSON :: (String -> String) -> J.Options
 taggedObjectJSON tagModifier =
   J.defaultOptions
-    { J.sumEncoding = J.TaggedObject "type" "data",
+    { J.sumEncoding = J.TaggedObject TaggedObjectJSONTag TaggedObjectJSONData,
       J.tagSingleConstructors = True,
       J.constructorTagModifier = tagModifier,
       J.allNullaryToStringTag = False,
@@ -129,6 +131,12 @@ taggedObjectJSON tagModifier =
       J.omitNothingFields = True
     }
 
+pattern TaggedObjectJSONTag :: (Eq a, IsString a) => a
+pattern TaggedObjectJSONTag = "type"
+
+pattern TaggedObjectJSONData :: (Eq a, IsString a) => a
+pattern TaggedObjectJSONData = "data"
+
 -- used in platform independent encoding, doesn't include tag for single-field encoding of sum types
 singleFieldJSON :: (String -> String) -> J.Options
 singleFieldJSON = singleFieldJSON_ Nothing