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

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

import Cardano.Ledger.Binary (
  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 GHC.Generics (Generic)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks (..))

data Block h era
  = Block !h !(TxSeq 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 (TxSeq era), Show h) =>
  Show (Block h era)

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

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

instance
  forall era h.
  ( Era era
  , EncCBORGroup (TxSeq era)
  , EncCBOR h
  ) =>
  EncCBOR (Block h era)
  where
  encCBOR :: Block h era -> Encoding
encCBOR (Block h
h TxSeq era
txns) =
    Word -> Encoding
encodeListLen (Word
1 Word -> Word -> Word
forall a. Num a => a -> a -> a
+ TxSeq era -> Word
forall a. EncCBORGroup a => a -> Word
listLen TxSeq 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
<> TxSeq era -> Encoding
forall a. EncCBORGroup a => a -> Encoding
encCBORGroup TxSeq era
txns

instance
  forall era h.
  ( Era era
  , EncCBORGroup (TxSeq era)
  , EncCBOR 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
  ( EraSegWits era
  , DecCBOR h
  ) =>
  DecCBOR (Block h era)
  where
  decCBOR :: forall s. Decoder s (Block h era)
decCBOR =
    Text
-> (Block h era -> Int)
-> Decoder s (Block h era)
-> Decoder s (Block h era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"Block" (Int -> Block h era -> Int
forall a b. a -> b -> a
const Int
blockSize) (Decoder s (Block h era) -> Decoder s (Block h era))
-> Decoder s (Block h era) -> Decoder s (Block h era)
forall a b. (a -> b) -> a -> b
$ h -> TxSeq era -> Block h era
forall h era. h -> TxSeq era -> Block h era
Block (h -> TxSeq era -> Block h era)
-> Decoder s h -> Decoder s (TxSeq era -> Block h era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s h
forall s. Decoder s h
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder s (TxSeq era -> Block h era)
-> Decoder s (TxSeq era) -> Decoder s (Block h era)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (TxSeq era)
forall s. Decoder s (TxSeq era)
forall a s. DecCBOR a => Decoder s a
decCBOR
    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. EraSegWits era => Word64
numSegComponents @era)

bheader ::
  Block h era ->
  h
bheader :: forall h era. Block h era -> h
bheader (Block h
bh TxSeq era
_) = h
bh

bbody :: Block h era -> TxSeq era
bbody :: forall h era. Block h era -> TxSeq era
bbody (Block h
_ TxSeq era
txs) = TxSeq era
txs

-- | 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.
  EraSegWits era =>
  Block h era ->
  Set TxIn
neededTxInsForBlock :: forall h era. EraSegWits era => Block h era -> Set TxIn
neededTxInsForBlock (Block h
_ TxSeq era
txsSeq) = (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 era]
txBodies = (Tx era -> TxBody era) -> [Tx era] -> [TxBody era]
forall a b. (a -> b) -> [a] -> [b]
map (Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL) ([Tx era] -> [TxBody era]) -> [Tx era] -> [TxBody era]
forall a b. (a -> b) -> a -> b
$ StrictSeq (Tx era) -> [Tx era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (Tx era) -> [Tx era]) -> StrictSeq (Tx era) -> [Tx era]
forall a b. (a -> b) -> a -> b
$ TxSeq era -> StrictSeq (Tx era)
forall era. EraSegWits era => TxSeq era -> StrictSeq (Tx era)
fromTxSeq TxSeq era
txsSeq
    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 era -> Set TxIn) -> [TxBody era] -> [Set TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => SimpleGetter (TxBody era) (Set TxIn)
SimpleGetter (TxBody era) (Set TxIn)
allInputsTxBodyF) [TxBody 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 era -> TxId) -> [TxBody era] -> [TxId]
forall a b. (a -> b) -> [a] -> [b]
map TxBody era -> TxId
forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody [TxBody 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