Implement CBOR canonicalisation according to CIP-21

Author: carbolymer

cardano-api/cardano-api.cabal

@@ -92,6 +92,7 @@ library
     Cardano.Api.Internal.ProtocolParameters
     Cardano.Api.Internal.Query
     Cardano.Api.Internal.Script
+    Cardano.Api.Internal.Serialise.Cbor.Canonical
     Cardano.Api.Internal.SerialiseLedgerCddl
     Cardano.Api.Internal.SerialiseTextEnvelope
     Cardano.Api.Internal.Tx.Body

cardano-api/src/Cardano/Api.hs

@@ -758,6 +758,7 @@ module Cardano.Api
   , readFileTextEnvelopeCddlAnyOf
   , deserialiseFromTextEnvelopeCddlAnyOf
   , writeTxFileTextEnvelopeCddl
+  , writeTxFileTextEnvelopeCanonicalCddl
   , writeTxWitnessFileTextEnvelopeCddl
   , deserialiseByronTxCddl
   , serialiseWitnessLedgerCddl

cardano-api/src/Cardano/Api/Internal/Serialise/Cbor/Canonical.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Cardano.Api.Internal.Serialise.Cbor.Canonical
+  ( canonicaliseCborBs
+  , canonicaliseTerm
+  )
+where
+
+import Cardano.Api.Internal.HasTypeProxy
+import Cardano.Api.Internal.Serialise.Cbor
+
+import Cardano.Binary (DecoderError (..))
+
+import Codec.CBOR.Read (deserialiseFromBytes)
+import Codec.CBOR.Term
+  ( Term (..)
+  , decodeTerm
+  , encodeTerm
+  )
+import Codec.CBOR.Write (toBuilder)
+import Control.Monad
+import Control.Monad.Except
+import Data.Bifunctor (first)
+import Data.ByteString qualified as BS
+import Data.ByteString.Builder qualified as BSB
+import Data.ByteString.Lazy qualified as LBS
+import Data.List (sortBy)
+import Data.Tuple.Extra (both)
+
+-- | This function implements CBOR canonicalisation (RFC 7049):
+--
+-- * Map keys are sorted lexicographically
+-- * Indefinite-length maps/lists are converted to finite-length maps/lists
+-- * The representation of the CBOR major types is as small as possible (provided by "cborg" package)
+--
+-- This function implements only CBOR canonicalisation from CIP-21. Other requirements from CIP-21 are not implemented.
+--
+-- 1. CBOR RFC 7049, Canonicalisation description: https://datatracker.ietf.org/doc/html/rfc7049#section-3.9
+-- 2. CIP-21: https://github.com/cardano-foundation/CIPs/blob/master/CIP-0021/README.md#canonical-cbor-serialization-format
+canonicaliseCborBs :: BS.ByteString -> Either DecoderError BS.ByteString
+canonicaliseCborBs originalCborBytes = serialiseToCBOR . canonicaliseTerm <$> deserialiseFromCBOR AsTerm originalCborBytes
+
+decodeTermFromBs
+  :: LBS.ByteString
+  -> Either DecoderError Term
+decodeTermFromBs input = do
+  (leftover, result) <-
+    first (DecoderErrorDeserialiseFailure "Cannot decode Term") $
+      deserialiseFromBytes decodeTerm input
+  unless (LBS.null leftover) $ do
+    throwError $
+      DecoderErrorLeftover "Invalid CBOR: some bytes were not consumed" (LBS.toStrict leftover)
+  pure result
+
+-- | This function implements CBOR canonicalisation at the Term level:
+--
+-- * Map keys are sorted lexicographically
+-- * Indefinite-length maps/lists are converted to finite-length maps/lists
+canonicaliseTerm :: Term -> Term
+canonicaliseTerm = \case
+  (TMap termPairs) ->
+    TMap . sortBy compareKeyTerms $ map (both canonicaliseTerm) termPairs
+  (TMapI termPairs) ->
+    TMap . sortBy compareKeyTerms $ map (both canonicaliseTerm) termPairs
+  (TTagged tag term) ->
+    TTagged tag $ canonicaliseTerm term
+  (TListI terms) ->
+    TList terms
+  term -> term
+
+-- | Implements sorting of CBOR terms for canonicalisation. CBOR terms are compared by lexical order of their
+-- bytes representation. We are only sorting the keys of the map here.
+-- See: https://datatracker.ietf.org/doc/html/rfc7049#section-3.9
+compareKeyTerms
+  :: (Term, a)
+  -- ^ (key, value) from a map
+  -> (Term, a)
+  -> Ordering
+compareKeyTerms (t1, _) (t2, _) = compare (serialiseToCBOR t1) (serialiseToCBOR t2)
+
+instance HasTypeProxy Term where
+  data AsType Term = AsTerm
+  proxyToAsType _ = AsTerm
+
+instance SerialiseAsCBOR Term where
+  serialiseToCBOR = LBS.toStrict . BSB.toLazyByteString . toBuilder . encodeTerm
+  deserialiseFromCBOR _proxy = decodeTermFromBs . LBS.fromStrict

cardano-api/src/Cardano/Api/Internal/SerialiseLedgerCddl.hs

@@ -20,6 +20,7 @@ module Cardano.Api.Internal.SerialiseLedgerCddl
   , readFileTextEnvelopeCddlAnyOf
   , deserialiseFromTextEnvelopeCddlAnyOf
   , writeTxFileTextEnvelopeCddl
+  , writeTxFileTextEnvelopeCanonicalCddl
   , writeTxWitnessFileTextEnvelopeCddl
   -- Exported for testing
   , deserialiseByronTxCddl
@@ -37,13 +38,15 @@ import Cardano.Api.Internal.Error
 import Cardano.Api.Internal.HasTypeProxy
 import Cardano.Api.Internal.IO
 import Cardano.Api.Internal.Pretty
+import Cardano.Api.Internal.Serialise.Cbor.Canonical
 import Cardano.Api.Internal.SerialiseTextEnvelope
   ( TextEnvelope (..)
   , TextEnvelopeDescr (TextEnvelopeDescr)
   , TextEnvelopeError (..)
   , TextEnvelopeType (TextEnvelopeType)
   , deserialiseFromTextEnvelope
   , legacyComparison
+  , serialiseTextEnvelope
   , serialiseToTextEnvelope
   )
 import Cardano.Api.Internal.Tx.Sign
@@ -55,13 +58,11 @@ import Cardano.Ledger.Binary qualified as CBOR
 
 import Control.Monad.Trans.Except.Extra
   ( firstExceptT
-  , handleIOExceptT
   , hoistEither
   , newExceptT
   , runExceptT
   )
 import Data.Aeson qualified as Aeson
-import Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', keyOrder)
 import Data.Bifunctor (first)
 import Data.ByteString (ByteString)
 import Data.ByteString.Lazy qualified as LBS
@@ -134,11 +135,10 @@ writeByronTxFileTextEnvelopeCddl
   :: File content Out
   -> Byron.ATxAux ByteString
   -> IO (Either (FileError ()) ())
-writeByronTxFileTextEnvelopeCddl path w =
-  runExceptT $ do
-    handleIOExceptT (FileIOError (unFile path)) $ LBS.writeFile (unFile path) txJson
- where
-  txJson = encodePretty' textEnvelopeCddlJSONConfig (serializeByronTx w) <> "\n"
+writeByronTxFileTextEnvelopeCddl path =
+  writeLazyByteStringFile path
+    . serialiseTextEnvelope
+    . serializeByronTx
 
 serializeByronTx :: Byron.ATxAux ByteString -> TextEnvelope
 serializeByronTx tx =
@@ -211,39 +211,59 @@ deserialiseWitnessLedgerCddl sbe te =
   legacyDecoding _ v = v
 
 writeTxFileTextEnvelopeCddl
-  :: ()
-  => ShelleyBasedEra era
+  :: ShelleyBasedEra era
   -> File content Out
   -> Tx era
   -> IO (Either (FileError ()) ())
-writeTxFileTextEnvelopeCddl era path tx =
-  runExceptT $ do
-    handleIOExceptT (FileIOError (unFile path)) $ LBS.writeFile (unFile path) txJson
+writeTxFileTextEnvelopeCddl sbe path =
+  writeLazyByteStringFile path
+    . serialiseTextEnvelope
+    . serialiseTxToTextEnvelope sbe
+
+-- | Write transaction in the text envelope format. The CBOR will be in canonical format according
+-- to RFC 7049. It is also a requirement of CIP-21, which is not fully implemented.
+--
+-- 1. RFC 7049: https://datatracker.ietf.org/doc/html/rfc7049#section-3.9
+-- 2. CIP-21: https://github.com/cardano-foundation/CIPs/blob/master/CIP-0021/README.md#canonical-cbor-serialization-format
+writeTxFileTextEnvelopeCanonicalCddl
+  :: ShelleyBasedEra era
+  -> File content Out
+  -> Tx era
+  -> IO (Either (FileError ()) ())
+writeTxFileTextEnvelopeCanonicalCddl sbe path =
+  writeLazyByteStringFile path
+    . serialiseTextEnvelope
+    . canonicaliseTextEnvelopeCbor
+    . serialiseTxToTextEnvelope sbe
  where
-  txJson = encodePretty' textEnvelopeCddlJSONConfig (serialiseTxLedgerCddl era tx) <> "\n"
+  canonicaliseTextEnvelopeCbor :: TextEnvelope -> TextEnvelope
+  canonicaliseTextEnvelopeCbor te = do
+    let canonicalisedTxBs =
+          either
+            ( \err ->
+                error $
+                  "writeTxFileTextEnvelopeCanonicalCddl: Impossible - deserialisation of just serialised bytes failed "
+                    <> show err
+            )
+            id
+            . canonicaliseCborBs
+            $ teRawCBOR te
+    te{teRawCBOR = canonicalisedTxBs}
 
-  serialiseTxLedgerCddl :: ShelleyBasedEra era -> Tx era -> TextEnvelope
-  serialiseTxLedgerCddl era' tx' =
-    shelleyBasedEraConstraints era' $
-      serialiseToTextEnvelope (Just (TextEnvelopeDescr "Ledger Cddl Format")) tx'
+serialiseTxToTextEnvelope :: ShelleyBasedEra era -> Tx era -> TextEnvelope
+serialiseTxToTextEnvelope era' tx' =
+  shelleyBasedEraConstraints era' $ do
+    serialiseToTextEnvelope (Just "Ledger Cddl Format") tx'
 
 writeTxWitnessFileTextEnvelopeCddl
   :: ShelleyBasedEra era
   -> File () Out
   -> KeyWitness era
   -> IO (Either (FileError ()) ())
-writeTxWitnessFileTextEnvelopeCddl sbe path w =
-  runExceptT $ do
-    handleIOExceptT (FileIOError (unFile path)) $ LBS.writeFile (unFile path) txJson
- where
-  txJson = encodePretty' textEnvelopeCddlJSONConfig (serialiseWitnessLedgerCddl sbe w) <> "\n"
-
-textEnvelopeCddlJSONConfig :: Config
-textEnvelopeCddlJSONConfig =
-  defConfig{confCompare = textEnvelopeCddlJSONKeyOrder}
-
-textEnvelopeCddlJSONKeyOrder :: Text -> Text -> Ordering
-textEnvelopeCddlJSONKeyOrder = keyOrder ["type", "description", "cborHex"]
+writeTxWitnessFileTextEnvelopeCddl sbe path =
+  writeLazyByteStringFile path
+    . serialiseTextEnvelope
+    . serialiseWitnessLedgerCddl sbe
 
 -- | This GADT allows us to deserialise a tx or key witness without
 -- having to provide the era.

cardano-api/src/Cardano/Api/Internal/SerialiseTextEnvelope.hs

@@ -25,6 +25,7 @@ module Cardano.Api.Internal.SerialiseTextEnvelope
   , readTextEnvelopeFromFile
   , readTextEnvelopeOfTypeFromFile
   , textEnvelopeToJSON
+  , serialiseTextEnvelope
   , legacyComparison
 
     -- * Reading one of several key types
@@ -115,11 +116,11 @@ instance FromJSON TextEnvelope where
     parseJSONBase16 v =
       either fail return . Base16.decode . Text.encodeUtf8 =<< parseJSON v
 
-textEnvelopeJSONConfig :: Config
-textEnvelopeJSONConfig = defConfig{confCompare = textEnvelopeJSONKeyOrder}
+textEnvelopeJsonConfig :: Config
+textEnvelopeJsonConfig = defConfig{confCompare = textEnvelopeJsonKeyOrder}
 
-textEnvelopeJSONKeyOrder :: Text -> Text -> Ordering
-textEnvelopeJSONKeyOrder = keyOrder ["type", "description", "cborHex"]
+textEnvelopeJsonKeyOrder :: Text -> Text -> Ordering
+textEnvelopeJsonKeyOrder = keyOrder ["type", "description", "cborHex"]
 
 textEnvelopeRawCBOR :: TextEnvelope -> ByteString
 textEnvelopeRawCBOR = teRawCBOR
@@ -254,7 +255,11 @@ writeFileTextEnvelope outputFile mbDescr a =
 
 textEnvelopeToJSON :: HasTextEnvelope a => Maybe TextEnvelopeDescr -> a -> LBS.ByteString
 textEnvelopeToJSON mbDescr a =
-  encodePretty' textEnvelopeJSONConfig (serialiseToTextEnvelope mbDescr a) <> "\n"
+  serialiseTextEnvelope $ serialiseToTextEnvelope mbDescr a
+
+-- | Serialise text envelope to pretty JSON
+serialiseTextEnvelope :: TextEnvelope -> LBS.ByteString
+serialiseTextEnvelope te = encodePretty' textEnvelopeJsonConfig te <> "\n"
 
 readFileTextEnvelope
   :: HasTextEnvelope a

cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs

@@ -12,13 +12,21 @@ where
 
 import Cardano.Api
 import Cardano.Api.Internal.Script
+import Cardano.Api.Internal.Serialise.Cbor.Canonical (canonicaliseCborBs)
 import Cardano.Api.Internal.SerialiseLedgerCddl (cddlTypeToEra)
 import Cardano.Api.Internal.SerialiseTextEnvelope (TextEnvelopeDescr (TextEnvelopeDescr))
 import Cardano.Api.Shelley (AsType (..))
 
+import Cardano.Binary qualified as CBOR
+
+import Codec.CBOR.Read qualified as CBOR
+import Codec.CBOR.Term (Term (..))
+import Codec.CBOR.Term qualified as CBOR
 import Data.ByteString.Base16 qualified as Base16
+import Data.ByteString.Builder qualified as BS
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString.Short qualified as SBS
+import Data.List (sortOn)
 import Data.Proxy (Proxy (..))
 import Data.Text (Text)
 import Data.Text qualified as T
@@ -28,7 +36,7 @@ import Test.Gen.Cardano.Api.Typed
 
 import Test.Cardano.Api.Orphans ()
 
-import Hedgehog (Property, forAll, property, tripping)
+import Hedgehog (Property, forAll, property, tripping, (===))
 import Hedgehog qualified as H
 import Hedgehog.Extras qualified as H
 import Hedgehog.Gen qualified as Gen
@@ -340,13 +348,72 @@ prop_roundtrip_GovernancePollAnswer_CBOR :: Property
 prop_roundtrip_GovernancePollAnswer_CBOR = property $ do
   H.trippingCbor AsGovernancePollAnswer =<< forAll genGovernancePollAnswer
 
+-- | Test CBOR canonicalisation (according to RFC 7049, part of CIP-21)
+-- We're only testing ordering of the map keys and converting to finite collections here
+-- - the smallest representation is implemented in cborg library.
+prop_canonicalise_cbor :: Property
+prop_canonicalise_cbor = property $ do
+  let inputMap =
+        TMapI
+          [ (TInt 22, TString "d")
+          , (TInt 11, TString "a")
+          , (TInt 1, TString "b")
+          , (TInt 3, TString "c")
+          , (TInt 2, TString "b")
+          , (TBytes "aa", TString "e")
+          , (TBytes "a", TString "f")
+          , (TBytes "a0", TString "f")
+          , (TBytes "bc", TString "g")
+          , (TBytes "b", TString "g")
+          , (TBytes "bb", TString "h")
+          , (TBytes "ba", TListI [TString "i", TString "j"])
+          ]
+      inputMapBs = CBOR.serialize' inputMap
+  inputMapTerm <- decodeExampleTerm inputMapBs
+
+  inputMapCanonicalisedBs <- H.leftFail $ canonicaliseCborBs inputMapBs
+
+  inputMapCanonicalisedTerm@(TMap elemTerms) <- decodeExampleTerm inputMapCanonicalisedBs
+
+  H.annotate "sanity check that cbor round trip does not change the order"
+  inputMap === inputMapTerm
+
+  H.annotate "Print bytes hex representation of the keys in the map"
+  H.annotateShow
+    . sortOn fst
+    . map (\(e, _) -> (BS.toLazyByteString . BS.byteStringHex $ CBOR.serialize' e, e))
+    $ elemTerms
+
+  H.annotate "Check that expected canonicalised CBOR is equal to the result"
+  TMap
+    [ (TInt 1, TString "b")
+    , (TInt 2, TString "b")
+    , (TInt 3, TString "c")
+    , (TInt 11, TString "a")
+    , (TInt 22, TString "d")
+    , (TBytes "a", TString "f")
+    , (TBytes "b", TString "g")
+    , (TBytes "a0", TString "f")
+    , (TBytes "aa", TString "e")
+    , (TBytes "ba", TList [TString "i", TString "j"])
+    , (TBytes "bb", TString "h")
+    , (TBytes "bc", TString "g")
+    ]
+    === inputMapCanonicalisedTerm
+ where
+  decodeExampleTerm bs = do
+    (leftover, term) <- H.leftFail $ CBOR.deserialiseFromBytes CBOR.decodeTerm (LBS.fromStrict bs)
+    H.assertWith leftover LBS.null
+    pure term
+
 -- -----------------------------------------------------------------------------
 
 tests :: TestTree
 tests =
   testGroup
     "Test.Cardano.Api.Typed.CBOR"
-    [ testProperty "rountrip txbody text envelope" prop_text_envelope_roundtrip_txbody_CBOR
+    [ testProperty "test canonicalisation of CBOR" prop_canonicalise_cbor
+    , testProperty "rountrip txbody text envelope" prop_text_envelope_roundtrip_txbody_CBOR
     , testProperty "txbody backwards compatibility" prop_txbody_backwards_compatibility
     , testProperty "rountrip tx text envelope" prop_text_envelope_roundtrip_tx_CBOR
     , testProperty "roundtrip witness CBOR" prop_roundtrip_witness_CBOR