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

-- | Byron mempool integration
module Ouroboros.Consensus.Byron.Ledger.Mempool (
    -- * Mempool integration
    GenTx (..)
  , TxId (..)
  , Validated (..)
    -- * Transaction IDs
  , byronIdDlg
  , byronIdProp
  , byronIdTx
  , byronIdVote
    -- * Serialisation
  , decodeByronApplyTxError
  , decodeByronGenTx
  , decodeByronGenTxId
  , encodeByronApplyTxError
  , encodeByronGenTx
  , encodeByronGenTxId
    -- * Low-level API (primarily for testing)
  , fromMempoolPayload
  , toMempoolPayload
    -- * Auxiliary functions
  , countByronGenTxs
  ) where

import           Codec.CBOR.Decoding (Decoder)
import qualified Codec.CBOR.Decoding as CBOR
import           Codec.CBOR.Encoding (Encoding)
import qualified Codec.CBOR.Encoding as CBOR
import           Control.Monad.Except
import           Data.ByteString (ByteString)
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import           Data.Maybe (maybeToList)
import           Data.Word
import           GHC.Generics (Generic)
import           NoThunks.Class (InspectHeapNamed (..), NoThunks (..))

import           Cardano.Binary (ByteSpan, DecoderError (..), FromCBOR (..),
                     ToCBOR (..), enforceSize, fromCBOR, serialize, slice,
                     toCBOR, unsafeDeserialize)
import           Cardano.Crypto (hashDecoded)
import           Cardano.Prelude (cborError)

import qualified Cardano.Chain.Block as CC
import qualified Cardano.Chain.Byron.API as CC
import qualified Cardano.Chain.Delegation as Delegation
import qualified Cardano.Chain.MempoolPayload as CC
import qualified Cardano.Chain.Update as Update
import qualified Cardano.Chain.UTxO as Utxo
import qualified Cardano.Chain.ValidationMode as CC

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Util (ShowProxy (..))
import           Ouroboros.Consensus.Util.Condense

import           Ouroboros.Consensus.Byron.Ledger.Block
import           Ouroboros.Consensus.Byron.Ledger.Conversions (toByronSlotNo)
import           Ouroboros.Consensus.Byron.Ledger.Ledger
import           Ouroboros.Consensus.Byron.Ledger.Orphans ()
import           Ouroboros.Consensus.Byron.Ledger.Serialisation
                     (byronBlockEncodingOverhead)
import           Ouroboros.Consensus.Mempool.TxLimits

{-------------------------------------------------------------------------------
  TxLimits
-------------------------------------------------------------------------------}

instance TxLimits ByronBlock where
  type TxMeasure ByronBlock = ByteSize
  txMeasure :: Validated (GenTx ByronBlock) -> TxMeasure ByronBlock
txMeasure        = Word32 -> ByteSize
ByteSize (Word32 -> ByteSize)
-> (Validated (GenTx ByronBlock) -> Word32)
-> Validated (GenTx ByronBlock)
-> ByteSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx ByronBlock -> Word32
forall blk. LedgerSupportsMempool blk => GenTx blk -> Word32
txInBlockSize (GenTx ByronBlock -> Word32)
-> (Validated (GenTx ByronBlock) -> GenTx ByronBlock)
-> Validated (GenTx ByronBlock)
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx ByronBlock) -> GenTx ByronBlock
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated
  txsBlockCapacity :: Ticked (LedgerState ByronBlock) -> TxMeasure ByronBlock
txsBlockCapacity = Word32 -> ByteSize
ByteSize (Word32 -> ByteSize)
-> (Ticked (LedgerState ByronBlock) -> Word32)
-> Ticked (LedgerState ByronBlock)
-> ByteSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState ByronBlock) -> Word32
forall blk.
LedgerSupportsMempool blk =>
TickedLedgerState blk -> Word32
txsMaxBytes

{-------------------------------------------------------------------------------
  Transactions
-------------------------------------------------------------------------------}

-- | Generalized transactions in Byron
--
-- This is effectively the same as 'CC.AMempoolPayload' but we cache the
-- transaction ID (a hash).
data instance GenTx ByronBlock
  = ByronTx             !Utxo.TxId                !(Utxo.ATxAux             ByteString)
  | ByronDlg            !Delegation.CertificateId !(Delegation.ACertificate ByteString)
  | ByronUpdateProposal !Update.UpId              !(Update.AProposal        ByteString)
  | ByronUpdateVote     !Update.VoteId            !(Update.AVote            ByteString)
  deriving (GenTx ByronBlock -> GenTx ByronBlock -> Bool
(GenTx ByronBlock -> GenTx ByronBlock -> Bool)
-> (GenTx ByronBlock -> GenTx ByronBlock -> Bool)
-> Eq (GenTx ByronBlock)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenTx ByronBlock -> GenTx ByronBlock -> Bool
$c/= :: GenTx ByronBlock -> GenTx ByronBlock -> Bool
== :: GenTx ByronBlock -> GenTx ByronBlock -> Bool
$c== :: GenTx ByronBlock -> GenTx ByronBlock -> Bool
Eq, (forall x. GenTx ByronBlock -> Rep (GenTx ByronBlock) x)
-> (forall x. Rep (GenTx ByronBlock) x -> GenTx ByronBlock)
-> Generic (GenTx ByronBlock)
forall x. Rep (GenTx ByronBlock) x -> GenTx ByronBlock
forall x. GenTx ByronBlock -> Rep (GenTx ByronBlock) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep (GenTx ByronBlock) x -> GenTx ByronBlock
$cfrom :: forall x. GenTx ByronBlock -> Rep (GenTx ByronBlock) x
Generic)
  deriving Context -> GenTx ByronBlock -> IO (Maybe ThunkInfo)
Proxy (GenTx ByronBlock) -> String
(Context -> GenTx ByronBlock -> IO (Maybe ThunkInfo))
-> (Context -> GenTx ByronBlock -> IO (Maybe ThunkInfo))
-> (Proxy (GenTx ByronBlock) -> String)
-> NoThunks (GenTx ByronBlock)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (GenTx ByronBlock) -> String
$cshowTypeOf :: Proxy (GenTx ByronBlock) -> String
wNoThunks :: Context -> GenTx ByronBlock -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> GenTx ByronBlock -> IO (Maybe ThunkInfo)
noThunks :: Context -> GenTx ByronBlock -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> GenTx ByronBlock -> IO (Maybe ThunkInfo)
NoThunks via InspectHeapNamed "GenTx ByronBlock" (GenTx ByronBlock)

instance ShowProxy (GenTx ByronBlock) where

newtype instance Validated (GenTx ByronBlock) = ValidatedByronTx {
      Validated (GenTx ByronBlock) -> GenTx ByronBlock
forgetValidatedByronTx :: GenTx ByronBlock
    }
  deriving (Validated (GenTx ByronBlock)
-> Validated (GenTx ByronBlock) -> Bool
(Validated (GenTx ByronBlock)
 -> Validated (GenTx ByronBlock) -> Bool)
-> (Validated (GenTx ByronBlock)
    -> Validated (GenTx ByronBlock) -> Bool)
-> Eq (Validated (GenTx ByronBlock))
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Validated (GenTx ByronBlock)
-> Validated (GenTx ByronBlock) -> Bool
$c/= :: Validated (GenTx ByronBlock)
-> Validated (GenTx ByronBlock) -> Bool
== :: Validated (GenTx ByronBlock)
-> Validated (GenTx ByronBlock) -> Bool
$c== :: Validated (GenTx ByronBlock)
-> Validated (GenTx ByronBlock) -> Bool
Eq, (forall x.
 Validated (GenTx ByronBlock)
 -> Rep (Validated (GenTx ByronBlock)) x)
-> (forall x.
    Rep (Validated (GenTx ByronBlock)) x
    -> Validated (GenTx ByronBlock))
-> Generic (Validated (GenTx ByronBlock))
forall x.
Rep (Validated (GenTx ByronBlock)) x
-> Validated (GenTx ByronBlock)
forall x.
Validated (GenTx ByronBlock)
-> Rep (Validated (GenTx ByronBlock)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep (Validated (GenTx ByronBlock)) x
-> Validated (GenTx ByronBlock)
$cfrom :: forall x.
Validated (GenTx ByronBlock)
-> Rep (Validated (GenTx ByronBlock)) x
Generic)
  deriving anyclass (Context -> Validated (GenTx ByronBlock) -> IO (Maybe ThunkInfo)
Proxy (Validated (GenTx ByronBlock)) -> String
(Context -> Validated (GenTx ByronBlock) -> IO (Maybe ThunkInfo))
-> (Context
    -> Validated (GenTx ByronBlock) -> IO (Maybe ThunkInfo))
-> (Proxy (Validated (GenTx ByronBlock)) -> String)
-> NoThunks (Validated (GenTx ByronBlock))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (Validated (GenTx ByronBlock)) -> String
$cshowTypeOf :: Proxy (Validated (GenTx ByronBlock)) -> String
wNoThunks :: Context -> Validated (GenTx ByronBlock) -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Validated (GenTx ByronBlock) -> IO (Maybe ThunkInfo)
noThunks :: Context -> Validated (GenTx ByronBlock) -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> Validated (GenTx ByronBlock) -> IO (Maybe ThunkInfo)
NoThunks)

type instance ApplyTxErr ByronBlock = CC.ApplyMempoolPayloadErr

-- orphaned instance
instance ShowProxy CC.ApplyMempoolPayloadErr where

instance LedgerSupportsMempool ByronBlock where
  -- Check that the annotation is the canonical encoding. This is currently
  -- enforced by 'decodeByronGenTx', see its docstring for more context.
  txInvariant :: GenTx ByronBlock -> Bool
txInvariant GenTx ByronBlock
tx =
      AMempoolPayload ByteString -> ByteString
CC.mempoolPayloadRecoverBytes AMempoolPayload ByteString
tx' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== AMempoolPayload ByteString -> ByteString
forall a. AMempoolPayload a -> ByteString
CC.mempoolPayloadReencode AMempoolPayload ByteString
tx'
    where
      tx' :: AMempoolPayload ByteString
tx' = GenTx ByronBlock -> AMempoolPayload ByteString
toMempoolPayload GenTx ByronBlock
tx

  applyTx :: LedgerConfig ByronBlock
-> WhetherToIntervene
-> SlotNo
-> GenTx ByronBlock
-> Ticked (LedgerState ByronBlock)
-> Except
     (ApplyTxErr ByronBlock)
     (Ticked (LedgerState ByronBlock), Validated (GenTx ByronBlock))
applyTx LedgerConfig ByronBlock
cfg WhetherToIntervene
_wti SlotNo
slot GenTx ByronBlock
tx Ticked (LedgerState ByronBlock)
st =
          (\Ticked (LedgerState ByronBlock)
st' -> (Ticked (LedgerState ByronBlock)
st', GenTx ByronBlock -> Validated (GenTx ByronBlock)
ValidatedByronTx GenTx ByronBlock
tx))
      (Ticked (LedgerState ByronBlock)
 -> (Ticked (LedgerState ByronBlock), Validated (GenTx ByronBlock)))
-> ExceptT
     ApplyMempoolPayloadErr Identity (Ticked (LedgerState ByronBlock))
-> ExceptT
     ApplyMempoolPayloadErr
     Identity
     (Ticked (LedgerState ByronBlock), Validated (GenTx ByronBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValidationMode
-> LedgerConfig ByronBlock
-> SlotNo
-> GenTx ByronBlock
-> Ticked (LedgerState ByronBlock)
-> Except (ApplyTxErr ByronBlock) (Ticked (LedgerState ByronBlock))
applyByronGenTx ValidationMode
validationMode LedgerConfig ByronBlock
cfg SlotNo
slot GenTx ByronBlock
tx Ticked (LedgerState ByronBlock)
st
    where
      validationMode :: ValidationMode
validationMode = BlockValidationMode -> TxValidationMode -> ValidationMode
CC.ValidationMode BlockValidationMode
CC.BlockValidation TxValidationMode
Utxo.TxValidation

  reapplyTx :: LedgerConfig ByronBlock
-> SlotNo
-> Validated (GenTx ByronBlock)
-> Ticked (LedgerState ByronBlock)
-> Except (ApplyTxErr ByronBlock) (Ticked (LedgerState ByronBlock))
reapplyTx LedgerConfig ByronBlock
cfg SlotNo
slot Validated (GenTx ByronBlock)
vtx Ticked (LedgerState ByronBlock)
st =
      ValidationMode
-> LedgerConfig ByronBlock
-> SlotNo
-> GenTx ByronBlock
-> Ticked (LedgerState ByronBlock)
-> Except (ApplyTxErr ByronBlock) (Ticked (LedgerState ByronBlock))
applyByronGenTx ValidationMode
validationMode LedgerConfig ByronBlock
cfg SlotNo
slot (Validated (GenTx ByronBlock) -> GenTx ByronBlock
forgetValidatedByronTx Validated (GenTx ByronBlock)
vtx) Ticked (LedgerState ByronBlock)
st
    where
      validationMode :: ValidationMode
validationMode = BlockValidationMode -> TxValidationMode -> ValidationMode
CC.ValidationMode BlockValidationMode
CC.NoBlockValidation TxValidationMode
Utxo.TxValidationNoCrypto

  txsMaxBytes :: Ticked (LedgerState ByronBlock) -> Word32
txsMaxBytes Ticked (LedgerState ByronBlock)
st =
    ChainValidationState -> Word32
CC.getMaxBlockSize (Ticked (LedgerState ByronBlock) -> ChainValidationState
tickedByronLedgerState Ticked (LedgerState ByronBlock)
st) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
byronBlockEncodingOverhead

  txInBlockSize :: GenTx ByronBlock -> Word32
txInBlockSize =
      Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    (Int -> Word32)
-> (GenTx ByronBlock -> Int) -> GenTx ByronBlock -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
Strict.length
    (ByteString -> Int)
-> (GenTx ByronBlock -> ByteString) -> GenTx ByronBlock -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AMempoolPayload ByteString -> ByteString
CC.mempoolPayloadRecoverBytes
    (AMempoolPayload ByteString -> ByteString)
-> (GenTx ByronBlock -> AMempoolPayload ByteString)
-> GenTx ByronBlock
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx ByronBlock -> AMempoolPayload ByteString
toMempoolPayload

  txForgetValidated :: Validated (GenTx ByronBlock) -> GenTx ByronBlock
txForgetValidated = Validated (GenTx ByronBlock) -> GenTx ByronBlock
forgetValidatedByronTx

data instance TxId (GenTx ByronBlock)
  = ByronTxId             !Utxo.TxId
  | ByronDlgId            !Delegation.CertificateId
  | ByronUpdateProposalId !Update.UpId
  | ByronUpdateVoteId     !Update.VoteId
  deriving (TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
(TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool)
-> (TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool)
-> Eq (TxId (GenTx ByronBlock))
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
$c/= :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
== :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
$c== :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
Eq, Eq (TxId (GenTx ByronBlock))
Eq (TxId (GenTx ByronBlock))
-> (TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Ordering)
-> (TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool)
-> (TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool)
-> (TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool)
-> (TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool)
-> (TxId (GenTx ByronBlock)
    -> TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock))
-> (TxId (GenTx ByronBlock)
    -> TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock))
-> Ord (TxId (GenTx ByronBlock))
TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Ordering
TxId (GenTx ByronBlock)
-> TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TxId (GenTx ByronBlock)
-> TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock)
$cmin :: TxId (GenTx ByronBlock)
-> TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock)
max :: TxId (GenTx ByronBlock)
-> TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock)
$cmax :: TxId (GenTx ByronBlock)
-> TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock)
>= :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
$c>= :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
> :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
$c> :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
<= :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
$c<= :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
< :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
$c< :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Bool
compare :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Ordering
$ccompare :: TxId (GenTx ByronBlock) -> TxId (GenTx ByronBlock) -> Ordering
$cp1Ord :: Eq (TxId (GenTx ByronBlock))
Ord)
  deriving Context -> TxId (GenTx ByronBlock) -> IO (Maybe ThunkInfo)
Proxy (TxId (GenTx ByronBlock)) -> String
(Context -> TxId (GenTx ByronBlock) -> IO (Maybe ThunkInfo))
-> (Context -> TxId (GenTx ByronBlock) -> IO (Maybe ThunkInfo))
-> (Proxy (TxId (GenTx ByronBlock)) -> String)
-> NoThunks (TxId (GenTx ByronBlock))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (TxId (GenTx ByronBlock)) -> String
$cshowTypeOf :: Proxy (TxId (GenTx ByronBlock)) -> String
wNoThunks :: Context -> TxId (GenTx ByronBlock) -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TxId (GenTx ByronBlock) -> IO (Maybe ThunkInfo)
noThunks :: Context -> TxId (GenTx ByronBlock) -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> TxId (GenTx ByronBlock) -> IO (Maybe ThunkInfo)
NoThunks via InspectHeapNamed "TxId (GenTx ByronBlock)" (TxId (GenTx ByronBlock))

instance ShowProxy (TxId (GenTx ByronBlock)) where

instance HasTxId (GenTx ByronBlock) where
  txId :: GenTx ByronBlock -> TxId (GenTx ByronBlock)
txId (ByronTx             i _) = TxId -> TxId (GenTx ByronBlock)
ByronTxId             TxId
i
  txId (ByronDlg            i _) = CertificateId -> TxId (GenTx ByronBlock)
ByronDlgId            CertificateId
i
  txId (ByronUpdateProposal i _) = UpId -> TxId (GenTx ByronBlock)
ByronUpdateProposalId UpId
i
  txId (ByronUpdateVote     i _) = VoteId -> TxId (GenTx ByronBlock)
ByronUpdateVoteId     VoteId
i

instance HasTxs ByronBlock where
  extractTxs :: ByronBlock -> [GenTx ByronBlock]
extractTxs ByronBlock
blk = case ByronBlock -> ABlockOrBoundary ByteString
byronBlockRaw ByronBlock
blk of
    -- EBBs don't contain transactions
    CC.ABOBBoundary ABoundaryBlock ByteString
_ebb    -> []
    CC.ABOBBlock ABlock ByteString
regularBlk -> AMempoolPayload ByteString -> GenTx ByronBlock
fromMempoolPayload (AMempoolPayload ByteString -> GenTx ByronBlock)
-> [AMempoolPayload ByteString] -> [GenTx ByronBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Maybe (AMempoolPayload ByteString) -> [AMempoolPayload ByteString]
forall a. Maybe a -> [a]
maybeToList Maybe (AMempoolPayload ByteString)
proposal [AMempoolPayload ByteString]
-> [AMempoolPayload ByteString] -> [AMempoolPayload ByteString]
forall a. Semigroup a => a -> a -> a
<> [AMempoolPayload ByteString]
votes [AMempoolPayload ByteString]
-> [AMempoolPayload ByteString] -> [AMempoolPayload ByteString]
forall a. Semigroup a => a -> a -> a
<> [AMempoolPayload ByteString]
dlgs [AMempoolPayload ByteString]
-> [AMempoolPayload ByteString] -> [AMempoolPayload ByteString]
forall a. Semigroup a => a -> a -> a
<> [AMempoolPayload ByteString]
txs
      where
        body :: ABody ByteString
body = ABlock ByteString -> ABody ByteString
forall a. ABlock a -> ABody a
CC.blockBody ABlock ByteString
regularBlk

        txs :: [AMempoolPayload ByteString]
txs      = ATxAux ByteString -> AMempoolPayload ByteString
forall a. ATxAux a -> AMempoolPayload a
CC.MempoolTx             (ATxAux ByteString -> AMempoolPayload ByteString)
-> [ATxAux ByteString] -> [AMempoolPayload ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ATxPayload ByteString -> [ATxAux ByteString]
forall a. ATxPayload a -> [ATxAux a]
Utxo.aUnTxPayload      (ABody ByteString -> ATxPayload ByteString
forall a. ABody a -> ATxPayload a
CC.bodyTxPayload     ABody ByteString
body)
        proposal :: Maybe (AMempoolPayload ByteString)
proposal = AProposal ByteString -> AMempoolPayload ByteString
forall a. AProposal a -> AMempoolPayload a
CC.MempoolUpdateProposal (AProposal ByteString -> AMempoolPayload ByteString)
-> Maybe (AProposal ByteString)
-> Maybe (AMempoolPayload ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> APayload ByteString -> Maybe (AProposal ByteString)
forall a. APayload a -> Maybe (AProposal a)
Update.payloadProposal (ABody ByteString -> APayload ByteString
forall a. ABody a -> APayload a
CC.bodyUpdatePayload ABody ByteString
body)
        votes :: [AMempoolPayload ByteString]
votes    = AVote ByteString -> AMempoolPayload ByteString
forall a. AVote a -> AMempoolPayload a
CC.MempoolUpdateVote     (AVote ByteString -> AMempoolPayload ByteString)
-> [AVote ByteString] -> [AMempoolPayload ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> APayload ByteString -> [AVote ByteString]
forall a. APayload a -> [AVote a]
Update.payloadVotes    (ABody ByteString -> APayload ByteString
forall a. ABody a -> APayload a
CC.bodyUpdatePayload ABody ByteString
body)
        dlgs :: [AMempoolPayload ByteString]
dlgs     = ACertificate ByteString -> AMempoolPayload ByteString
forall a. ACertificate a -> AMempoolPayload a
CC.MempoolDlg            (ACertificate ByteString -> AMempoolPayload ByteString)
-> [ACertificate ByteString] -> [AMempoolPayload ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> APayload ByteString -> [ACertificate ByteString]
forall a. APayload a -> [ACertificate a]
Delegation.getPayload  (ABody ByteString -> APayload ByteString
forall a. ABody a -> APayload a
CC.bodyDlgPayload    ABody ByteString
body)

{-------------------------------------------------------------------------------
  Conversion to and from 'AMempoolPayload'
-------------------------------------------------------------------------------}

toMempoolPayload :: GenTx ByronBlock -> CC.AMempoolPayload ByteString
toMempoolPayload :: GenTx ByronBlock -> AMempoolPayload ByteString
toMempoolPayload = GenTx ByronBlock -> AMempoolPayload ByteString
go
  where
    -- Just extract the payload @p@
    go :: GenTx ByronBlock -> CC.AMempoolPayload ByteString
    go :: GenTx ByronBlock -> AMempoolPayload ByteString
go (ByronTx             _ p) = ATxAux ByteString -> AMempoolPayload ByteString
forall a. ATxAux a -> AMempoolPayload a
CC.MempoolTx             ATxAux ByteString
p
    go (ByronDlg            _ p) = ACertificate ByteString -> AMempoolPayload ByteString
forall a. ACertificate a -> AMempoolPayload a
CC.MempoolDlg            ACertificate ByteString
p
    go (ByronUpdateProposal _ p) = AProposal ByteString -> AMempoolPayload ByteString
forall a. AProposal a -> AMempoolPayload a
CC.MempoolUpdateProposal AProposal ByteString
p
    go (ByronUpdateVote     _ p) = AVote ByteString -> AMempoolPayload ByteString
forall a. AVote a -> AMempoolPayload a
CC.MempoolUpdateVote     AVote ByteString
p

fromMempoolPayload :: CC.AMempoolPayload ByteString -> GenTx ByronBlock
fromMempoolPayload :: AMempoolPayload ByteString -> GenTx ByronBlock
fromMempoolPayload = AMempoolPayload ByteString -> GenTx ByronBlock
go
  where
    -- Bundle the payload @p@ with its ID
    go :: CC.AMempoolPayload ByteString -> GenTx ByronBlock
    go :: AMempoolPayload ByteString -> GenTx ByronBlock
go (CC.MempoolTx             ATxAux ByteString
p) = TxId -> ATxAux ByteString -> GenTx ByronBlock
ByronTx             (ATxAux ByteString -> TxId
byronIdTx   ATxAux ByteString
p) ATxAux ByteString
p
    go (CC.MempoolDlg            ACertificate ByteString
p) = CertificateId -> ACertificate ByteString -> GenTx ByronBlock
ByronDlg            (ACertificate ByteString -> CertificateId
byronIdDlg  ACertificate ByteString
p) ACertificate ByteString
p
    go (CC.MempoolUpdateProposal AProposal ByteString
p) = UpId -> AProposal ByteString -> GenTx ByronBlock
ByronUpdateProposal (AProposal ByteString -> UpId
byronIdProp AProposal ByteString
p) AProposal ByteString
p
    go (CC.MempoolUpdateVote     AVote ByteString
p) = VoteId -> AVote ByteString -> GenTx ByronBlock
ByronUpdateVote     (AVote ByteString -> VoteId
byronIdVote AVote ByteString
p) AVote ByteString
p

{-------------------------------------------------------------------------------
  Auxiliary: transaction IDs
-------------------------------------------------------------------------------}

-- TODO: move to cardano-ledger-byron (cardano-ledger-byron#581)
byronIdTx :: Utxo.ATxAux ByteString -> Utxo.TxId
byronIdTx :: ATxAux ByteString -> TxId
byronIdTx = Annotated Tx ByteString -> TxId
forall t. Decoded t => t -> Hash (BaseType t)
hashDecoded (Annotated Tx ByteString -> TxId)
-> (ATxAux ByteString -> Annotated Tx ByteString)
-> ATxAux ByteString
-> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ATxAux ByteString -> Annotated Tx ByteString
forall a. ATxAux a -> Annotated Tx a
Utxo.aTaTx

byronIdDlg :: Delegation.ACertificate ByteString -> Delegation.CertificateId
byronIdDlg :: ACertificate ByteString -> CertificateId
byronIdDlg = ACertificate ByteString -> CertificateId
Delegation.recoverCertificateId

byronIdProp :: Update.AProposal ByteString -> Update.UpId
byronIdProp :: AProposal ByteString -> UpId
byronIdProp = AProposal ByteString -> UpId
Update.recoverUpId

byronIdVote :: Update.AVote ByteString -> Update.VoteId
byronIdVote :: AVote ByteString -> VoteId
byronIdVote = AVote ByteString -> VoteId
Update.recoverVoteId

{-------------------------------------------------------------------------------
  Pretty-printing
-------------------------------------------------------------------------------}

instance Condense (GenTx ByronBlock) where
  condense :: GenTx ByronBlock -> String
condense = AMempoolPayload ByteString -> String
forall a. Condense a => a -> String
condense (AMempoolPayload ByteString -> String)
-> (GenTx ByronBlock -> AMempoolPayload ByteString)
-> GenTx ByronBlock
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx ByronBlock -> AMempoolPayload ByteString
toMempoolPayload

instance Condense (GenTxId ByronBlock) where
  condense :: TxId (GenTx ByronBlock) -> String
condense (ByronTxId             i) = TxId -> String
forall a. Condense a => a -> String
condense TxId
i
  condense (ByronDlgId            i) = CertificateId -> String
forall a. Condense a => a -> String
condense CertificateId
i
  condense (ByronUpdateProposalId i) = UpId -> String
forall a. Condense a => a -> String
condense UpId
i
  condense (ByronUpdateVoteId     i) = VoteId -> String
forall a. Condense a => a -> String
condense VoteId
i

instance Show (GenTx ByronBlock) where
  show :: GenTx ByronBlock -> String
show = GenTx ByronBlock -> String
forall a. Condense a => a -> String
condense

instance Show (Validated (GenTx ByronBlock)) where
  show :: Validated (GenTx ByronBlock) -> String
show Validated (GenTx ByronBlock)
vtx = String
"Validated-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> GenTx ByronBlock -> String
forall a. Condense a => a -> String
condense (Validated (GenTx ByronBlock) -> GenTx ByronBlock
forgetValidatedByronTx Validated (GenTx ByronBlock)
vtx)

instance Show (GenTxId ByronBlock) where
  show :: TxId (GenTx ByronBlock) -> String
show = TxId (GenTx ByronBlock) -> String
forall a. Condense a => a -> String
condense

{-------------------------------------------------------------------------------
  Applying transactions
-------------------------------------------------------------------------------}

applyByronGenTx :: CC.ValidationMode
                -> LedgerConfig ByronBlock
                -> SlotNo
                -> GenTx ByronBlock
                -> TickedLedgerState ByronBlock
                -> Except (ApplyTxErr ByronBlock) (TickedLedgerState ByronBlock)
applyByronGenTx :: ValidationMode
-> LedgerConfig ByronBlock
-> SlotNo
-> GenTx ByronBlock
-> Ticked (LedgerState ByronBlock)
-> Except (ApplyTxErr ByronBlock) (Ticked (LedgerState ByronBlock))
applyByronGenTx ValidationMode
validationMode LedgerConfig ByronBlock
cfg SlotNo
slot GenTx ByronBlock
genTx Ticked (LedgerState ByronBlock)
st =
    (\ChainValidationState
state -> Ticked (LedgerState ByronBlock)
R:TickedLedgerState
st {tickedByronLedgerState :: ChainValidationState
tickedByronLedgerState = ChainValidationState
state}) (ChainValidationState -> Ticked (LedgerState ByronBlock))
-> ExceptT ApplyMempoolPayloadErr Identity ChainValidationState
-> ExceptT
     ApplyMempoolPayloadErr Identity (Ticked (LedgerState ByronBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      ValidationMode
-> Config
-> SlotNumber
-> AMempoolPayload ByteString
-> ChainValidationState
-> ExceptT ApplyMempoolPayloadErr Identity ChainValidationState
forall (m :: * -> *).
MonadError ApplyMempoolPayloadErr m =>
ValidationMode
-> Config
-> SlotNumber
-> AMempoolPayload ByteString
-> ChainValidationState
-> m ChainValidationState
CC.applyMempoolPayload
        ValidationMode
validationMode
        LedgerConfig ByronBlock
Config
cfg
        (SlotNo -> SlotNumber
toByronSlotNo SlotNo
slot)
        (GenTx ByronBlock -> AMempoolPayload ByteString
toMempoolPayload GenTx ByronBlock
genTx)
        (Ticked (LedgerState ByronBlock) -> ChainValidationState
tickedByronLedgerState Ticked (LedgerState ByronBlock)
st)

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

encodeByronGenTx :: GenTx ByronBlock -> Encoding
encodeByronGenTx :: GenTx ByronBlock -> Encoding
encodeByronGenTx GenTx ByronBlock
genTx = AMempoolPayload ByteString -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (GenTx ByronBlock -> AMempoolPayload ByteString
toMempoolPayload GenTx ByronBlock
genTx)

-- | The 'ByteString' annotation will be the canonical encoding.
--
-- While the new implementation does not care about canonical encodings, the
-- old one does. When a generalised transaction arrives that is not in its
-- canonical encoding (only the 'CC.UTxO.ATxAux' of the 'ByronTx' can be
-- produced by nodes that are not under our control), the old implementation
-- will reject it. Therefore, we need to reject them too. See #905.
--
-- We use the ledger to check for canonical encodings: the ledger will check
-- whether the signed hash of the transaction (in the case of a
-- 'CC.UTxO.ATxAux', the transaction witness) matches the annotated
-- bytestring. Is therefore __important__ that the annotated bytestring be the
-- /canonical/ encoding, not the /original, possibly non-canonical/ encoding.
decodeByronGenTx :: Decoder s (GenTx ByronBlock)
decodeByronGenTx :: Decoder s (GenTx ByronBlock)
decodeByronGenTx = AMempoolPayload ByteString -> GenTx ByronBlock
fromMempoolPayload (AMempoolPayload ByteString -> GenTx ByronBlock)
-> (AMempoolPayload ByteSpan -> AMempoolPayload ByteString)
-> AMempoolPayload ByteSpan
-> GenTx ByronBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AMempoolPayload ByteSpan -> AMempoolPayload ByteString
canonicalise (AMempoolPayload ByteSpan -> GenTx ByronBlock)
-> Decoder s (AMempoolPayload ByteSpan)
-> Decoder s (GenTx ByronBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (AMempoolPayload ByteSpan)
forall a s. FromCBOR a => Decoder s a
fromCBOR
  where
    -- Fill in the 'ByteString' annotation with a canonical encoding of the
    -- 'GenTx'. We must reserialise the deserialised 'GenTx' to be sure we
    -- have the canonical one. We don't have access to the original
    -- 'ByteString' anyway, so having to reserialise here gives us a
    -- 'ByteString' we can use.
    canonicalise :: CC.AMempoolPayload ByteSpan
                 -> CC.AMempoolPayload ByteString
    canonicalise :: AMempoolPayload ByteSpan -> AMempoolPayload ByteString
canonicalise AMempoolPayload ByteSpan
mp = ByteString -> ByteString
Lazy.toStrict (ByteString -> ByteString)
-> (ByteSpan -> ByteString) -> ByteSpan -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteSpan -> ByteString
slice ByteString
canonicalBytes (ByteSpan -> ByteString)
-> AMempoolPayload ByteSpan -> AMempoolPayload ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AMempoolPayload ByteSpan
mp'
      where
        canonicalBytes :: ByteString
canonicalBytes = AMempoolPayload () -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize (AMempoolPayload ByteSpan -> AMempoolPayload ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void AMempoolPayload ByteSpan
mp)
        -- 'unsafeDeserialize' cannot fail, since we just 'serialize'd it.
        -- Note that we cannot reuse @mp@, as its 'ByteSpan' might differ from
        -- the canonical encoding's 'ByteSpan'.
        mp' :: AMempoolPayload ByteSpan
mp'            = ByteString -> AMempoolPayload ByteSpan
forall a. FromCBOR a => ByteString -> a
unsafeDeserialize ByteString
canonicalBytes

encodeByronGenTxId :: GenTxId ByronBlock -> Encoding
encodeByronGenTxId :: TxId (GenTx ByronBlock) -> Encoding
encodeByronGenTxId TxId (GenTx ByronBlock)
genTxId = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
CBOR.encodeListLen Word
2
    , case TxId (GenTx ByronBlock)
genTxId of
        ByronTxId             i -> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
0 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> TxId -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR TxId
i
        ByronDlgId            i -> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
1 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CertificateId -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR CertificateId
i
        ByronUpdateProposalId i -> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
2 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UpId -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR UpId
i
        ByronUpdateVoteId     i -> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
3 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> VoteId -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR VoteId
i
    ]

decodeByronGenTxId :: Decoder s (GenTxId ByronBlock)
decodeByronGenTxId :: Decoder s (TxId (GenTx ByronBlock))
decodeByronGenTxId = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"GenTxId (ByronBlock cfg)" Int
2
    Decoder s Word8
forall s. Decoder s Word8
CBOR.decodeWord8 Decoder s Word8
-> (Word8 -> Decoder s (TxId (GenTx ByronBlock)))
-> Decoder s (TxId (GenTx ByronBlock))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Word8
0   -> TxId -> TxId (GenTx ByronBlock)
ByronTxId             (TxId -> TxId (GenTx ByronBlock))
-> Decoder s TxId -> Decoder s (TxId (GenTx ByronBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s TxId
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
1   -> CertificateId -> TxId (GenTx ByronBlock)
ByronDlgId            (CertificateId -> TxId (GenTx ByronBlock))
-> Decoder s CertificateId -> Decoder s (TxId (GenTx ByronBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s CertificateId
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
2   -> UpId -> TxId (GenTx ByronBlock)
ByronUpdateProposalId (UpId -> TxId (GenTx ByronBlock))
-> Decoder s UpId -> Decoder s (TxId (GenTx ByronBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s UpId
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
3   -> VoteId -> TxId (GenTx ByronBlock)
ByronUpdateVoteId     (VoteId -> TxId (GenTx ByronBlock))
-> Decoder s VoteId -> Decoder s (TxId (GenTx ByronBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s VoteId
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
tag -> DecoderError -> Decoder s (TxId (GenTx ByronBlock))
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Decoder s (TxId (GenTx ByronBlock)))
-> DecoderError -> Decoder s (TxId (GenTx ByronBlock))
forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"GenTxId (ByronBlock cfg)" Word8
tag

encodeByronApplyTxError :: ApplyTxErr ByronBlock -> Encoding
encodeByronApplyTxError :: ApplyTxErr ByronBlock -> Encoding
encodeByronApplyTxError = ApplyTxErr ByronBlock -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR

decodeByronApplyTxError :: Decoder s (ApplyTxErr ByronBlock)
decodeByronApplyTxError :: Decoder s (ApplyTxErr ByronBlock)
decodeByronApplyTxError = Decoder s (ApplyTxErr ByronBlock)
forall a s. FromCBOR a => Decoder s a
fromCBOR

{-------------------------------------------------------------------------------
  Auxiliary functions
-------------------------------------------------------------------------------}

-- | Count all (generalized) transactions in the block
countByronGenTxs :: ByronBlock -> Word64
countByronGenTxs :: ByronBlock -> Word64
countByronGenTxs = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> (ByronBlock -> Int) -> ByronBlock -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenTx ByronBlock] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([GenTx ByronBlock] -> Int)
-> (ByronBlock -> [GenTx ByronBlock]) -> ByronBlock -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByronBlock -> [GenTx ByronBlock]
forall blk. HasTxs blk => blk -> [GenTx blk]
extractTxs