{-# 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.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
  -- bytes representing a (Map index metadata). Missing indices have SNothing for metadata
  }
  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 EraSegWits ShelleyEra where
  type TxSeq ShelleyEra = ShelleyTxSeq ShelleyEra
  fromTxSeq :: TxSeq ShelleyEra -> StrictSeq (Tx ShelleyEra)
fromTxSeq = forall era. ShelleyTxSeq era -> StrictSeq (ShelleyTx era)
txSeqTxns
  toTxSeq :: StrictSeq (Tx ShelleyEra) -> TxSeq ShelleyEra
toTxSeq = forall era.
(EraTx era, Tx era ~ ShelleyTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx era) -> ShelleyTxSeq era
ShelleyTxSeq
  hashTxSeq :: TxSeq ShelleyEra -> Hash HASH EraIndependentBlockBody
hashTxSeq = forall era. ShelleyTxSeq era -> Hash HASH 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)

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

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 (TxAuxData era))
auxDataTxL

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

-- | Constuct a TxSeq (with all it bytes) from just Tx's
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
            , -- bytes encoding "Seq (TxBody era)"
              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
            , -- bytes encoding "Seq (TxWits era)"
              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
            , -- bytes encoding a "Map Int TxAuxData"
              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

-- | Hash a given block body
bbHash :: ShelleyTxSeq era -> Hash HASH EraIndependentBlockBody
bbHash :: forall era. ShelleyTxSeq era -> Hash HASH 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 HASH 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 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 -> ByteString
hashPart = forall h a. Hash h a -> ByteString
Hash.hashToBytes 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

-- | Given a size and a mapping from indices to maybe metadata,
--  return a sequence whose size is the size paramater and
--  whose non-Nothing values correspond to the values in the mapping.
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])

-- | 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 TxSeq, used in decoding a Block.
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 -- TODO this PR introduces this new test, That didn't used to run in the Shelley
        (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)) -- Era,  Is it possible there might be some blocks, that should have been caught on the chain?
        (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 ->
  BlocksMade ->
  BlocksMade
incrBlocks :: Bool -> KeyHash 'StakePool -> BlocksMade -> BlocksMade
incrBlocks Bool
isOverlay KeyHash 'StakePool
hk b' :: BlocksMade
b'@(BlocksMade Map (KeyHash 'StakePool) Natural
b)
  | Bool
isOverlay = BlocksMade
b'
  | Bool
otherwise = Map (KeyHash 'StakePool) Natural -> BlocksMade
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
hk Natural
1 Map (KeyHash 'StakePool) Natural
b
      Just Natural
n -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash 'StakePool
hk (Natural
n forall a. Num a => a -> a -> a
+ Natural
1) Map (KeyHash 'StakePool) Natural
b
  where
    hkVal :: Maybe Natural
hkVal = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
hk Map (KeyHash 'StakePool) Natural
b