From fe7dc938f5aeba9573ff4547c1cecbaf2f340380 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Tue, 14 May 2024 00:18:37 +0200 Subject: [PATCH 1/8] Add deprecation warning to `serialiseTxLedgerCddl` --- cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs | 1 + .../test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs | 2 ++ 2 files changed, 3 insertions(+) diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index 7bb799d6f0..b9761e9efb 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -134,6 +134,7 @@ instance Error TextEnvelopeCddlError where TextEnvelopeCddlErrByronKeyWitnessUnsupported -> "TextEnvelopeCddl error: Byron key witnesses are currently unsupported." +{-# DEPRECATED serialiseTxLedgerCddl "Use 'serialiseToTextEnvelope' from 'Cardano.Api.SerialiseTextEnvelope' instead." #-} serialiseTxLedgerCddl :: ShelleyBasedEra era -> Tx era -> TextEnvelopeCddl serialiseTxLedgerCddl era tx = shelleyBasedEraConstraints era $ diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs index 61ca2ddda5..204852aea1 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} @@ -27,6 +28,7 @@ import Test.Tasty.Hedgehog (testProperty) -- TODO: Need to add PaymentExtendedKey roundtrip tests however -- we can't derive an Eq instance for Crypto.HD.XPrv + prop_roundtrip_txbody_CBOR :: Property prop_roundtrip_txbody_CBOR = H.property $ do AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound] From e41749faccf0e8143f2318f5f692201c038880c6 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Fri, 17 May 2024 22:17:15 +0200 Subject: [PATCH 2/8] Add ToDo to remove `-Wno-deprecations` tag when appropriate MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Clément Hurlin --- .../test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs index 204852aea1..efe1d080b0 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-deprecations #-} -- TODO remove when serialiseTxLedgerCddl is removed {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} From 1d239998beb8f6705aa47e45c5f0855eea21823a Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Sat, 18 May 2024 01:56:55 +0200 Subject: [PATCH 3/8] Remove type `TextEnvelopeCddl` --- .../Cardano/Api/SerialiseLedgerCddl.hs | 181 ++++++------------ cardano-api/src/Cardano/Api.hs | 2 - 2 files changed, 56 insertions(+), 127 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index b9761e9efb..ca62ffcbc8 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -4,15 +4,13 @@ {-# LANGUAGE EmptyCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | Ledger CDDL Serialisation -- module Cardano.Api.SerialiseLedgerCddl - ( TextEnvelopeCddl(..) - , TextEnvelopeCddlError (..) + ( TextEnvelopeCddlError (..) , FromSomeTypeCDDL(..) -- * Reading one of several transaction or @@ -41,7 +39,9 @@ import Cardano.Api.Error import Cardano.Api.HasTypeProxy import Cardano.Api.IO import Cardano.Api.Pretty -import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseTextEnvelope (TextEnvelope (..), + TextEnvelopeDescr (TextEnvelopeDescr), TextEnvelopeError (..), + deserialiseFromTextEnvelope, serialiseToTextEnvelope) import Cardano.Api.Tx.Sign import Cardano.Api.Utils @@ -51,17 +51,16 @@ import qualified Cardano.Ledger.Binary as CBOR import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, newExceptT, runExceptT) -import Data.Aeson import qualified Data.Aeson as Aeson import Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', keyOrder) import Data.Bifunctor (first) import Data.ByteString (ByteString) -import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as LBS import Data.Data (Data) +import Data.Either.Combinators (mapLeft) import qualified Data.List as List import Data.Text (Text) -import qualified Data.Text.Encoding as Text +import qualified Data.Text as T -- Why have we gone this route? The serialization format of `TxBody era` -- differs from the CDDL. We serialize to an intermediate type in order to simplify @@ -77,29 +76,6 @@ import qualified Data.Text.Encoding as Text -- ease removal of the non-CDDL spec serialization, we have opted to create a separate -- data type to encompass this in the interim. -data TextEnvelopeCddl = TextEnvelopeCddl - { teCddlType :: !Text - , teCddlDescription :: !Text - , teCddlRawCBOR :: !ByteString - } deriving (Eq, Show) - -instance ToJSON TextEnvelopeCddl where - toJSON TextEnvelopeCddl {teCddlType, teCddlDescription, teCddlRawCBOR} = - object [ "type" .= teCddlType - , "description" .= teCddlDescription - , "cborHex" .= Text.decodeUtf8 (Base16.encode teCddlRawCBOR) - ] - -instance FromJSON TextEnvelopeCddl where - parseJSON = withObject "TextEnvelopeCddl" $ \v -> - TextEnvelopeCddl <$> (v .: "type") - <*> (v .: "description") - <*> (parseJSONBase16 =<< v .: "cborHex") - where - parseJSONBase16 v = - either fail return . Base16.decode . Text.encodeUtf8 =<< parseJSON v - - data TextEnvelopeCddlError = TextEnvelopeCddlErrCBORDecodingError DecoderError | TextEnvelopeCddlAesonDecodeError FilePath String @@ -111,6 +87,13 @@ data TextEnvelopeCddlError | TextEnvelopeCddlErrByronKeyWitnessUnsupported deriving (Show, Eq, Data) +textEnvelopeErrorToTextEnvelopeCddlError :: TextEnvelopeError -> TextEnvelopeCddlError +textEnvelopeErrorToTextEnvelopeCddlError = \case + TextEnvelopeTypeError expectedTypes actualType -> TextEnvelopeCddlTypeError (map (T.pack . show) expectedTypes) + (T.pack $ show actualType) + TextEnvelopeDecodeError decoderError -> TextEnvelopeCddlErrCBORDecodingError decoderError + TextEnvelopeAesonDecodeError errorString -> TextEnvelopeCddlAesonDecodeError "" errorString + instance Error TextEnvelopeCddlError where prettyError = \case TextEnvelopeCddlErrCBORDecodingError decoderError -> @@ -135,36 +118,20 @@ instance Error TextEnvelopeCddlError where "TextEnvelopeCddl error: Byron key witnesses are currently unsupported." {-# DEPRECATED serialiseTxLedgerCddl "Use 'serialiseToTextEnvelope' from 'Cardano.Api.SerialiseTextEnvelope' instead." #-} -serialiseTxLedgerCddl :: ShelleyBasedEra era -> Tx era -> TextEnvelopeCddl -serialiseTxLedgerCddl era tx = - shelleyBasedEraConstraints era $ - TextEnvelopeCddl - { teCddlType = genType tx - , teCddlDescription = "Ledger Cddl Format" - , teCddlRawCBOR = serialiseToCBOR tx - -- The SerialiseAsCBOR (Tx era) instance serializes to the Cddl format - } - where - genType :: Tx era -> Text - genType tx' = case getTxWitnesses tx' of - [] -> "Unwitnessed " <> genTxType - _ -> "Witnessed " <> genTxType - genTxType :: Text - genTxType = - case era of - ShelleyBasedEraShelley -> "Tx ShelleyEra" - ShelleyBasedEraAllegra -> "Tx AllegraEra" - ShelleyBasedEraMary -> "Tx MaryEra" - ShelleyBasedEraAlonzo -> "Tx AlonzoEra" - ShelleyBasedEraBabbage -> "Tx BabbageEra" - ShelleyBasedEraConway -> "Tx ConwayEra" - -deserialiseTxLedgerCddl :: () - => ShelleyBasedEra era - -> TextEnvelopeCddl - -> Either TextEnvelopeCddlError (Tx era) -deserialiseTxLedgerCddl era tec = - first TextEnvelopeCddlErrCBORDecodingError . deserialiseTx era $ teCddlRawCBOR tec +serialiseTxLedgerCddl :: ShelleyBasedEra era -> Tx era -> TextEnvelope +serialiseTxLedgerCddl era tx = shelleyBasedEraConstraints era $ + serialiseToTextEnvelope (Just (TextEnvelopeDescr "Ledger Cddl Format")) tx + +{-# DEPRECATED deserialiseTxLedgerCddl "Use 'deserialiseFromTextEnvelope' from 'Cardano.Api.SerialiseTextEnvelope' instead." #-} +deserialiseTxLedgerCddl :: forall era . + ShelleyBasedEra era + -> TextEnvelope + -> Either TextEnvelopeError (Tx era) +deserialiseTxLedgerCddl era = shelleyBasedEraConstraints era $ + deserialiseFromTextEnvelope asType + where + asType :: AsType (Tx era) + asType = shelleyBasedEraConstraints era $ proxyToAsType Proxy writeByronTxFileTextEnvelopeCddl :: File content Out @@ -176,75 +143,39 @@ writeByronTxFileTextEnvelopeCddl path w = where txJson = encodePretty' textEnvelopeCddlJSONConfig (serializeByronTx w) <> "\n" -serializeByronTx :: Byron.ATxAux ByteString -> TextEnvelopeCddl +serializeByronTx :: Byron.ATxAux ByteString -> TextEnvelope serializeByronTx tx = - TextEnvelopeCddl - { teCddlType = "Tx ByronEra" - , teCddlDescription = "Ledger Cddl Format" - , teCddlRawCBOR = CBOR.recoverBytes tx + TextEnvelope + { teType = "Tx ByronEra" + , teDescription = "Ledger Cddl Format" + , teRawCBOR = CBOR.recoverBytes tx } -deserialiseByronTxCddl :: TextEnvelopeCddl -> Either TextEnvelopeCddlError (Byron.ATxAux ByteString) +deserialiseByronTxCddl :: TextEnvelope -> Either TextEnvelopeCddlError (Byron.ATxAux ByteString) deserialiseByronTxCddl tec = first TextEnvelopeCddlErrCBORDecodingError $ CBOR.decodeFullAnnotatedBytes CBOR.byronProtVer "Byron Tx" - CBOR.decCBOR (LBS.fromStrict $ teCddlRawCBOR tec) + CBOR.decCBOR (LBS.fromStrict $ teRawCBOR tec) -deserialiseTx :: () - => ShelleyBasedEra era - -> ByteString - -> Either DecoderError (Tx era) -deserialiseTx sbe = - shelleyBasedEraConstraints sbe - $ deserialiseFromCBOR (AsTx (proxyToAsType Proxy)) - -serialiseWitnessLedgerCddl :: forall era. ShelleyBasedEra era -> KeyWitness era -> TextEnvelopeCddl -serialiseWitnessLedgerCddl sbe kw = - TextEnvelopeCddl - { teCddlType = witEra sbe - , teCddlDescription = genDesc kw - , teCddlRawCBOR = cddlSerialiseWitness kw - } +serialiseWitnessLedgerCddl :: forall era. ShelleyBasedEra era -> KeyWitness era -> TextEnvelope +serialiseWitnessLedgerCddl sbe kw = shelleyBasedEraConstraints sbe $ + serialiseToTextEnvelope (Just (TextEnvelopeDescr $ T.unpack $ genDesc kw)) kw where - cddlSerialiseWitness :: KeyWitness era -> ByteString - cddlSerialiseWitness (ShelleyBootstrapWitness era wit) = CBOR.serialize' (eraProtVerLow era) wit - cddlSerialiseWitness (ShelleyKeyWitness era wit) = CBOR.serialize' (eraProtVerLow era) wit - cddlSerialiseWitness ByronKeyWitness{} = case sbe of {} - genDesc :: KeyWitness era -> Text genDesc ByronKeyWitness{} = case sbe of {} genDesc ShelleyBootstrapWitness{} = "Key BootstrapWitness ShelleyEra" genDesc ShelleyKeyWitness{} = "Key Witness ShelleyEra" - witEra :: ShelleyBasedEra era -> Text - witEra ShelleyBasedEraShelley = "TxWitness ShelleyEra" - witEra ShelleyBasedEraAllegra = "TxWitness AllegraEra" - witEra ShelleyBasedEraMary = "TxWitness MaryEra" - witEra ShelleyBasedEraAlonzo = "TxWitness AlonzoEra" - witEra ShelleyBasedEraBabbage = "TxWitness BabbageEra" - witEra ShelleyBasedEraConway = "TxWitness ConwayEra" - -deserialiseWitnessLedgerCddl - :: ShelleyBasedEra era - -> TextEnvelopeCddl - -> Either TextEnvelopeCddlError (KeyWitness era) -deserialiseWitnessLedgerCddl sbe TextEnvelopeCddl{teCddlRawCBOR,teCddlDescription} = - --TODO: Parse these into types because this will increase code readability and - -- will make it easier to keep track of the different Cddl descriptions via - -- a single sum data type. - case teCddlDescription of - "Key BootstrapWitness ShelleyEra" -> do - w <- first TextEnvelopeCddlErrCBORDecodingError - $ CBOR.decodeFullAnnotator - (eraProtVerLow sbe) "Shelley Witness" CBOR.decCBOR (LBS.fromStrict teCddlRawCBOR) - Right $ ShelleyBootstrapWitness sbe w - "Key Witness ShelleyEra" -> do - w <- first TextEnvelopeCddlErrCBORDecodingError - $ CBOR.decodeFullAnnotator - (eraProtVerLow sbe) "Shelley Witness" CBOR.decCBOR (LBS.fromStrict teCddlRawCBOR) - Right $ ShelleyKeyWitness sbe w - _ -> Left TextEnvelopeCddlUnknownKeyWitness +deserialiseWitnessLedgerCddl :: forall era . + ShelleyBasedEra era + -> TextEnvelope + -> Either TextEnvelopeError (KeyWitness era) +deserialiseWitnessLedgerCddl sbe te = shelleyBasedEraConstraints sbe $ + deserialiseFromTextEnvelope asType te + where + asType :: AsType (KeyWitness era) + asType = shelleyBasedEraConstraints sbe $ proxyToAsType Proxy writeTxFileTextEnvelopeCddl :: () => ShelleyBasedEra era @@ -281,16 +212,16 @@ data FromSomeTypeCDDL c b where FromCDDLTx :: Text -- ^ CDDL type that we want -> (InAnyShelleyBasedEra Tx -> b) - -> FromSomeTypeCDDL TextEnvelopeCddl b + -> FromSomeTypeCDDL TextEnvelope b FromCDDLWitness :: Text -- ^ CDDL type that we want -> (InAnyShelleyBasedEra KeyWitness -> b) - -> FromSomeTypeCDDL TextEnvelopeCddl b + -> FromSomeTypeCDDL TextEnvelope b deserialiseFromTextEnvelopeCddlAnyOf - :: [FromSomeTypeCDDL TextEnvelopeCddl b] - -> TextEnvelopeCddl + :: [FromSomeTypeCDDL TextEnvelope b] + -> TextEnvelope -> Either TextEnvelopeCddlError b deserialiseFromTextEnvelopeCddlAnyOf types teCddl = case List.find matching types of @@ -299,19 +230,19 @@ deserialiseFromTextEnvelopeCddlAnyOf types teCddl = Just (FromCDDLTx ttoken f) -> do AnyShelleyBasedEra era <- cddlTypeToEra ttoken - f . InAnyShelleyBasedEra era <$> deserialiseTxLedgerCddl era teCddl + f . InAnyShelleyBasedEra era <$> mapLeft textEnvelopeErrorToTextEnvelopeCddlError (deserialiseTxLedgerCddl era teCddl) Just (FromCDDLWitness ttoken f) -> do AnyShelleyBasedEra era <- cddlTypeToEra ttoken - f . InAnyShelleyBasedEra era <$> deserialiseWitnessLedgerCddl era teCddl + f . InAnyShelleyBasedEra era <$> mapLeft textEnvelopeErrorToTextEnvelopeCddlError (deserialiseWitnessLedgerCddl era teCddl) where actualType :: Text - actualType = teCddlType teCddl + actualType = T.pack $ show $ teType teCddl expectedTypes :: [Text] expectedTypes = [ typ | FromCDDLTx typ _f <- types ] - matching :: FromSomeTypeCDDL TextEnvelopeCddl b -> Bool + matching :: FromSomeTypeCDDL TextEnvelope b -> Bool matching (FromCDDLTx ttoken _f) = actualType == ttoken matching (FromCDDLWitness ttoken _f) = actualType == ttoken @@ -341,7 +272,7 @@ cddlTypeToEra = \case unknownCddlType -> Left $ TextEnvelopeCddlErrUnknownType unknownCddlType readFileTextEnvelopeCddlAnyOf - :: [FromSomeTypeCDDL TextEnvelopeCddl b] + :: [FromSomeTypeCDDL TextEnvelope b] -> FilePath -> IO (Either (FileError TextEnvelopeCddlError) b) readFileTextEnvelopeCddlAnyOf types path = @@ -352,7 +283,7 @@ readFileTextEnvelopeCddlAnyOf types path = readTextEnvelopeCddlFromFile :: FilePath - -> IO (Either (FileError TextEnvelopeCddlError) TextEnvelopeCddl) + -> IO (Either (FileError TextEnvelopeCddlError) TextEnvelope) readTextEnvelopeCddlFromFile path = runExceptT $ do bs <- fileIOExceptT path readFileBlocking diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index fc966e074c..036d540134 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -679,8 +679,6 @@ module Cardano.Api ( deserialiseByronTxCddl, serialiseWitnessLedgerCddl, deserialiseWitnessLedgerCddl, - TextEnvelopeCddl(..), -- TODO: Deprecate this when we stop supporting the cli's - -- intermediate txbody format. TextEnvelopeCddlError(..), -- *** Reading one of several key types From d34d5b8edb731ecdc4ca4c28e67ea77f422030dc Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Tue, 21 May 2024 21:19:40 +0200 Subject: [PATCH 4/8] Add compatibility layer --- .../Cardano/Api/SerialiseLedgerCddl.hs | 19 ++++++++-- .../Cardano/Api/SerialiseTextEnvelope.hs | 36 +++++++++++++++++-- 2 files changed, 51 insertions(+), 4 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index ca62ffcbc8..3243afa65c 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -41,7 +41,8 @@ import Cardano.Api.IO import Cardano.Api.Pretty import Cardano.Api.SerialiseTextEnvelope (TextEnvelope (..), TextEnvelopeDescr (TextEnvelopeDescr), TextEnvelopeError (..), - deserialiseFromTextEnvelope, serialiseToTextEnvelope) + TextEnvelopeType (TextEnvelopeType), deserialiseFromTextEnvelope, + serialiseToTextEnvelope) import Cardano.Api.Tx.Sign import Cardano.Api.Utils @@ -120,7 +121,21 @@ instance Error TextEnvelopeCddlError where {-# DEPRECATED serialiseTxLedgerCddl "Use 'serialiseToTextEnvelope' from 'Cardano.Api.SerialiseTextEnvelope' instead." #-} serialiseTxLedgerCddl :: ShelleyBasedEra era -> Tx era -> TextEnvelope serialiseTxLedgerCddl era tx = shelleyBasedEraConstraints era $ - serialiseToTextEnvelope (Just (TextEnvelopeDescr "Ledger Cddl Format")) tx + (serialiseToTextEnvelope (Just (TextEnvelopeDescr "Ledger Cddl Format")) tx){teType = TextEnvelopeType $ T.unpack $ genType tx} + where + genType :: Tx era -> Text + genType tx' = case getTxWitnesses tx' of + [] -> "Unwitnessed " <> genTxType + _ -> "Witnessed " <> genTxType + genTxType :: Text + genTxType = + case era of + ShelleyBasedEraShelley -> "Tx ShelleyEra" + ShelleyBasedEraAllegra -> "Tx AllegraEra" + ShelleyBasedEraMary -> "Tx MaryEra" + ShelleyBasedEraAlonzo -> "Tx AlonzoEra" + ShelleyBasedEraBabbage -> "Tx BabbageEra" + ShelleyBasedEraConway -> "Tx ConwayEra" {-# DEPRECATED deserialiseTxLedgerCddl "Use 'deserialiseFromTextEnvelope' from 'Cardano.Api.SerialiseTextEnvelope' instead." #-} deserialiseTxLedgerCddl :: forall era . diff --git a/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs b/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs index 4d10194c46..6bd81ae58b 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs @@ -159,9 +159,41 @@ instance Error TextEnvelopeError where -- expectTextEnvelopeOfType :: TextEnvelopeType -> TextEnvelope -> Either TextEnvelopeError () expectTextEnvelopeOfType expectedType TextEnvelope { teType = actualType } = - unless (expectedType == actualType) $ + unless (expectedType `legacyComparison` actualType) $ Left (TextEnvelopeTypeError [expectedType] actualType) +-- | This is a backwards-compatibility patch to ensure that old envelopes +-- generated by 'serialiseTxLedgerCddl' can be deserialised after switching +-- to the 'serialiseToTextEnvelope'. +legacyComparison :: TextEnvelopeType -> TextEnvelopeType -> Bool +legacyComparison (TextEnvelopeType expectedType) (TextEnvelopeType actualType) = + case (expectedType, actualType) of + ("TxSignedShelley", "Witnessed Tx ShelleyEra") -> True + ("Tx AllegraEra", "Witnessed Tx AllegraEra") -> True + ("Tx MaryEra", "Witnessed Tx MaryEra") -> True + ("Tx AlonzoEra", "Witnessed Tx AlonzoEra") -> True + ("Tx BabbageEra", "Witnessed Tx BabbageEra") -> True + ("Tx ConwayEra", "Witnessed Tx ConwayEra") -> True + ("TxSignedShelley", "Unwitnessed Tx ShelleyEra") -> True + ("Tx AllegraEra", "Unwitnessed Tx AllegraEra") -> True + ("Tx MaryEra", "Unwitnessed Tx MaryEra") -> True + ("Tx AlonzoEra", "Unwitnessed Tx AlonzoEra") -> True + ("Tx BabbageEra", "Unwitnessed Tx BabbageEra") -> True + ("Tx ConwayEra", "Unwitnessed Tx ConwayEra") -> True + ("TxUnsignedShelley", "Unwitnessed Tx ShelleyEra") -> True + ("TxBodyAllegra", "Unwitnessed Tx AllegraEra") -> True + ("TxBodyMary", "Unwitnessed Tx MaryEra") -> True + ("TxBodyAlonzo", "Unwitnessed Tx AlonzoEra") -> True + ("TxBodyBabbage", "Unwitnessed Tx BabbageEra") -> True + ("TxBodyConway", "Unwitnessed Tx ConwayEra") -> True + ("TxUnsignedShelley", "Tx ShelleyEra") -> True + ("TxBodyAllegra", "Tx AllegraEra") -> True + ("TxBodyMary", "Tx MaryEra") -> True + ("TxBodyAlonzo", "Tx AlonzoEra") -> True + ("TxBodyBabbage", "Tx BabbageEra") -> True + ("TxBodyConway", "Tx ConwayEra") -> True + (expectedOther, expectedActual) -> expectedOther == expectedActual + -- ---------------------------------------------------------------------------- -- Serialisation in text envelope format @@ -220,7 +252,7 @@ deserialiseFromTextEnvelopeAnyOf types te = expectedTypes = [ textEnvelopeType ttoken | FromSomeType ttoken _f <- types ] - matching (FromSomeType ttoken _f) = actualType == textEnvelopeType ttoken + matching (FromSomeType ttoken _f) = textEnvelopeType ttoken `legacyComparison` actualType writeFileTextEnvelope :: HasTextEnvelope a => File content Out From 80216367062725adc32e74f549ce545a326e818a Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Tue, 28 May 2024 20:17:50 +0200 Subject: [PATCH 5/8] Strengthen compatibility layer --- .../Cardano/Api/SerialiseLedgerCddl.hs | 25 ++++++++++++------- .../Cardano/Api/SerialiseTextEnvelope.hs | 13 +--------- 2 files changed, 17 insertions(+), 21 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index 3243afa65c..13653b7825 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} -- | Ledger CDDL Serialisation -- @@ -42,7 +43,7 @@ import Cardano.Api.Pretty import Cardano.Api.SerialiseTextEnvelope (TextEnvelope (..), TextEnvelopeDescr (TextEnvelopeDescr), TextEnvelopeError (..), TextEnvelopeType (TextEnvelopeType), deserialiseFromTextEnvelope, - serialiseToTextEnvelope) + serialiseToTextEnvelope, HasTextEnvelope (textEnvelopeType), legacyComparison) import Cardano.Api.Tx.Sign import Cardano.Api.Utils @@ -142,8 +143,8 @@ deserialiseTxLedgerCddl :: forall era . ShelleyBasedEra era -> TextEnvelope -> Either TextEnvelopeError (Tx era) -deserialiseTxLedgerCddl era = shelleyBasedEraConstraints era $ - deserialiseFromTextEnvelope asType +deserialiseTxLedgerCddl era te = + shelleyBasedEraConstraints era $ deserialiseFromTextEnvelope asType te{teType = textEnvelopeType asType} where asType :: AsType (Tx era) asType = shelleyBasedEraConstraints era $ proxyToAsType Proxy @@ -185,9 +186,15 @@ serialiseWitnessLedgerCddl sbe kw = shelleyBasedEraConstraints sbe $ deserialiseWitnessLedgerCddl :: forall era . ShelleyBasedEra era -> TextEnvelope - -> Either TextEnvelopeError (KeyWitness era) -deserialiseWitnessLedgerCddl sbe te = shelleyBasedEraConstraints sbe $ - deserialiseFromTextEnvelope asType te + -> Either TextEnvelopeCddlError (KeyWitness era) +deserialiseWitnessLedgerCddl sbe te@TextEnvelope{teDescription} = + let res = shelleyBasedEraConstraints sbe $ mapLeft textEnvelopeErrorToTextEnvelopeCddlError $ + deserialiseFromTextEnvelope asType te{teType = textEnvelopeType asType} in + case teDescription of + "Key BootstrapWitness ShelleyEra" -> res + "Key Witness ShelleyEra" -> res + _ -> Left TextEnvelopeCddlUnknownKeyWitness + where asType :: AsType (KeyWitness era) asType = shelleyBasedEraConstraints sbe $ proxyToAsType Proxy @@ -249,7 +256,7 @@ deserialiseFromTextEnvelopeCddlAnyOf types teCddl = Just (FromCDDLWitness ttoken f) -> do AnyShelleyBasedEra era <- cddlTypeToEra ttoken - f . InAnyShelleyBasedEra era <$> mapLeft textEnvelopeErrorToTextEnvelopeCddlError (deserialiseWitnessLedgerCddl era teCddl) + f . InAnyShelleyBasedEra era <$> deserialiseWitnessLedgerCddl era teCddl where actualType :: Text actualType = T.pack $ show $ teType teCddl @@ -258,8 +265,8 @@ deserialiseFromTextEnvelopeCddlAnyOf types teCddl = expectedTypes = [ typ | FromCDDLTx typ _f <- types ] matching :: FromSomeTypeCDDL TextEnvelope b -> Bool - matching (FromCDDLTx ttoken _f) = actualType == ttoken - matching (FromCDDLWitness ttoken _f) = actualType == ttoken + matching (FromCDDLTx ttoken _f) = TextEnvelopeType (T.unpack ttoken) `legacyComparison` teType teCddl + matching (FromCDDLWitness ttoken _f) = TextEnvelopeType (T.unpack ttoken) `legacyComparison` teType teCddl -- Parse the text into types because this will increase code readability and -- will make it easier to keep track of the different Cddl descriptions via diff --git a/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs b/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs index 6bd81ae58b..ae5d208e8e 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs @@ -26,6 +26,7 @@ module Cardano.Api.SerialiseTextEnvelope , readTextEnvelopeFromFile , readTextEnvelopeOfTypeFromFile , textEnvelopeToJSON + , legacyComparison -- * Reading one of several key types , FromSomeType(..) @@ -180,18 +181,6 @@ legacyComparison (TextEnvelopeType expectedType) (TextEnvelopeType actualType) = ("Tx AlonzoEra", "Unwitnessed Tx AlonzoEra") -> True ("Tx BabbageEra", "Unwitnessed Tx BabbageEra") -> True ("Tx ConwayEra", "Unwitnessed Tx ConwayEra") -> True - ("TxUnsignedShelley", "Unwitnessed Tx ShelleyEra") -> True - ("TxBodyAllegra", "Unwitnessed Tx AllegraEra") -> True - ("TxBodyMary", "Unwitnessed Tx MaryEra") -> True - ("TxBodyAlonzo", "Unwitnessed Tx AlonzoEra") -> True - ("TxBodyBabbage", "Unwitnessed Tx BabbageEra") -> True - ("TxBodyConway", "Unwitnessed Tx ConwayEra") -> True - ("TxUnsignedShelley", "Tx ShelleyEra") -> True - ("TxBodyAllegra", "Tx AllegraEra") -> True - ("TxBodyMary", "Tx MaryEra") -> True - ("TxBodyAlonzo", "Tx AlonzoEra") -> True - ("TxBodyBabbage", "Tx BabbageEra") -> True - ("TxBodyConway", "Tx ConwayEra") -> True (expectedOther, expectedActual) -> expectedOther == expectedActual From 260a6aa60c3c30e4fb510f304499d85a55ab28fd Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Tue, 28 May 2024 20:27:57 +0200 Subject: [PATCH 6/8] Remove unnecessary wrapping --- .../internal/Cardano/Api/SerialiseLedgerCddl.hs | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index 13653b7825..02619bc2da 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -6,7 +6,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NamedFieldPuns #-} -- | Ledger CDDL Serialisation -- @@ -43,7 +42,7 @@ import Cardano.Api.Pretty import Cardano.Api.SerialiseTextEnvelope (TextEnvelope (..), TextEnvelopeDescr (TextEnvelopeDescr), TextEnvelopeError (..), TextEnvelopeType (TextEnvelopeType), deserialiseFromTextEnvelope, - serialiseToTextEnvelope, HasTextEnvelope (textEnvelopeType), legacyComparison) + serialiseToTextEnvelope, legacyComparison) import Cardano.Api.Tx.Sign import Cardano.Api.Utils @@ -143,8 +142,8 @@ deserialiseTxLedgerCddl :: forall era . ShelleyBasedEra era -> TextEnvelope -> Either TextEnvelopeError (Tx era) -deserialiseTxLedgerCddl era te = - shelleyBasedEraConstraints era $ deserialiseFromTextEnvelope asType te{teType = textEnvelopeType asType} +deserialiseTxLedgerCddl era = + shelleyBasedEraConstraints era $ deserialiseFromTextEnvelope asType where asType :: AsType (Tx era) asType = shelleyBasedEraConstraints era $ proxyToAsType Proxy @@ -187,13 +186,9 @@ deserialiseWitnessLedgerCddl :: forall era . ShelleyBasedEra era -> TextEnvelope -> Either TextEnvelopeCddlError (KeyWitness era) -deserialiseWitnessLedgerCddl sbe te@TextEnvelope{teDescription} = - let res = shelleyBasedEraConstraints sbe $ mapLeft textEnvelopeErrorToTextEnvelopeCddlError $ - deserialiseFromTextEnvelope asType te{teType = textEnvelopeType asType} in - case teDescription of - "Key BootstrapWitness ShelleyEra" -> res - "Key Witness ShelleyEra" -> res - _ -> Left TextEnvelopeCddlUnknownKeyWitness +deserialiseWitnessLedgerCddl sbe te = + shelleyBasedEraConstraints sbe $ mapLeft textEnvelopeErrorToTextEnvelopeCddlError $ + deserialiseFromTextEnvelope asType te where asType :: AsType (KeyWitness era) From 5743a60be307540f7aae6562f1ca8a1f21915768 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Tue, 28 May 2024 21:17:58 +0200 Subject: [PATCH 7/8] Add legacy backup decoding for `deserialiseWitnessLedgerCddl` --- .../Cardano/Api/SerialiseLedgerCddl.hs | 22 +++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index 02619bc2da..da4c982d43 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} -- | Ledger CDDL Serialisation -- @@ -187,13 +188,30 @@ deserialiseWitnessLedgerCddl :: forall era . -> TextEnvelope -> Either TextEnvelopeCddlError (KeyWitness era) deserialiseWitnessLedgerCddl sbe te = - shelleyBasedEraConstraints sbe $ mapLeft textEnvelopeErrorToTextEnvelopeCddlError $ + shelleyBasedEraConstraints sbe $ legacyDecoding te $ mapLeft textEnvelopeErrorToTextEnvelopeCddlError $ deserialiseFromTextEnvelope asType te - where asType :: AsType (KeyWitness era) asType = shelleyBasedEraConstraints sbe $ proxyToAsType Proxy + -- | This wrapper ensures that we can still decode the key witness + -- that were serialized before we migrated to using 'serialiseToTextEnvelope' + legacyDecoding :: TextEnvelope -> Either TextEnvelopeCddlError (KeyWitness era) -> Either TextEnvelopeCddlError (KeyWitness era) + legacyDecoding TextEnvelope{teDescription, teRawCBOR} (Left (TextEnvelopeCddlErrCBORDecodingError _)) = + case teDescription of + "Key BootstrapWitness ShelleyEra" -> do + w <- first TextEnvelopeCddlErrCBORDecodingError + $ CBOR.decodeFullAnnotator + (eraProtVerLow sbe) "Shelley Witness" CBOR.decCBOR (LBS.fromStrict teRawCBOR) + Right $ ShelleyBootstrapWitness sbe w + "Key Witness ShelleyEra" -> do + w <- first TextEnvelopeCddlErrCBORDecodingError + $ CBOR.decodeFullAnnotator + (eraProtVerLow sbe) "Shelley Witness" CBOR.decCBOR (LBS.fromStrict teRawCBOR) + Right $ ShelleyKeyWitness sbe w + _ -> Left TextEnvelopeCddlUnknownKeyWitness + legacyDecoding _ v = v + writeTxFileTextEnvelopeCddl :: () => ShelleyBasedEra era -> File content Out From 0266459187966ffe86c579b884c7ca7176f1d81d Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Tue, 28 May 2024 21:41:22 +0200 Subject: [PATCH 8/8] Stylish Haskell --- cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index da4c982d43..d85554f9e1 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -4,9 +4,9 @@ {-# LANGUAGE EmptyCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NamedFieldPuns #-} -- | Ledger CDDL Serialisation -- @@ -43,7 +43,7 @@ import Cardano.Api.Pretty import Cardano.Api.SerialiseTextEnvelope (TextEnvelope (..), TextEnvelopeDescr (TextEnvelopeDescr), TextEnvelopeError (..), TextEnvelopeType (TextEnvelopeType), deserialiseFromTextEnvelope, - serialiseToTextEnvelope, legacyComparison) + legacyComparison, serialiseToTextEnvelope) import Cardano.Api.Tx.Sign import Cardano.Api.Utils