Merge branch 'master' into ep/journal-mode-wal

2026-04-26 13:07:25 +00:00 · 2023-10-07 21:12:19 +01:00
parent f097c24e6b 6b0da8ac50
commit cf75d4f5e4
16 changed files with 278 additions and 28 deletions
--- 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
--- 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.*
--- 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.*
--- 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
--- 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
--- 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)
--- 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 #-}
@@ -224,7 +225,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)
@@ -306,14 +307,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)
--- 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

--- 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)

+-- Do not enable, to avoid leaking key data
+-- instance StrEncoding (PrivateKey Ed25519) where
+
+-- 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,13 @@ instance StrEncoding KeyHash where
  strEncode = strEncode . unKeyHash
  strP = KeyHash <$> strP

+instance ToJSON KeyHash where
+  toEncoding = strToJEncoding
+  toJSON = strToJSON
+
+instance FromJSON KeyHash where
+  parseJSON = strParseJSON "KeyHash"
+
 instance IsString KeyHash where
  fromString = parseString $ parseAll strP

@@ -967,6 +1001,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.
--- 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
--- 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)
@@ -107,17 +109,21 @@ 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

+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,
@@ -125,10 +131,20 @@ 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 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,
--- 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
--- 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
--- 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
--- a/src/Simplex/Messaging/Transport/Credentials.hs
+++ 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)]
--- 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