{-# 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
  -- 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 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)

-- ===========================
-- 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 (AuxiliaryData 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 ::
  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

-- | 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 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