diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index a3918bf26d..f0f69cd005 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -475,5 +475,6 @@ test-suite cardano-api-golden Test.Golden.Cardano.Api.Genesis Test.Golden.Cardano.Api.Ledger Test.Golden.Cardano.Api.Script + Test.Golden.Cardano.Api.Tx Test.Golden.Cardano.Api.Value Test.Golden.ErrorsSpec diff --git a/cardano-api/src/Cardano/Api/Serialise/Cbor/Canonical.hs b/cardano-api/src/Cardano/Api/Serialise/Cbor/Canonical.hs index 4b44acacd5..f9dae2804e 100644 --- a/cardano-api/src/Cardano/Api/Serialise/Cbor/Canonical.hs +++ b/cardano-api/src/Cardano/Api/Serialise/Cbor/Canonical.hs @@ -67,7 +67,9 @@ canonicaliseTerm = \case (TTagged tag term) -> TTagged tag $ canonicaliseTerm term (TListI terms) -> - TList terms + TList $ map canonicaliseTerm terms + (TList terms) -> + TList $ map canonicaliseTerm terms term -> term -- | Implements sorting of CBOR terms for canonicalisation. CBOR terms are compared by lexical order of their diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Tx.hs b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Tx.hs new file mode 100644 index 0000000000..3184014744 --- /dev/null +++ b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Tx.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Golden.Cardano.Api.Tx + ( test_golden_tx + ) +where + +import Cardano.Api +import Cardano.Api.Experimental qualified as Exp + +import Cardano.Crypto.Seed (mkSeedFromBytes) + +import Control.Monad (void) +import Data.ByteString.Char8 qualified as BSC + +import Hedgehog (Property) +import Hedgehog qualified as H +import Hedgehog.Extras qualified as H +import Test.Tasty (TestTree) +import Test.Tasty.Hedgehog (testProperty) + +test_golden_tx :: TestTree +test_golden_tx = + testProperty "golden tx canonical" tx_canonical + +-- This test can be run with: cabal test cardano-api-golden --test-options="-p \"golden tx canonical\"" +tx_canonical :: Property +tx_canonical = H.propertyOnce $ do + H.workspace "tx-canonical" $ \wsPath -> do + let goldenFile = "test/cardano-api-golden/files/tx-canonical.json" + outFileCanonical <- H.noteTempFile wsPath "tx-canonical.json" + outFileNonCanonical <- H.noteTempFile wsPath "tx-non-canonical.json" + + let era = Exp.ConwayEra + sbe = convert era + txBodyContent = defaultTxBodyContent sbe + dummyTxId <- + H.evalEither $ + deserialiseFromRawBytesHex $ + BSC.pack "01f4b788593d4f70de2a45c2e1e87088bfbdfa29577ae1b62aba60e095e3ab53" + let txIn = TxIn dummyTxId (TxIx 0) + seedSize1 = fromIntegral $ deterministicSigningKeySeedSize AsPaymentKey + seedSize2 = fromIntegral $ deterministicSigningKeySeedSize AsStakeKey + dummyKey = deterministicSigningKey AsPaymentKey (mkSeedFromBytes (BSC.pack (replicate seedSize1 '\0'))) + dummyStakeKey = deterministicSigningKey AsStakeKey (mkSeedFromBytes (BSC.pack (replicate seedSize2 '\0'))) + + let addr1 = + makeShelleyAddressInEra + sbe + Mainnet + (PaymentCredentialByKey (verificationKeyHash $ getVerificationKey dummyKey)) + (StakeAddressByValue (StakeCredentialByKey (verificationKeyHash $ getVerificationKey dummyStakeKey))) + + simpleScript = SimpleScript (RequireSignature (verificationKeyHash $ getVerificationKey dummyKey)) + refScript = ReferenceScript BabbageEraOnwardsConway (ScriptInAnyLang SimpleScriptLanguage simpleScript) + + txOut = + TxOut + addr1 + (lovelaceToTxOutValue sbe 1) + TxOutDatumNone + refScript + + txBodyContent' = + txBodyContent + { txIns = [(txIn, BuildTxWith (KeyWitness KeyWitnessForSpending))] + , txOuts = [txOut] + , txFee = TxFeeExplicit sbe (Coin 0) + , txValidityLowerBound = TxValidityLowerBound AllegraEraOnwardsConway (SlotNo 0) + , txValidityUpperBound = TxValidityUpperBound sbe Nothing + , txTotalCollateral = TxTotalCollateral BabbageEraOnwardsConway (Coin 1) + , txReturnCollateral = TxReturnCollateral BabbageEraOnwardsConway txOut + } + + unsignedTx <- H.evalEither $ Exp.makeUnsignedTx era txBodyContent' + let tx = Exp.signTx era [] [] unsignedTx + let Exp.SignedTx ledgerTx = tx + let oldStyleTx = ShelleyTx sbe ledgerTx + + void . H.evalIO $ writeTxFileTextEnvelope sbe (File outFileNonCanonical) oldStyleTx + void . H.evalIO $ writeTxFileTextEnvelopeCanonical sbe (File outFileCanonical) oldStyleTx + + canonical <- H.readFile outFileCanonical + nonCanonical <- H.readFile outFileNonCanonical + + -- Ensure canonical is different from non canonical + H.assert $ canonical /= nonCanonical + + -- Ensure canonical file matches golden + H.diffFileVsGoldenFile outFileCanonical goldenFile diff --git a/cardano-api/test/cardano-api-golden/files/tx-canonical.json b/cardano-api/test/cardano-api-golden/files/tx-canonical.json new file mode 100644 index 0000000000..ec84713f55 --- /dev/null +++ b/cardano-api/test/cardano-api-golden/files/tx-canonical.json @@ -0,0 +1,5 @@ +{ + "type": "Tx ConwayEra", + "description": "Ledger Cddl Format", + "cborHex": "84a600d901028182582001f4b788593d4f70de2a45c2e1e87088bfbdfa29577ae1b62aba60e095e3ab53000181a300583901cb9358529df4729c3246a2a033cb9821abbfd16de4888005904abc41cb9358529df4729c3246a2a033cb9821abbfd16de4888005904abc41010103d818582282008200581ccb9358529df4729c3246a2a033cb9821abbfd16de4888005904abc410200080010a300583901cb9358529df4729c3246a2a033cb9821abbfd16de4888005904abc41cb9358529df4729c3246a2a033cb9821abbfd16de4888005904abc41010103d818582282008200581ccb9358529df4729c3246a2a033cb9821abbfd16de4888005904abc411101a0f5f6" +} diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs index a713ef26c2..176068a9f3 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs @@ -27,6 +27,7 @@ import Data.ByteString.Short qualified as SBS import Data.List (sortOn) import Data.Text (Text) import Data.Text qualified as T +import GHC.Stack (callStack) import GHC.Stack qualified as GHC import Test.Gen.Cardano.Api.Hardcoded @@ -415,15 +416,27 @@ prop_canonicalise_cbor = property $ do , (TBytes "bb", TString "h") , (TBytes "ba", TListI [TString "i", TString "j"]) ] - inputMapBs = CBOR.serialize' inputMap - inputMapTerm <- decodeExampleTerm inputMapBs + inputMapInIndefiniteList = TListI [inputMap] + inputMapInDefiniteList = TList [inputMap] - inputMapCanonicalisedBs <- H.leftFail $ canonicaliseCborBs inputMapBs + input <- forAll $ Gen.element [inputMap, inputMapInIndefiniteList, inputMapInDefiniteList] + let inputBs = CBOR.serialize' input - inputMapCanonicalisedTerm@(TMap elemTerms) <- decodeExampleTerm inputMapCanonicalisedBs + inputTerm <- decodeExampleTerm inputBs + + inputCanonicalisedBs <- H.leftFail $ canonicaliseCborBs inputBs + + decodedTerm <- decodeExampleTerm inputCanonicalisedBs + inputMapCanonicalisedTerm@(TMap elemTerms) <- + case decodedTerm of + TMap elemTerms -> pure $ TMap elemTerms + TList [TMap elemTerms] -> pure $ TMap elemTerms + t -> + H.failMessage callStack $ + "Expected canonicalised term to be a map or a list with a single map: " <> show t H.annotate "sanity check that cbor round trip does not change the order" - inputMap === inputMapTerm + input === inputTerm H.annotate "Print bytes hex representation of the keys in the map" H.annotateShow