{-# 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 #-}
module Cardano.Ledger.Shelley.BlockChain (
ShelleyTxSeq (ShelleyTxSeq, txSeqTxns', TxSeq'),
constructMetadata,
txSeqTxns,
bbHash,
bBodySize,
slotToNonce,
incrBlocks,
coreAuxDataBytes,
txSeqDecoder,
)
where
import qualified Cardano.Crypto.Hash.Class as Hash
import Cardano.Ledger.BaseTypes (
BlocksMade (..),
Nonce (..),
StrictMaybe (..),
mkNonceFromNumber,
strictMaybeToMaybe,
)
import Cardano.Ledger.Binary (
Annotator (..),
DecCBOR (decCBOR),
Decoder,
EncCBOR (..),
EncCBORGroup (..),
encodeFoldableEncoder,
encodeFoldableMapEncoder,
encodePreEncoded,
serialize,
withSlice,
)
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto
import Cardano.Ledger.Keys (Hash, KeyHash, KeyRole (..))
import Cardano.Ledger.SafeHash (SafeToHash (..))
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.Shelley.Tx (ShelleyTx, segwitTx)
import Cardano.Ledger.Slot (SlotNo (..))
import Control.Monad (unless)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BSL
import Data.Coerce (coerce)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
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 ((^.))
import NoThunks.Class (AllowThunksIn (..), NoThunks (..))
data ShelleyTxSeq era = TxSeq'
{ forall era. ShelleyTxSeq era -> StrictSeq (ShelleyTx era)
txSeqTxns' :: !(StrictSeq (ShelleyTx era))
, forall era. ShelleyTxSeq era -> ByteString
txSeqBodyBytes :: BSL.ByteString
, forall era. ShelleyTxSeq era -> ByteString
txSeqWitsBytes :: BSL.ByteString
, forall era. ShelleyTxSeq era -> ByteString
txSeqMetadataBytes :: BSL.ByteString
}
deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ShelleyTxSeq era) x -> ShelleyTxSeq era
forall era x. ShelleyTxSeq era -> Rep (ShelleyTxSeq era) x
$cto :: forall era x. Rep (ShelleyTxSeq era) x -> ShelleyTxSeq era
$cfrom :: forall era x. ShelleyTxSeq era -> Rep (ShelleyTxSeq era) x
Generic)
instance Crypto c => EraSegWits (ShelleyEra c) where
type TxSeq (ShelleyEra c) = ShelleyTxSeq (ShelleyEra c)
fromTxSeq :: TxSeq (ShelleyEra c) -> StrictSeq (Tx (ShelleyEra c))
fromTxSeq = forall era. ShelleyTxSeq era -> StrictSeq (ShelleyTx era)
txSeqTxns
toTxSeq :: StrictSeq (Tx (ShelleyEra c)) -> TxSeq (ShelleyEra c)
toTxSeq = forall era.
(EraTx era, Tx era ~ ShelleyTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx era) -> ShelleyTxSeq era
ShelleyTxSeq
hashTxSeq :: TxSeq (ShelleyEra c)
-> Hash (HASH (EraCrypto (ShelleyEra c))) EraIndependentBlockBody
hashTxSeq = forall era.
Era era =>
ShelleyTxSeq era -> Hash (EraCrypto era) EraIndependentBlockBody
bbHash
numSegComponents :: Word64
numSegComponents = Word64
3
deriving via
AllowThunksIn
'[ "txSeqBodyBytes"
, "txSeqWitsBytes"
, "txSeqMetadataBytes"
]
(ShelleyTxSeq era)
instance
(Typeable era, NoThunks (ShelleyTx era)) => NoThunks (ShelleyTxSeq era)
deriving stock instance
Show (ShelleyTx era) =>
Show (ShelleyTxSeq era)
deriving stock instance
Eq (ShelleyTx era) =>
Eq (ShelleyTxSeq era)
coreWitnessBytes ::
(EraTx era, SafeToHash (TxWits era)) =>
Tx era ->
ByteString
coreWitnessBytes :: forall era.
(EraTx era, SafeToHash (TxWits era)) =>
Tx era -> ByteString
coreWitnessBytes Tx era
tx = forall t. SafeToHash t => t -> ByteString
originalBytes forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL
coreBodyBytes :: EraTx era => Tx era -> ByteString
coreBodyBytes :: forall era. EraTx era => Tx era -> ByteString
coreBodyBytes Tx era
tx = forall t. SafeToHash t => t -> ByteString
originalBytes forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
coreAuxDataBytes :: EraTx era => Tx era -> StrictMaybe ByteString
coreAuxDataBytes :: forall era. EraTx era => Tx era -> StrictMaybe ByteString
coreAuxDataBytes Tx era
tx = forall t. SafeToHash t => t -> ByteString
originalBytes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (AuxiliaryData era))
auxDataTxL
pattern ShelleyTxSeq ::
forall era.
( EraTx era
, Tx era ~ ShelleyTx era
, SafeToHash (TxWits era)
) =>
StrictSeq (Tx era) ->
ShelleyTxSeq era
pattern $bShelleyTxSeq :: forall era.
(EraTx era, Tx era ~ ShelleyTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx era) -> ShelleyTxSeq era
$mShelleyTxSeq :: forall {r} {era}.
(EraTx era, Tx era ~ ShelleyTx era, SafeToHash (TxWits era)) =>
ShelleyTxSeq era -> (StrictSeq (Tx era) -> r) -> ((# #) -> r) -> r
ShelleyTxSeq xs <-
TxSeq' xs _ _ _
where
ShelleyTxSeq StrictSeq (Tx era)
txns =
let version :: Version
version = forall era. Era era => Version
eraProtVerLow @era
serializeFoldable :: StrictSeq ByteString -> ByteString
serializeFoldable 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
encodePair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe StrictMaybe ByteString
m
where
encodePair :: ByteString -> Encoding
encodePair ByteString
metadata = forall a. EncCBOR a => a -> Encoding
encCBOR a
index forall a. Semigroup a => a -> a -> a
<> ByteString -> Encoding
encodePreEncoded ByteString
metadata
in TxSeq'
{ txSeqTxns' :: StrictSeq (ShelleyTx era)
txSeqTxns' = StrictSeq (Tx era)
txns
,
txSeqBodyBytes :: ByteString
txSeqBodyBytes = StrictSeq ByteString -> ByteString
serializeFoldable forall a b. (a -> b) -> a -> b
$ forall era. EraTx era => Tx era -> ByteString
coreBodyBytes @era forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (Tx era)
txns
,
txSeqWitsBytes :: ByteString
txSeqWitsBytes = StrictSeq ByteString -> ByteString
serializeFoldable forall a b. (a -> b) -> a -> b
$ forall era.
(EraTx era, SafeToHash (TxWits era)) =>
Tx era -> ByteString
coreWitnessBytes @era 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 era. EraTx era => Tx era -> StrictMaybe ByteString
coreAuxDataBytes @era forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (Tx era)
txns
}
{-# COMPLETE ShelleyTxSeq #-}
txSeqTxns :: ShelleyTxSeq era -> StrictSeq (ShelleyTx era)
txSeqTxns :: forall era. ShelleyTxSeq era -> StrictSeq (ShelleyTx era)
txSeqTxns (TxSeq' StrictSeq (ShelleyTx era)
ts ByteString
_ ByteString
_ ByteString
_) = StrictSeq (ShelleyTx era)
ts
instance
forall era.
Era era =>
EncCBORGroup (ShelleyTxSeq era)
where
encCBORGroup :: ShelleyTxSeq era -> Encoding
encCBORGroup (TxSeq' StrictSeq (ShelleyTx era)
_ ByteString
bodyBytes ByteString
witsBytes ByteString
metadataBytes) =
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
encodedGroupSizeExpr :: (forall x. EncCBOR x => Proxy x -> Size)
-> Proxy (ShelleyTxSeq era) -> Size
encodedGroupSizeExpr forall x. EncCBOR x => Proxy x -> Size
size Proxy (ShelleyTxSeq 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)
listLen :: ShelleyTxSeq era -> Word
listLen ShelleyTxSeq era
_ = Word
3
listLenBound :: Proxy (ShelleyTxSeq era) -> Word
listLenBound Proxy (ShelleyTxSeq era)
_ = Word
3
bbHash ::
forall era.
Era era =>
ShelleyTxSeq era ->
Hash (EraCrypto era) EraIndependentBlockBody
bbHash :: forall era.
Era era =>
ShelleyTxSeq era -> Hash (EraCrypto era) EraIndependentBlockBody
bbHash (TxSeq' StrictSeq (ShelleyTx era)
_ ByteString
bodies ByteString
wits ByteString
md) =
coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$
ByteString -> Hash (EraCrypto era) ByteString
hashStrict
( ByteString -> ByteString
hashPart ByteString
bodies
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
hashPart ByteString
wits
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
hashPart ByteString
md
)
where
hashStrict :: ByteString -> Hash (EraCrypto era) ByteString
hashStrict :: ByteString -> Hash (EraCrypto era) ByteString
hashStrict = forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Hash.hashWith forall a. a -> a
id
hashPart :: ByteString -> ByteString
hashPart = forall h a. Hash h a -> ByteString
Hash.hashToBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Hash (EraCrypto era) ByteString
hashStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict
constructMetadata ::
forall era.
Int ->
Map Int (Annotator (TxAuxData era)) ->
Seq (Maybe (Annotator (TxAuxData era)))
constructMetadata :: forall era.
Int
-> Map Int (Annotator (TxAuxData era))
-> Seq (Maybe (Annotator (TxAuxData era)))
constructMetadata Int
n Map Int (Annotator (TxAuxData era))
md = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Int (Annotator (TxAuxData era))
md) (forall a. [a] -> Seq a
Seq.fromList [Int
0 .. Int
n forall a. Num a => a -> a -> a
- Int
1])
txSeqDecoder ::
forall era.
EraTx era =>
Bool ->
forall s.
Decoder s (Annotator (ShelleyTxSeq era))
txSeqDecoder :: forall era.
EraTx era =>
Bool -> forall s. Decoder s (Annotator (ShelleyTxSeq era))
txSeqDecoder Bool
lax = 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))
wits, 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))
wits
(Seq (Maybe (Annotator (TxAuxData era)))
metadata, Annotator ByteString
metadataAnn) <- 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
(Bool
lax Bool -> Bool -> Bool
|| 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 @era Int
b Map Int (Annotator (TxAuxData era))
m)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
(Bool
lax Bool -> Bool -> Bool
|| 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
")"
)
let txns :: Annotator (StrictSeq (ShelleyTx 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.
(a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
Seq.zipWith3 forall era.
EraTx era =>
Annotator (TxBody era)
-> Annotator (TxWits era)
-> Maybe (Annotator (TxAuxData era))
-> Annotator (ShelleyTx era)
segwitTx Seq (Annotator (TxBody era))
bodies Seq (Annotator (TxWits era))
wits Seq (Maybe (Annotator (TxAuxData era)))
metadata
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
StrictSeq (ShelleyTx era)
-> ByteString -> ByteString -> ByteString -> ShelleyTxSeq era
TxSeq' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator (StrictSeq (ShelleyTx 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
metadataAnn
instance EraTx era => DecCBOR (Annotator (ShelleyTxSeq era)) where
decCBOR :: forall s. Decoder s (Annotator (ShelleyTxSeq era))
decCBOR = forall era.
EraTx era =>
Bool -> forall s. Decoder s (Annotator (ShelleyTxSeq era))
txSeqDecoder Bool
False
slotToNonce :: SlotNo -> Nonce
slotToNonce :: SlotNo -> Nonce
slotToNonce (SlotNo Word64
s) = Word64 -> Nonce
mkNonceFromNumber Word64
s
incrBlocks ::
Bool ->
KeyHash 'StakePool c ->
BlocksMade c ->
BlocksMade c
incrBlocks :: forall c.
Bool -> KeyHash 'StakePool c -> BlocksMade c -> BlocksMade c
incrBlocks Bool
isOverlay KeyHash 'StakePool c
hk b' :: BlocksMade c
b'@(BlocksMade Map (KeyHash 'StakePool c) Natural
b)
| Bool
isOverlay = BlocksMade c
b'
| Bool
otherwise = forall c. Map (KeyHash 'StakePool c) Natural -> BlocksMade c
BlocksMade forall a b. (a -> b) -> a -> b
$ case Maybe Natural
hkVal of
Maybe Natural
Nothing -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool c
hk Natural
1 Map (KeyHash 'StakePool c) Natural
b
Just Natural
n -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool c
hk (Natural
n forall a. Num a => a -> a -> a
+ Natural
1) Map (KeyHash 'StakePool c) Natural
b
where
hkVal :: Maybe Natural
hkVal = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool c
hk Map (KeyHash 'StakePool c) Natural
b