From 67b78cf8143420cd603e7f6ff2c8359f5be7dca4 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Sun, 22 Nov 2020 01:59:46 +0000 Subject: [PATCH] Generalise the ShelleyTxBody representation over multiple eras The 'ShelleyBasedEra' GADT tells us what era we are in. The 'ShelleyLedgerEra' type family maps that to the era type from the ledger lib. The 'Ledger.TxBody' type family maps that to a specific tx body type, which is different for each Shelley-based era. Due to this use of GADTs We now need custom Eq and Show instances. Do the minimal changes elsewhere, inserting error cases to fill in next. --- cardano-api/src/Cardano/Api/Tx.hs | 16 +++-- cardano-api/src/Cardano/Api/TxBody.hs | 90 +++++++++++++++++++++++---- 2 files changed, 90 insertions(+), 16 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Tx.hs b/cardano-api/src/Cardano/Api/Tx.hs index c36ff79f915..9e8bda4c8f8 100644 --- a/cardano-api/src/Cardano/Api/Tx.hs +++ b/cardano-api/src/Cardano/Api/Tx.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -262,7 +263,7 @@ getTxBody (ShelleyTx Shelley.Tx { Shelley._body = txbody, Shelley._metadata = txmetadata }) = - ShelleyTxBody txbody (strictMaybeToMaybe txmetadata) + ShelleyTxBody ShelleyBasedEraShelley txbody (strictMaybeToMaybe txmetadata) getTxWitnesses :: Tx era -> [Witness era] @@ -297,7 +298,7 @@ makeSignedTransaction witnesses (ByronTxBody txbody) = selectByronWitness :: Witness ByronEra -> Byron.TxInWitness selectByronWitness (ByronKeyWitness w) = w -makeSignedTransaction witnesses (ShelleyTxBody txbody txmetadata) = +makeSignedTransaction witnesses (ShelleyTxBody ShelleyBasedEraShelley txbody txmetadata) = ShelleyTx $ Shelley.Tx txbody @@ -307,11 +308,16 @@ makeSignedTransaction witnesses (ShelleyTxBody txbody txmetadata) = | ShelleyScriptWitness sw <- witnesses ]) (Set.fromList [ w | ShelleyBootstrapWitness w <- witnesses ])) (maybeToStrictMaybe txmetadata) +makeSignedTransaction _ (ShelleyTxBody ShelleyBasedEraAllegra _ _) = + error "TODO: makeSignedTransaction AllegraEra" +makeSignedTransaction _ (ShelleyTxBody ShelleyBasedEraMary _ _) = + error "TODO: makeSignedTransaction MaryEra" makeByronKeyWitness :: NetworkId -> TxBody ByronEra -> SigningKey ByronKey -> Witness ByronEra +makeByronKeyWitness _ (ShelleyTxBody era _ _) = case era of {} makeByronKeyWitness nw (ByronTxBody txbody) = let txhash :: Byron.Hash Byron.Tx txhash = Byron.hashDecoded txbody @@ -347,7 +353,9 @@ makeShelleyBootstrapWitness :: WitnessNetworkIdOrByronAddress -> TxBody ShelleyEra -> SigningKey ByronKey -> Witness ShelleyEra -makeShelleyBootstrapWitness nwOrAddr (ShelleyTxBody txbody _) (ByronSigningKey sk) = +makeShelleyBootstrapWitness nwOrAddr + (ShelleyTxBody ShelleyBasedEraShelley txbody _) + (ByronSigningKey sk) = ShelleyBootstrapWitness $ -- Byron era witnesses were weird. This reveals all that weirdness. Shelley.BootstrapWitness { @@ -434,7 +442,7 @@ data ShelleyWitnessSigningKey = makeShelleyKeyWitness :: TxBody ShelleyEra -> ShelleyWitnessSigningKey -> Witness ShelleyEra -makeShelleyKeyWitness (ShelleyTxBody txbody _) = +makeShelleyKeyWitness (ShelleyTxBody ShelleyBasedEraShelley txbody _) = let txhash :: Shelley.Hash StandardCrypto Shelley.EraIndependentTxBody txhash = Shelley.hashAnnotated txbody diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index 248e632ddfd..602d73592f2 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -68,6 +68,7 @@ import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Ledger.Era as Ledger import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Shelley as Ledger +import qualified Cardano.Ledger.ShelleyMA.TxBody () import Ouroboros.Consensus.Shelley.Eras (StandardShelley) import Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto) @@ -134,12 +135,20 @@ getTxId (ByronTxBody tx) = . recoverBytes $ tx -getTxId (ShelleyTxBody tx _) = - TxId - . Crypto.castHash - . (\(Shelley.TxId txhash) -> txhash) - . Shelley.txid - $ tx +getTxId (ShelleyTxBody era tx _) = + case era of + ShelleyBasedEraShelley -> getTxIdShelley tx + ShelleyBasedEraAllegra -> getTxIdShelley tx + ShelleyBasedEraMary -> getTxIdShelley tx + where + getTxIdShelley :: Ledger.Crypto ledgerera ~ StandardCrypto + => Ledger.TxBodyConstraints ledgerera + => Ledger.TxBody ledgerera -> TxId + getTxIdShelley = + TxId + . Crypto.castHash + . (\(Shelley.TxId txhash) -> txhash) + . Shelley.txid -- ---------------------------------------------------------------------------- @@ -217,12 +226,63 @@ data TxBody era where -> TxBody ByronEra ShelleyTxBody - :: Ledger.TxBody StandardShelley + :: ShelleyBasedEra era + -> Ledger.TxBody (ShelleyLedgerEra era) -> Maybe Shelley.MetaData - -> TxBody ShelleyEra - -deriving instance Eq (TxBody era) -deriving instance Show (TxBody era) + -> TxBody era + -- The 'ShelleyBasedEra' GADT tells us what era we are in. + -- The 'ShelleyLedgerEra' type family maps that to the era type from the + -- ledger lib. The 'Ledger.TxBody' type family maps that to a specific + -- tx body type, which is different for each Shelley-based era. + + +-- The GADT in the ShelleyTxBody case requires a custom instance +instance Eq (TxBody era) where + (==) (ByronTxBody txbodyA) + (ByronTxBody txbodyB) = txbodyA == txbodyB + + (==) (ShelleyTxBody era txbodyA txmetadataA) + (ShelleyTxBody _ txbodyB txmetadataB) = + txmetadataA == txmetadataB + && case era of + ShelleyBasedEraShelley -> txbodyA == txbodyB + ShelleyBasedEraAllegra -> txbodyA == txbodyB + ShelleyBasedEraMary -> txbodyA == txbodyB + + (==) (ByronTxBody{}) (ShelleyTxBody era _ _) = case era of {} + + +-- The GADT in the ShelleyTxBody case requires a custom instance +instance Show (TxBody era) where + showsPrec p (ByronTxBody txbody) = + showParen (p >= 11) + ( showString "ByronTxBody " + . showsPrec 11 txbody + ) + + showsPrec p (ShelleyTxBody ShelleyBasedEraShelley txbody txmetadata) = + showParen (p >= 11) + ( showString "ShelleyTxBody ShelleyBasedEraShelley " + . showsPrec 11 txbody + . showChar ' ' + . showsPrec 11 txmetadata + ) + + showsPrec p (ShelleyTxBody ShelleyBasedEraAllegra txbody txmetadata) = + showParen (p >= 11) + ( showString "ShelleyTxBody ShelleyBasedEraAllegra " + . showsPrec 11 txbody + . showChar ' ' + . showsPrec 11 txmetadata + ) + + showsPrec p (ShelleyTxBody ShelleyBasedEraMary txbody txmetadata) = + showParen (p >= 11) + ( showString "ShelleyTxBody ShelleyBasedEraMary " + . showsPrec 11 txbody + . showChar ' ' + . showsPrec 11 txmetadata + ) instance HasTypeProxy era => HasTypeProxy (TxBody era) where data AsType (TxBody era) = AsTxBody (AsType era) @@ -242,11 +302,15 @@ instance IsCardanoEra era => SerialiseAsCBOR (TxBody era) where serialiseToCBOR (ByronTxBody txbody) = recoverBytes txbody - serialiseToCBOR (ShelleyTxBody txbody txmetadata) = + serialiseToCBOR (ShelleyTxBody ShelleyBasedEraShelley txbody txmetadata) = CBOR.serializeEncoding' $ CBOR.encodeListLen 2 <> CBOR.toCBOR txbody <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata + serialiseToCBOR (ShelleyTxBody ShelleyBasedEraAllegra _ _) = + error "TODO: SerialiseAsCBOR (TxBody AllegraEra)" + serialiseToCBOR (ShelleyTxBody ShelleyBasedEraMary _ _) = + error "TODO: SerialiseAsCBOR (TxBody MaryEra)" deserialiseFromCBOR _ bs = case cardanoEra :: CardanoEra era of @@ -271,6 +335,7 @@ instance IsCardanoEra era => SerialiseAsCBOR (TxBody era) where txmetadata <- CBOR.decodeNullMaybe fromCBOR return $ CBOR.Annotator $ \fbs -> ShelleyTxBody + ShelleyBasedEraShelley (CBOR.runAnnotator txbody fbs) (CBOR.runAnnotator <$> txmetadata <*> pure fbs) @@ -348,6 +413,7 @@ makeShelleyTransaction TxExtraContent { case shelleyBasedEra :: ShelleyBasedEra era of ShelleyBasedEraShelley -> ShelleyTxBody + ShelleyBasedEraShelley (Shelley.TxBody (Set.fromList (map toShelleyTxIn ins)) (Seq.fromList (map toShelleyTxOut outs))