WIP type instance GenTx (ShelleyBlock era) = TxInBlock era

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs

@@ -586,4 +586,4 @@ translateValidatedTxMaryToAlonzoWrapper ctxt = InjectValidatedTx $
       fmap (\(WrapTxInBlock tx) -> WrapValidatedGenTx (mkShelleyValidatedTx tx))
     . eitherToMaybe . runExcept
     . SL.translateEra @(AlonzoEra c) ctxt
-    . (\(WrapValidatedGenTx (ShelleyValidatedTx _txId tx)) -> WrapTxInBlock tx)
+    . (\(WrapValidatedGenTx (ShelleyValidatedTx (ShelleyTx _txId tx))) -> WrapTxInBlock tx)

ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs

@@ -89,7 +89,7 @@ fromShelleyLedgerExamples ShelleyLedgerExamples {
     blk = mkShelleyBlock sleBlock
     hash = ShelleyHash sleHashHeader
     serialisedBlock = Serialised "<BLOCK>"
-    tx = mkShelleyTx sleTx
+    tx = mkShelleyTx (toPhase2ValidTxInBlock sleTx)
     serialisedHeader =
       SerialisedHeaderFromDepPair $ GenDepPair (NestedCtxt CtxtShelley) (Serialised "<HEADER>")
     queries = labelled [

ouroboros-consensus-shelley-test/src/Test/ThreadNet/Infra/Shelley.hs

@@ -87,7 +87,8 @@ import qualified Shelley.Spec.Ledger.PParams as SL (emptyPParams,
 import qualified Shelley.Spec.Ledger.Tx as SL (WitnessSetHKD (..))
 import qualified Shelley.Spec.Ledger.UTxO as SL (makeWitnessesVKey)
 
-import           Ouroboros.Consensus.Shelley.Eras (EraCrypto, ShelleyEra)
+import           Ouroboros.Consensus.Shelley.Eras (EraCrypto, ShelleyEra,
+                     toPhase2ValidTxInBlock)
 import           Ouroboros.Consensus.Shelley.Ledger (GenTx (..),
                      ShelleyBasedEra, ShelleyBlock, mkShelleyTx)
 import           Ouroboros.Consensus.Shelley.Node
@@ -563,6 +564,7 @@ mkMASetDecentralizationParamTxs ::
 mkMASetDecentralizationParamTxs coreNodes pVer ttl dNew =
     (:[]) $
     mkShelleyTx $
+    toPhase2ValidTxInBlock @era $
     SL.Tx
       { body          = body
       , wits          = witnessSet

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Eras.hs

@@ -4,13 +4,16 @@
 {-# LANGUAGE FlexibleInstances       #-}
 {-# LANGUAGE LambdaCase              #-}
 {-# LANGUAGE MultiParamTypeClasses   #-}
+{-# LANGUAGE NamedFieldPuns          #-}
 {-# LANGUAGE OverloadedStrings       #-}
 {-# LANGUAGE ScopedTypeVariables     #-}
 {-# LANGUAGE TypeApplications        #-}
 {-# LANGUAGE TypeFamilies            #-}
 {-# LANGUAGE UndecidableInstances    #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module Ouroboros.Consensus.Shelley.Eras (
     -- * Eras based on the Shelley ledger
     AllegraEra
@@ -46,7 +49,8 @@ import           GHC.Records
 import           NoThunks.Class (NoThunks)
 import           Numeric.Natural (Natural)
 
-import           Cardano.Binary (FromCBOR (..), ToCBOR (..), enforceSize)
+import           Cardano.Binary (Annotator (..), FromCBOR (..), ToCBOR (..),
+                     encodeListLen, enforceSize)
 
 import           Cardano.Ledger.Allegra (AllegraEra)
 import           Cardano.Ledger.Allegra.Translation ()
@@ -65,6 +69,7 @@ import           Cardano.Ledger.Serialization
 import           Cardano.Ledger.Shelley (ShelleyEra)
 import           Cardano.Ledger.ShelleyMA ()
 import           Control.State.Transition (State)
+import qualified Data.Coders as DC
 import qualified Shelley.Spec.Ledger.API as SL
 
 import           Ouroboros.Consensus.Ledger.SupportsMempool
@@ -140,9 +145,11 @@ class ( SL.ShelleyBasedEra era
       , SL.AdditionalGenesisConfig era ~ Core.TranslationContext era
       , ToCBORGroup (TxSeq era)
 
-      , Eq (Core.TxInBlock era)
-      , NoThunks (Core.TxInBlock era)
-      , Show (Core.TxInBlock era)
+      , Eq (TxInBlock era)
+      , NoThunks (TxInBlock era)
+      , Show (TxInBlock era)
+      , FromCBOR (Annotator (TxInBlock era))
+      , ToCBOR (TxInBlock era)
 
       , NoThunks (Core.TranslationContext era)
 
@@ -160,14 +167,16 @@ class ( SL.ShelleyBasedEra era
   -- etc.
   shelleyBasedEraName :: proxy era -> Text
 
+  toPhase2ValidTxInBlock :: SL.Tx era -> TxInBlock era
+
   toShelleyApplyTxError :: proxy era -> SL.ApplyTxError era -> ShelleyApplyTxError era
 
   applyShelleyBasedTx ::
        SL.Globals
     -> SL.LedgerEnv    era
     -> SL.MempoolState era
     -> WhetherToIntervene
-    -> SL.Tx           era
+    -> TxInBlock       era
     -> Except
          (ShelleyApplyTxError era)
          ( SL.MempoolState era
@@ -201,6 +210,8 @@ instance (SL.PraosCrypto c, ShowProxy (SL.ApplyTxError (ShelleyEra c))) => Shell
 
   shelleyBasedEraName _ = "Shelley"
 
+  toPhase2ValidTxInBlock = id
+
   toShelleyApplyTxError _prx = id
 
   applyShelleyBasedTx = defaultApplyShelleyBasedTx
@@ -210,6 +221,8 @@ instance (SL.PraosCrypto c, ShowProxy (SL.ApplyTxError (AllegraEra c))) => Shell
 
   shelleyBasedEraName _ = "Allegra"
 
+  toPhase2ValidTxInBlock = id
+
   toShelleyApplyTxError _prx = id
 
   applyShelleyBasedTx = defaultApplyShelleyBasedTx
@@ -219,34 +232,78 @@ instance (SL.PraosCrypto c, ShowProxy (SL.ApplyTxError (MaryEra c))) => ShelleyB
 
   shelleyBasedEraName _ = "Mary"
 
+  toPhase2ValidTxInBlock = id
+
   toShelleyApplyTxError _prx = id
 
   applyShelleyBasedTx = defaultApplyShelleyBasedTx
 
+instance SL.PraosCrypto c => ToCBOR (Alonzo.ValidatedTx (AlonzoEra c)) where
+  toCBOR vtx =
+         encodeListLen 4
+      <> toCBOR body
+      <> toCBOR wits
+      <> encodeNullMaybe toCBOR (strictMaybeToMaybe auxiliaryData)
+      <> toCBOR isValidating
+    where
+      Alonzo.ValidatedTx {
+          Alonzo.auxiliaryData
+        , Alonzo.body
+        , Alonzo.isValidating
+        , Alonzo.wits
+        } = vtx
+
+instance SL.PraosCrypto c => FromCBOR (Annotator (Alonzo.ValidatedTx (AlonzoEra c))) where
+  fromCBOR =
+      DC.decode
+    $ DC.Ann (DC.RecD Alonzo.ValidatedTx)
+        DC.<*! DC.From
+        DC.<*! DC.From
+        DC.<*! DC.D ((Annotator . const) <$> fromCBOR)
+        DC.<*! DC.D
+          ( sequence . maybeToStrictMaybe
+              <$> DC.decodeNullMaybe fromCBOR
+          )
+
 instance SL.PraosCrypto c => ShelleyBasedEra (AlonzoEra c) where
   type ShelleyApplyTxError (AlonzoEra c) = AlonzoApplyTxError c
 
   shelleyBasedEraName _ = "Alonzo"
 
   toShelleyApplyTxError _prx = AlonzoApplyTxErrorProper
 
-  applyShelleyBasedTx globals ledgerEnv mempoolState wti tx = do
-      (mempoolState', vtx) <- defaultApplyShelleyBasedTx
+  toPhase2ValidTxInBlock tx =
+      Alonzo.ValidatedTx {
+          Alonzo.auxiliaryData
+        , Alonzo.body
+        , Alonzo.isValidating = Alonzo.IsValidating True
+        , Alonzo.wits
+        }
+    where
+      SL.Tx {
+          SL.auxiliaryData
+        , SL.body
+        , SL.wits
+        } = tx
+
+  applyShelleyBasedTx globals ledgerEnv mempoolState wti vtx = do
+      (mempoolState', vtx') <- defaultApplyShelleyBasedTx
         globals
         ledgerEnv
         mempoolState
         wti
-        tx
+        (SL.extractTx vtx)
 
-      let Alonzo.IsValidating scriptsOK = Alonzo.isValidating vtx
-      case wti of
-        Intervene | not scriptsOK ->
+      let incorrectClaim = Alonzo.isValidating vtx /= Alonzo.isValidating vtx'
+      when incorrectClaim $ case wti of
+        DoNotIntervene -> pure ()
+        Intervene      ->
             throwError
           $ AlonzoApplyTxErrorPromotedWarning
-          $ AlonzoPlutusErrors []
-        _ -> pure ()
+          $ AlonzoPlutusErrors []   -- TODO include Plutus errors
 
-      pure (mempoolState', vtx)
+      -- TODO applyTx needs to include incorrectClaim in its result
+      pure (mempoolState', vtx')
 
 -- | An /error/ arising from applying an Alonzo transaction
 data AlonzoApplyTxError c
@@ -308,7 +365,7 @@ instance FromCBOR AlonzoApplyTxWarning where
   TxInBlock wrapper
 -------------------------------------------------------------------------------}
 
--- | Wrapper for partially applying 'Core.TxInBlock'
+-- | Wrapper for partially applying 'TxInBlock'
 --
 -- For generality, Consensus uses that type family as eg the index of
 -- 'Core.TranslateEra'. We thus need to partially apply it.
@@ -318,7 +375,7 @@ instance FromCBOR AlonzoApplyTxWarning where
 -- to use for previous eras. Also, we use a @Wrap@ prefix in Consensus. Hence
 -- this minor mediating definition. TODO I'm not even fully persuading myself
 -- with this justification.
-newtype WrapTxInBlock era = WrapTxInBlock {unwrapTxInBlock :: Core.TxInBlock era}
+newtype WrapTxInBlock era = WrapTxInBlock {unwrapTxInBlock :: TxInBlock era}
 
 instance ShelleyBasedEra (AllegraEra c) => Core.TranslateEra (AllegraEra c) WrapTxInBlock where
   type TranslationError (AllegraEra c) WrapTxInBlock = Core.TranslationError (AllegraEra c) SL.Tx

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs

@@ -73,7 +73,7 @@ forgeShelleyBlock hotKey canBeLeader cfg curNo curSlot tickedLedger maxTxCapacit
     computedMaxTxCapacity = computeMaxTxCapacity tickedLedger maxTxCapacityOverride
 
     extractTxInBlock :: (Validated (GenTx (ShelleyBlock era))) -> SL.TxInBlock era
-    extractTxInBlock (ShelleyValidatedTx _ tx) = tx
+    extractTxInBlock (ShelleyValidatedTx (ShelleyTx _txid tx)) = tx
 
     mkHeader TPraosFields { tpraosSignature, tpraosToSign } =
       SL.BHeader tpraosToSign tpraosSignature

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs

@@ -47,8 +47,6 @@ import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsMempool
 import           Ouroboros.Consensus.Mempool.TxLimits
-import           Ouroboros.Consensus.Shelley.Eras (AllegraEra, AlonzoEra,
-                     MaryEra, ShelleyEra)
 import           Ouroboros.Consensus.Util (ShowProxy (..))
 import           Ouroboros.Consensus.Util.Condense
 
@@ -65,7 +63,7 @@ import           Ouroboros.Consensus.Shelley.Ledger.Ledger
                      Ticked (TickedShelleyLedgerState, tickedShelleyLedgerState),
                      getPParams)
 
-data instance GenTx (ShelleyBlock era) = ShelleyTx !(SL.TxId (EraCrypto era)) !(SL.Tx era)
+data instance GenTx (ShelleyBlock era) = ShelleyTx !(SL.TxId (EraCrypto era)) !(SL.TxInBlock era)
   deriving stock    (Generic)
 
 deriving instance ShelleyBasedEra era => NoThunks (GenTx (ShelleyBlock era))
@@ -74,19 +72,12 @@ deriving instance ShelleyBasedEra era => Eq (GenTx (ShelleyBlock era))
 
 instance Typeable era => ShowProxy (GenTx (ShelleyBlock era)) where
 
-data instance Validated (GenTx (ShelleyBlock era)) =
-    ShelleyValidatedTx
-      !(SL.TxId (EraCrypto era))
-      !(SL.TxInBlock era)
+newtype instance Validated (GenTx (ShelleyBlock era)) = ShelleyValidatedTx {
+    shelleyForgetValidatedTx :: GenTx (ShelleyBlock era)
+  }
   deriving stock (Generic)
-
-deriving instance ShelleyBasedEra era => NoThunks (Validated (GenTx (ShelleyBlock era)))
-
-deriving instance ShelleyBasedEra era => Eq (Validated (GenTx (ShelleyBlock era)))
-
-deriving instance ShelleyBasedEra era => Show (Validated (GenTx (ShelleyBlock era)))
-
-instance Typeable era => ShowProxy (Validated (GenTx (ShelleyBlock era))) where
+  deriving newtype (Eq,Show)
+  deriving anyclass (NoThunks, ShowProxy)
 
 type instance ApplyTxErr (ShelleyBlock era) = ShelleyApplyTxError era
 
@@ -134,17 +125,16 @@ instance ShelleyBasedEra era
     where
       txSize = fromIntegral $ getField @"txsize" tx
 
-  txForgetValidated (ShelleyValidatedTx txid tx) = ShelleyTx txid (SL.extractTx tx)
+  txForgetValidated (ShelleyValidatedTx gtx) = gtx
 
-mkShelleyTx :: forall era. ShelleyBasedEra era => SL.Tx era -> GenTx (ShelleyBlock era)
+mkShelleyTx :: forall era. ShelleyBasedEra era => SL.TxInBlock era -> GenTx (ShelleyBlock era)
 mkShelleyTx tx = ShelleyTx (SL.txid @era (getField @"body" tx)) tx
 
 mkShelleyValidatedTx :: forall era.
      ShelleyBasedEra era
   => SL.TxInBlock era
   -> Validated (GenTx (ShelleyBlock era))
-mkShelleyValidatedTx tx =
-    ShelleyValidatedTx (SL.txid @era (getField @"body" tx)) tx
+mkShelleyValidatedTx = ShelleyValidatedTx . mkShelleyTx
 
 newtype instance TxId (GenTx (ShelleyBlock era)) = ShelleyTxId (SL.TxId (EraCrypto era))
   deriving newtype (Eq, Ord, NoThunks)
@@ -235,7 +225,7 @@ applyShelleyValidatedTx :: forall era.
   -> Validated (GenTx (ShelleyBlock era))
   -> TickedLedgerState (ShelleyBlock era)
   -> Except (ApplyTxErr (ShelleyBlock era)) (TickedLedgerState (ShelleyBlock era))
-applyShelleyValidatedTx cfg slot (ShelleyValidatedTx _ tx) st = do
+applyShelleyValidatedTx cfg slot vtx st = do
     mempoolState' <-
         withExcept (toShelleyApplyTxError (Proxy @era))
       $ SL.applyTxInBlock
@@ -246,6 +236,8 @@ applyShelleyValidatedTx cfg slot (ShelleyValidatedTx _ tx) st = do
 
     pure $ set theLedgerLens mempoolState' st
   where
+    ShelleyValidatedTx (ShelleyTx _txid tx) = vtx
+
     innerSt = tickedShelleyLedgerState st
 
 -- | The lens combinator
@@ -314,9 +306,9 @@ instance ( SL.PraosCrypto c
   lessEq (AlonzoMeasure bs1 exu1) (AlonzoMeasure bs2 exu2) =
     bs1 <= bs2 && pointWiseExUnits (<=) exu1 exu2
 
-  txMeasure validatedGenTx@(ShelleyValidatedTx _ tx) =
+  txMeasure (ShelleyValidatedTx genTx@(ShelleyTx _txid tx)) =
     AlonzoMeasure {
-        byteSize = ByteSize . txInBlockSize $ txForgetValidated validatedGenTx
+        byteSize = ByteSize $ txInBlockSize genTx
       , exUnits  = totExUnits tx
       }
 

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs

@@ -308,17 +308,17 @@ instance ( ShelleyBasedEra era
         }
 
 instance ( ShelleyBasedEra era
-         , SL.TranslateEra era SL.Tx
+         , SL.TranslateEra era WrapTxInBlock
          ) => SL.TranslateEra era (GenTx :.: ShelleyBlock) where
-  type TranslationError era (GenTx :.: ShelleyBlock) = SL.TranslationError era SL.Tx
+  type TranslationError era (GenTx :.: ShelleyBlock) = SL.TranslationError era WrapTxInBlock
   translateEra ctxt (Comp (ShelleyTx _txId tx)) =
-    -- TODO will the txId stay the same? If so, we could avoid recomputing it
-    Comp . mkShelleyTx <$> SL.translateEra ctxt tx
+        Comp . mkShelleyTx . unwrapTxInBlock @era
+    <$> SL.translateEra ctxt (WrapTxInBlock @(SL.PreviousEra era) tx)
 
 instance ( ShelleyBasedEra era
          , SL.TranslateEra era WrapTxInBlock
          ) => SL.TranslateEra era (WrapValidatedGenTx :.: ShelleyBlock) where
   type TranslationError era (WrapValidatedGenTx :.: ShelleyBlock) = SL.TranslationError era WrapTxInBlock
-  translateEra ctxt (Comp (WrapValidatedGenTx (ShelleyValidatedTx _txId tx))) =
-        Comp . WrapValidatedGenTx . mkShelleyValidatedTx . unwrapTxInBlock @era
-    <$> SL.translateEra ctxt (WrapTxInBlock @(SL.PreviousEra era) tx)
+  translateEra ctxt (Comp (WrapValidatedGenTx (ShelleyValidatedTx tx))) =
+        Comp . WrapValidatedGenTx . ShelleyValidatedTx . unComp
+    <$> SL.translateEra ctxt (Comp tx)