core: convert single-field to tagged JSON encoding (#3183)

* core: convert single-field to tagged JSON encoding

* rename

* rename

* fixes, test

* refactor

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

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.*

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";

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.*

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

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

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)

tests/RemoteTests.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module RemoteTests where

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