diff --git a/cabal.project b/cabal.project index 3da442ac49..1364d77bf2 100644 --- a/cabal.project +++ b/cabal.project @@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: 919550948501d315aa8845cbed1781d4298d4ced + tag: 6b0da8ac50b1582c9f5187c316b93fc8f12c9365 source-repository-package type: git diff --git a/package.yaml b/package.yaml index f7fc614789..861d0c494a 100644 --- a/package.yaml +++ b/package.yaml @@ -120,9 +120,11 @@ tests: - apps/simplex-directory-service/src main: Test.hs dependencies: + - QuickCheck == 2.14.* - simplex-chat - async == 2.2.* - deepseq == 1.4.* + - generic-random == 1.5.* - hspec == 2.11.* - network == 3.1.* - silently == 1.2.* diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 0a199779d0..e1880738d7 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."919550948501d315aa8845cbed1781d4298d4ced" = "05d0cadhlazqi2lxcb7nvyjrf8q49c6ax7b8rahawbh1zmwg38nm"; + "https://github.com/simplex-chat/simplexmq.git"."6b0da8ac50b1582c9f5187c316b93fc8f12c9365" = "18n0b1l1adraw5rq118a6iz9pqg43yf41vrzm193q1si06iwk24b"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "0kiwhvml42g9anw4d2v0zd1fpc790pj9syg5x3ik4l97fnkbbwpp"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 81a71a9109..4fc023bc3b 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -488,6 +488,7 @@ test-suite simplex-chat-test ChatTests.Groups ChatTests.Profiles ChatTests.Utils + JSONTests MarkdownTests MobileTests ProtocolTests @@ -509,7 +510,8 @@ test-suite simplex-chat-test apps/simplex-directory-service/src ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded build-depends: - aeson ==2.2.* + QuickCheck ==2.14.* + , aeson ==2.2.* , ansi-terminal >=0.10 && <0.12 , async ==2.2.* , attoparsec ==0.14.* @@ -528,6 +530,7 @@ test-suite simplex-chat-test , email-validate ==2.3.* , exceptions ==0.10.* , filepath ==1.4.* + , generic-random ==1.5.* , hspec ==2.11.* , http-types ==0.12.* , http2 ==4.1.* diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 0f03c1fdb5..b81ba33cda 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -4,6 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -16,7 +17,10 @@ import Control.Monad.IO.Class import Control.Monad.Reader (asks) import Control.Monad.STM (retry) import Crypto.Random (getRandomBytes) +import Data.Aeson ((.=)) import qualified Data.Aeson as J +import qualified Data.Aeson.Key as JK +import qualified Data.Aeson.KeyMap as JM import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Binary.Builder as Binary import Data.ByteString (ByteString, hPut) @@ -47,6 +51,7 @@ import Simplex.FileTransfer.Util (uniqueCombine) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Encoding.String (StrEncoding (..)) +import Simplex.Messaging.Parsers (pattern SingleFieldJSONTag, pattern TaggedObjectJSONTag, pattern TaggedObjectJSONData) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) @@ -233,9 +238,37 @@ handleRcvFileComplete http storePath remoteUser cif@CIFile {fileId, fileName, fi -- | Convert swift single-field sum encoding into tagged/discriminator-field owsf2tagged :: J.Value -> J.Value -owsf2tagged = \case - J.Object todo'convert -> J.Object todo'convert - skip -> skip +owsf2tagged = fst . convert + where + convert val = case val of + J.Object o + | JM.size o == 2 -> + case JM.toList o of + [OwsfTag, o'] -> tagged o' + [o', OwsfTag] -> tagged o' + _ -> props + | otherwise -> props + where + props = (J.Object $ fmap owsf2tagged o, False) + J.Array a -> (J.Array $ fmap owsf2tagged a, False) + _ -> (val, False) + -- `tagged` converts the pair of single-field object encoding to tagged encoding. + -- It sets innerTag returned by `convert` to True to prevent the tag being overwritten. + tagged (k, v) = (J.Object pairs, True) + where + (v', innerTag) = convert v + pairs = case v' of + -- `innerTag` indicates that internal object already has tag, + -- so the current tag cannot be inserted into it. + J.Object o + | innerTag -> pair + | otherwise -> JM.insert TaggedObjectJSONTag tag o + _ -> pair + tag = J.String $ JK.toText k + pair = JM.fromList [TaggedObjectJSONTag .= tag, TaggedObjectJSONData .= v'] + +pattern OwsfTag :: (JK.Key, J.Value) +pattern OwsfTag = (SingleFieldJSONTag, J.Bool True) storeRemoteFile :: (MonadUnliftIO m) => HTTP2Client -> FilePath -> m (Maybe FilePath) storeRemoteFile http localFile = do diff --git a/stack.yaml b/stack.yaml index 5d9fc214fb..e467b040e9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -49,7 +49,7 @@ extra-deps: # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561 # - ../simplexmq - github: simplex-chat/simplexmq - commit: 919550948501d315aa8845cbed1781d4298d4ced + commit: 6b0da8ac50b1582c9f5187c316b93fc8f12c9365 - github: kazu-yamamoto/http2 commit: b5a1b7200cf5bc7044af34ba325284271f6dff25 # - ../direct-sqlcipher diff --git a/tests/JSONTests.hs b/tests/JSONTests.hs new file mode 100644 index 0000000000..11567d94af --- /dev/null +++ b/tests/JSONTests.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveGeneric #-} + +module JSONTests where + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as J +import qualified Data.Aeson.Types as JT +import qualified Data.ByteString.Lazy.Char8 as LB +import GHC.Generics (Generic) +import Generic.Random (genericArbitraryU) +import MobileTests +import Simplex.Chat.Remote (owsf2tagged) +import Simplex.Messaging.Parsers +import Test.Hspec +import Test.Hspec.QuickCheck (modifyMaxSuccess) +import Test.QuickCheck (Arbitrary (..), property) + +jsonTests :: Spec +jsonTests = describe "owsf2tagged" $ do + it "should convert chat types" owsf2TaggedJSONTest + describe "SomeType" owsf2TaggedSomeTypeTests + +owsf2TaggedJSONTest :: IO () +owsf2TaggedJSONTest = do + noActiveUserSwift `to` noActiveUserTagged + activeUserExistsSwift `to` activeUserExistsTagged + activeUserSwift `to` activeUserTagged + chatStartedSwift `to` chatStartedTagged + contactSubSummarySwift `to` contactSubSummaryTagged + memberSubSummarySwift `to` memberSubSummaryTagged + userContactSubSummarySwift `to` userContactSubSummaryTagged + pendingSubSummarySwift `to` pendingSubSummaryTagged + parsedMarkdownSwift `to` parsedMarkdownTagged + where + to :: LB.ByteString -> LB.ByteString -> IO () + owsf `to` tagged = + case J.eitherDecode owsf of + Right json -> Right (owsf2tagged json) `shouldBe` J.eitherDecode tagged + Left e -> expectationFailure e + +data SomeType + = Nullary + | Unary (Maybe SomeType) + | Product String (Maybe SomeType) + | Record + { testOne :: Int, + testTwo :: Maybe Bool, + testThree :: Maybe SomeType + } + | List [Int] + deriving (Eq, Show, Generic) + +instance Arbitrary SomeType where arbitrary = genericArbitraryU + +instance ToJSON SomeType where + toJSON = J.genericToJSON $ singleFieldJSON_ (Just SingleFieldJSONTag) id + toEncoding = J.genericToEncoding $ singleFieldJSON_ (Just SingleFieldJSONTag) id + +instance FromJSON SomeType where + parseJSON = J.genericParseJSON $ taggedObjectJSON id + +owsf2TaggedSomeTypeTests :: Spec +owsf2TaggedSomeTypeTests = + modifyMaxSuccess (const 10000) $ it "should convert to tagged" $ property $ \x -> + (JT.parseMaybe J.parseJSON . owsf2tagged . J.toJSON) x == Just (x :: SomeType) diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index 34e2b04a6f..84f361a4a4 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} module RemoteTests where diff --git a/tests/Test.hs b/tests/Test.hs index 1e2cad0376..071ff3791e 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -5,6 +5,7 @@ import ChatTests import ChatTests.Utils (xdescribe'') import Control.Logger.Simple import Data.Time.Clock.System +import JSONTests import MarkdownTests import MobileTests import ProtocolTests @@ -22,6 +23,7 @@ main = do withGlobalLogging logCfg . hspec $ do describe "Schema dump" schemaDumpTest describe "SimpleX chat markdown" markdownTests + describe "JSON Tests" jsonTests describe "SimpleX chat view" viewTests describe "SimpleX chat protocol" protocolTests describe "WebRTC encryption" webRTCTests