From 511d793b927b1e2f12999e0829718671b3a8f0cb Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 26 Oct 2023 09:20:30 +0100 Subject: [PATCH] derive JSON instances with TH (#869) * derive JSON instances with TH * defaultJSON * remove ToJSON --- simplexmq.cabal | 1 + src/Simplex/FileTransfer/Description.hs | 29 ++--- src/Simplex/FileTransfer/Protocol.hs | 28 ++--- src/Simplex/Messaging/Agent/Client.hs | 47 +++---- src/Simplex/Messaging/Agent/Protocol.hs | 115 ++++++------------ src/Simplex/Messaging/Agent/Store/SQLite.hs | 22 ++-- .../Messaging/Agent/Store/SQLite/DB.hs | 13 +- .../Agent/Store/SQLite/Migrations.hs | 14 +-- src/Simplex/Messaging/Client.hs | 38 ++---- src/Simplex/Messaging/Crypto/File.hs | 21 ++-- src/Simplex/Messaging/Crypto/Ratchet.hs | 47 ++++--- .../Notifications/Server/Push/APNS.hs | 54 +++----- .../Server/Push/APNS/Internal.hs | 20 +++ src/Simplex/Messaging/Parsers.hs | 3 + src/Simplex/Messaging/Protocol.hs | 33 ++--- src/Simplex/Messaging/Transport.hs | 28 ++--- src/Simplex/Messaging/Transport/KeepAlive.hs | 13 +- tests/CoreTests/ProtocolErrorTests.hs | 31 ++++- tests/NtfClient.hs | 7 ++ 19 files changed, 245 insertions(+), 319 deletions(-) create mode 100644 src/Simplex/Messaging/Notifications/Server/Push/APNS/Internal.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index c95e4ff05..7ad59b427 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -107,6 +107,7 @@ library Simplex.Messaging.Notifications.Server.Env Simplex.Messaging.Notifications.Server.Main Simplex.Messaging.Notifications.Server.Push.APNS + Simplex.Messaging.Notifications.Server.Push.APNS.Internal Simplex.Messaging.Notifications.Server.Stats Simplex.Messaging.Notifications.Server.Store Simplex.Messaging.Notifications.Server.StoreLog diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs index 65b18e16d..64a1d8a32 100644 --- a/src/Simplex/FileTransfer/Description.hs +++ b/src/Simplex/FileTransfer/Description.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} @@ -9,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.FileTransfer.Description @@ -37,7 +37,7 @@ where import Control.Applicative (optional) import Control.Monad ((<=<)) import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) @@ -53,12 +53,11 @@ import Data.Word (Word32) import qualified Data.Yaml as Y import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) -import GHC.Generics (Generic) import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Protocol import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (parseAll) +import Simplex.Messaging.Parsers (defaultJSON, parseAll) import Simplex.Messaging.Protocol (XFTPServer) import Simplex.Messaging.Util (bshow, groupAllOn, (<$?>)) @@ -149,21 +148,13 @@ data YAMLFileDescription = YAMLFileDescription chunkSize :: String, replicas :: [YAMLServerReplicas] } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON YAMLFileDescription where - toJSON = J.genericToJSON J.defaultOptions - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data YAMLServerReplicas = YAMLServerReplicas { server :: XFTPServer, chunks :: [String] } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON YAMLServerReplicas where - toJSON = J.genericToJSON J.defaultOptions - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data FileServerReplica = FileServerReplica { chunkNo :: Int, @@ -175,6 +166,13 @@ data FileServerReplica = FileServerReplica } deriving (Show) +newtype FileSize a = FileSize {unFileSize :: a} + deriving (Eq, Show) + +$(J.deriveJSON defaultJSON ''YAMLServerReplicas) + +$(J.deriveJSON defaultJSON ''YAMLFileDescription) + instance FilePartyI p => StrEncoding (ValidFileDescription p) where strEncode (ValidFD fd) = strEncode fd strDecode s = strDecode s >>= (\(AVFD fd) -> checkParty fd) @@ -216,9 +214,6 @@ encodeFileDescription FileDescription {party, size, digest, key, nonce, chunkSiz replicas = encodeFileReplicas chunkSize chunks } -newtype FileSize a = FileSize {unFileSize :: a} - deriving (Eq, Show) - instance (Integral a, Show a) => StrEncoding (FileSize a) where strEncode (FileSize b) | b' /= 0 = bshow b diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 84627ee0c..9d87a8f52 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -7,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} @@ -14,8 +14,7 @@ module Simplex.FileTransfer.Protocol where import Control.Applicative ((<|>)) -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) @@ -25,7 +24,6 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) import Data.Type.Equality import Data.Word (Word32) -import GHC.Generics (Generic) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -67,14 +65,7 @@ xftpBlockSize = 16384 -- | File protocol clients data FileParty = FRecipient | FSender - deriving (Eq, Show, Generic) - -instance FromJSON FileParty where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "F" - -instance ToJSON FileParty where - toJSON = J.genericToJSON . enumJSON $ dropPrefix "F" - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "F" + deriving (Eq, Show) data SFileParty :: FileParty -> Type where SFRecipient :: SFileParty FRecipient @@ -353,14 +344,7 @@ data XFTPErrorType INTERNAL | -- | used internally, never returned by the server (to be removed) DUPLICATE_ -- not part of SMP protocol, used internally - deriving (Eq, Generic, Read, Show) - -instance ToJSON XFTPErrorType where - toJSON = J.genericToJSON $ sumTypeJSON id - toEncoding = J.genericToEncoding $ sumTypeJSON id - -instance FromJSON XFTPErrorType where - parseJSON = J.genericParseJSON $ sumTypeJSON id + deriving (Eq, Read, Show) instance StrEncoding XFTPErrorType where strEncode = \case @@ -431,3 +415,7 @@ xftpDecodeTransmission sessionId t = do case tParse True t' of t'' :| [] -> Right $ tDecodeParseValidate sessionId currentXFTPVersion t'' _ -> Left BLOCK + +$(J.deriveJSON (enumJSON $ dropPrefix "F") ''FileParty) + +$(J.deriveJSON (sumTypeJSON id) ''XFTPErrorType) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index d384babb0..23ba9f8be 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -2,7 +2,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -15,6 +14,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} @@ -118,8 +118,7 @@ import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader import Crypto.Random (getRandomBytes) -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import Data.Bifunctor (bimap, first, second) import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) @@ -138,7 +137,6 @@ import Data.Text (Text) import Data.Text.Encoding import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime) import Data.Word (Word16) -import GHC.Generics (Generic) import Network.Socket (HostName) import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError) import qualified Simplex.FileTransfer.Client as X @@ -165,7 +163,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Client import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Types -import Simplex.Messaging.Parsers (dropPrefix, enumJSON, parse) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parse) import Simplex.Messaging.Protocol ( AProtocolType (..), BrokerMsg, @@ -288,9 +286,7 @@ data AgentLocks = AgentLocks srvLocks :: Map String String, delLock :: Maybe String } - deriving (Show, Generic, FromJSON) - -instance ToJSON AgentLocks where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data AgentStatsKey = AgentStatsKey { userId :: UserId, @@ -738,22 +734,13 @@ data ProtocolTestStep | TSDownloadFile | TSCompareFile | TSDeleteFile - deriving (Eq, Show, Generic) - -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" + deriving (Eq, Show) data ProtocolTestFailure = ProtocolTestFailure { testStep :: ProtocolTestStep, testError :: AgentErrorType } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON ProtocolTestFailure where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) runSMPServerTest :: AgentMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe ProtocolTestFailure) runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do @@ -1368,22 +1355,14 @@ withNextSrv c userId usedSrvs initUsed action = do action srvAuth data SubInfo = SubInfo {userId :: UserId, server :: Text, rcvId :: Text, subError :: Maybe String} - deriving (Show, Generic) - -instance ToJSON SubInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} - -instance FromJSON SubInfo where parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True} + deriving (Show) data SubscriptionsInfo = SubscriptionsInfo { activeSubscriptions :: [SubInfo], pendingSubscriptions :: [SubInfo], removedSubscriptions :: [SubInfo] } - deriving (Show, Generic) - -instance ToJSON SubscriptionsInfo where toEncoding = J.genericToEncoding J.defaultOptions - -instance FromJSON SubscriptionsInfo where parseJSON = J.genericParseJSON J.defaultOptions + deriving (Show) getAgentSubscriptions :: MonadIO m => AgentClient -> m SubscriptionsInfo getAgentSubscriptions c = do @@ -1398,3 +1377,13 @@ getAgentSubscriptions c = do subInfo (uId, srv, rId) err = SubInfo {userId = uId, server = enc srv, rcvId = enc rId, subError = show <$> err} enc :: StrEncoding a => a -> Text enc = decodeLatin1 . strEncode + +$(J.deriveJSON defaultJSON ''AgentLocks) + +$(J.deriveJSON (enumJSON $ dropPrefix "TS") ''ProtocolTestStep) + +$(J.deriveJSON defaultJSON ''ProtocolTestFailure) + +$(J.deriveJSON defaultJSON ''SubInfo) + +$(J.deriveJSON defaultJSON ''SubscriptionsInfo) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 321149538..481034e01 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -13,6 +12,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -151,7 +151,7 @@ import Control.Monad (unless) import Control.Monad.Except (runExceptT, throwError) import Control.Monad.IO.Class import Data.Aeson (FromJSON (..), ToJSON (..)) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Base64 @@ -176,7 +176,6 @@ import Data.Typeable () import Data.Word (Word32) import Database.SQLite.Simple.FromField import Database.SQLite.Simple.ToField -import GHC.Generics (Generic) import Simplex.FileTransfer.Description import Simplex.FileTransfer.Protocol (FileParty (..), XFTPErrorType) import Simplex.Messaging.Agent.QueryString @@ -612,11 +611,7 @@ data RcvQueueInfo = RcvQueueInfo rcvSwitchStatus :: Maybe RcvSwitchStatus, canAbortSwitch :: Bool } - deriving (Eq, Show, Generic) - -instance ToJSON RcvQueueInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} - -instance FromJSON RcvQueueInfo where parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) instance StrEncoding RcvQueueInfo where strEncode RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch} = @@ -633,11 +628,7 @@ data SndQueueInfo = SndQueueInfo { sndServer :: SMPServer, sndSwitchStatus :: Maybe SndSwitchStatus } - deriving (Eq, Show, Generic) - -instance ToJSON SndQueueInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} - -instance FromJSON SndQueueInfo where parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) instance StrEncoding SndQueueInfo where strEncode SndQueueInfo {sndServer, sndSwitchStatus} = @@ -654,9 +645,7 @@ data ConnectionStats = ConnectionStats ratchetSyncState :: RatchetSyncState, ratchetSyncSupported :: Bool } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON ConnectionStats where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) instance StrEncoding ConnectionStats where strEncode ConnectionStats {connAgentVersion, rcvQueuesInfo, sndQueuesInfo, ratchetSyncState, ratchetSyncSupported} = @@ -1389,7 +1378,7 @@ type AgentMsgId = Int64 -- | Result of received message integrity validation. data MsgIntegrity = MsgOk | MsgError {errorInfo :: MsgErrorType} - deriving (Eq, Show, Generic) + deriving (Eq, Show) instance StrEncoding MsgIntegrity where strP = "OK" $> MsgOk <|> "ERR " *> (MsgError <$> strP) @@ -1397,20 +1386,13 @@ instance StrEncoding MsgIntegrity where MsgOk -> "OK" MsgError e -> "ERR " <> strEncode e -instance ToJSON MsgIntegrity where - toJSON = J.genericToJSON $ sumTypeJSON fstToLower - toEncoding = J.genericToEncoding $ sumTypeJSON fstToLower - -instance FromJSON MsgIntegrity where - parseJSON = J.genericParseJSON $ sumTypeJSON fstToLower - -- | Error of message integrity validation. data MsgErrorType = MsgSkipped {fromMsgId :: AgentMsgId, toMsgId :: AgentMsgId} | MsgBadId {msgId :: AgentMsgId} | MsgBadHash | MsgDuplicate - deriving (Eq, Show, Generic) + deriving (Eq, Show) instance StrEncoding MsgErrorType where strP = @@ -1425,13 +1407,6 @@ instance StrEncoding MsgErrorType where MsgBadHash -> "HASH" MsgDuplicate -> "DUPLICATE" -instance ToJSON MsgErrorType where - toJSON = J.genericToJSON $ sumTypeJSON fstToLower - toEncoding = J.genericToEncoding $ sumTypeJSON fstToLower - -instance FromJSON MsgErrorType where - parseJSON = J.genericParseJSON $ sumTypeJSON fstToLower - -- | Error type used in errors sent to agent clients. data AgentErrorType = -- | command or response error @@ -1452,14 +1427,7 @@ data AgentErrorType INTERNAL {internalErr :: String} | -- | agent inactive INACTIVE - deriving (Eq, Generic, Show, Exception) - -instance ToJSON AgentErrorType where - toJSON = J.genericToJSON $ sumTypeJSON id - toEncoding = J.genericToEncoding $ sumTypeJSON id - -instance FromJSON AgentErrorType where - parseJSON = J.genericParseJSON $ sumTypeJSON id + deriving (Eq, Show, Exception) -- | SMP agent protocol command or response error. data CommandErrorType @@ -1473,14 +1441,7 @@ data CommandErrorType SIZE | -- | message does not fit in SMP block LARGE - deriving (Eq, Generic, Read, Show, Exception) - -instance ToJSON CommandErrorType where - toJSON = J.genericToJSON $ sumTypeJSON id - toEncoding = J.genericToEncoding $ sumTypeJSON id - -instance FromJSON CommandErrorType where - parseJSON = J.genericParseJSON $ sumTypeJSON id + deriving (Eq, Read, Show, Exception) -- | Connection error. data ConnectionErrorType @@ -1494,14 +1455,7 @@ data ConnectionErrorType NOT_ACCEPTED | -- | connection not available on reply confirmation/HELLO after timeout NOT_AVAILABLE - deriving (Eq, Generic, Read, Show, Exception) - -instance ToJSON ConnectionErrorType where - toJSON = J.genericToJSON $ sumTypeJSON id - toEncoding = J.genericToEncoding $ sumTypeJSON id - -instance FromJSON ConnectionErrorType where - parseJSON = J.genericParseJSON $ sumTypeJSON id + deriving (Eq, Read, Show, Exception) -- | SMP server errors. data BrokerErrorType @@ -1517,14 +1471,7 @@ data BrokerErrorType TRANSPORT {transportErr :: TransportError} | -- | command response timeout TIMEOUT - deriving (Eq, Generic, Read, Show, Exception) - -instance ToJSON BrokerErrorType where - toJSON = J.genericToJSON $ sumTypeJSON id - toEncoding = J.genericToEncoding $ sumTypeJSON id - -instance FromJSON BrokerErrorType where - parseJSON = J.genericParseJSON $ sumTypeJSON id + deriving (Eq, Read, Show, Exception) -- | Errors of another SMP agent. data SMPAgentError @@ -1541,7 +1488,7 @@ data SMPAgentError A_DUPLICATE | -- | error in the message to add/delete/etc queue in connection A_QUEUE {queueErr :: String} - deriving (Eq, Generic, Read, Show, Exception) + deriving (Eq, Read, Show, Exception) data AgentCryptoError = -- | AES decryption error @@ -1554,14 +1501,7 @@ data AgentCryptoError RATCHET_EARLIER Word32 | -- | too many skipped messages RATCHET_SKIPPED Word32 - deriving (Eq, Generic, Read, Show, Exception) - -instance ToJSON AgentCryptoError where - toJSON = J.genericToJSON $ sumTypeJSON id - toEncoding = J.genericToEncoding $ sumTypeJSON id - -instance FromJSON AgentCryptoError where - parseJSON = J.genericParseJSON $ sumTypeJSON id + deriving (Eq, Read, Show, Exception) instance StrEncoding AgentCryptoError where strP = @@ -1577,13 +1517,6 @@ instance StrEncoding AgentCryptoError where RATCHET_EARLIER n -> "RATCHET_EARLIER " <> strEncode n RATCHET_SKIPPED n -> "RATCHET_SKIPPED " <> strEncode n -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) @@ -1943,3 +1876,25 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody unless (B.null s) $ throwError $ CMD SIZE pure body Nothing -> return . Left $ CMD SYNTAX + +$(J.deriveJSON defaultJSON ''RcvQueueInfo) + +$(J.deriveJSON defaultJSON ''SndQueueInfo) + +$(J.deriveJSON defaultJSON ''ConnectionStats) + +$(J.deriveJSON (sumTypeJSON fstToLower) ''MsgErrorType) + +$(J.deriveJSON (sumTypeJSON fstToLower) ''MsgIntegrity) + +$(J.deriveJSON (sumTypeJSON id) ''CommandErrorType) + +$(J.deriveJSON (sumTypeJSON id) ''ConnectionErrorType) + +$(J.deriveJSON (sumTypeJSON id) ''BrokerErrorType) + +$(J.deriveJSON (sumTypeJSON id) ''AgentCryptoError) + +$(J.deriveJSON (sumTypeJSON id) ''SMPAgentError) + +$(J.deriveJSON (sumTypeJSON id) ''AgentErrorType) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index ab2c294d8..a08b758bd 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -17,6 +16,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -219,8 +219,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import Crypto.Random (ChaChaDRG, randomBytesGenerate) -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (second) import Data.ByteString (ByteString) @@ -246,7 +245,6 @@ import Database.SQLite.Simple.FromField import Database.SQLite.Simple.QQ (sql) import Database.SQLite.Simple.ToField (ToField (..)) import qualified Database.SQLite3 as SQLite3 -import GHC.Generics (Generic) import Network.Socket (ServiceName) import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description @@ -266,7 +264,7 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..)) import Simplex.Messaging.Notifications.Types -import Simplex.Messaging.Parsers (blobFieldParser, dropPrefix, fromTextField_, sumTypeJSON) +import Simplex.Messaging.Parsers (blobFieldParser, defaultJSON, dropPrefix, fromTextField_, sumTypeJSON) import Simplex.Messaging.Protocol import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport.Client (TransportHost) @@ -286,7 +284,7 @@ data MigrationError = MEUpgrade {upMigrations :: [UpMigration]} | MEDowngrade {downMigrations :: [String]} | MigrationError {mtrError :: MTRError} - deriving (Eq, Show, Generic) + deriving (Eq, Show) migrationErrorDescription :: MigrationError -> String migrationErrorDescription = \case @@ -296,18 +294,12 @@ migrationErrorDescription = \case "Database version is newer than the app.\nConfirm to back up and downgrade using these migrations: " <> intercalate ", " dms MigrationError err -> mtrErrorDescription err -instance ToJSON MigrationError where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "ME" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "ME" - data UpMigration = UpMigration {upName :: String, withDown :: Bool} - deriving (Eq, Show, Generic, FromJSON) + deriving (Eq, Show) upMigration :: Migration -> UpMigration upMigration Migration {name, down} = UpMigration name $ isJust down -instance ToJSON UpMigration where toEncoding = J.genericToEncoding J.defaultOptions - data MigrationConfirmation = MCYesUp | MCYesUpDown | MCConsole | MCError deriving (Eq, Show) @@ -2745,3 +2737,7 @@ deleteDeletedSndChunkReplicasExpired :: DB.Connection -> NominalDiffTime -> IO ( deleteDeletedSndChunkReplicasExpired db ttl = do cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime DB.execute db "DELETE FROM deleted_snd_chunk_replicas WHERE created_at < ?" (Only cutoffTs) + +$(J.deriveJSON defaultJSON ''UpMigration) + +$(J.deriveToJSON (sumTypeJSON $ dropPrefix "ME") ''MigrationError) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs index 789f7214e..bfba973c1 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} module Simplex.Messaging.Agent.Store.SQLite.DB ( Connection (..), @@ -20,13 +20,12 @@ where import Control.Concurrent.STM import Control.Monad (when) -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import Data.Int (Int64) import Data.Time (diffUTCTime, getCurrentTime) import Database.SQLite.Simple (FromRow, NamedParam, Query, ToRow) import qualified Database.SQLite.Simple as SQL -import GHC.Generics (Generic) +import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (diffToMilliseconds) @@ -41,9 +40,7 @@ data SlowQueryStats = SlowQueryStats timeMax :: Int64, timeAvg :: Int64 } - deriving (Show, Generic, FromJSON) - -instance ToJSON SlowQueryStats where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) timeIt :: TMap Query SlowQueryStats -> Query -> IO a -> IO a timeIt slow sql a = do @@ -100,3 +97,5 @@ query_ Connection {conn, slow} sql = timeIt slow sql $ SQL.query_ conn sql queryNamed :: FromRow r => Connection -> Query -> [NamedParam] -> IO [r] queryNamed Connection {conn, slow} sql = timeIt slow sql . SQL.queryNamed conn sql {-# INLINE queryNamed #-} + +$(J.deriveJSON defaultJSON ''SlowQueryStats) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index d638c53c6..8ce7d6514 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} @@ -6,6 +5,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Simplex.Messaging.Agent.Store.SQLite.Migrations @@ -26,8 +26,7 @@ module Simplex.Messaging.Agent.Store.SQLite.Migrations where import Control.Monad (forM_, when) -import Data.Aeson (ToJSON) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import Data.List (intercalate, sortOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as M @@ -39,7 +38,6 @@ import Database.SQLite.Simple (Connection, Only (..), Query (..)) import qualified Database.SQLite.Simple as DB import Database.SQLite.Simple.QQ (sql) import qualified Database.SQLite3 as SQLite3 -import GHC.Generics (Generic) import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts) import Simplex.Messaging.Agent.Store.SQLite.Common import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial @@ -168,11 +166,7 @@ data MigrationsToRun = MTRUp [Migration] | MTRDown [DownMigration] | MTRNone data MTRError = MTRENoDown {dbMigrations :: [String]} | MTREDifferent {appMigration :: String, dbMigration :: String} - deriving (Eq, Show, Generic) - -instance ToJSON MTRError where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "MTRE" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "MTRE" + deriving (Eq, Show) mtrErrorDescription :: MTRError -> String mtrErrorDescription = \case @@ -191,3 +185,5 @@ migrationsToRun [] dbMs migrationsToRun (a : as) (d : ds) | name a == name d = migrationsToRun as ds | otherwise = Left $ MTREDifferent (name a) (name d) + +$(J.deriveJSON (sumTypeJSON $ dropPrefix "MTRE") ''MTRError) diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 1a4696e6d..11d75b7ee 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -10,6 +9,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -86,8 +86,7 @@ import Control.Exception import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except -import Data.Aeson (FromJSON (..), ToJSON (..)) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) @@ -97,13 +96,12 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe) import Data.Time.Clock (UTCTime, getCurrentTime) -import GHC.Generics (Generic) import Network.Socket (ServiceName) import Numeric.Natural import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, enumJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) import Simplex.Messaging.Protocol as SMP import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM @@ -190,14 +188,7 @@ data HostMode HMOnion | -- | prefer (or require) public hosts HMPublic - deriving (Eq, Show, Generic) - -instance FromJSON HostMode where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "HM" - -instance ToJSON HostMode where - toJSON = J.genericToJSON . enumJSON $ dropPrefix "HM" - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HM" + deriving (Eq, Show) -- | network configuration for the client data NetworkConfig = NetworkConfig @@ -223,21 +214,10 @@ data NetworkConfig = NetworkConfig smpPingCount :: Int, logTLSErrors :: Bool } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON NetworkConfig where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) data TransportSessionMode = TSMUser | TSMEntity - deriving (Eq, Show, Generic) - -instance ToJSON TransportSessionMode where - toJSON = J.genericToJSON . enumJSON $ dropPrefix "TSM" - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "TSM" - -instance FromJSON TransportSessionMode where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "TSM" + deriving (Eq, Show) defaultNetworkConfig :: NetworkConfig defaultNetworkConfig = @@ -765,3 +745,9 @@ mkTransmission ProtocolClient {sessionId, thVersion, client_ = PClient {clientCo r <- Request entId <$> newEmptyTMVar TM.insert corrId r sentCommands pure r + +$(J.deriveJSON (enumJSON $ dropPrefix "HM") ''HostMode) + +$(J.deriveJSON (enumJSON $ dropPrefix "TSM") ''TransportSessionMode) + +$(J.deriveJSON defaultJSON ''NetworkConfig) diff --git a/src/Simplex/Messaging/Crypto/File.hs b/src/Simplex/Messaging/Crypto/File.hs index 43b8ac22d..9afc5d583 100644 --- a/src/Simplex/Messaging/Crypto/File.hs +++ b/src/Simplex/Messaging/Crypto/File.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Simplex.Messaging.Crypto.File ( CryptoFile (..), @@ -23,19 +23,18 @@ where import Control.Exception import Control.Monad import Control.Monad.Except -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import qualified Data.ByteArray as BA import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust) -import GHC.Generics (Generic) import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Lazy (LazyByteString) import qualified Simplex.Messaging.Crypto.Lazy as LC +import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Util (liftEitherWith) import System.Directory (getFileSize) import UnliftIO (Handle, IOMode (..), liftIO) @@ -44,16 +43,10 @@ import UnliftIO.STM -- Possibly encrypted local file data CryptoFile = CryptoFile {filePath :: FilePath, cryptoArgs :: Maybe CryptoFileArgs} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON CryptoFile where - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) data CryptoFileArgs = CFArgs {fileKey :: C.SbKey, fileNonce :: C.CbNonce} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON CryptoFileArgs where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data CryptoFileHandle = CFHandle Handle (Maybe (TVar LC.SbState)) @@ -123,3 +116,7 @@ getFileContentsSize :: CryptoFile -> IO Integer getFileContentsSize (CryptoFile path cfArgs) = do size <- getFileSize path pure $ if isJust cfArgs then size - fromIntegral C.authTagSize else size + +$(J.deriveJSON defaultJSON ''CryptoFileArgs) + +$(J.deriveJSON defaultJSON ''CryptoFile) diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index ba3e8c77d..b84975a3d 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -20,8 +20,9 @@ import Control.Monad.Trans.Except import Crypto.Cipher.AES (AES256) import Crypto.Hash (SHA512) import qualified Crypto.KDF.HKDF as H -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J +import qualified Data.Aeson.TH as JQ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB @@ -33,12 +34,11 @@ import Data.Typeable (Typeable) import Data.Word (Word32) import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) -import GHC.Generics import Simplex.Messaging.Agent.QueryString import Simplex.Messaging.Crypto import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (blobFieldDecoder, parseE, parseE') +import Simplex.Messaging.Parsers (blobFieldDecoder, defaultJSON, parseE, parseE') import Simplex.Messaging.Version currentE2EEncryptVersion :: Version @@ -135,29 +135,20 @@ data Ratchet a = Ratchet rcNHKs :: HeaderKey, rcNHKr :: HeaderKey } - deriving (Eq, Show, Generic, FromJSON) - -instance AlgorithmI a => ToJSON (Ratchet a) where - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data SndRatchet a = SndRatchet { rcDHRr :: PublicKey a, rcCKs :: RatchetKey, rcHKs :: HeaderKey } - deriving (Eq, Show, Generic, FromJSON) - -instance AlgorithmI a => ToJSON (SndRatchet a) where - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data RcvRatchet = RcvRatchet { rcCKr :: RatchetKey, rcHKr :: HeaderKey } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON RcvRatchet where - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) type SkippedMsgKeys = Map HeaderKey SkippedHdrMsgKeys @@ -204,10 +195,6 @@ instance ToJSON RatchetKey where instance FromJSON RatchetKey where parseJSON = fmap RatchetKey . strParseJSON "Key" -instance AlgorithmI a => ToField (Ratchet a) where toField = toField . LB.toStrict . J.encode - -instance (AlgorithmI a, Typeable a) => FromField (Ratchet a) where fromField = blobFieldDecoder J.eitherDecodeStrict' - instance ToField MessageKey where toField = toField . smpEncode instance FromField MessageKey where fromField = blobFieldDecoder smpDecode @@ -493,3 +480,23 @@ hkdf3 salt ikm info = (s1, s2, s3) out = H.expand prk info 96 (s1, rest) = B.splitAt 32 out (s2, s3) = B.splitAt 32 rest + +$(JQ.deriveJSON defaultJSON ''RcvRatchet) + +instance AlgorithmI a => ToJSON (SndRatchet a) where + toEncoding = $(JQ.mkToEncoding defaultJSON ''SndRatchet) + toJSON = $(JQ.mkToJSON defaultJSON ''SndRatchet) + +instance AlgorithmI a => FromJSON (SndRatchet a) where + parseJSON = $(JQ.mkParseJSON defaultJSON ''SndRatchet) + +instance AlgorithmI a => ToJSON (Ratchet a) where + toEncoding = $(JQ.mkToEncoding defaultJSON ''Ratchet) + toJSON = $(JQ.mkToJSON defaultJSON ''Ratchet) + +instance AlgorithmI a => FromJSON (Ratchet a) where + parseJSON = $(JQ.mkParseJSON defaultJSON ''Ratchet) + +instance AlgorithmI a => ToField (Ratchet a) where toField = toField . LB.toStrict . J.encode + +instance (AlgorithmI a, Typeable a) => FromField (Ratchet a) where fromField = blobFieldDecoder J.eitherDecodeStrict' diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 5e03c9fc1..fd07e0a02 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use newtype instead of data" #-} @@ -23,15 +23,15 @@ import qualified Crypto.Store.PKCS8 as PK import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding import Data.ASN1.Types -import Data.Aeson (FromJSON, ToJSON, (.=)) +import Data.Aeson (ToJSON, (.=)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE +import qualified Data.Aeson.TH as JQ import Data.Bifunctor (first) import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Builder (lazyByteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB -import qualified Data.CaseInsensitive as CI import Data.Int (Int64) import Data.Map.Strict (Map) import Data.Maybe (isNothing) @@ -40,8 +40,7 @@ import qualified Data.Text as T import Data.Time.Clock.System import qualified Data.X509 as X import qualified Data.X509.CertificateStore as XS -import GHC.Generics (Generic) -import Network.HTTP.Types (HeaderName, Status) +import Network.HTTP.Types (Status) import qualified Network.HTTP.Types as N import Network.HTTP2.Client (Request) import qualified Network.HTTP2.Client as H @@ -49,7 +48,9 @@ import Network.Socket (HostName, ServiceName) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol +import Simplex.Messaging.Notifications.Server.Push.APNS.Internal import Simplex.Messaging.Notifications.Server.Store (NtfTknData (..)) +import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Protocol (EncNMsgMeta) import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..)) import Simplex.Messaging.Transport.HTTP2.Client @@ -61,17 +62,13 @@ data JWTHeader = JWTHeader { alg :: Text, -- key algorithm, ES256 for APNS kid :: Text -- key ID } - deriving (Show, Generic) - -instance ToJSON JWTHeader where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data JWTClaims = JWTClaims { iss :: Text, -- issuer, team ID for APNS iat :: Int64 -- issue time, seconds from epoch } - deriving (Show, Generic) - -instance ToJSON JWTClaims where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data JWTToken = JWTToken JWTHeader JWTClaims deriving (Show) @@ -83,6 +80,10 @@ mkJWTToken hdr iss = do type SignedJWTToken = ByteString +$(JQ.deriveToJSON defaultJSON ''JWTHeader) + +$(JQ.deriveToJSON defaultJSON ''JWTClaims) + signedJWTToken :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken signedJWTToken pk (JWTToken hdr claims) = do let hc = jwtEncode hdr <> "." <> jwtEncode claims @@ -122,24 +123,13 @@ instance StrEncoding PNMessageData where pure PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} data APNSNotification = APNSNotification {aps :: APNSNotificationBody, notificationData :: Maybe J.Value} - deriving (Show, Generic) - -instance ToJSON APNSNotification where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Show) data APNSNotificationBody = APNSBackground {contentAvailable :: Int} | APNSMutableContent {mutableContent :: Int, alert :: APNSAlertBody, category :: Maybe Text} | APNSAlert {alert :: APNSAlertBody, badge :: Maybe Int, sound :: Maybe Text, category :: Maybe Text} - deriving (Show, Generic) - -apnsJSONOptions :: J.Options -apnsJSONOptions = J.defaultOptions {J.omitNothingFields = True, J.sumEncoding = J.UntaggedValue, J.fieldLabelModifier = J.camelTo2 '-'} - -instance ToJSON APNSNotificationBody where - toJSON = J.genericToJSON apnsJSONOptions - toEncoding = J.genericToEncoding apnsJSONOptions + deriving (Show) type APNSNotificationData = Map Text Text @@ -305,6 +295,10 @@ apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case -- apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing} +$(JQ.deriveToJSON apnsJSONOptions ''APNSNotificationBody) + +$(JQ.deriveToJSON defaultJSON ''APNSNotification) + apnsRequest :: APNSPushClient -> ByteString -> APNSNotification -> IO Request apnsRequest c tkn ntf@APNSNotification {aps} = do signedJWT <- getApnsJWTToken c @@ -337,7 +331,8 @@ type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProvider -- this is not a newtype on purpose to have a correct JSON encoding as a record data APNSErrorResponse = APNSErrorResponse {reason :: Text} - deriving (Generic, FromJSON) + +$(JQ.deriveFromJSON defaultJSON ''APNSErrorResponse) apnsPushProviderClient :: APNSPushClient -> PushProviderClient apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken _ tknStr} pn = do @@ -372,12 +367,3 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke err :: Maybe Status -> Text -> ExceptT PushProviderError IO () err s r = throwError $ PPResponseError s r liftHTTPS2 a = ExceptT $ first PPConnection <$> a - -hApnsTopic :: HeaderName -hApnsTopic = CI.mk "apns-topic" - -hApnsPushType :: HeaderName -hApnsPushType = CI.mk "apns-push-type" - -hApnsPriority :: HeaderName -hApnsPriority = CI.mk "apns-priority" diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS/Internal.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS/Internal.hs new file mode 100644 index 000000000..8e79d40e3 --- /dev/null +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS/Internal.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.Messaging.Notifications.Server.Push.APNS.Internal where + +import qualified Data.Aeson as J +import qualified Data.CaseInsensitive as CI +import Network.HTTP.Types (HeaderName) +import Simplex.Messaging.Parsers (defaultJSON) + +hApnsTopic :: HeaderName +hApnsTopic = CI.mk "apns-topic" + +hApnsPushType :: HeaderName +hApnsPushType = CI.mk "apns-push-type" + +hApnsPriority :: HeaderName +hApnsPriority = CI.mk "apns-priority" + +apnsJSONOptions :: J.Options +apnsJSONOptions = defaultJSON {J.sumEncoding = J.UntaggedValue, J.fieldLabelModifier = J.camelTo2 '-'} diff --git a/src/Simplex/Messaging/Parsers.hs b/src/Simplex/Messaging/Parsers.hs index 10bd71a27..39cb0383c 100644 --- a/src/Simplex/Messaging/Parsers.hs +++ b/src/Simplex/Messaging/Parsers.hs @@ -151,3 +151,6 @@ singleFieldJSON_ objectTag tagModifier = J.nullaryToObject = True, J.omitNothingFields = True } + +defaultJSON :: J.Options +defaultJSON = J.defaultOptions {J.omitNothingFields = True} diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 44d33a381..3d5d44c7d 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -1,7 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -17,6 +16,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} @@ -155,7 +155,7 @@ import Control.Applicative (optional, (<|>)) import Control.Concurrent (threadDelay) import Control.Monad.Except import Data.Aeson (FromJSON (..), ToJSON (..)) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import Data.Attoparsec.ByteString.Char8 (Parser, ()) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) @@ -170,7 +170,6 @@ import Data.Maybe (isJust, isNothing) import Data.String import Data.Time.Clock.System (SystemTime (..)) import Data.Type.Equality -import GHC.Generics (Generic) import GHC.TypeLits (ErrorMessage (..), TypeError, type (+)) import Network.Socket (HostName, ServiceName) import qualified Simplex.Messaging.Crypto as C @@ -472,9 +471,7 @@ instance Encoding NMsgMeta where -- it must be data for correct JSON encoding data MsgFlags = MsgFlags {notification :: Bool} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON MsgFlags where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) -- this encoding should not become bigger than 7 bytes (currently it is 1 byte) instance Encoding MsgFlags where @@ -997,14 +994,7 @@ data ErrorType INTERNAL | -- | used internally, never returned by the server (to be removed) DUPLICATE_ -- not part of SMP protocol, used internally - deriving (Eq, Generic, Read, Show) - -instance ToJSON ErrorType where - toJSON = J.genericToJSON $ sumTypeJSON id - toEncoding = J.genericToEncoding $ sumTypeJSON id - -instance FromJSON ErrorType where - parseJSON = J.genericParseJSON $ sumTypeJSON id + deriving (Eq, Read, Show) instance StrEncoding ErrorType where strEncode = \case @@ -1026,14 +1016,7 @@ data CommandError HAS_AUTH | -- | transmission has no required entity ID (e.g. SMP queue) NO_ENTITY - deriving (Eq, Generic, Read, Show) - -instance ToJSON CommandError where - toJSON = J.genericToJSON $ sumTypeJSON id - toEncoding = J.genericToEncoding $ sumTypeJSON id - -instance FromJSON CommandError where - parseJSON = J.genericParseJSON $ sumTypeJSON id + deriving (Eq, Read, Show) -- | SMP transmission parser. transmissionP :: Parser RawTransmission @@ -1381,3 +1364,9 @@ tDecodeParseValidate sessionId v = \case tParseValidate signed t@(sig, corrId, entityId, command) = let cmd = parseProtocol @err @cmd v command >>= checkCredentials t in (sig, signed, (CorrId corrId, entityId, cmd)) + +$(J.deriveJSON defaultJSON ''MsgFlags) + +$(J.deriveJSON (sumTypeJSON id) ''CommandError) + +$(J.deriveJSON (sumTypeJSON id) ''ErrorType) diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 2281dce87..6509c1f6f 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -1,7 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -10,6 +9,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -- | @@ -63,8 +63,7 @@ where import Control.Applicative ((<|>)) import Control.Monad.Except import Control.Monad.Trans.Except (throwE) -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import Data.Attoparsec.ByteString.Char8 (Parser) import Data.Bifunctor (first) import Data.Bitraversable (bimapM) @@ -74,7 +73,6 @@ import qualified Data.ByteString.Lazy as BL import Data.Default (def) import Data.Functor (($>)) import Data.Version (showVersion) -import GHC.Generics (Generic) import GHC.IO.Handle.Internals (ioe_EOF) import Network.Socket import qualified Network.TLS as T @@ -282,14 +280,7 @@ data TransportError TEBadSession | -- | transport handshake error TEHandshake {handshakeErr :: HandshakeError} - deriving (Eq, Generic, Read, Show, Exception) - -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" + deriving (Eq, Read, Show, Exception) -- | Transport handshake error. data HandshakeError @@ -299,14 +290,7 @@ data HandshakeError VERSION | -- | incorrect server identity IDENTITY - deriving (Eq, Generic, Read, Show, Exception) - -instance ToJSON HandshakeError where - toJSON = J.genericToJSON $ sumTypeJSON id - toEncoding = J.genericToEncoding $ sumTypeJSON id - -instance FromJSON HandshakeError where - parseJSON = J.genericParseJSON $ sumTypeJSON id + deriving (Eq, Read, Show, Exception) -- | SMP encrypted transport error parser. transportErrorP :: Parser TransportError @@ -379,3 +363,7 @@ getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock t smpTHandle :: Transport c => c -> THandle c smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, batch = False} + +$(J.deriveJSON (sumTypeJSON id) ''HandshakeError) + +$(J.deriveJSON (sumTypeJSON $ dropPrefix "TE") ''TransportError) diff --git a/src/Simplex/Messaging/Transport/KeepAlive.hs b/src/Simplex/Messaging/Transport/KeepAlive.hs index 35ef21fb5..52d5e7aaf 100644 --- a/src/Simplex/Messaging/Transport/KeepAlive.hs +++ b/src/Simplex/Messaging/Transport/KeepAlive.hs @@ -1,25 +1,22 @@ {-# LANGUAGE CApiFFI #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} module Simplex.Messaging.Transport.KeepAlive where -import Data.Aeson (FromJSON (..), ToJSON (..)) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import Foreign.C (CInt (..)) -import GHC.Generics (Generic) import Network.Socket +import Simplex.Messaging.Parsers (defaultJSON) data KeepAliveOpts = KeepAliveOpts { keepIdle :: Int, keepIntvl :: Int, keepCnt :: Int } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON KeepAliveOpts where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) defaultKeepAliveOpts :: KeepAliveOpts defaultKeepAliveOpts = @@ -68,3 +65,5 @@ setSocketKeepAlive sock KeepAliveOpts {keepCnt, keepIdle, keepIntvl} = do setSocketOption sock (SockOpt _SOL_TCP _TCP_KEEPIDLE) keepIdle setSocketOption sock (SockOpt _SOL_TCP _TCP_KEEPINTVL) keepIntvl setSocketOption sock (SockOpt _SOL_TCP _TCP_KEEPCNT) keepCnt + +$(J.deriveJSON defaultJSON ''KeepAliveOpts) diff --git a/tests/CoreTests/ProtocolErrorTests.hs b/tests/CoreTests/ProtocolErrorTests.hs index e653ab43a..cc6da7b6c 100644 --- a/tests/CoreTests/ProtocolErrorTests.hs +++ b/tests/CoreTests/ProtocolErrorTests.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} module CoreTests.ProtocolErrorTests where @@ -7,13 +9,14 @@ module CoreTests.ProtocolErrorTests where import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) +import GHC.Generics (Generic) import Generic.Random (genericArbitraryU) -import Simplex.FileTransfer.Protocol (XFTPErrorType) +import Simplex.FileTransfer.Protocol (XFTPErrorType (..)) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (CommandError, ErrorType) -import Simplex.Messaging.Transport (HandshakeError, TransportError) +import Simplex.Messaging.Protocol (CommandError (..), ErrorType (..)) +import Simplex.Messaging.Transport (HandshakeError (..), TransportError (..)) import Test.Hspec import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck @@ -33,6 +36,28 @@ protocolErrorTests = modifyMaxSuccess (const 1000) $ do _ -> False hasSpaces s = ' ' `B.elem` encodeUtf8 (T.pack s) +deriving instance Generic AgentErrorType + +deriving instance Generic CommandErrorType + +deriving instance Generic ConnectionErrorType + +deriving instance Generic BrokerErrorType + +deriving instance Generic SMPAgentError + +deriving instance Generic AgentCryptoError + +deriving instance Generic ErrorType + +deriving instance Generic CommandError + +deriving instance Generic TransportError + +deriving instance Generic HandshakeError + +deriving instance Generic XFTPErrorType + instance Arbitrary AgentErrorType where arbitrary = genericArbitraryU instance Arbitrary CommandErrorType where arbitrary = genericArbitraryU diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index d4f6a856d..15a42fa8c 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -38,6 +38,7 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Notifications.Server (runNtfServerBlocking) import Simplex.Messaging.Notifications.Server.Env import Simplex.Messaging.Notifications.Server.Push.APNS +import Simplex.Messaging.Notifications.Server.Push.APNS.Internal import Simplex.Messaging.Notifications.Transport import Simplex.Messaging.Protocol import Simplex.Messaging.Transport @@ -186,10 +187,16 @@ instance FromJSON APNSAlertBody where parseJSON (J.String v) = pure $ APNSAlertText v parseJSON invalid = JT.prependFailure "parsing Coord failed, " (JT.typeMismatch "Object" invalid) +deriving instance Generic APNSNotificationBody + instance FromJSON APNSNotificationBody where parseJSON = J.genericParseJSON apnsJSONOptions {J.rejectUnknownFields = True} +deriving instance Generic APNSNotification + deriving instance FromJSON APNSNotification +deriving instance Generic APNSErrorResponse + deriving instance ToJSON APNSErrorResponse getAPNSMockServer :: HTTP2ServerConfig -> IO APNSMockServer