simplex-chat/tests/JSONTests.hs
spaced4ndy e05a35e26e
core: support postgres backend (#5403)
* postgres: modules structure (#5401)

* postgres: schema, field conversions (#5430)

* postgres: rework chat list pagination query (#5441)

* prepare cabal for merge

* restore cabal changes

* simplexmq

* postgres: implementation wip (tests don't pass) (#5481)

* restore ios file

* postgres: implementation - tests pass (#5487)

* refactor DB options

* refactor

* line

* style

* style

* refactor

* $

* update simplexmq

* constraintError

* handleDBErrors

* fix

* remove param

* Ok

* case

* case

* case

* comment

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
2025-01-10 11:27:29 +00:00

86 lines
3.2 KiB
Haskell

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
module JSONTests where
import Control.Monad (join)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import qualified Data.Aeson.Types as JT
import Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Lazy.Char8 as LB
import GHC.Generics (Generic)
import Generic.Random (genericArbitraryU)
import JSONFixtures
import Simplex.Chat.Remote.Protocol (owsf2tagged)
import Simplex.Messaging.Parsers
import Test.Hspec
import Test.Hspec.QuickCheck (modifyMaxSuccess)
import Test.QuickCheck (Arbitrary (..), property)
owsf2TaggedJSONTest :: IO ()
owsf2TaggedJSONTest = do
noActiveUserSwift `to` noActiveUserTagged
activeUserExistsSwift `to` activeUserExistsTagged
activeUserSwift `to` activeUserTagged
chatStartedSwift `to` chatStartedTagged
networkStatusesSwift `to` networkStatusesTagged
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)
$(pure [])
thToJSON :: SomeType -> J.Value
thToJSON = $(JQ.mkToJSON (singleFieldJSON_ (Just SingleFieldJSONTag) id) ''SomeType)
thToEncoding :: SomeType -> J.Encoding
thToEncoding = $(JQ.mkToEncoding (singleFieldJSON_ (Just SingleFieldJSONTag) id) ''SomeType)
thParseJSON :: J.Value -> JT.Parser SomeType
thParseJSON = $(JQ.mkParseJSON (taggedObjectJSON id) ''SomeType)
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) $ do
it "should convert to tagged" $ property $ \x ->
(JT.parseMaybe J.parseJSON . owsf2tagged . J.toJSON) x == Just (x :: SomeType)
it "should convert to tagged via encoding" $ property $ \x ->
(join . fmap (JT.parseMaybe J.parseJSON . owsf2tagged) . J.decode . J.encode) x == Just (x :: SomeType)
it "should convert to tagged via TH" $ property $ \x ->
(JT.parseMaybe thParseJSON . owsf2tagged . thToJSON) x == Just (x :: SomeType)
it "should convert to tagged via TH encoding" $ property $ \x ->
(join . fmap (JT.parseMaybe thParseJSON . owsf2tagged) . J.decode . toLazyByteString . J.fromEncoding . thToEncoding) x == Just (x :: SomeType)
jsonTests :: Spec
jsonTests = describe "owsf2tagged" $ do
it "should convert chat types" owsf2TaggedJSONTest
describe "SomeType" owsf2TaggedSomeTypeTests