diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index b9761e9efb..05493f1866 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,8 @@ 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), serialiseToTextEnvelope, deserialiseFromTextEnvelope, TextEnvelopeError (..)) import Cardano.Api.Tx.Sign import Cardano.Api.Utils @@ -51,17 +50,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 qualified Data.List as List import Data.Text (Text) -import qualified Data.Text.Encoding as Text +import qualified Data.Text as T +import Data.Either.Combinators (mapLeft) -- 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 +75,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 +86,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 +117,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 +142,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 +211,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 +229,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 +271,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 +282,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