diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs index 847f7ba07a3..edb4b58a4c9 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs @@ -12,10 +12,6 @@ module Cardano.Ledger.Alonzo.Translation where import Cardano.Binary ( DecoderError, - FromCBOR (..), - ToCBOR (..), - decodeAnnotator, - serialize, ) import Cardano.Ledger.Alonzo (AlonzoEra) import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..), extendPPWithGenesis) @@ -31,6 +27,7 @@ import Cardano.Ledger.Era translateEra', ) import Cardano.Ledger.Mary (MaryEra) +import Cardano.Ledger.Serialization (translateViaCBORAnn) import Cardano.Ledger.Shelley.API ( EpochState (..), NewEpochState (..), @@ -41,9 +38,6 @@ import qualified Cardano.Ledger.Shelley.API as API import qualified Cardano.Ledger.Shelley.PParams as Shelley import qualified Cardano.Ledger.Shelley.Tx as LTX import qualified Cardano.Ledger.Shelley.TxBody as Shelley -import Control.Monad.Except (Except, throwError) -import Data.Coders -import Data.Text (Text) -------------------------------------------------------------------------------- -- Translation from Mary to Alonzo @@ -126,12 +120,6 @@ instance -- Auxiliary instances and functions -------------------------------------------------------------------------------- -translateViaCBORAnn :: (ToCBOR a, FromCBOR (Annotator b)) => Text -> a -> Except DecoderError b -translateViaCBORAnn name x = - case decodeAnnotator name fromCBOR (serialize x) of - Right newx -> pure newx - Left decoderError -> throwError decoderError - instance (Crypto c, Functor f) => TranslateEra (AlonzoEra c) (API.PParams' f) instance Crypto c => TranslateEra (AlonzoEra c) EpochState where diff --git a/eras/babbage/impl/cardano-ledger-babbage.cabal b/eras/babbage/impl/cardano-ledger-babbage.cabal index bdd6a572009..8198459a75a 100644 --- a/eras/babbage/impl/cardano-ledger-babbage.cabal +++ b/eras/babbage/impl/cardano-ledger-babbage.cabal @@ -38,6 +38,7 @@ library Cardano.Ledger.Babbage.PParams Cardano.Ledger.Babbage.Tx Cardano.Ledger.Babbage.TxBody + Cardano.Ledger.Babbage.Translation Cardano.Ledger.Babbage build-depends: array, diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs new file mode 100644 index 00000000000..bc041f3d325 --- /dev/null +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babbage.Translation where + +import Cardano.Binary + ( DecoderError, + ) +import Cardano.Ledger.Alonzo (AlonzoEra) +import qualified Cardano.Ledger.Alonzo.PParams as Alonzo +import qualified Cardano.Ledger.Alonzo.Tx as Alonzo +import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxOut (..)) +import Cardano.Ledger.Babbage (BabbageEra) +import Cardano.Ledger.Babbage.Genesis (AlonzoGenesis (..)) +import Cardano.Ledger.Babbage.PParams (PParams' (..)) +import Cardano.Ledger.Babbage.Tx (ValidatedTx (..)) +import Cardano.Ledger.Babbage.TxBody (Datum (..), TxOut (..)) +import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.Era + ( PreviousEra, + TranslateEra (..), + TranslationContext, + translateEra', + ) +import Cardano.Ledger.Serialization (translateViaCBORAnn) +import Cardano.Ledger.Shelley.API + ( EpochState (..), + NewEpochState (..), + ShelleyGenesis, + StrictMaybe (..), + ) +import qualified Cardano.Ledger.Shelley.API as API + +-------------------------------------------------------------------------------- +-- Translation from Alonzo to Babbage +-- +-- The instances below are needed by the consensus layer. Do not remove any of +-- them without coordinating with consensus. +-- +-- Please add auxiliary instances and other declarations at the bottom of this +-- module, not in the list below so that it remains clear which instances the +-- consensus layer needs. +-- +-- WARNING: when a translation instance currently uses the default +-- 'TranslationError', i.e., 'Void', it means the consensus layer relies on it +-- being total. Do not change it! +-------------------------------------------------------------------------------- + +type instance PreviousEra (BabbageEra c) = AlonzoEra c + +type instance TranslationContext (BabbageEra c) = AlonzoGenesis + +instance + (Crypto c) => + TranslateEra (BabbageEra c) NewEpochState + where + translateEra ctxt nes = + pure $ + NewEpochState + { nesEL = nesEL nes, + nesBprev = nesBprev nes, + nesBcur = nesBcur nes, + nesEs = translateEra' ctxt $ nesEs nes, + nesRu = nesRu nes, + nesPd = nesPd nes + } + +instance Crypto c => TranslateEra (BabbageEra c) ShelleyGenesis where + translateEra ctxt genesis = + pure + API.ShelleyGenesis + { API.sgSystemStart = API.sgSystemStart genesis, + API.sgNetworkMagic = API.sgNetworkMagic genesis, + API.sgNetworkId = API.sgNetworkId genesis, + API.sgActiveSlotsCoeff = API.sgActiveSlotsCoeff genesis, + API.sgSecurityParam = API.sgSecurityParam genesis, + API.sgEpochLength = API.sgEpochLength genesis, + API.sgSlotsPerKESPeriod = API.sgSlotsPerKESPeriod genesis, + API.sgMaxKESEvolutions = API.sgMaxKESEvolutions genesis, + API.sgSlotLength = API.sgSlotLength genesis, + API.sgUpdateQuorum = API.sgUpdateQuorum genesis, + API.sgMaxLovelaceSupply = API.sgMaxLovelaceSupply genesis, + API.sgProtocolParams = translateEra' ctxt (API.sgProtocolParams genesis), + API.sgGenDelegs = API.sgGenDelegs genesis, + API.sgInitialFunds = API.sgInitialFunds genesis, + API.sgStaking = API.sgStaking genesis + } + +newtype Tx era = Tx {unTx :: Core.Tx era} + +instance + ( Crypto c, + Core.Tx (BabbageEra c) ~ ValidatedTx (BabbageEra c) + ) => + TranslateEra (BabbageEra c) Tx + where + type TranslationError (BabbageEra c) Tx = DecoderError + translateEra _ctxt (Tx tx) = do + -- Note that this does not preserve the hidden bytes field of the transaction. + -- This is under the premise that this is irrelevant for TxInBlocks, which are + -- not transmitted as contiguous chunks. + bdy <- translateViaCBORAnn "txbody" $ Alonzo.body tx + txwits <- translateViaCBORAnn "txwitness" $ Alonzo.wits tx + aux <- case Alonzo.auxiliaryData tx of + SNothing -> pure SNothing + SJust axd -> SJust <$> translateViaCBORAnn "auxiliarydata" axd + let validating = Alonzo.isValid tx + pure $ Tx $ ValidatedTx bdy txwits validating aux + +-------------------------------------------------------------------------------- +-- Auxiliary instances and functions +-------------------------------------------------------------------------------- + +instance (Crypto c, Functor f) => TranslateEra (BabbageEra c) (API.PParams' f) + +instance Crypto c => TranslateEra (BabbageEra c) EpochState where + translateEra ctxt es = + pure + EpochState + { esAccountState = esAccountState es, + esSnapshots = esSnapshots es, + esLState = translateEra' ctxt $ esLState es, + esPrevPp = translatePParams $ esPrevPp es, + esPp = translatePParams $ esPp es, + esNonMyopic = esNonMyopic es + } + +instance Crypto c => TranslateEra (BabbageEra c) API.LedgerState where + translateEra ctxt ls = + pure + API.LedgerState + { API._utxoState = translateEra' ctxt $ API._utxoState ls, + API._delegationState = API._delegationState ls + } + +instance Crypto c => TranslateEra (BabbageEra c) API.UTxOState where + translateEra ctxt us = + pure + API.UTxOState + { API._utxo = translateEra' ctxt $ API._utxo us, + API._deposited = API._deposited us, + API._fees = API._fees us, + API._ppups = translateEra' ctxt $ API._ppups us, + API._stakeDistro = API._stakeDistro us + } + +instance Crypto c => TranslateEra (BabbageEra c) API.UTxO where + translateEra _ctxt utxo = + pure $ API.UTxO $ translateTxOut <$> API.unUTxO utxo + +instance Crypto c => TranslateEra (BabbageEra c) API.PPUPState where + translateEra ctxt ps = + pure + API.PPUPState + { API.proposals = translateEra' ctxt $ API.proposals ps, + API.futureProposals = translateEra' ctxt $ API.futureProposals ps + } + +instance Crypto c => TranslateEra (BabbageEra c) API.ProposedPPUpdates where + translateEra _ctxt (API.ProposedPPUpdates ppup) = + pure $ API.ProposedPPUpdates $ fmap translatePParams ppup + +translateTxOut :: + Crypto c => + Core.TxOut (AlonzoEra c) -> + Core.TxOut (BabbageEra c) +translateTxOut (Alonzo.TxOut addr value dh) = TxOut addr value d + where + d = case dh of + SNothing -> NoDatum + SJust d' -> DatumHash d' + +translatePParams :: + Alonzo.PParams' f (AlonzoEra c) -> PParams' f (BabbageEra c) +translatePParams (Alonzo.PParams {..}) = PParams {..} diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Serialization.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Serialization.hs index cde5002b6c5..525c2af1fcd 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Serialization.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Serialization.hs @@ -35,6 +35,7 @@ module Cardano.Ledger.Serialization ratioFromCBOR, mapToCBOR, mapFromCBOR, + translateViaCBORAnn, -- IPv4 ipv4ToBytes, ipv4FromBytes, @@ -61,14 +62,17 @@ import Cardano.Binary FromCBOR (..), Size, ToCBOR (..), + decodeAnnotator, decodeListLenOrIndef, decodeTag, encodeListLen, encodeTag, + serialize, withWordSize, ) import Cardano.Prelude (cborError) import Control.Monad (unless, when) +import Control.Monad.Except (Except, MonadError (throwError)) import Data.Binary.Get (Get, getWord32le, runGetOrFail) import Data.Binary.Put (putWord32le, runPut) import qualified Data.ByteString as BS @@ -76,7 +80,8 @@ import qualified Data.ByteString.Builder as BS import qualified Data.ByteString.Builder.Extra as BS import qualified Data.ByteString.Lazy as BSL import Data.Coders - ( decodeCollectionWithLen, + ( Annotator, + decodeCollectionWithLen, decodeList, decodeMap, decodeMapContents, @@ -299,3 +304,9 @@ utcTimeFromCBOR = do UTCTime (fromOrdinalDate year dayOfYear) (picosecondsToDiffTime diff) + +translateViaCBORAnn :: (ToCBOR a, FromCBOR (Annotator b)) => Text -> a -> Except DecoderError b +translateViaCBORAnn name x = + case decodeAnnotator name fromCBOR (serialize x) of + Right newx -> pure newx + Left decoderError -> throwError decoderError