{-# 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 UndecidableSuperClasses #-}
{-# 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.Dijkstra.BlockBody.Internal (
  DijkstraBlockBody (DijkstraBlockBody, ..),
  hashDijkstraSegWits,
  alignedValidFlags,
  mkBasicBlockBodyDijkstra,
  DijkstraEraBlockBody (..),
) where

import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), IsValid (..))
import Cardano.Ledger.BaseTypes (PerasCert)
import Cardano.Ledger.Binary (
  Annotator (..),
  DecCBOR (..),
  EncCBORGroup (..),
  decodeListLen,
  encCBOR,
  encodeFoldableEncoder,
  encodeFoldableMapEncoder,
  encodePreEncoded,
  serialize,
  withSlice,
 )
import Cardano.Ledger.Core
import Cardano.Ledger.Dijkstra.Era
import Cardano.Ledger.Dijkstra.Tx ()
import Cardano.Ledger.Shelley.BlockBody (auxDataSeqDecoder)
import Control.Monad (unless)
import Data.Bifunctor (Bifunctor (..))
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 (fromMaybe)
import Data.Maybe.Strict (
  StrictMaybe (..),
  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 DijkstraBlockBody era = DijkstraBlockBodyInternal
  { forall era. DijkstraBlockBody era -> StrictSeq (Tx TopTx era)
dbbTxs :: !(StrictSeq (Tx TopTx era))
  , forall era. DijkstraBlockBody era -> StrictMaybe PerasCert
dbbPerasCert :: !(StrictMaybe PerasCert)
  -- ^ Optional Peras certificate
  , forall era.
DijkstraBlockBody era -> Hash HASH EraIndependentBlockBody
dbbHash :: Hash.Hash HASH EraIndependentBlockBody
  -- ^ Memoized hash to avoid recomputation. Lazy on purpose.
  , forall era. DijkstraBlockBody era -> ByteString
dbbTxsBodyBytes :: BSL.ByteString
  -- ^ Bytes encoding @Seq ('TxBody' era)@
  , forall era. DijkstraBlockBody era -> ByteString
dbbTxsWitsBytes :: BSL.ByteString
  -- ^ Bytes encoding @Seq ('TxWits' era)@
  , forall era. DijkstraBlockBody era -> ByteString
dbbTxsAuxDataBytes :: BSL.ByteString
  -- ^ Bytes encoding a @'TxAuxData')@. Missing indices have
  -- 'SNothing' for metadata
  , forall era. DijkstraBlockBody era -> ByteString
dbbTxsIsValidBytes :: BSL.ByteString
  -- ^ Bytes representing a set of integers. These are the indices of
  -- transactions with 'isValid' == False.
  , forall era. DijkstraBlockBody era -> Maybe ByteString
dbbPerasCertBytes :: Maybe BSL.ByteString
  -- ^ Bytes encoding the optional Peras certificate
  }
  deriving ((forall x. DijkstraBlockBody era -> Rep (DijkstraBlockBody era) x)
-> (forall x.
    Rep (DijkstraBlockBody era) x -> DijkstraBlockBody era)
-> Generic (DijkstraBlockBody era)
forall x. Rep (DijkstraBlockBody era) x -> DijkstraBlockBody era
forall x. DijkstraBlockBody era -> Rep (DijkstraBlockBody era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (DijkstraBlockBody era) x -> DijkstraBlockBody era
forall era x.
DijkstraBlockBody era -> Rep (DijkstraBlockBody era) x
$cfrom :: forall era x.
DijkstraBlockBody era -> Rep (DijkstraBlockBody era) x
from :: forall x. DijkstraBlockBody era -> Rep (DijkstraBlockBody era) x
$cto :: forall era x.
Rep (DijkstraBlockBody era) x -> DijkstraBlockBody era
to :: forall x. Rep (DijkstraBlockBody era) x -> DijkstraBlockBody era
Generic)

instance EraBlockBody DijkstraEra where
  type BlockBody DijkstraEra = DijkstraBlockBody DijkstraEra
  mkBasicBlockBody :: BlockBody DijkstraEra
mkBasicBlockBody = BlockBody DijkstraEra
forall era.
(SafeToHash (TxWits era), BlockBody era ~ DijkstraBlockBody era,
 AlonzoEraTx era) =>
BlockBody era
mkBasicBlockBodyDijkstra
  txSeqBlockBodyL :: Lens' (BlockBody DijkstraEra) (StrictSeq (Tx TopTx DijkstraEra))
txSeqBlockBodyL = (DijkstraBlockBody DijkstraEra -> StrictSeq (Tx TopTx DijkstraEra))
-> (DijkstraBlockBody DijkstraEra
    -> StrictSeq (Tx TopTx DijkstraEra)
    -> DijkstraBlockBody DijkstraEra)
-> Lens
     (DijkstraBlockBody DijkstraEra)
     (DijkstraBlockBody DijkstraEra)
     (StrictSeq (Tx TopTx DijkstraEra))
     (StrictSeq (Tx TopTx DijkstraEra))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DijkstraBlockBody DijkstraEra -> StrictSeq (Tx TopTx DijkstraEra)
forall era. DijkstraBlockBody era -> StrictSeq (Tx TopTx era)
dbbTxs (\DijkstraBlockBody DijkstraEra
bb StrictSeq (Tx TopTx DijkstraEra)
p -> DijkstraBlockBody DijkstraEra
bb {dbbTxs = p})
  hashBlockBody :: BlockBody DijkstraEra -> Hash HASH EraIndependentBlockBody
hashBlockBody = BlockBody DijkstraEra -> Hash HASH EraIndependentBlockBody
DijkstraBlockBody DijkstraEra -> Hash HASH EraIndependentBlockBody
forall era.
DijkstraBlockBody era -> Hash HASH EraIndependentBlockBody
dbbHash
  numSegComponents :: Word64
numSegComponents = Word64
5

mkBasicBlockBodyDijkstra ::
  ( SafeToHash (TxWits era)
  , BlockBody era ~ DijkstraBlockBody era
  , AlonzoEraTx era
  ) =>
  BlockBody era
mkBasicBlockBodyDijkstra :: forall era.
(SafeToHash (TxWits era), BlockBody era ~ DijkstraBlockBody era,
 AlonzoEraTx era) =>
BlockBody era
mkBasicBlockBodyDijkstra = StrictSeq (Tx TopTx era)
-> StrictMaybe PerasCert -> DijkstraBlockBody era
forall era.
(AlonzoEraTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx TopTx era)
-> StrictMaybe PerasCert -> DijkstraBlockBody era
DijkstraBlockBody StrictSeq (Tx TopTx era)
forall a. Monoid a => a
mempty StrictMaybe PerasCert
forall a. StrictMaybe a
SNothing
{-# INLINEABLE mkBasicBlockBodyDijkstra #-}

-- | Dijkstra-specific extensions to 'EraBlockBody'
class EraBlockBody era => DijkstraEraBlockBody era where
  perasCertBlockBodyL :: Lens' (BlockBody era) (StrictMaybe PerasCert)
  -- ^ Lens to access the optional Peras certificate in the block body

instance DijkstraEraBlockBody DijkstraEra where
  perasCertBlockBodyL :: Lens' (BlockBody DijkstraEra) (StrictMaybe PerasCert)
perasCertBlockBodyL = (DijkstraBlockBody DijkstraEra -> StrictMaybe PerasCert)
-> (DijkstraBlockBody DijkstraEra
    -> StrictMaybe PerasCert -> DijkstraBlockBody DijkstraEra)
-> Lens
     (DijkstraBlockBody DijkstraEra)
     (DijkstraBlockBody DijkstraEra)
     (StrictMaybe PerasCert)
     (StrictMaybe PerasCert)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DijkstraBlockBody DijkstraEra -> StrictMaybe PerasCert
forall era. DijkstraBlockBody era -> StrictMaybe PerasCert
dbbPerasCert (\DijkstraBlockBody DijkstraEra
bb StrictMaybe PerasCert
c -> DijkstraBlockBody DijkstraEra
bb {dbbPerasCert = c})

pattern DijkstraBlockBody ::
  forall era.
  ( AlonzoEraTx era
  , SafeToHash (TxWits era)
  ) =>
  StrictSeq (Tx TopTx era) ->
  StrictMaybe PerasCert ->
  DijkstraBlockBody era
pattern $mDijkstraBlockBody :: forall {r} {era}.
(AlonzoEraTx era, SafeToHash (TxWits era)) =>
DijkstraBlockBody era
-> (StrictSeq (Tx TopTx era) -> StrictMaybe PerasCert -> r)
-> ((# #) -> r)
-> r
$bDijkstraBlockBody :: forall era.
(AlonzoEraTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx TopTx era)
-> StrictMaybe PerasCert -> DijkstraBlockBody era
DijkstraBlockBody xs mbPerasCert <-
  DijkstraBlockBodyInternal xs mbPerasCert _ _ _ _ _ _
  where
    DijkstraBlockBody StrictSeq (Tx TopTx era)
txns StrictMaybe PerasCert
mbPerasCert =
      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
          mbPerasCertBytes :: Maybe ByteString
mbPerasCertBytes =
            (PerasCert -> ByteString) -> Maybe PerasCert -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Version -> PerasCert -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version) (StrictMaybe PerasCert -> Maybe PerasCert
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe StrictMaybe PerasCert
mbPerasCert)
       in DijkstraBlockBodyInternal
            { dbbTxs :: StrictSeq (Tx TopTx era)
dbbTxs = StrictSeq (Tx TopTx era)
txns
            , dbbPerasCert :: StrictMaybe PerasCert
dbbPerasCert = StrictMaybe PerasCert
mbPerasCert
            , dbbHash :: Hash HASH EraIndependentBlockBody
dbbHash =
                ByteString
-> ByteString
-> ByteString
-> ByteString
-> Maybe ByteString
-> Hash HASH EraIndependentBlockBody
hashDijkstraSegWits
                  ByteString
txSeqBodies
                  ByteString
txSeqWits
                  ByteString
txSeqAuxDatas
                  ByteString
txSeqIsValids
                  Maybe ByteString
mbPerasCertBytes
            , dbbTxsBodyBytes :: ByteString
dbbTxsBodyBytes = ByteString
txSeqBodies
            , dbbTxsWitsBytes :: ByteString
dbbTxsWitsBytes = ByteString
txSeqWits
            , dbbTxsAuxDataBytes :: ByteString
dbbTxsAuxDataBytes = ByteString
txSeqAuxDatas
            , dbbTxsIsValidBytes :: ByteString
dbbTxsIsValidBytes = ByteString
txSeqIsValids
            , dbbPerasCertBytes :: Maybe ByteString
dbbPerasCertBytes = Maybe ByteString
mbPerasCertBytes
            }

{-# COMPLETE DijkstraBlockBody #-}

deriving via
  AllowThunksIn
    '[ "dbbHash"
     , "dbbTxsBodyBytes"
     , "dbbTxsWitsBytes"
     , "dbbTxsAuxDataBytes"
     , "dbbTxsIsValidBytes"
     , "dbbPerasCertBytes"
     ]
    (DijkstraBlockBody era)
  instance
    (Typeable era, NoThunks (Tx TopTx era)) => NoThunks (DijkstraBlockBody era)

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

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

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

instance Era era => EncCBORGroup (DijkstraBlockBody era) where
  encCBORGroup :: DijkstraBlockBody era -> Encoding
encCBORGroup DijkstraBlockBody era
blockBody =
    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
$
        DijkstraBlockBody era -> ByteString
forall era. DijkstraBlockBody era -> ByteString
dbbTxsBodyBytes DijkstraBlockBody era
blockBody
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DijkstraBlockBody era -> ByteString
forall era. DijkstraBlockBody era -> ByteString
dbbTxsWitsBytes DijkstraBlockBody era
blockBody
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DijkstraBlockBody era -> ByteString
forall era. DijkstraBlockBody era -> ByteString
dbbTxsAuxDataBytes DijkstraBlockBody era
blockBody
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> DijkstraBlockBody era -> ByteString
forall era. DijkstraBlockBody era -> ByteString
dbbTxsIsValidBytes DijkstraBlockBody era
blockBody
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
BSL.empty (DijkstraBlockBody era -> Maybe ByteString
forall era. DijkstraBlockBody era -> Maybe ByteString
dbbPerasCertBytes DijkstraBlockBody era
blockBody)
  listLen :: Proxy (DijkstraBlockBody era) -> Word
listLen Proxy (DijkstraBlockBody era)
_ = Word
5

hashDijkstraSegWits ::
  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
  Maybe BSL.ByteString ->
  -- | Bytes for optional Peras certificate
  Hash HASH EraIndependentBlockBody
hashDijkstraSegWits :: ByteString
-> ByteString
-> ByteString
-> ByteString
-> Maybe ByteString
-> Hash HASH EraIndependentBlockBody
hashDijkstraSegWits ByteString
txSeqBodies ByteString
txSeqWits ByteString
txAuxData ByteString
txSeqIsValids Maybe ByteString
mbPerasCert =
  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
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> (ByteString -> Builder) -> Maybe ByteString -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty ByteString -> Builder
hashPart Maybe ByteString
mbPerasCert
  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 hashDijkstraSegWits #-}

instance
  ( AlonzoEraTx era
  , DecCBOR (Annotator (TxAuxData era))
  , DecCBOR (Annotator (TxBody TopTx era))
  , DecCBOR (Annotator (TxWits era))
  ) =>
  DecCBOR (Annotator (DijkstraBlockBody era))
  where
  decCBOR :: forall s. Decoder s (Annotator (DijkstraBlockBody era))
decCBOR = do
    len <- Decoder s Int
forall s. Decoder s Int
decodeListLen

    (bodies, bodiesAnn) <- withSlice 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)
dijkstraSegwitTx Seq (Annotator (TxBody TopTx era))
bodies Seq (Annotator (TxWits era))
wits Seq IsValid
validFlags Seq (Maybe (Annotator (TxAuxData era)))
auxData

    (mbPerasCert, mbPerasCertAnn) <-
      case len of
        Int
4 -> (Annotator (StrictMaybe PerasCert), Annotator (Maybe ByteString))
-> Decoder
     s (Annotator (StrictMaybe PerasCert), Annotator (Maybe ByteString))
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (StrictMaybe PerasCert -> Annotator (StrictMaybe PerasCert)
forall a. a -> Annotator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictMaybe PerasCert
forall a. StrictMaybe a
SNothing, Maybe ByteString -> Annotator (Maybe ByteString)
forall a. a -> Annotator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing)
        Int
5 -> (PerasCert -> Annotator (StrictMaybe PerasCert))
-> (Annotator ByteString -> Annotator (Maybe ByteString))
-> (PerasCert, Annotator ByteString)
-> (Annotator (StrictMaybe PerasCert),
    Annotator (Maybe ByteString))
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (StrictMaybe PerasCert -> Annotator (StrictMaybe PerasCert)
forall a. a -> Annotator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StrictMaybe PerasCert -> Annotator (StrictMaybe PerasCert))
-> (PerasCert -> StrictMaybe PerasCert)
-> PerasCert
-> Annotator (StrictMaybe PerasCert)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasCert -> StrictMaybe PerasCert
forall a. a -> StrictMaybe a
SJust) ((ByteString -> Maybe ByteString)
-> Annotator ByteString -> Annotator (Maybe ByteString)
forall a b. (a -> b) -> Annotator a -> Annotator b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just) ((PerasCert, Annotator ByteString)
 -> (Annotator (StrictMaybe PerasCert),
     Annotator (Maybe ByteString)))
-> Decoder s (PerasCert, Annotator ByteString)
-> Decoder
     s (Annotator (StrictMaybe PerasCert), Annotator (Maybe ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s PerasCert -> Decoder s (PerasCert, Annotator ByteString)
forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice Decoder s PerasCert
forall s. Decoder s PerasCert
forall a s. DecCBOR a => Decoder s a
decCBOR
        Int
_ -> String
-> Decoder
     s (Annotator (StrictMaybe PerasCert), Annotator (Maybe ByteString))
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
 -> Decoder
      s
      (Annotator (StrictMaybe PerasCert), Annotator (Maybe ByteString)))
-> String
-> Decoder
     s (Annotator (StrictMaybe PerasCert), Annotator (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ String
"unexpected body length: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
len

    pure $
      DijkstraBlockBodyInternal
        <$> txns
        <*> mbPerasCert
        <*> ( hashDijkstraSegWits
                <$> bodiesAnn
                <*> witsAnn
                <*> auxDataAnn
                <*> isValAnn
                <*> mbPerasCertAnn
            )
        <*> bodiesAnn
        <*> witsAnn
        <*> auxDataAnn
        <*> isValAnn
        <*> mbPerasCertAnn

--------------------------------------------------------------------------------
-- 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 Dijkstra style transaction.
dijkstraSegwitTx ::
  AlonzoEraTx era =>
  Annotator (TxBody TopTx era) ->
  Annotator (TxWits era) ->
  IsValid ->
  Maybe (Annotator (TxAuxData era)) ->
  Annotator (Tx TopTx era)
dijkstraSegwitTx :: forall era.
AlonzoEraTx era =>
Annotator (TxBody TopTx era)
-> Annotator (TxWits era)
-> IsValid
-> Maybe (Annotator (TxAuxData era))
-> Annotator (Tx TopTx era)
dijkstraSegwitTx 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