{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.Block (
  Block (..),
  neededTxInsForBlock,
) where

import Cardano.Ledger.Binary (
  Annotator,
  DecCBOR (decCBOR),
  EncCBOR (..),
  EncCBORGroup (..),
  decodeRecordNamed,
  encodeListLen,
  toPlainEncoding,
 )
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Core
import Cardano.Ledger.TxIn (TxIn (..))
import Data.Foldable (toList)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks (..))

data Block h era = Block
  { forall h era. Block h era -> h
blockHeader :: !h
  , forall h era. Block h era -> BlockBody era
blockBody :: !(BlockBody era)
  }
  deriving ((forall x. Block h era -> Rep (Block h era) x)
-> (forall x. Rep (Block h era) x -> Block h era)
-> Generic (Block h era)
forall x. Rep (Block h era) x -> Block h era
forall x. Block h era -> Rep (Block h era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall h era x. Rep (Block h era) x -> Block h era
forall h era x. Block h era -> Rep (Block h era) x
$cfrom :: forall h era x. Block h era -> Rep (Block h era) x
from :: forall x. Block h era -> Rep (Block h era) x
$cto :: forall h era x. Rep (Block h era) x -> Block h era
to :: forall x. Rep (Block h era) x -> Block h era
Generic)

deriving stock instance
  (Era era, Show (BlockBody era), Show h) =>
  Show (Block h era)

deriving stock instance
  (Era era, Eq (BlockBody era), Eq h) =>
  Eq (Block h era)

deriving anyclass instance
  ( Era era
  , NoThunks (BlockBody era)
  , NoThunks h
  ) =>
  NoThunks (Block h era)

instance
  forall era h.
  ( Era era
  , EncCBORGroup (BlockBody era)
  , EncCBOR h
  ) =>
  EncCBOR (Block h era)
  where
  encCBOR :: Block h era -> Encoding
encCBOR (Block h
h BlockBody era
txns) =
    Word -> Encoding
encodeListLen (Word
1 Word -> Word -> Word
forall a. Num a => a -> a -> a
+ BlockBody era -> Word
forall a. EncCBORGroup a => a -> Word
listLen BlockBody era
txns) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> h -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR h
h Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> BlockBody era -> Encoding
forall a. EncCBORGroup a => a -> Encoding
encCBORGroup BlockBody era
txns

instance
  forall era h.
  ( Era era
  , EncCBORGroup (BlockBody era)
  , EncCBOR h
  , Typeable h
  ) =>
  Plain.ToCBOR (Block h era)
  where
  toCBOR :: Block h era -> Encoding
toCBOR = Version -> Encoding -> Encoding
toPlainEncoding (forall era. Era era => Version
eraProtVerLow @era) (Encoding -> Encoding)
-> (Block h era -> Encoding) -> Block h era -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block h era -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR

instance
  ( EraBlockBody era
  , DecCBOR (Annotator h)
  , Typeable h
  ) =>
  DecCBOR (Annotator (Block h era))
  where
  decCBOR :: forall s. Decoder s (Annotator (Block h era))
decCBOR = Text
-> (Annotator (Block h era) -> Int)
-> Decoder s (Annotator (Block h era))
-> Decoder s (Annotator (Block h era))
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"Block" (Int -> Annotator (Block h era) -> Int
forall a b. a -> b -> a
const Int
blockSize) (Decoder s (Annotator (Block h era))
 -> Decoder s (Annotator (Block h era)))
-> Decoder s (Annotator (Block h era))
-> Decoder s (Annotator (Block h era))
forall a b. (a -> b) -> a -> b
$ do
    header <- Decoder s (Annotator h)
forall s. Decoder s (Annotator h)
forall a s. DecCBOR a => Decoder s a
decCBOR
    txns <- decCBOR
    pure $ Block <$> header <*> txns
    where
      blockSize :: Int
blockSize = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall era. EraBlockBody era => Word64
numSegComponents @era)

-- | The validity of any individual block depends only on a subset
-- of the UTxO stored in the ledger state. This function returns
-- the transaction inputs corresponding to the required UTxO for a
-- given Block.
--
-- This function will be used by the consensus layer to enable storing
-- the UTxO on disk. In particular, given a block, the consensus layer
-- will use 'neededTxInsForBlock' to retrieve the needed UTxO from disk
-- and present only those to the ledger.
neededTxInsForBlock ::
  forall h era.
  EraBlockBody era =>
  Block h era ->
  Set TxIn
neededTxInsForBlock :: forall h era. EraBlockBody era => Block h era -> Set TxIn
neededTxInsForBlock Block {BlockBody era
blockBody :: forall h era. Block h era -> BlockBody era
blockBody :: BlockBody era
blockBody} = (TxIn -> Bool) -> Set TxIn -> Set TxIn
forall a. (a -> Bool) -> Set a -> Set a
Set.filter TxIn -> Bool
isNotNewInput Set TxIn
allTxIns
  where
    txBodies :: [TxBody TopTx era]
txBodies = (Tx TopTx era -> TxBody TopTx era)
-> [Tx TopTx era] -> [TxBody TopTx era]
forall a b. (a -> b) -> [a] -> [b]
map (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) ([Tx TopTx era] -> [TxBody TopTx era])
-> [Tx TopTx era] -> [TxBody TopTx era]
forall a b. (a -> b) -> a -> b
$ StrictSeq (Tx TopTx era) -> [Tx TopTx era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (Tx TopTx era) -> [Tx TopTx era])
-> StrictSeq (Tx TopTx era) -> [Tx TopTx era]
forall a b. (a -> b) -> a -> b
$ BlockBody era
blockBody BlockBody era
-> Getting
     (StrictSeq (Tx TopTx era))
     (BlockBody era)
     (StrictSeq (Tx TopTx era))
-> StrictSeq (Tx TopTx era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (Tx TopTx era))
  (BlockBody era)
  (StrictSeq (Tx TopTx era))
forall era.
EraBlockBody era =>
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
txSeqBlockBodyL
    allTxIns :: Set TxIn
allTxIns = [Set TxIn] -> Set TxIn
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set TxIn] -> Set TxIn) -> [Set TxIn] -> Set TxIn
forall a b. (a -> b) -> a -> b
$ (TxBody TopTx era -> Set TxIn) -> [TxBody TopTx era] -> [Set TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (TxBody TopTx era
-> Getting (Set TxIn) (TxBody TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx era) (Set TxIn)
forall era.
EraTxBody era =>
SimpleGetter (TxBody TopTx era) (Set TxIn)
SimpleGetter (TxBody TopTx era) (Set TxIn)
allInputsTxBodyF) [TxBody TopTx era]
txBodies
    newTxIds :: Set TxId
newTxIds = [TxId] -> Set TxId
forall a. Ord a => [a] -> Set a
Set.fromList ([TxId] -> Set TxId) -> [TxId] -> Set TxId
forall a b. (a -> b) -> a -> b
$ (TxBody TopTx era -> TxId) -> [TxBody TopTx era] -> [TxId]
forall a b. (a -> b) -> [a] -> [b]
map TxBody TopTx era -> TxId
forall era (l :: TxLevel). EraTxBody era => TxBody l era -> TxId
txIdTxBody [TxBody TopTx era]
txBodies
    isNotNewInput :: TxIn -> Bool
isNotNewInput (TxIn TxId
txId TxIx
_) = TxId
txId TxId -> Set TxId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set TxId
newTxIds