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

-- | Provides TxSeq 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.TxSeq.Internal (
  AlonzoTxSeq (.., AlonzoTxSeq),
  hashAlonzoTxSeq,
)
where

import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.Alonzo.Era
import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), IsValid (..), alonzoSegwitTx)
import Cardano.Ledger.Binary (
  Annotator,
  DecCBOR (..),
  EncCBORGroup (..),
  encCBOR,
  encodeFoldableEncoder,
  encodeFoldableMapEncoder,
  encodePreEncoded,
  encodedSizeExpr,
  serialize,
  withSlice,
 )
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.BlockChain (constructMetadata)
import Control.Monad (unless)
import Data.ByteString (ByteString)
import Data.ByteString.Builder (shortByteString, toLazyByteString)
import qualified Data.ByteString.Lazy as BSL
import Data.Coerce (coerce)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (strictMaybeToMaybe)
import Data.Proxy (Proxy (..))
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)

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

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

data AlonzoTxSeq era = AlonzoTxSeqRaw
  { forall era. AlonzoTxSeq era -> StrictSeq (Tx era)
txSeqTxns :: !(StrictSeq (Tx era))
  , forall era. AlonzoTxSeq era -> ByteString
txSeqBodyBytes :: BSL.ByteString
  -- ^ Bytes encoding @Seq ('AlonzoTxBody' era)@
  , forall era. AlonzoTxSeq era -> ByteString
txSeqWitsBytes :: BSL.ByteString
  -- ^ Bytes encoding @Seq ('TxWitness' era)@
  , forall era. AlonzoTxSeq era -> ByteString
txSeqMetadataBytes :: BSL.ByteString
  -- ^ Bytes encoding a @Map Int ('AuxiliaryData')@. Missing indices have
  -- 'SNothing' for metadata
  , forall era. AlonzoTxSeq era -> ByteString
txSeqIsValidBytes :: BSL.ByteString
  -- ^ Bytes representing a set of integers. These are the indices of
  -- transactions with 'isValid' == False.
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (AlonzoTxSeq era) x -> AlonzoTxSeq era
forall era x. AlonzoTxSeq era -> Rep (AlonzoTxSeq era) x
$cto :: forall era x. Rep (AlonzoTxSeq era) x -> AlonzoTxSeq era
$cfrom :: forall era x. AlonzoTxSeq era -> Rep (AlonzoTxSeq era) x
Generic)

instance EraSegWits AlonzoEra where
  type TxSeq AlonzoEra = AlonzoTxSeq AlonzoEra
  fromTxSeq :: TxSeq AlonzoEra -> StrictSeq (Tx AlonzoEra)
fromTxSeq = forall era. AlonzoTxSeq era -> StrictSeq (Tx era)
txSeqTxns
  toTxSeq :: StrictSeq (Tx AlonzoEra) -> TxSeq AlonzoEra
toTxSeq = forall era.
(AlonzoEraTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx era) -> AlonzoTxSeq era
AlonzoTxSeq
  hashTxSeq :: TxSeq AlonzoEra -> Hash HASH EraIndependentBlockBody
hashTxSeq = forall era. AlonzoTxSeq era -> Hash HASH EraIndependentBlockBody
hashAlonzoTxSeq
  numSegComponents :: Word64
numSegComponents = Word64
4

pattern AlonzoTxSeq ::
  forall era.
  ( AlonzoEraTx era
  , SafeToHash (TxWits era)
  ) =>
  StrictSeq (Tx era) ->
  AlonzoTxSeq era
pattern $bAlonzoTxSeq :: forall era.
(AlonzoEraTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx era) -> AlonzoTxSeq era
$mAlonzoTxSeq :: forall {r} {era}.
(AlonzoEraTx era, SafeToHash (TxWits era)) =>
AlonzoTxSeq era -> (StrictSeq (Tx era) -> r) -> ((# #) -> r) -> r
AlonzoTxSeq xs <-
  AlonzoTxSeqRaw xs _ _ _ _
  where
    AlonzoTxSeq StrictSeq (Tx era)
txns =
      let version :: Version
version = forall era. Era era => Version
eraProtVerLow @era
          serializeFoldablePreEncoded :: StrictSeq ByteString -> ByteString
serializeFoldablePreEncoded StrictSeq ByteString
x =
            forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version forall a b. (a -> b) -> a -> b
$
              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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe StrictMaybe ByteString
m
            where
              encodeIndexed :: ByteString -> Encoding
encodeIndexed ByteString
metadata = forall a. EncCBOR a => a -> Encoding
encCBOR a
index forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
encodePreEncoded ByteString
metadata
       in AlonzoTxSeqRaw
            { txSeqTxns :: StrictSeq (Tx era)
txSeqTxns = StrictSeq (Tx era)
txns
            , txSeqBodyBytes :: ByteString
txSeqBodyBytes =
                StrictSeq ByteString -> ByteString
serializeFoldablePreEncoded forall a b. (a -> b) -> a -> b
$ forall t. SafeToHash t => t -> ByteString
originalBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (Tx era)
txns
            , txSeqWitsBytes :: ByteString
txSeqWitsBytes =
                StrictSeq ByteString -> ByteString
serializeFoldablePreEncoded forall a b. (a -> b) -> a -> b
$ forall t. SafeToHash t => t -> ByteString
originalBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (Tx era)
txns
            , txSeqMetadataBytes :: ByteString
txSeqMetadataBytes =
                forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Foldable f =>
(Word -> a -> Maybe Encoding) -> f a -> Encoding
encodeFoldableMapEncoder forall {a}.
EncCBOR a =>
a -> StrictMaybe ByteString -> Maybe Encoding
metaChunk forall a b. (a -> b) -> a -> b
$
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t. SafeToHash t => t -> ByteString
originalBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (TxAuxData era))
auxDataTxL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (Tx era)
txns
            , txSeqIsValidBytes :: ByteString
txSeqIsValidBytes =
                forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version forall a b. (a -> b) -> a -> b
$ forall a. EncCBOR a => a -> Encoding
encCBOR forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraTx era => StrictSeq (Tx era) -> [Int]
nonValidatingIndices StrictSeq (Tx era)
txns
            }

{-# COMPLETE AlonzoTxSeq #-}

deriving via
  AllowThunksIn
    '[ "txSeqBodyBytes"
     , "txSeqWitsBytes"
     , "txSeqMetadataBytes"
     , "txSeqIsValidBytes"
     ]
    (AlonzoTxSeq era)
  instance
    (Typeable era, NoThunks (Tx era)) => NoThunks (AlonzoTxSeq era)

deriving stock instance Show (Tx era) => Show (AlonzoTxSeq era)

deriving stock instance Eq (Tx era) => Eq (AlonzoTxSeq era)

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

instance Era era => EncCBORGroup (AlonzoTxSeq era) where
  encCBORGroup :: AlonzoTxSeq era -> Encoding
encCBORGroup (AlonzoTxSeqRaw StrictSeq (Tx era)
_ ByteString
bodyBytes ByteString
witsBytes ByteString
metadataBytes ByteString
invalidBytes) =
    ByteString -> Encoding
encodePreEncoded forall a b. (a -> b) -> a -> b
$
      ByteString -> ByteString
BSL.toStrict forall a b. (a -> b) -> a -> b
$
        ByteString
bodyBytes forall a. Semigroup a => a -> a -> a
<> ByteString
witsBytes forall a. Semigroup a => a -> a -> a
<> ByteString
metadataBytes forall a. Semigroup a => a -> a -> a
<> ByteString
invalidBytes
  encodedGroupSizeExpr :: (forall x. EncCBOR x => Proxy x -> Size)
-> Proxy (AlonzoTxSeq era) -> Size
encodedGroupSizeExpr forall x. EncCBOR x => Proxy x -> Size
size Proxy (AlonzoTxSeq era)
_proxy =
    forall a.
EncCBOR a =>
(forall x. EncCBOR x => Proxy x -> Size) -> Proxy a -> Size
encodedSizeExpr forall x. EncCBOR x => Proxy x -> Size
size (forall {k} (t :: k). Proxy t
Proxy :: Proxy ByteString)
      forall a. Num a => a -> a -> a
+ forall a.
EncCBOR a =>
(forall x. EncCBOR x => Proxy x -> Size) -> Proxy a -> Size
encodedSizeExpr forall x. EncCBOR x => Proxy x -> Size
size (forall {k} (t :: k). Proxy t
Proxy :: Proxy ByteString)
      forall a. Num a => a -> a -> a
+ forall a.
EncCBOR a =>
(forall x. EncCBOR x => Proxy x -> Size) -> Proxy a -> Size
encodedSizeExpr forall x. EncCBOR x => Proxy x -> Size
size (forall {k} (t :: k). Proxy t
Proxy :: Proxy ByteString)
      forall a. Num a => a -> a -> a
+ forall a.
EncCBOR a =>
(forall x. EncCBOR x => Proxy x -> Size) -> Proxy a -> Size
encodedSizeExpr forall x. EncCBOR x => Proxy x -> Size
size (forall {k} (t :: k). Proxy t
Proxy :: Proxy ByteString)
  listLen :: AlonzoTxSeq era -> Word
listLen AlonzoTxSeq era
_ = Word
4
  listLenBound :: Proxy (AlonzoTxSeq era) -> Word
listLenBound Proxy (AlonzoTxSeq era)
_ = Word
4

-- | Hash a given block body
hashAlonzoTxSeq ::
  forall era.
  AlonzoTxSeq era ->
  Hash HASH EraIndependentBlockBody
hashAlonzoTxSeq :: forall era. AlonzoTxSeq era -> Hash HASH EraIndependentBlockBody
hashAlonzoTxSeq (AlonzoTxSeqRaw StrictSeq (Tx era)
_ ByteString
bodies ByteString
ws ByteString
md ByteString
vs) =
  coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$
    ByteString -> Hash HASH ByteString
hashStrict forall a b. (a -> b) -> a -> b
$
      ByteString -> ByteString
BSL.toStrict forall a b. (a -> b) -> a -> b
$
        Builder -> ByteString
toLazyByteString forall a b. (a -> b) -> a -> b
$
          forall a. Monoid a => [a] -> a
mconcat
            [ ByteString -> Builder
hashPart ByteString
bodies
            , ByteString -> Builder
hashPart ByteString
ws
            , ByteString -> Builder
hashPart ByteString
md
            , ByteString -> Builder
hashPart ByteString
vs
            ]
  where
    hashStrict :: ByteString -> Hash HASH ByteString
    hashStrict :: ByteString -> Hash HASH ByteString
hashStrict = forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Hash.hashWith forall a. a -> a
id
    hashPart :: ByteString -> Builder
hashPart = ShortByteString -> Builder
shortByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a. Hash h a -> ShortByteString
Hash.hashToBytesShort forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Hash HASH ByteString
hashStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict

instance AlonzoEraTx era => DecCBOR (Annotator (AlonzoTxSeq era)) where
  decCBOR :: forall s. Decoder s (Annotator (AlonzoTxSeq era))
decCBOR = do
    (Seq (Annotator (TxBody era))
bodies, Annotator ByteString
bodiesAnn) <- forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice forall a s. DecCBOR a => Decoder s a
decCBOR
    (Seq (Annotator (TxWits era))
ws, Annotator ByteString
witsAnn) <- forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice forall a s. DecCBOR a => Decoder s a
decCBOR
    let b :: Int
b = forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (Annotator (TxBody era))
bodies
        inRange :: Int -> Bool
inRange Int
x = (Int
0 forall a. Ord a => a -> a -> Bool
<= Int
x) Bool -> Bool -> Bool
&& (Int
x forall a. Ord a => a -> a -> Bool
<= (Int
b forall a. Num a => a -> a -> a
- Int
1))
        w :: Int
w = forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (Annotator (TxWits era))
ws
    (Seq (Maybe (Annotator (TxAuxData era)))
auxData, Annotator ByteString
auxDataAnn) <- forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice forall a b. (a -> b) -> a -> b
$
      do
        Map Int (Annotator (TxAuxData era))
m <- forall a s. DecCBOR a => Decoder s a
decCBOR
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
          (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Int -> Bool
inRange (forall k a. Map k a -> Set k
Map.keysSet Map Int (Annotator (TxAuxData era))
m))
          ( forall (m :: * -> *) a. MonadFail m => String -> m a
fail
              ( String
"Some Auxiliarydata index is not in the range: 0 .. "
                  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
b forall a. Num a => a -> a -> a
- Int
1)
              )
          )
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era.
Int
-> Map Int (Annotator (TxAuxData era))
-> Seq (Maybe (Annotator (TxAuxData era)))
constructMetadata Int
b Map Int (Annotator (TxAuxData era))
m)
    ([Int]
isValIdxs, Annotator ByteString
isValAnn) <- forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice forall a s. DecCBOR a => Decoder s a
decCBOR
    let vs :: Seq IsValid
vs = Int -> [Int] -> Seq IsValid
alignedValidFlags Int
b [Int]
isValIdxs
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
      (Int
b forall a. Eq a => a -> a -> Bool
== Int
w)
      ( forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
          String
"different number of transaction bodies ("
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
b
            forall a. Semigroup a => a -> a -> a
<> String
") and witness sets ("
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
w
            forall a. Semigroup a => a -> a -> a
<> String
")"
      )
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
      (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Int -> Bool
inRange [Int]
isValIdxs)
      ( forall (m :: * -> *) a. MonadFail m => String -> m a
fail
          ( String
"Some IsValid index is not in the range: 0 .. "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
b forall a. Num a => a -> a -> a
- Int
1)
              forall a. [a] -> [a] -> [a]
++ String
", "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Int]
isValIdxs
          )
      )

    let txns :: Annotator (StrictSeq (Tx era))
txns =
          forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall a b. (a -> b) -> a -> b
$
            forall a. Seq a -> StrictSeq a
StrictSeq.forceToStrict forall a b. (a -> b) -> a -> b
$
              forall a b c d e.
(a -> b -> c -> d -> e)
-> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
Seq.zipWith4 forall era.
AlonzoEraTx era =>
Annotator (TxBody era)
-> Annotator (TxWits era)
-> IsValid
-> Maybe (Annotator (TxAuxData era))
-> Annotator (Tx era)
alonzoSegwitTx Seq (Annotator (TxBody era))
bodies Seq (Annotator (TxWits era))
ws Seq IsValid
vs Seq (Maybe (Annotator (TxAuxData era)))
auxData
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      forall era.
StrictSeq (Tx era)
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> AlonzoTxSeq era
AlonzoTxSeqRaw
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator (StrictSeq (Tx era))
txns
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator ByteString
bodiesAnn
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator ByteString
witsAnn
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator ByteString
auxDataAnn
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator ByteString
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 era) -> [Int]
nonValidatingIndices :: forall era. AlonzoEraTx era => StrictSeq (Tx era) -> [Int]
nonValidatingIndices (forall a. StrictSeq a -> Seq a
StrictSeq.fromStrict -> Seq (Tx era)
xs) =
  forall a b. (Int -> a -> b -> b) -> b -> Seq a -> b
Seq.foldrWithIndex
    ( \Int
idx Tx era
tx [Int]
acc ->
        if Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL forall a. Eq a => a -> a -> Bool
== Bool -> IsValid
IsValid Bool
False
          then Int
idx forall a. a -> [a] -> [a]
: [Int]
acc
          else [Int]
acc
    )
    []
    Seq (Tx 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 [] = forall a. Int -> a -> Seq a
Seq.replicate Int
n forall a b. (a -> b) -> a -> b
$ Bool -> IsValid
IsValid Bool
True
    alignedValidFlags' Int
prev Int
n (Int
x : [Int]
xs) =
      forall a. Int -> a -> Seq a
Seq.replicate (Int
x forall a. Num a => a -> a -> a
- Int
prev forall a. Num a => a -> a -> a
- Int
1) (Bool -> IsValid
IsValid Bool
True)
        forall a. Seq a -> Seq a -> Seq a
Seq.>< Bool -> IsValid
IsValid Bool
False
        forall a. a -> Seq a -> Seq a
Seq.<| Int -> Int -> [Int] -> Seq IsValid
alignedValidFlags' Int
x (Int
n forall a. Num a => a -> a -> a
- (Int
x forall a. Num a => a -> a -> a
- Int
prev)) [Int]
xs