diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index 7bb799d6f0..d85554f9e1 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -11,8 +11,7 @@ -- | Ledger CDDL Serialisation -- module Cardano.Api.SerialiseLedgerCddl - ( TextEnvelopeCddl(..) - , TextEnvelopeCddlError (..) + ( TextEnvelopeCddlError (..) , FromSomeTypeCDDL(..) -- * Reading one of several transaction or @@ -41,7 +40,10 @@ 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 (..), + TextEnvelopeType (TextEnvelopeType), deserialiseFromTextEnvelope, + legacyComparison, serialiseToTextEnvelope) import Cardano.Api.Tx.Sign import Cardano.Api.Utils @@ -51,17 +53,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 +78,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 +89,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 -> @@ -134,36 +119,35 @@ instance Error TextEnvelopeCddlError where TextEnvelopeCddlErrByronKeyWitnessUnsupported -> "TextEnvelopeCddl error: Byron key witnesses are currently unsupported." -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 +{-# 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){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 . + 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 @@ -175,75 +159,58 @@ 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 +deserialiseWitnessLedgerCddl :: forall era . + ShelleyBasedEra era + -> TextEnvelope -> 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 sbe te = + 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 @@ -280,16 +247,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 @@ -298,21 +265,21 @@ 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 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 (FromCDDLTx ttoken _f) = actualType == ttoken - matching (FromCDDLWitness ttoken _f) = actualType == ttoken + matching :: FromSomeTypeCDDL TextEnvelope b -> Bool + 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 @@ -340,7 +307,7 @@ cddlTypeToEra = \case unknownCddlType -> Left $ TextEnvelopeCddlErrUnknownType unknownCddlType readFileTextEnvelopeCddlAnyOf - :: [FromSomeTypeCDDL TextEnvelopeCddl b] + :: [FromSomeTypeCDDL TextEnvelope b] -> FilePath -> IO (Either (FileError TextEnvelopeCddlError) b) readFileTextEnvelopeCddlAnyOf types path = @@ -351,7 +318,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/internal/Cardano/Api/SerialiseTextEnvelope.hs b/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs index 4d10194c46..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(..) @@ -159,9 +160,29 @@ 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 + (expectedOther, expectedActual) -> expectedOther == expectedActual + -- ---------------------------------------------------------------------------- -- Serialisation in text envelope format @@ -220,7 +241,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 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 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..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,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} -- TODO remove when serialiseTxLedgerCddl is removed {-# 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]