{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# 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.Shelley.BlockBody.Internal (
  ShelleyBlockBody (ShelleyBlockBody, ..),
  mkBasicBlockBodyShelley,
  txSeqBlockBodyShelleyL,
  auxDataSeqDecoder,
  hashShelleySegWits,
  bBodySize,
  slotToNonce,
  --
  incrBlocks,
  coreAuxDataBytes,
) where

import qualified Cardano.Crypto.Hash.Class as Hash
import Cardano.Ledger.BaseTypes (
  BlocksMade (..),
  Nonce (..),
  StrictMaybe (..),
  maybeToStrictMaybe,
  mkNonceFromNumber,
  strictMaybeToMaybe,
 )
import Cardano.Ledger.Binary (
  Annotator (..),
  DecCBOR (decCBOR),
  Decoder,
  EncCBOR (..),
  EncCBORGroup (..),
  encodeFoldableEncoder,
  encodeFoldableMapEncoder,
  encodePreEncoded,
  serialize,
  withSlice,
 )
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.Shelley.Tx ()
import Cardano.Ledger.Slot (SlotNo (..))
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.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import qualified Data.Map.Strict as Map
import Data.Monoid (All (..))
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Sequence.Strict (StrictSeq)
import qualified Data.Sequence.Strict as StrictSeq
import Data.Typeable
import GHC.Generics (Generic)
import Lens.Micro hiding (ix)
import NoThunks.Class (AllowThunksIn (..), NoThunks (..))

data ShelleyBlockBody era = ShelleyBlockBodyInternal
  { forall era. ShelleyBlockBody era -> StrictSeq (Tx TopTx era)
sbbTxs :: !(StrictSeq (Tx TopTx era))
  , forall era.
ShelleyBlockBody era -> Hash HASH EraIndependentBlockBody
sbbHash :: Hash.Hash HASH EraIndependentBlockBody
  -- ^ Memoized hash to avoid recomputation. Lazy on purpose.
  , forall era. ShelleyBlockBody era -> ByteString
sbbTxsBodyBytes :: BSL.ByteString
  -- ^ Bytes encoding @Seq ('TxBody' era)@
  , forall era. ShelleyBlockBody era -> ByteString
sbbTxsWitsBytes :: BSL.ByteString
  -- ^ Bytes encoding @Seq ('TxWits' era)@
  , forall era. ShelleyBlockBody era -> ByteString
sbbTxsAuxDataBytes :: BSL.ByteString
  -- ^ Bytes encoding a @Seq ('TxAuxData' era)@. Missing indices have
  -- 'SNothing' for metadata
  }
  deriving ((forall x. ShelleyBlockBody era -> Rep (ShelleyBlockBody era) x)
-> (forall x. Rep (ShelleyBlockBody era) x -> ShelleyBlockBody era)
-> Generic (ShelleyBlockBody era)
forall x. Rep (ShelleyBlockBody era) x -> ShelleyBlockBody era
forall x. ShelleyBlockBody era -> Rep (ShelleyBlockBody era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ShelleyBlockBody era) x -> ShelleyBlockBody era
forall era x. ShelleyBlockBody era -> Rep (ShelleyBlockBody era) x
$cfrom :: forall era x. ShelleyBlockBody era -> Rep (ShelleyBlockBody era) x
from :: forall x. ShelleyBlockBody era -> Rep (ShelleyBlockBody era) x
$cto :: forall era x. Rep (ShelleyBlockBody era) x -> ShelleyBlockBody era
to :: forall x. Rep (ShelleyBlockBody era) x -> ShelleyBlockBody era
Generic)

instance EraBlockBody ShelleyEra where
  type BlockBody ShelleyEra = ShelleyBlockBody ShelleyEra
  mkBasicBlockBody :: BlockBody ShelleyEra
mkBasicBlockBody = BlockBody ShelleyEra
forall era.
(EraBlockBody era, SafeToHash (TxWits era),
 BlockBody era ~ ShelleyBlockBody era) =>
BlockBody era
mkBasicBlockBodyShelley
  txSeqBlockBodyL :: Lens' (BlockBody ShelleyEra) (StrictSeq (Tx TopTx ShelleyEra))
txSeqBlockBodyL = (StrictSeq (Tx TopTx ShelleyEra)
 -> f (StrictSeq (Tx TopTx ShelleyEra)))
-> BlockBody ShelleyEra -> f (BlockBody ShelleyEra)
forall era.
(EraBlockBody era, SafeToHash (TxWits era),
 BlockBody era ~ ShelleyBlockBody era) =>
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
Lens' (BlockBody ShelleyEra) (StrictSeq (Tx TopTx ShelleyEra))
txSeqBlockBodyShelleyL
  hashBlockBody :: BlockBody ShelleyEra -> Hash HASH EraIndependentBlockBody
hashBlockBody = BlockBody ShelleyEra -> Hash HASH EraIndependentBlockBody
ShelleyBlockBody ShelleyEra -> Hash HASH EraIndependentBlockBody
forall era.
ShelleyBlockBody era -> Hash HASH EraIndependentBlockBody
sbbHash
  numSegComponents :: Word64
numSegComponents = Word64
3

mkBasicBlockBodyShelley ::
  ( EraBlockBody era
  , SafeToHash (TxWits era)
  , BlockBody era ~ ShelleyBlockBody era
  ) =>
  BlockBody era
mkBasicBlockBodyShelley :: forall era.
(EraBlockBody era, SafeToHash (TxWits era),
 BlockBody era ~ ShelleyBlockBody era) =>
BlockBody era
mkBasicBlockBodyShelley = StrictSeq (Tx TopTx era) -> ShelleyBlockBody era
forall era.
(EraTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx TopTx era) -> ShelleyBlockBody era
ShelleyBlockBody StrictSeq (Tx TopTx era)
forall a. Monoid a => a
mempty
{-# INLINEABLE mkBasicBlockBodyShelley #-}

txSeqBlockBodyShelleyL ::
  ( EraBlockBody era
  , SafeToHash (TxWits era)
  , BlockBody era ~ ShelleyBlockBody era
  ) =>
  Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
txSeqBlockBodyShelleyL :: forall era.
(EraBlockBody era, SafeToHash (TxWits era),
 BlockBody era ~ ShelleyBlockBody era) =>
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
txSeqBlockBodyShelleyL = (ShelleyBlockBody era -> StrictSeq (Tx TopTx era))
-> (ShelleyBlockBody era
    -> StrictSeq (Tx TopTx era) -> ShelleyBlockBody era)
-> Lens
     (ShelleyBlockBody era)
     (ShelleyBlockBody 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 ShelleyBlockBody era -> StrictSeq (Tx TopTx era)
forall era. ShelleyBlockBody era -> StrictSeq (Tx TopTx era)
sbbTxs (\ShelleyBlockBody era
_ StrictSeq (Tx TopTx era)
s -> StrictSeq (Tx TopTx era) -> ShelleyBlockBody era
forall era.
(EraTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx TopTx era) -> ShelleyBlockBody era
ShelleyBlockBody StrictSeq (Tx TopTx era)
s)
{-# INLINEABLE txSeqBlockBodyShelleyL #-}

deriving via
  AllowThunksIn
    '[ "sbbHash"
     , "sbbTxsBodyBytes"
     , "sbbTxsWitsBytes"
     , "sbbTxsAuxDataBytes"
     ]
    (ShelleyBlockBody era)
  instance
    (Typeable era, NoThunks (Tx TopTx era)) => NoThunks (ShelleyBlockBody era)

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

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

-- ===========================
-- Getting bytes from pieces of a Tx

coreWitnessBytes ::
  (EraTx era, SafeToHash (TxWits era)) =>
  Tx TopTx era ->
  ByteString
coreWitnessBytes :: forall era.
(EraTx era, SafeToHash (TxWits era)) =>
Tx TopTx era -> ByteString
coreWitnessBytes Tx TopTx era
tx = TxWits era -> ByteString
forall t. SafeToHash t => t -> ByteString
originalBytes (TxWits era -> ByteString) -> TxWits era -> ByteString
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
tx Tx TopTx era
-> Getting (TxWits era) (Tx TopTx era) (TxWits era) -> TxWits era
forall s a. s -> Getting a s a -> a
^. 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

coreBodyBytes :: EraTx era => Tx TopTx era -> ByteString
coreBodyBytes :: forall era. EraTx era => Tx TopTx era -> ByteString
coreBodyBytes Tx TopTx era
tx = TxBody TopTx era -> ByteString
forall t. SafeToHash t => t -> ByteString
originalBytes (TxBody TopTx era -> ByteString) -> TxBody TopTx era -> ByteString
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
tx Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. 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

coreAuxDataBytes :: EraTx era => Tx TopTx era -> StrictMaybe ByteString
coreAuxDataBytes :: forall era. EraTx era => Tx TopTx era -> StrictMaybe ByteString
coreAuxDataBytes Tx TopTx era
tx = TxAuxData era -> ByteString
forall t. SafeToHash t => t -> ByteString
originalBytes (TxAuxData era -> ByteString)
-> StrictMaybe (TxAuxData era) -> StrictMaybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx TopTx era
tx Tx TopTx era
-> Getting
     (StrictMaybe (TxAuxData era))
     (Tx TopTx era)
     (StrictMaybe (TxAuxData era))
-> StrictMaybe (TxAuxData era)
forall s a. s -> Getting a s a -> a
^. 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

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

-- | Constuct a BlockBody (with all it bytes) from just Tx's
pattern ShelleyBlockBody ::
  forall era.
  ( EraTx era
  , SafeToHash (TxWits era)
  ) =>
  StrictSeq (Tx TopTx era) ->
  ShelleyBlockBody era
pattern $mShelleyBlockBody :: forall {r} {era}.
(EraTx era, SafeToHash (TxWits era)) =>
ShelleyBlockBody era
-> (StrictSeq (Tx TopTx era) -> r) -> ((# #) -> r) -> r
$bShelleyBlockBody :: forall era.
(EraTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx TopTx era) -> ShelleyBlockBody era
ShelleyBlockBody xs <-
  ShelleyBlockBodyInternal xs _ _ _ _
  where
    ShelleyBlockBody StrictSeq (Tx TopTx era)
txns =
      let version :: Version
version = forall era. Era era => Version
eraProtVerLow @era
          serializeFoldable :: StrictSeq ByteString -> ByteString
serializeFoldable 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
encodePair (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
              encodePair :: ByteString -> Encoding
encodePair 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
serializeFoldable (StrictSeq ByteString -> ByteString)
-> StrictSeq ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ forall era. EraTx era => Tx TopTx era -> ByteString
coreBodyBytes @era (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
serializeFoldable (StrictSeq ByteString -> ByteString)
-> StrictSeq ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ forall era.
(EraTx era, SafeToHash (TxWits era)) =>
Tx TopTx era -> ByteString
coreWitnessBytes @era (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
$ forall era. EraTx era => Tx TopTx era -> StrictMaybe ByteString
coreAuxDataBytes @era (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
       in ShelleyBlockBodyInternal
            { sbbTxs :: StrictSeq (Tx TopTx era)
sbbTxs = StrictSeq (Tx TopTx era)
txns
            , sbbHash :: Hash HASH EraIndependentBlockBody
sbbHash = ByteString
-> ByteString -> ByteString -> Hash HASH EraIndependentBlockBody
hashShelleySegWits ByteString
txSeqBodies ByteString
txSeqWits ByteString
txSeqAuxDatas
            , -- bytes encoding "Seq (TxBody era)"
              sbbTxsBodyBytes :: ByteString
sbbTxsBodyBytes = ByteString
txSeqBodies
            , -- bytes encoding "Seq (TxWits era)"
              sbbTxsWitsBytes :: ByteString
sbbTxsWitsBytes = ByteString
txSeqWits
            , -- bytes encoding a "Map Int TxAuxData"
              sbbTxsAuxDataBytes :: ByteString
sbbTxsAuxDataBytes = ByteString
txSeqAuxDatas
            }

{-# COMPLETE ShelleyBlockBody #-}

instance Era era => EncCBORGroup (ShelleyBlockBody era) where
  encCBORGroup :: ShelleyBlockBody era -> Encoding
encCBORGroup (ShelleyBlockBodyInternal StrictSeq (Tx TopTx era)
_ Hash HASH EraIndependentBlockBody
_ ByteString
bodyBytes ByteString
witsBytes ByteString
metadataBytes) =
    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
  listLen :: ShelleyBlockBody era -> Word
listLen ShelleyBlockBody era
_ = Word
3
  listLenBound :: Proxy (ShelleyBlockBody era) -> Word
listLenBound Proxy (ShelleyBlockBody era)
_ = Word
3

hashShelleySegWits ::
  BSL.ByteString ->
  -- | Bytes for transaction bodies
  BSL.ByteString ->
  -- | Bytes for transaction witnesses
  BSL.ByteString ->
  -- | Bytes for transaction auxiliary datas
  Hash HASH EraIndependentBlockBody
hashShelleySegWits :: ByteString
-> ByteString -> ByteString -> Hash HASH EraIndependentBlockBody
hashShelleySegWits ByteString
bodies ByteString
wits ByteString
md =
  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
bodies Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
hashPart ByteString
wits Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
hashPart ByteString
md
  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 hashShelleySegWits #-}

auxDataSeqDecoder ::
  Int -> IntMap a -> Decoder s (Seq (Maybe a))
auxDataSeqDecoder :: forall a s. Int -> IntMap a -> Decoder s (Seq (Maybe a))
auxDataSeqDecoder Int
bodiesLength IntMap a
auxDataMap = do
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    (All -> Bool
getAll ((Int -> a -> All) -> IntMap a -> All
forall m a. Monoid m => (Int -> a -> m) -> IntMap a -> m
IntMap.foldMapWithKey (\Int
k a
_ -> Bool -> All
All (Int -> Bool
inRange Int
k)) IntMap a
auxDataMap))
    (String -> Decoder s ()
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Some Auxiliarydata index is not in the range: 0 .. " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
bodiesLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)))
  Seq (Maybe a) -> Decoder s (Seq (Maybe a))
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> IntMap a -> Seq (Maybe a)
forall a. Int -> IntMap a -> Seq (Maybe a)
indexLookupSeq Int
bodiesLength IntMap a
auxDataMap)
  where
    inRange :: Int -> Bool
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))
    -- Given a size and a mapping from indices to maybe values,
    -- return a sequence whose size is the size parameter and
    -- whose non-Nothing values correspond to the values in the mapping.
    indexLookupSeq :: Int -> IntMap a -> Seq (Maybe a)
    indexLookupSeq :: forall a. Int -> IntMap a -> Seq (Maybe a)
indexLookupSeq Int
n IntMap a
ixMap = [Maybe a] -> Seq (Maybe a)
forall a. [a] -> Seq a
Seq.fromList [Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
ix IntMap a
ixMap | Int
ix <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

instance
  ( EraTx era
  , DecCBOR (Annotator (TxAuxData era))
  , DecCBOR (Annotator (TxBody TopTx era))
  , DecCBOR (Annotator (TxWits era))
  ) =>
  DecCBOR (Annotator (ShelleyBlockBody era))
  where
  -- \| The parts of the Tx in Blocks that have to have DecCBOR(Annotator x) instances.
  --   These are exactly the parts that are SafeToHash.
  -- \| Decode a BlockBody, used in decoding a Block.
  decCBOR :: forall s. Decoder s (Annotator (ShelleyBlockBody 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
        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
    (metadata, metadataAnn) <- withSlice $ do
      auxDataMap <- decCBOR
      auxDataSeqDecoder bodiesLength auxDataMap

    unless
      (bodiesLength == witsLength)
      ( fail $
          "different number of transaction bodies ("
            <> show bodiesLength
            <> ") and witness sets ("
            <> show witsLength
            <> ")"
      )

    let
      segWitAnnTx Annotator (TxBody TopTx era)
txBodyAnn Annotator (TxWits era)
txWitsAnn Maybe (Annotator (TxAuxData era))
txAuxDataAnnMaybe = (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) txAuxDataAnnMaybe
        pure $
          mkBasicTx @era txBody
            & witsTxL .~ txWits
            & auxDataTxL .~ maybeToStrictMaybe txAuxData
      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)
 -> Maybe (Annotator (TxAuxData era))
 -> Annotator (Tx TopTx era))
-> Seq (Annotator (TxBody TopTx era))
-> Seq (Annotator (TxWits era))
-> Seq (Maybe (Annotator (TxAuxData era)))
-> Seq (Annotator (Tx TopTx era))
forall a b c d.
(a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
Seq.zipWith3 Annotator (TxBody TopTx era)
-> Annotator (TxWits era)
-> Maybe (Annotator (TxAuxData era))
-> Annotator (Tx TopTx era)
segWitAnnTx Seq (Annotator (TxBody TopTx era))
bodies Seq (Annotator (TxWits era))
wits Seq (Maybe (Annotator (TxAuxData era)))
metadata
      hashAnn = ByteString
-> ByteString -> ByteString -> Hash HASH EraIndependentBlockBody
hashShelleySegWits (ByteString
 -> ByteString -> ByteString -> Hash HASH EraIndependentBlockBody)
-> Annotator ByteString
-> Annotator
     (ByteString -> ByteString -> Hash HASH EraIndependentBlockBody)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator ByteString
bodiesAnn Annotator
  (ByteString -> ByteString -> Hash HASH EraIndependentBlockBody)
-> Annotator ByteString
-> Annotator (ByteString -> Hash HASH EraIndependentBlockBody)
forall a b. Annotator (a -> b) -> Annotator a -> Annotator b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator ByteString
witsAnn Annotator (ByteString -> Hash HASH EraIndependentBlockBody)
-> Annotator ByteString
-> Annotator (Hash HASH EraIndependentBlockBody)
forall a b. Annotator (a -> b) -> Annotator a -> Annotator b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator ByteString
metadataAnn
    pure $ ShelleyBlockBodyInternal <$> txns <*> hashAnn <*> bodiesAnn <*> witsAnn <*> metadataAnn

slotToNonce :: SlotNo -> Nonce
slotToNonce :: SlotNo -> Nonce
slotToNonce (SlotNo Word64
s) = Word64 -> Nonce
mkNonceFromNumber Word64
s

incrBlocks ::
  Bool ->
  KeyHash StakePool ->
  BlocksMade ->
  BlocksMade
incrBlocks :: Bool -> KeyHash StakePool -> BlocksMade -> BlocksMade
incrBlocks Bool
isOverlay KeyHash StakePool
hk blocksMade :: BlocksMade
blocksMade@(BlocksMade Map (KeyHash StakePool) Natural
blocksMadeMap)
  | Bool
isOverlay = BlocksMade
blocksMade
  | Bool
otherwise = Map (KeyHash StakePool) Natural -> BlocksMade
BlocksMade (Map (KeyHash StakePool) Natural -> BlocksMade)
-> Map (KeyHash StakePool) Natural -> BlocksMade
forall a b. (a -> b) -> a -> b
$ (Natural -> Natural -> Natural)
-> KeyHash StakePool
-> Natural
-> Map (KeyHash StakePool) Natural
-> Map (KeyHash StakePool) Natural
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(+) KeyHash StakePool
hk Natural
1 Map (KeyHash StakePool) Natural
blocksMadeMap