{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_HADDOCK not-home #-}

-- | Provides BlockBody internals
--
-- = Warning
--
-- This module is considered __internal__.
--
-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
module Cardano.Ledger.Alonzo.BlockBody.Internal (
  AlonzoBlockBody (AlonzoBlockBody, ..),
  hashAlonzoSegWits,
  alignedValidFlags,
  mkBasicBlockBodyAlonzo,
  txSeqBlockBodyAlonzoL,
) where

import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.Alonzo.Era
import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), IsValid (..))
import Cardano.Ledger.Binary (
  Annotator (..),
  DecCBOR (..),
  EncCBORGroup (..),
  encCBOR,
  encodeFoldableEncoder,
  encodeFoldableMapEncoder,
  encodePreEncoded,
  serialize,
  withSlice,
 )
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.BlockBody (auxDataSeqDecoder)
import Control.Monad (unless)
import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder, shortByteString, toLazyByteString)
import qualified Data.ByteString.Lazy as BSL
import Data.Coerce (coerce)
import Data.Maybe.Strict (maybeToStrictMaybe, strictMaybeToMaybe)
import qualified Data.Sequence as Seq
import Data.Sequence.Strict (StrictSeq)
import qualified Data.Sequence.Strict as StrictSeq
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Lens.Micro
import Lens.Micro.Extras (view)
import NoThunks.Class (AllowThunksIn (..), NoThunks)

-- =================================================

-- $BlockBody
--
-- * BlockBody
--
-- BlockBody provides an alternate way of formatting transactions in a block, in
-- order to support segregated witnessing.

data AlonzoBlockBody era = AlonzoBlockBodyInternal
  { forall era. AlonzoBlockBody era -> StrictSeq (Tx TopTx era)
abbTxs :: !(StrictSeq (Tx TopTx era))
  , forall era.
AlonzoBlockBody era -> Hash HASH EraIndependentBlockBody
abbHash :: Hash.Hash HASH EraIndependentBlockBody
  -- ^ Memoized hash to avoid recomputation. Lazy on purpose.
  , forall era. AlonzoBlockBody era -> ByteString
abbTxsBodyBytes :: BSL.ByteString
  -- ^ Bytes encoding @Seq ('TxBody' era)@
  , forall era. AlonzoBlockBody era -> ByteString
abbTxsWitsBytes :: BSL.ByteString
  -- ^ Bytes encoding @Seq ('TxWits' era)@
  , forall era. AlonzoBlockBody era -> ByteString
abbTxsAuxDataBytes :: BSL.ByteString
  -- ^ Bytes encoding a @'TxAuxData')@. Missing indices have
  -- 'SNothing' for metadata
  , forall era. AlonzoBlockBody era -> ByteString
abbTxsIsValidBytes :: BSL.ByteString
  -- ^ Bytes representing a set of integers. These are the indices of
  -- transactions with 'isValid' == False.
  }
  deriving ((forall x. AlonzoBlockBody era -> Rep (AlonzoBlockBody era) x)
-> (forall x. Rep (AlonzoBlockBody era) x -> AlonzoBlockBody era)
-> Generic (AlonzoBlockBody era)
forall x. Rep (AlonzoBlockBody era) x -> AlonzoBlockBody era
forall x. AlonzoBlockBody era -> Rep (AlonzoBlockBody era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (AlonzoBlockBody era) x -> AlonzoBlockBody era
forall era x. AlonzoBlockBody era -> Rep (AlonzoBlockBody era) x
$cfrom :: forall era x. AlonzoBlockBody era -> Rep (AlonzoBlockBody era) x
from :: forall x. AlonzoBlockBody era -> Rep (AlonzoBlockBody era) x
$cto :: forall era x. Rep (AlonzoBlockBody era) x -> AlonzoBlockBody era
to :: forall x. Rep (AlonzoBlockBody era) x -> AlonzoBlockBody era
Generic)

instance EraBlockBody AlonzoEra where
  type BlockBody AlonzoEra = AlonzoBlockBody AlonzoEra
  mkBasicBlockBody :: BlockBody AlonzoEra
mkBasicBlockBody = BlockBody AlonzoEra
forall era.
(SafeToHash (TxWits era), BlockBody era ~ AlonzoBlockBody era,
 AlonzoEraTx era) =>
BlockBody era
mkBasicBlockBodyAlonzo
  txSeqBlockBodyL :: Lens' (BlockBody AlonzoEra) (StrictSeq (Tx TopTx AlonzoEra))
txSeqBlockBodyL = (StrictSeq (Tx TopTx AlonzoEra)
 -> f (StrictSeq (Tx TopTx AlonzoEra)))
-> BlockBody AlonzoEra -> f (BlockBody AlonzoEra)
forall era.
(SafeToHash (TxWits era), BlockBody era ~ AlonzoBlockBody era,
 AlonzoEraTx era) =>
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
Lens' (BlockBody AlonzoEra) (StrictSeq (Tx TopTx AlonzoEra))
txSeqBlockBodyAlonzoL
  hashBlockBody :: BlockBody AlonzoEra -> Hash HASH EraIndependentBlockBody
hashBlockBody = BlockBody AlonzoEra -> Hash HASH EraIndependentBlockBody
AlonzoBlockBody AlonzoEra -> Hash HASH EraIndependentBlockBody
forall era.
AlonzoBlockBody era -> Hash HASH EraIndependentBlockBody
abbHash
  numSegComponents :: Word64
numSegComponents = Word64
4

mkBasicBlockBodyAlonzo ::
  ( SafeToHash (TxWits era)
  , BlockBody era ~ AlonzoBlockBody era
  , AlonzoEraTx era
  ) =>
  BlockBody era
mkBasicBlockBodyAlonzo :: forall era.
(SafeToHash (TxWits era), BlockBody era ~ AlonzoBlockBody era,
 AlonzoEraTx era) =>
BlockBody era
mkBasicBlockBodyAlonzo = StrictSeq (Tx TopTx era) -> AlonzoBlockBody era
forall era.
(AlonzoEraTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx TopTx era) -> AlonzoBlockBody era
AlonzoBlockBody StrictSeq (Tx TopTx era)
forall a. Monoid a => a
mempty
{-# INLINEABLE mkBasicBlockBodyAlonzo #-}

txSeqBlockBodyAlonzoL ::
  ( SafeToHash (TxWits era)
  , BlockBody era ~ AlonzoBlockBody era
  , AlonzoEraTx era
  ) =>
  Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
txSeqBlockBodyAlonzoL :: forall era.
(SafeToHash (TxWits era), BlockBody era ~ AlonzoBlockBody era,
 AlonzoEraTx era) =>
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
txSeqBlockBodyAlonzoL = (AlonzoBlockBody era -> StrictSeq (Tx TopTx era))
-> (AlonzoBlockBody era
    -> StrictSeq (Tx TopTx era) -> AlonzoBlockBody era)
-> Lens
     (AlonzoBlockBody era)
     (AlonzoBlockBody era)
     (StrictSeq (Tx TopTx era))
     (StrictSeq (Tx TopTx era))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens AlonzoBlockBody era -> StrictSeq (Tx TopTx era)
forall era. AlonzoBlockBody era -> StrictSeq (Tx TopTx era)
abbTxs (\AlonzoBlockBody era
_ StrictSeq (Tx TopTx era)
s -> StrictSeq (Tx TopTx era) -> AlonzoBlockBody era
forall era.
(AlonzoEraTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx TopTx era) -> AlonzoBlockBody era
AlonzoBlockBody StrictSeq (Tx TopTx era)
s)
{-# INLINEABLE txSeqBlockBodyAlonzoL #-}

pattern AlonzoBlockBody ::
  forall era.
  ( AlonzoEraTx era
  , SafeToHash (TxWits era)
  ) =>
  StrictSeq (Tx TopTx era) ->
  AlonzoBlockBody era
pattern $mAlonzoBlockBody :: forall {r} {era}.
(AlonzoEraTx era, SafeToHash (TxWits era)) =>
AlonzoBlockBody era
-> (StrictSeq (Tx TopTx era) -> r) -> ((# #) -> r) -> r
$bAlonzoBlockBody :: forall era.
(AlonzoEraTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx TopTx era) -> AlonzoBlockBody era
AlonzoBlockBody xs <-
  AlonzoBlockBodyInternal xs _ _ _ _ _
  where
    AlonzoBlockBody StrictSeq (Tx TopTx era)
txns =
      let version :: Version
version = forall era. Era era => Version
eraProtVerLow @era
          serializeFoldablePreEncoded :: StrictSeq ByteString -> ByteString
serializeFoldablePreEncoded StrictSeq ByteString
x =
            Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$
              (ByteString -> Encoding) -> StrictSeq ByteString -> Encoding
forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableEncoder ByteString -> Encoding
encodePreEncoded StrictSeq ByteString
x
          metaChunk :: a -> StrictMaybe ByteString -> Maybe Encoding
metaChunk a
index StrictMaybe ByteString
m = ByteString -> Encoding
encodeIndexed (ByteString -> Encoding) -> Maybe ByteString -> Maybe Encoding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe ByteString -> Maybe ByteString
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe StrictMaybe ByteString
m
            where
              encodeIndexed :: ByteString -> Encoding
encodeIndexed ByteString
metadata = a -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR a
index Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
encodePreEncoded ByteString
metadata
          txSeqBodies :: ByteString
txSeqBodies =
            StrictSeq ByteString -> ByteString
serializeFoldablePreEncoded (StrictSeq ByteString -> ByteString)
-> StrictSeq ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ TxBody TopTx era -> ByteString
forall t. SafeToHash t => t -> ByteString
originalBytes (TxBody TopTx era -> ByteString)
-> (Tx TopTx era -> TxBody TopTx era) -> Tx TopTx era -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> Tx TopTx era -> TxBody TopTx era
forall a s. Getting a s a -> s -> a
view Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL (Tx TopTx era -> ByteString)
-> StrictSeq (Tx TopTx era) -> StrictSeq ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (Tx TopTx era)
txns
          txSeqWits :: ByteString
txSeqWits =
            StrictSeq ByteString -> ByteString
serializeFoldablePreEncoded (StrictSeq ByteString -> ByteString)
-> StrictSeq ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ TxWits era -> ByteString
forall t. SafeToHash t => t -> ByteString
originalBytes (TxWits era -> ByteString)
-> (Tx TopTx era -> TxWits era) -> Tx TopTx era -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (TxWits era) (Tx TopTx era) (TxWits era)
-> Tx TopTx era -> TxWits era
forall a s. Getting a s a -> s -> a
view Getting (TxWits era) (Tx TopTx era) (TxWits era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL (Tx TopTx era -> ByteString)
-> StrictSeq (Tx TopTx era) -> StrictSeq ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (Tx TopTx era)
txns
          txSeqAuxDatas :: ByteString
txSeqAuxDatas =
            Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version (Encoding -> ByteString)
-> (StrictSeq (StrictMaybe ByteString) -> Encoding)
-> StrictSeq (StrictMaybe ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word -> StrictMaybe ByteString -> Maybe Encoding)
-> StrictSeq (StrictMaybe ByteString) -> Encoding
forall (f :: * -> *) a.
Foldable f =>
(Word -> a -> Maybe Encoding) -> f a -> Encoding
encodeFoldableMapEncoder Word -> StrictMaybe ByteString -> Maybe Encoding
forall {a}.
EncCBOR a =>
a -> StrictMaybe ByteString -> Maybe Encoding
metaChunk (StrictSeq (StrictMaybe ByteString) -> ByteString)
-> StrictSeq (StrictMaybe ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$
              (TxAuxData era -> ByteString)
-> StrictMaybe (TxAuxData era) -> StrictMaybe ByteString
forall a b. (a -> b) -> StrictMaybe a -> StrictMaybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxAuxData era -> ByteString
forall t. SafeToHash t => t -> ByteString
originalBytes (StrictMaybe (TxAuxData era) -> StrictMaybe ByteString)
-> (Tx TopTx era -> StrictMaybe (TxAuxData era))
-> Tx TopTx era
-> StrictMaybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (StrictMaybe (TxAuxData era))
  (Tx TopTx era)
  (StrictMaybe (TxAuxData era))
-> Tx TopTx era -> StrictMaybe (TxAuxData era)
forall a s. Getting a s a -> s -> a
view Getting
  (StrictMaybe (TxAuxData era))
  (Tx TopTx era)
  (StrictMaybe (TxAuxData era))
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
auxDataTxL (Tx TopTx era -> StrictMaybe ByteString)
-> StrictSeq (Tx TopTx era) -> StrictSeq (StrictMaybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (Tx TopTx era)
txns
          txSeqIsValids :: ByteString
txSeqIsValids =
            Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ [Int] -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ([Int] -> Encoding) -> [Int] -> Encoding
forall a b. (a -> b) -> a -> b
$ StrictSeq (Tx TopTx era) -> [Int]
forall era. AlonzoEraTx era => StrictSeq (Tx TopTx era) -> [Int]
nonValidatingIndices StrictSeq (Tx TopTx era)
txns
       in AlonzoBlockBodyInternal
            { abbTxs :: StrictSeq (Tx TopTx era)
abbTxs = StrictSeq (Tx TopTx era)
txns
            , abbHash :: Hash HASH EraIndependentBlockBody
abbHash = ByteString
-> ByteString
-> ByteString
-> ByteString
-> Hash HASH EraIndependentBlockBody
hashAlonzoSegWits ByteString
txSeqBodies ByteString
txSeqWits ByteString
txSeqAuxDatas ByteString
txSeqIsValids
            , abbTxsBodyBytes :: ByteString
abbTxsBodyBytes = ByteString
txSeqBodies
            , abbTxsWitsBytes :: ByteString
abbTxsWitsBytes = ByteString
txSeqWits
            , abbTxsAuxDataBytes :: ByteString
abbTxsAuxDataBytes = ByteString
txSeqAuxDatas
            , abbTxsIsValidBytes :: ByteString
abbTxsIsValidBytes = ByteString
txSeqIsValids
            }

{-# COMPLETE AlonzoBlockBody #-}

deriving via
  AllowThunksIn
    '[ "abbHash"
     , "abbTxsBodyBytes"
     , "abbTxsWitsBytes"
     , "abbTxsAuxDataBytes"
     , "abbTxsIsValidBytes"
     ]
    (AlonzoBlockBody era)
  instance
    (Typeable era, NoThunks (Tx TopTx era)) => NoThunks (AlonzoBlockBody era)

deriving stock instance Show (Tx TopTx era) => Show (AlonzoBlockBody era)

deriving stock instance Eq (Tx TopTx era) => Eq (AlonzoBlockBody era)

--------------------------------------------------------------------------------
-- Serialisation and hashing
--------------------------------------------------------------------------------

instance Era era => EncCBORGroup (AlonzoBlockBody era) where
  encCBORGroup :: AlonzoBlockBody era -> Encoding
encCBORGroup (AlonzoBlockBodyInternal StrictSeq (Tx TopTx era)
_ Hash HASH EraIndependentBlockBody
_ ByteString
bodyBytes ByteString
witsBytes ByteString
metadataBytes ByteString
invalidBytes) =
    ByteString -> Encoding
encodePreEncoded (ByteString -> Encoding) -> ByteString -> Encoding
forall a b. (a -> b) -> a -> b
$
      ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
        ByteString
bodyBytes ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
witsBytes ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
metadataBytes ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
invalidBytes
  listLen :: AlonzoBlockBody era -> Word
listLen AlonzoBlockBody era
_ = Word
4
  listLenBound :: Proxy (AlonzoBlockBody era) -> Word
listLenBound Proxy (AlonzoBlockBody era)
_ = Word
4

hashAlonzoSegWits ::
  BSL.ByteString ->
  -- | Bytes for transaction bodies
  BSL.ByteString ->
  -- | Bytes for transaction witnesses
  BSL.ByteString ->
  -- | Bytes for transaction auxiliary datas
  BSL.ByteString ->
  -- | Bytes for transaction isValid flags
  Hash HASH EraIndependentBlockBody
hashAlonzoSegWits :: ByteString
-> ByteString
-> ByteString
-> ByteString
-> Hash HASH EraIndependentBlockBody
hashAlonzoSegWits ByteString
txSeqBodies ByteString
txSeqWits ByteString
txAuxData ByteString
txSeqIsValids =
  Hash HASH ByteString -> Hash HASH EraIndependentBlockBody
forall a b. Coercible a b => a -> b
coerce (Hash HASH ByteString -> Hash HASH EraIndependentBlockBody)
-> (Builder -> Hash HASH ByteString)
-> Builder
-> Hash HASH EraIndependentBlockBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Hash HASH ByteString
hashLazy (ByteString -> Hash HASH ByteString)
-> (Builder -> ByteString) -> Builder -> Hash HASH ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> Hash HASH EraIndependentBlockBody)
-> Builder -> Hash HASH EraIndependentBlockBody
forall a b. (a -> b) -> a -> b
$
    ByteString -> Builder
hashPart ByteString
txSeqBodies
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
hashPart ByteString
txSeqWits
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
hashPart ByteString
txAuxData
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
hashPart ByteString
txSeqIsValids
  where
    hashLazy :: BSL.ByteString -> Hash HASH ByteString
    hashLazy :: ByteString -> Hash HASH ByteString
hashLazy = (ByteString -> ByteString) -> ByteString -> Hash HASH ByteString
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Hash.hashWith ByteString -> ByteString
forall a. a -> a
id (ByteString -> Hash HASH ByteString)
-> (ByteString -> ByteString) -> ByteString -> Hash HASH ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict
    {-# INLINE hashLazy #-}
    hashPart :: BSL.ByteString -> Builder
    hashPart :: ByteString -> Builder
hashPart = ShortByteString -> Builder
shortByteString (ShortByteString -> Builder)
-> (ByteString -> ShortByteString) -> ByteString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash HASH ByteString -> ShortByteString
forall h a. Hash h a -> ShortByteString
Hash.hashToBytesShort (Hash HASH ByteString -> ShortByteString)
-> (ByteString -> Hash HASH ByteString)
-> ByteString
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Hash HASH ByteString
hashLazy
    {-# INLINE hashPart #-}
{-# INLINE hashAlonzoSegWits #-}

instance
  ( AlonzoEraTx era
  , DecCBOR (Annotator (TxAuxData era))
  , DecCBOR (Annotator (TxBody TopTx era))
  , DecCBOR (Annotator (TxWits era))
  ) =>
  DecCBOR (Annotator (AlonzoBlockBody era))
  where
  decCBOR :: forall s. Decoder s (Annotator (AlonzoBlockBody era))
decCBOR = do
    (bodies, bodiesAnn) <- Decoder s (Seq (Annotator (TxBody TopTx era)))
-> Decoder
     s (Seq (Annotator (TxBody TopTx era)), Annotator ByteString)
forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice Decoder s (Seq (Annotator (TxBody TopTx era)))
forall s. Decoder s (Seq (Annotator (TxBody TopTx era)))
forall a s. DecCBOR a => Decoder s a
decCBOR
    (wits, witsAnn) <- withSlice decCBOR
    let bodiesLength = Seq (Annotator (TxBody TopTx era)) -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (Annotator (TxBody TopTx era))
bodies
        inRange Int
x = (Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x) Bool -> Bool -> Bool
&& (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int
bodiesLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
        witsLength = Seq (Annotator (TxWits era)) -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (Annotator (TxWits era))
wits
    (auxData, auxDataAnn) <- withSlice $ do
      auxDataMap <- decCBOR
      auxDataSeqDecoder bodiesLength auxDataMap

    (isValIdxs, isValAnn) <- withSlice decCBOR
    let validFlags = Int -> [Int] -> Seq IsValid
alignedValidFlags Int
bodiesLength [Int]
isValIdxs
    unless (bodiesLength == witsLength) $
      fail $
        "different number of transaction bodies ("
          <> show bodiesLength
          <> ") and witness sets ("
          <> show witsLength
          <> ")"
    unless (all inRange isValIdxs) $
      fail $
        "Some IsValid index is not in the range: 0 .. "
          ++ show (bodiesLength - 1)
          ++ ", "
          ++ show isValIdxs

    let txns =
          StrictSeq (Annotator (Tx TopTx era))
-> Annotator (StrictSeq (Tx TopTx era))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
StrictSeq (f a) -> f (StrictSeq a)
sequenceA (StrictSeq (Annotator (Tx TopTx era))
 -> Annotator (StrictSeq (Tx TopTx era)))
-> StrictSeq (Annotator (Tx TopTx era))
-> Annotator (StrictSeq (Tx TopTx era))
forall a b. (a -> b) -> a -> b
$
            Seq (Annotator (Tx TopTx era))
-> StrictSeq (Annotator (Tx TopTx era))
forall a. Seq a -> StrictSeq a
StrictSeq.forceToStrict (Seq (Annotator (Tx TopTx era))
 -> StrictSeq (Annotator (Tx TopTx era)))
-> Seq (Annotator (Tx TopTx era))
-> StrictSeq (Annotator (Tx TopTx era))
forall a b. (a -> b) -> a -> b
$
              (Annotator (TxBody TopTx era)
 -> Annotator (TxWits era)
 -> IsValid
 -> Maybe (Annotator (TxAuxData era))
 -> Annotator (Tx TopTx era))
-> Seq (Annotator (TxBody TopTx era))
-> Seq (Annotator (TxWits era))
-> Seq IsValid
-> Seq (Maybe (Annotator (TxAuxData era)))
-> Seq (Annotator (Tx TopTx era))
forall a b c d e.
(a -> b -> c -> d -> e)
-> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
Seq.zipWith4 Annotator (TxBody TopTx era)
-> Annotator (TxWits era)
-> IsValid
-> Maybe (Annotator (TxAuxData era))
-> Annotator (Tx TopTx era)
forall era.
AlonzoEraTx era =>
Annotator (TxBody TopTx era)
-> Annotator (TxWits era)
-> IsValid
-> Maybe (Annotator (TxAuxData era))
-> Annotator (Tx TopTx era)
alonzoSegwitTx Seq (Annotator (TxBody TopTx era))
bodies Seq (Annotator (TxWits era))
wits Seq IsValid
validFlags Seq (Maybe (Annotator (TxAuxData era)))
auxData
    pure $
      AlonzoBlockBodyInternal
        <$> txns
        <*> (hashAlonzoSegWits <$> bodiesAnn <*> witsAnn <*> auxDataAnn <*> isValAnn)
        <*> bodiesAnn
        <*> witsAnn
        <*> auxDataAnn
        <*> isValAnn

--------------------------------------------------------------------------------
-- Internal utility functions
--------------------------------------------------------------------------------

-- | Given a sequence of transactions, return the indices of those which do not
-- validate. We store the indices of the non-validating transactions because we
-- expect this to be a much smaller set than the validating transactions.
nonValidatingIndices :: AlonzoEraTx era => StrictSeq (Tx TopTx era) -> [Int]
nonValidatingIndices :: forall era. AlonzoEraTx era => StrictSeq (Tx TopTx era) -> [Int]
nonValidatingIndices (StrictSeq (Tx TopTx era) -> Seq (Tx TopTx era)
forall a. StrictSeq a -> Seq a
StrictSeq.fromStrict -> Seq (Tx TopTx era)
xs) =
  (Int -> Tx TopTx era -> [Int] -> [Int])
-> [Int] -> Seq (Tx TopTx era) -> [Int]
forall a b. (Int -> a -> b -> b) -> b -> Seq a -> b
Seq.foldrWithIndex
    ( \Int
idx Tx TopTx era
tx [Int]
acc ->
        if Tx TopTx era
tx Tx TopTx era -> Getting IsValid (Tx TopTx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx TopTx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL IsValid -> IsValid -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> IsValid
IsValid Bool
False
          then Int
idx Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
acc
          else [Int]
acc
    )
    []
    Seq (Tx TopTx era)
xs

-- | Given the number of transactions, and the set of indices for which these
-- transactions do not validate, create an aligned sequence of `IsValid`
-- flags.
--
-- This function operates much as the inverse of 'nonValidatingIndices'.
alignedValidFlags :: Int -> [Int] -> Seq.Seq IsValid
alignedValidFlags :: Int -> [Int] -> Seq IsValid
alignedValidFlags = Int -> Int -> [Int] -> Seq IsValid
alignedValidFlags' (-Int
1)
  where
    alignedValidFlags' :: Int -> Int -> [Int] -> Seq IsValid
alignedValidFlags' Int
_ Int
n [] = Int -> IsValid -> Seq IsValid
forall a. Int -> a -> Seq a
Seq.replicate Int
n (IsValid -> Seq IsValid) -> IsValid -> Seq IsValid
forall a b. (a -> b) -> a -> b
$ Bool -> IsValid
IsValid Bool
True
    alignedValidFlags' Int
prev Int
n (Int
x : [Int]
xs) =
      Int -> IsValid -> Seq IsValid
forall a. Int -> a -> Seq a
Seq.replicate (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
prev Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Bool -> IsValid
IsValid Bool
True)
        Seq IsValid -> Seq IsValid -> Seq IsValid
forall a. Seq a -> Seq a -> Seq a
Seq.>< Bool -> IsValid
IsValid Bool
False
        IsValid -> Seq IsValid -> Seq IsValid
forall a. a -> Seq a -> Seq a
Seq.<| Int -> Int -> [Int] -> Seq IsValid
alignedValidFlags' Int
x (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
prev)) [Int]
xs

-- | Construct an annotated Alonzo style transaction.
alonzoSegwitTx ::
  AlonzoEraTx era =>
  Annotator (TxBody TopTx era) ->
  Annotator (TxWits era) ->
  IsValid ->
  Maybe (Annotator (TxAuxData era)) ->
  Annotator (Tx TopTx era)
alonzoSegwitTx :: forall era.
AlonzoEraTx era =>
Annotator (TxBody TopTx era)
-> Annotator (TxWits era)
-> IsValid
-> Maybe (Annotator (TxAuxData era))
-> Annotator (Tx TopTx era)
alonzoSegwitTx Annotator (TxBody TopTx era)
txBodyAnn Annotator (TxWits era)
txWitsAnn IsValid
txIsValid Maybe (Annotator (TxAuxData era))
txAuxDataAnn = (FullByteString -> Either DecoderError (Tx TopTx era))
-> Annotator (Tx TopTx era)
forall a. (FullByteString -> Either DecoderError a) -> Annotator a
Annotator ((FullByteString -> Either DecoderError (Tx TopTx era))
 -> Annotator (Tx TopTx era))
-> (FullByteString -> Either DecoderError (Tx TopTx era))
-> Annotator (Tx TopTx era)
forall a b. (a -> b) -> a -> b
$ \FullByteString
bytes -> do
  txBody <- Annotator (TxBody TopTx era)
-> FullByteString -> Either DecoderError (TxBody TopTx era)
forall a. Annotator a -> FullByteString -> Either DecoderError a
runAnnotator Annotator (TxBody TopTx era)
txBodyAnn FullByteString
bytes
  txWits <- runAnnotator txWitsAnn bytes
  txAuxData <- mapM (`runAnnotator` bytes) txAuxDataAnn
  pure $
    mkBasicTx txBody
      & witsTxL .~ txWits
      & auxDataTxL .~ maybeToStrictMaybe txAuxData
      & isValidTxL .~ txIsValid