Skip to content

Commit

Permalink
Merge pull request #517 from IntersectMBO/mgalazyn/fix/sort-metadata-…
Browse files Browse the repository at this point in the history 
…keys-for-cbor

Sort metadata keys for no-schema json for canonical CBOR
  • Loading branch information
@carbolymer
carbolymer authored Apr 12, 2024
2 parents 3bbdf8a + 6cd7f73 commit f912577
Show file tree
Hide file tree
Showing 3 changed files with 162 additions and 50 deletions.
1 change: 1 addition & 0 deletions cardano-api/cardano-api.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -319,6 +319,7 @@ test-suite cardano-api-test
, hedgehog >= 1.1
, hedgehog-extras
, hedgehog-quickcheck
, interpolatedstring-perl6
, mtl
, QuickCheck
, tasty
Expand Down
32 changes: 25 additions & 7 deletions cardano-api/internal/Cardano/Api/TxMetadata.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -57,6 +57,7 @@ import Cardano.Api.SerialiseCBOR (SerialiseAsCBOR (..))
import qualified Cardano.Ledger.Binary as CBOR
import qualified Cardano.Ledger.Shelley.TxAuxData as Shelley

import qualified Codec.CBOR.Magic as CBOR
import Control.Applicative (Alternative (..))
import Control.Monad (guard, when)
import qualified Data.Aeson as Aeson
Expand Down Expand Up @@ -85,13 +86,11 @@ import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Vector as Vector
import Data.Word

{- HLINT ignore "Use lambda-case" -}

-- ----------------------------------------------------------------------------
-- TxMetadata types
--

newtype TxMetadata = TxMetadata (Map Word64 TxMetadataValue)
newtype TxMetadata = TxMetadata { unTxMetadata :: Map Word64 TxMetadataValue }
deriving (Eq, Show)

data TxMetadataValue = TxMetaMap [(TxMetadataValue, TxMetadataValue)]
Expand Down Expand Up @@ -133,7 +132,7 @@ instance SerialiseAsCBOR TxMetadata where
-- protocol version be supplied as an argument.
CBOR.serialize' CBOR.shelleyProtVer
. toShelleyMetadata
. (\(TxMetadata m) -> m)
. unTxMetadata

deserialiseFromCBOR AsTxMetadata bs =
TxMetadata
Expand Down Expand Up @@ -429,7 +428,7 @@ metadataFromJson :: TxMetadataJsonSchema
-> Aeson.Value
-> Either TxMetadataJsonError TxMetadata
metadataFromJson schema =
\vtop -> case vtop of
\case
-- The top level has to be an object
-- with unsigned integer (decimal or hex) keys
Aeson.Object m ->
Expand Down Expand Up @@ -556,9 +555,11 @@ metadataValueFromJsonNoSchema = conv
$ Vector.toList vs

conv (Aeson.Object kvs) =
fmap TxMetaMap
fmap
( TxMetaMap
. sortCanonicalForCbor
)
. traverse (\(k,v) -> (,) (convKey k) <$> conv v)
. List.sortOn fst
. fmap (first Aeson.toText)
$ KeyMap.toList kvs

Expand All @@ -574,6 +575,23 @@ bytesPrefix :: Text
bytesPrefix = "0x"


-- | Sorts the list by the first value in the tuple using the rules for canonical CBOR (RFC 7049 section 3.9)
--
-- This function is used when transforming data from JSON. In principle the JSON standard and aeson library
-- do not provide any guarantees about the order of keys in 'Aeson.Object' which means we are free to pick any.
-- Because we're dumping data into CBOR we are picking a canonical way of sorting keys in a map - the keys are
-- sorted according to the value of their byte representation.
--
-- Details described here: https://datatracker.ietf.org/doc/html/rfc7049#section-3.9
sortCanonicalForCbor :: [(TxMetadataValue, TxMetadataValue)]
-> [(TxMetadataValue, TxMetadataValue)]
sortCanonicalForCbor =
map snd
. List.sortOn fst
. map (\e@(k, _) -> (CBOR.uintegerFromBytes $ serialiseKey k, e))
where
serialiseKey = CBOR.serialize' CBOR.shelleyProtVer . toShelleyMetadatum

-- ----------------------------------------------------------------------------
-- JSON conversion using the "detailed schema" style
--
Expand Down
179 changes: 136 additions & 43 deletions cardano-api/test/cardano-api-test/Test/Cardano/Api/Metadata.hs
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

module Test.Cardano.Api.Metadata
( tests
Expand All @@ -14,11 +15,14 @@ import Data.ByteString (ByteString)
import qualified Data.Map.Strict as Map
import Data.Maybe (mapMaybe)
import Data.Word (Word64)
import GHC.Stack
import Text.InterpolatedString.Perl6

import Test.Gen.Cardano.Api.Metadata

import Hedgehog (Gen, Property, property, (===))
import qualified Hedgehog
import Hedgehog (Gen, Property, (===))
import qualified Hedgehog as H
import qualified Hedgehog.Extras as H
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Tasty (TestTree, testGroup)
Expand All @@ -29,63 +33,151 @@ import Test.Tasty.Hedgehog (testProperty)
--

prop_golden_1 :: Property
prop_golden_1 = matchMetadata
"{\"0\": 1}"
prop_golden_1 = matchMetadata TxMetadataJsonNoSchema
[q|{"0": 1}|]
(TxMetadata (Map.fromList [(0, TxMetaNumber 1)]))

prop_golden_2 :: Property
prop_golden_2 = matchMetadata
"{\"0\": \"deadbeef\"}"
prop_golden_2 = matchMetadata TxMetadataJsonNoSchema
[q|{"0": "deadbeef"}|]
(txMetadataSingleton 0 (TxMetaText "deadbeef"))

prop_golden_3 :: Property
prop_golden_3 = matchMetadata
"{\"0\": \"0xDEADBEEF\"}"
prop_golden_3 = matchMetadata TxMetadataJsonNoSchema
[q|{"0": "0xDEADBEEF"}|]
(txMetadataSingleton 0 (TxMetaText "0xDEADBEEF"))

prop_golden_4 :: Property
prop_golden_4 = matchMetadata
"{\"0\": \"0xdeadbeef\"}"
prop_golden_4 = matchMetadata TxMetadataJsonNoSchema
[q|{"0": "0xdeadbeef"}|]
(txMetadataSingleton 0 (TxMetaBytes "\xde\xad\xbe\xef"))

prop_golden_5 :: Property
prop_golden_5 = matchMetadata
"{\"0\": [] }"
prop_golden_5 = matchMetadata TxMetadataJsonNoSchema
[q|{"0": [] }|]
(txMetadataSingleton 0 (TxMetaList []))

prop_golden_6 :: Property
prop_golden_6 = matchMetadata
"{\"0\": [1, \"a\", \"0x42\"] }"
prop_golden_6 = matchMetadata TxMetadataJsonNoSchema
[q|{"0": [1, "a", "0x42"] }|]
(txMetadataSingleton 0
(TxMetaList [TxMetaNumber 1
,TxMetaText "a"
,TxMetaBytes "\x42"]))

prop_golden_7 :: Property
prop_golden_7 = matchMetadata
"{\"0\": {} }"
prop_golden_7 = matchMetadata TxMetadataJsonNoSchema
[q|{"0": {} }|]
(txMetadataSingleton 0 (TxMetaMap []))

prop_golden_8 :: Property
prop_golden_8 = matchMetadata
"{\"0\": { \"0x41\": \"0x42\", \"1\": 2, \"a\" : \"b\" }}"
(txMetadataSingleton 0
(TxMetaMap [(TxMetaBytes "\x41", TxMetaBytes "\x42")
,(TxMetaNumber 1, TxMetaNumber 2)
,(TxMetaText "a", TxMetaText "b")]))
prop_golden_8 =
matchMetadata TxMetadataJsonNoSchema
[q|{"0": {
"0x41": "0x42",
"0x154041": "0x44",
"0x104041": "0x43",
"0x3041": "0x45",
"aab": "ba",
"abb": "ba",
"11": 3,
"1": 2,
"a": "b",
"aa": "bb",
"ab": "ba",
"aba": {
"0x41": "0x42",
"0x154041": "0x44",
"0x104041": "0x43",
"0x3041": "0x45",
"aab": "ba",
"abb": "ba",
"11": 3,
"1": 2,
"a": "b",
"aa": "bb",
"ab": "ba"
}
}}|]
( txMetadataSingleton 0
( TxMetaMap
[ ( TxMetaNumber 1 , TxMetaNumber 2 )
, ( TxMetaNumber 11 , TxMetaNumber 3 )
, ( TxMetaBytes "A" , TxMetaBytes "B" )
, ( TxMetaText "a" , TxMetaText "b" )
, ( TxMetaBytes "0A" , TxMetaBytes "E" )
, ( TxMetaText "aa" , TxMetaText "bb" )
, ( TxMetaText "ab" , TxMetaText "ba" )
, ( TxMetaBytes "\DLE@A" , TxMetaBytes "C" )
, ( TxMetaBytes "\NAK@A" , TxMetaBytes "D" )
, ( TxMetaText "aab" , TxMetaText "ba" )
, ( TxMetaText "aba"
, TxMetaMap
[ ( TxMetaNumber 1 , TxMetaNumber 2 )
, ( TxMetaNumber 11 , TxMetaNumber 3 )
, ( TxMetaBytes "A" , TxMetaBytes "B" )
, ( TxMetaText "a" , TxMetaText "b" )
, ( TxMetaBytes "0A" , TxMetaBytes "E" )
, ( TxMetaText "aa" , TxMetaText "bb" )
, ( TxMetaText "ab" , TxMetaText "ba" )
, ( TxMetaBytes "\DLE@A" , TxMetaBytes "C" )
, ( TxMetaBytes "\NAK@A" , TxMetaBytes "D" )
, ( TxMetaText "aab" , TxMetaText "ba" )
, ( TxMetaText "abb" , TxMetaText "ba" )
]
)
, ( TxMetaText "abb" , TxMetaText "ba" )
]
))

prop_golden_9 :: Property
prop_golden_9 =
matchMetadata TxMetadataJsonDetailedSchema
[q|{"0":
{"map":
[ { "k": {"string": "aaa"}
, "v": {"string": "b4"}
}
, { "k": {"int": 1}
, "v": {"string": "b6"}
}
, { "k": {"string": "aa"}
, "v": {"string": "b2"}
}
, { "k": {"string": "ab"}
, "v": {"string": "b3"}
}
, { "k": {"string": "b"}
, "v": {"string": "b5"}
}
, { "k": {"string": "a"}
, "v": {"string": "b1"}
}
]
}}|]
( txMetadataSingleton 0
( TxMetaMap
[ ( TxMetaText "aaa" , TxMetaText "b4" )
, ( TxMetaNumber 1 , TxMetaText "b6" )
, ( TxMetaText "aa" , TxMetaText "b2" )
, ( TxMetaText "ab" , TxMetaText "b3" )
, ( TxMetaText "b" , TxMetaText "b5" )
, ( TxMetaText "a" , TxMetaText "b1" )
]
))

txMetadataSingleton :: Word64 -> TxMetadataValue -> TxMetadata
txMetadataSingleton n v = TxMetadata (Map.fromList [(n, v)])

matchMetadata :: ByteString -> TxMetadata -> Property
matchMetadata jsonStr metadata =
Hedgehog.withTests 1 $ Hedgehog.property $ Hedgehog.test $
case Aeson.decodeStrict' jsonStr of
Nothing -> Hedgehog.failure
Just json -> do
Hedgehog.annotateShow json
metadataFromJson TxMetadataJsonNoSchema json === Right metadata

matchMetadata :: HasCallStack
=> TxMetadataJsonSchema
-> ByteString -- ^ json string to test
-> TxMetadata -- ^ expected metadata
-> Property
matchMetadata hasSchema jsonStr expectedMetadata = withFrozenCallStack $ H.propertyOnce $ do
json <- H.noteShowM . H.nothingFail $ Aeson.decodeStrict' jsonStr
metadata <- H.noteShowM . H.leftFail $ metadataFromJson hasSchema json
metadata === expectedMetadata

-- ----------------------------------------------------------------------------
-- Round trip properties
Expand All @@ -99,17 +191,17 @@ matchMetadata jsonStr metadata =
-- original value.
--
prop_noschema_json_roundtrip_via_metadata :: Property
prop_noschema_json_roundtrip_via_metadata = Hedgehog.property $ do
json <- Hedgehog.forAll (genJsonForTxMetadata TxMetadataJsonNoSchema)
prop_noschema_json_roundtrip_via_metadata = H.property $ do
json <- H.forAll (genJsonForTxMetadata TxMetadataJsonNoSchema)
Right json === (fmap (metadataToJson TxMetadataJsonNoSchema)
. metadataFromJson TxMetadataJsonNoSchema) json

-- | Any JSON (fitting the detailed schema) can be converted to tx metadata and
-- back, to give the same original JSON.
--
prop_schema_json_roundtrip_via_metadata :: Property
prop_schema_json_roundtrip_via_metadata = Hedgehog.property $ do
json <- Hedgehog.forAll (genJsonForTxMetadata TxMetadataJsonDetailedSchema)
prop_schema_json_roundtrip_via_metadata = H.property $ do
json <- H.forAll (genJsonForTxMetadata TxMetadataJsonDetailedSchema)
Right json === (fmap (metadataToJson TxMetadataJsonDetailedSchema)
. metadataFromJson TxMetadataJsonDetailedSchema) json

Expand All @@ -118,8 +210,8 @@ prop_schema_json_roundtrip_via_metadata = Hedgehog.property $ do
-- back, to give the same original tx metadata.
--
prop_metadata_roundtrip_via_schema_json :: Property
prop_metadata_roundtrip_via_schema_json = Hedgehog.property $ do
md <- Hedgehog.forAll genTxMetadata
prop_metadata_roundtrip_via_schema_json = H.property $ do
md <- H.forAll genTxMetadata
Right md === (metadataFromJson TxMetadataJsonDetailedSchema
. metadataToJson TxMetadataJsonDetailedSchema) md

Expand All @@ -129,19 +221,19 @@ prop_metadata_chunks
-> (str -> TxMetadataValue)
-> (TxMetadataValue -> Maybe str)
-> Property
prop_metadata_chunks genStr toMetadataValue extractChunk = Hedgehog.property $ do
str <- Hedgehog.forAll genStr
prop_metadata_chunks genStr toMetadataValue extractChunk = H.property $ do
str <- H.forAll genStr
case toMetadataValue str of
metadataValue@(TxMetaList chunks) -> do
Hedgehog.cover 1 "Empty chunks" (null chunks)
Hedgehog.cover 5 "Single chunks" (length chunks == 1)
Hedgehog.cover 25 "Many chunks" (length chunks > 1)
H.cover 1 "Empty chunks" (null chunks)
H.cover 5 "Single chunks" (length chunks == 1)
H.cover 25 "Many chunks" (length chunks > 1)
str === mconcat (mapMaybe extractChunk chunks)
Right () === validateTxMetadata metadata
where
metadata = makeTransactionMetadata (Map.singleton 0 metadataValue)
_ ->
Hedgehog.failure
H.failure

prop_metadata_text_chunks :: Property
prop_metadata_text_chunks =
Expand Down Expand Up @@ -177,6 +269,7 @@ tests = testGroup "Test.Cardano.Api.Metadata"
, testProperty "golden 6" prop_golden_6
, testProperty "golden 7" prop_golden_7
, testProperty "golden 8" prop_golden_8
, testProperty "golden 9" prop_golden_9
, testProperty "noschema json roundtrip via metadata" prop_noschema_json_roundtrip_via_metadata
, testProperty "schema json roundtrip via metadata" prop_schema_json_roundtrip_via_metadata
, testProperty "metadata roundtrip via schema json" prop_metadata_roundtrip_via_schema_json
Expand Down

0 comments on commit f912577

Please sign in to comment.