Babbage: Translation

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

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,

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 {..}

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,22 +62,26 @@ 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
 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