Fix canonical CBOR bug

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

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

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

cardano-api/test/cardano-api-golden/files/tx-canonical.json

@@ -0,0 +1,5 @@
+{
+    "type": "Tx ConwayEra",
+    "description": "Ledger Cddl Format",
+    "cborHex": "84a600d901028182582001f4b788593d4f70de2a45c2e1e87088bfbdfa29577ae1b62aba60e095e3ab53000181a300583901cb9358529df4729c3246a2a033cb9821abbfd16de4888005904abc41cb9358529df4729c3246a2a033cb9821abbfd16de4888005904abc41010103d818582282008200581ccb9358529df4729c3246a2a033cb9821abbfd16de4888005904abc410200080010a300583901cb9358529df4729c3246a2a033cb9821abbfd16de4888005904abc41cb9358529df4729c3246a2a033cb9821abbfd16de4888005904abc41010103d818582282008200581ccb9358529df4729c3246a2a033cb9821abbfd16de4888005904abc411101a0f5f6"
+}

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