consensus: use distinct types for validated and unvalidated transactions

This is necessary for Alonzo. But, as for everything else, Consensus integrates
it generally, not just for Alonzo.

The root changes are as follows:

  * introduce the `Validated` data family

  * change the result of `applyTx` to include a `Validated`; `applyTx` is _the_
    proper way to constructor a `Validated (GenTx blk)` value

  * change the argument of `reapplyTx` to use `Validated`

Everything follows from those changes. In particular, we must update the
mempool to hold _validated_ transactions and, relatedly, the block forging
routines to now take a sequence of _validated_ transactions. Note that we still
only send/receive unvalidated transactions (no peer can trust another's
validation), so `TxSub` still only handles unvalidated transactions. Thus we
need the `txForgetValidated` method as well.

At least for now, we have no cause to send/receive validated transactions. Thus
we do not need serialization for validated transactions.

Note that we to translate both unvalidated and validated transactions from one
era to the next.

  * Unvalidated for the same reasons as before: a transaction might be sent
    before the boundary but only be received after the boundary.

  * For validated, it's much the same idea. A transaction might have entered
    the mempool before the boundary but will only be baked into a block after
    the boundary. (At some point the mempool will " reapply " its contents to a
    new era ledger state, and that requires the translation of validated
    transactions.)

We define 'Validated' as an independent data family because we plan to re-use
it for blocks as well. Validated-ness is a fundamental concept, much liked
'Ticked', and so we encode it as a fundamental building block. The use of a
data family also brings the usual type inference benefits as well as forcing us
to respect the (intentionally emphasized!) distinction even in definitions that
have monomorphic block types (where the unvalidated and validated transaction
types in the ledger might be nominally equivalent).

ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Ledger.hs

@@ -152,7 +152,7 @@ instance Bridge ByronBlock ByronSpecBlock where
       }
 
   updateBridgeWithTx genTx bridge = bridge {
-        toImplIds = toImplIds bridge <> dualGenTxBridge genTx
+        toImplIds = toImplIds bridge <> vDualGenTxBridge genTx
       }
 
 {-------------------------------------------------------------------------------
@@ -210,10 +210,10 @@ forgeDualByronBlock
   -> BlockNo                            -- ^ Current block number
   -> SlotNo                             -- ^ Current slot number
   -> TickedLedgerState DualByronBlock   -- ^ Ledger
-  -> [GenTx DualByronBlock]             -- ^ Txs to add in the block
+  -> [Validated (GenTx DualByronBlock)] -- ^ Txs to add in the block
   -> PBftIsLeader PBftByronCrypto       -- ^ Leader proof ('IsLeader')
   -> DualByronBlock
-forgeDualByronBlock cfg curBlockNo curSlotNo tickedLedger txs isLeader =
+forgeDualByronBlock cfg curBlockNo curSlotNo tickedLedger vtxs isLeader =
     -- NOTE: We do not /elaborate/ the real Byron block from the spec one, but
     -- instead we /forge/ it. This is important, because we want to test that
     -- codepath. This does mean that we do not get any kind of "bridge" between
@@ -224,7 +224,7 @@ forgeDualByronBlock cfg curBlockNo curSlotNo tickedLedger txs isLeader =
     DualBlock {
         dualBlockMain   = main
       , dualBlockAux    = Just aux
-      , dualBlockBridge = mconcat $ map dualGenTxBridge txs
+      , dualBlockBridge = mconcat $ map vDualGenTxBridge vtxs
       }
   where
     main :: ByronBlock
@@ -233,15 +233,15 @@ forgeDualByronBlock cfg curBlockNo curSlotNo tickedLedger txs isLeader =
              curBlockNo
              curSlotNo
              (tickedDualLedgerStateMain tickedLedger)
-             (map dualGenTxMain txs)
+             (map vDualGenTxMain vtxs)
              isLeader
 
     aux :: ByronSpecBlock
     aux = forgeByronSpecBlock
             curBlockNo
             curSlotNo
             (tickedDualLedgerStateAux tickedLedger)
-            (map dualGenTxAux txs)
+            (map vDualGenTxAux vtxs)
             (bridgeToSpecKey
                (tickedDualLedgerStateBridge tickedLedger)
                (hashVerKey . deriveVerKeyDSIGN . pbftIsLeaderSignKey $ isLeader))

ouroboros-consensus-byron-test/src/Test/Consensus/Byron/Examples.hs

@@ -126,7 +126,7 @@ exampleBlock =
       (BlockNo 1)
       (SlotNo 1)
       (applyChainTick ledgerConfig (SlotNo 1) ledgerStateAfterEBB)
-      [exampleGenTx]
+      [ValidatedByronTx exampleGenTx]
       (fakeMkIsLeader leaderCredentials)
   where
     -- | Normally, we'd have to use 'checkIsLeader' to produce this proof.

ouroboros-consensus-byron-test/test/Test/ThreadNet/DualByron.hs

@@ -279,8 +279,8 @@ instance TxGen DualByronBlock where
                              curSlotNo
                              tx
                              st of
-            Right st' -> go (tx:acc) (n - 1) st'
-            Left _    -> error "testGenTxs: unexpected invalid tx"
+            Right (st', _vtx) -> go (tx:acc) (n - 1) st'
+            Left _            -> error "testGenTxs: unexpected invalid tx"
 
 -- | Generate transaction
 --

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Forge.hs

@@ -35,6 +35,7 @@ import           Cardano.Crypto.DSIGN
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Ledger.Abstract
+import           Ouroboros.Consensus.Ledger.SupportsMempool (txForgetValidated)
 import           Ouroboros.Consensus.Protocol.PBFT
 
 import           Ouroboros.Consensus.Byron.Crypto.DSIGN
@@ -50,7 +51,7 @@ forgeByronBlock
   -> BlockNo                         -- ^ Current block number
   -> SlotNo                          -- ^ Current slot number
   -> TickedLedgerState ByronBlock    -- ^ Current ledger
-  -> [GenTx ByronBlock]              -- ^ Txs to add in the block
+  -> [Validated (GenTx ByronBlock)]  -- ^ Txs to add in the block
   -> PBftIsLeader PBftByronCrypto    -- ^ Leader proof ('IsLeader')
   -> ByronBlock
 forgeByronBlock cfg = forgeRegularBlock (configBlock cfg)
@@ -125,7 +126,7 @@ forgeRegularBlock
   -> BlockNo                           -- ^ Current block number
   -> SlotNo                            -- ^ Current slot number
   -> TickedLedgerState ByronBlock      -- ^ Current ledger
-  -> [GenTx ByronBlock]                -- ^ Txs to add in the block
+  -> [Validated (GenTx ByronBlock)]    -- ^ Txs to add in the block
   -> PBftIsLeader PBftByronCrypto      -- ^ Leader proof ('IsLeader')
   -> ByronBlock
 forgeRegularBlock cfg bno sno st txs isLeader =
@@ -139,7 +140,11 @@ forgeRegularBlock cfg bno sno st txs isLeader =
     epochSlots = byronEpochSlots cfg
 
     blockPayloads :: BlockPayloads
-    blockPayloads = foldr extendBlockPayloads initBlockPayloads txs
+    blockPayloads =
+        foldr
+          extendBlockPayloads
+          initBlockPayloads
+          (map txForgetValidated txs)
 
     txPayload :: CC.UTxO.TxPayload
     txPayload = CC.UTxO.mkTxPayload (bpTxs blockPayloads)

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Mempool.hs

@@ -1,15 +1,16 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE DerivingVia       #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE NamedFieldPuns    #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingVia                #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilies               #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -18,6 +19,7 @@ module Ouroboros.Consensus.Byron.Ledger.Mempool (
     -- * Mempool integration
     GenTx (..)
   , TxId (..)
+  , Validated (..)
     -- * Transaction IDs
   , byronIdDlg
   , byronIdProp
@@ -95,6 +97,12 @@ data instance GenTx ByronBlock
 
 instance ShowProxy (GenTx ByronBlock) where
 
+newtype instance Validated (GenTx ByronBlock) = ValidatedByronTx {
+      forgetValidatedByronTx :: GenTx ByronBlock
+    }
+  deriving (Eq, Generic)
+  deriving anyclass (NoThunks)
+
 type instance ApplyTxErr ByronBlock = CC.ApplyMempoolPayloadErr
 
 -- orphaned instance
@@ -108,11 +116,14 @@ instance LedgerSupportsMempool ByronBlock where
     where
       tx' = toMempoolPayload tx
 
-  applyTx = applyByronGenTx validationMode
+  applyTx cfg slot tx st =
+          (\st' -> (st', ValidatedByronTx tx))
+      <$> applyByronGenTx validationMode cfg slot tx st
     where
       validationMode = CC.ValidationMode CC.BlockValidation Utxo.TxValidation
 
-  reapplyTx = applyByronGenTx validationMode
+  reapplyTx cfg slot vtx st =
+      applyByronGenTx validationMode cfg slot (forgetValidatedByronTx vtx) st
     where
       validationMode = CC.ValidationMode CC.NoBlockValidation Utxo.TxValidationNoCrypto
 
@@ -125,6 +136,8 @@ instance LedgerSupportsMempool ByronBlock where
     . CC.mempoolPayloadRecoverBytes
     . toMempoolPayload
 
+  txForgetValidated = forgetValidatedByronTx
+
 data instance TxId (GenTx ByronBlock)
   = ByronTxId             !Utxo.TxId
   | ByronDlgId            !Delegation.CertificateId
@@ -145,7 +158,7 @@ instance HasTxs ByronBlock where
   extractTxs blk = case byronBlockRaw blk of
     -- EBBs don't contain transactions
     CC.ABOBBoundary _ebb    -> []
-    CC.ABOBBlock regularBlk -> fromMempoolPayload <$>
+    CC.ABOBBlock regularBlk -> ValidatedByronTx . fromMempoolPayload <$>
         maybeToList proposal <> votes <> dlgs <> txs
       where
         body = CC.blockBody regularBlk
@@ -212,6 +225,9 @@ instance Condense (GenTxId ByronBlock) where
 instance Show (GenTx ByronBlock) where
   show = condense
 
+instance Show (Validated (GenTx ByronBlock)) where
+  show vtx = "Validated-" <> condense (forgetValidatedByronTx vtx)
+
 instance Show (GenTxId ByronBlock) where
   show = condense
 

ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Forge.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE RecordWildCards #-}
-
 module Ouroboros.Consensus.ByronSpec.Ledger.Forge (forgeByronSpecBlock) where
 
 import qualified Byron.Spec.Chain.STS.Block as Spec
@@ -24,7 +22,7 @@ import           Ouroboros.Consensus.ByronSpec.Ledger.Orphans ()
 forgeByronSpecBlock :: BlockNo
                     -> SlotNo
                     -> Ticked (LedgerState ByronSpecBlock)
-                    -> [GenTx ByronSpecBlock]
+                    -> [Validated (GenTx ByronSpecBlock)]
                     -> Spec.VKey
                     -> ByronSpecBlock
 forgeByronSpecBlock curBlockNo curSlotNo (TickedByronSpecLedgerState _ st) txs vkey =
@@ -34,7 +32,9 @@ forgeByronSpecBlock curBlockNo curSlotNo (TickedByronSpecLedgerState _ st) txs v
       , byronSpecBlockHash = Spec.bhHash $ Spec._bHeader block
       }
   where
-    (ds, ts, us, vs) = GenTx.partition (map unByronSpecGenTx txs)
+    (ds, ts, us, vs) =
+        GenTx.partition
+          (map (unByronSpecGenTx . forgetValidatedByronSpecGenTx) txs)
 
     -- TODO: Don't take protocol version from ledger state
     -- <https://github.com/input-output-hk/ouroboros-network/issues/1495>

ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs

@@ -1,13 +1,15 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric  #-}
-{-# LANGUAGE DerivingVia    #-}
-{-# LANGUAGE TypeFamilies   #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingVia                #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies               #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Ouroboros.Consensus.ByronSpec.Ledger.Mempool (
     -- * Type family instances
     GenTx (..)
+  , Validated (..)
   ) where
 
 import           Codec.Serialise
@@ -30,16 +32,30 @@ newtype instance GenTx ByronSpecBlock = ByronSpecGenTx {
   deriving anyclass (Serialise)
   deriving NoThunks via AllowThunk (GenTx ByronSpecBlock)
 
+newtype instance Validated (GenTx ByronSpecBlock) = ValidatedByronSpecGenTx {
+      forgetValidatedByronSpecGenTx :: GenTx ByronSpecBlock
+    }
+  deriving stock (Show, Generic)
+  deriving anyclass NoThunks
+
 type instance ApplyTxErr ByronSpecBlock = ByronSpecGenTxErr
 
 instance LedgerSupportsMempool ByronSpecBlock where
   applyTx cfg _slot tx (TickedByronSpecLedgerState tip st) =
-      TickedByronSpecLedgerState tip <$>
-        GenTx.apply cfg (unByronSpecGenTx tx) st
+        fmap (\st' ->
+               ( TickedByronSpecLedgerState tip st'
+               , ValidatedByronSpecGenTx tx
+               )
+             )
+      $ GenTx.apply cfg (unByronSpecGenTx tx) st
 
   -- Byron spec doesn't have multiple validation modes
-  reapplyTx = applyTx
+  reapplyTx cfg slot vtx st =
+        fmap fst
+      $ applyTx cfg slot (forgetValidatedByronSpecGenTx vtx) st
 
   -- Dummy values, as these are not used in practice.
   maxTxCapacity = const maxBound
   txInBlockSize = const 0
+
+  txForgetValidated = forgetValidatedByronSpecGenTx

ouroboros-consensus-cardano-test/src/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs

@@ -123,6 +123,7 @@ type ShelleyBasedHardForkConstraints era1 era2 =
   , SL.TranslateEra       era2 SL.Tx
   , SL.TranslateEra       era2 SL.NewEpochState
   , SL.TranslateEra       era2 SL.ShelleyGenesis
+  , SL.TranslateEra       era2 WrapTxInBlock
 
   , SL.TranslationError   era2 SL.NewEpochState  ~ Void
   , SL.TranslationError   era2 SL.ShelleyGenesis ~ Void
@@ -163,14 +164,25 @@ instance ShelleyBasedHardForkConstraints era1 era2
 
   hardForkChainSel = Tails.mk2 SelectSameProtocol
 
-  hardForkInjectTxs = InPairs.mk2 $ InPairs.ignoringBoth (InjectTx translateTx)
+  hardForkInjectTxs =
+        InPairs.mk2
+      $ InPairs.ignoringBoth
+      $ Pair2 (InjectTx translateTx) (InjectValidatedTx translateValidatedTx)
     where
       translateTx ::
-           GenTx (ShelleyBlock era1)
+                  GenTx (ShelleyBlock era1)
         -> Maybe (GenTx (ShelleyBlock era2))
       translateTx =
           fmap unComp . eitherToMaybe . runExcept . SL.translateEra () . Comp
 
+      translateValidatedTx ::
+                  WrapValidatedGenTx (ShelleyBlock era1)
+        -> Maybe (WrapValidatedGenTx (ShelleyBlock era2))
+      translateValidatedTx =
+            fmap unComp
+          . eitherToMaybe . runExcept . SL.translateEra ()
+          . Comp
+
 instance ShelleyBasedHardForkConstraints era1 era2
       => SupportedNetworkProtocolVersion (ShelleyBasedHardForkBlock era1 era2) where
   supportedNodeToNodeVersions _ = Map.fromList $

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

@@ -284,9 +284,17 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where
       $ TCons Nil
       $ TNil
   hardForkInjectTxs =
-        PCons (ignoringBoth cannotInjectTx)
-      $ PCons (ignoringBoth translateTxShelleyToAllegraWrapper)
-      $ PCons (ignoringBoth translateTxAllegraToMaryWrapper)
+        PCons (ignoringBoth $ Pair2 cannotInjectTx cannotInjectValidatedTx)
+      $ PCons (   ignoringBoth
+                $ Pair2
+                    translateTxShelleyToAllegraWrapper
+                    translateValidatedTxShelleyToAllegraWrapper
+              )
+      $ PCons (   ignoringBoth
+                $ Pair2
+                    translateTxAllegraToMaryWrapper
+                    translateValidatedTxAllegraToMaryWrapper
+              )
       $ PNil
 
 {-------------------------------------------------------------------------------
@@ -474,6 +482,14 @@ translateTxShelleyToAllegraWrapper ::
 translateTxShelleyToAllegraWrapper = InjectTx $
     fmap unComp . eitherToMaybe . runExcept . SL.translateEra () . Comp
 
+translateValidatedTxShelleyToAllegraWrapper ::
+     PraosCrypto c
+  => InjectValidatedTx
+       (ShelleyBlock (ShelleyEra c))
+       (ShelleyBlock (AllegraEra c))
+translateValidatedTxShelleyToAllegraWrapper = InjectValidatedTx $
+    fmap unComp . eitherToMaybe . runExcept . SL.translateEra () . Comp
+
 {-------------------------------------------------------------------------------
   Translation from Shelley to Allegra
 -------------------------------------------------------------------------------}
@@ -497,3 +513,11 @@ translateTxAllegraToMaryWrapper ::
        (ShelleyBlock (MaryEra c))
 translateTxAllegraToMaryWrapper = InjectTx $
     fmap unComp . eitherToMaybe . runExcept . SL.translateEra () . Comp
+
+translateValidatedTxAllegraToMaryWrapper ::
+     PraosCrypto c
+  => InjectValidatedTx
+       (ShelleyBlock (AllegraEra c))
+       (ShelleyBlock (MaryEra c))
+translateValidatedTxAllegraToMaryWrapper = InjectValidatedTx $
+    fmap unComp . eitherToMaybe . runExcept . SL.translateEra () . Comp

ouroboros-consensus-cardano/tools/db-analyser/Block/Shelley.hs

@@ -22,8 +22,8 @@ import           GHC.Records (HasField, getField)
 import           Options.Applicative
 
 import qualified Cardano.Ledger.Core as Core
+import qualified Cardano.Ledger.Era as CL
 import qualified Shelley.Spec.Ledger.API as SL
-import qualified Shelley.Spec.Ledger.BlockChain as SL (TxSeq (..))
 
 import           Ouroboros.Consensus.Node.ProtocolInfo
 
@@ -43,14 +43,15 @@ instance ( ShelleyBasedEra era
          , HasField "outputs" (Core.TxBody era) (StrictSeq (SL.TxOut era))
          ) => HasAnalysis (ShelleyBlock era) where
   countTxOutputs blk = case Shelley.shelleyBlockRaw blk of
-      SL.Block _ (SL.TxSeq txs) -> sum $ fmap countOutputs txs
+      SL.Block _ body -> sum $ fmap countOutputs (CL.fromTxSeq @era body)
     where
-      countOutputs :: SL.Tx era -> Int
+      countOutputs :: CL.TxInBlock era -> Int
       countOutputs = length . getField @"outputs" . getField @"body"
 
   blockTxSizes blk = case Shelley.shelleyBlockRaw blk of
-      SL.Block _ (SL.TxSeq txs) ->
-        toList $ fmap (fromIntegral . (getField @"txsize")) txs
+      SL.Block _ body ->
+          toList
+        $ fmap (fromIntegral . (getField @"txsize")) (CL.fromTxSeq @era body)
 
   knownEBBs = const Map.empty