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

module Cardano.Ledger.Block
  ( Block (Block, Block', UnserialisedBlock, UnsafeUnserialisedBlock),
    BlockAnn,
    bheader,
    bbody,
    neededTxInsForBlock,
  )
where

import Cardano.Binary
  ( Annotator (..),
    FromCBOR (fromCBOR),
    ToCBOR (..),
    annotatorSlice,
    encodeListLen,
    encodePreEncoded,
    serializeEncoding,
  )
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Era (Crypto, Era (getAllTxInputs), ValidateScript (..))
import qualified Cardano.Ledger.Era as Era
import Cardano.Ledger.Serialization
  ( ToCBORGroup (..),
    decodeRecordNamed,
  )
import Cardano.Ledger.TxIn (TxIn (..), txid)
import qualified Data.ByteString.Lazy as BSL
import Data.Foldable (toList)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Typeable
import GHC.Generics (Generic)
import GHC.Records (HasField (..))
import NoThunks.Class (NoThunks (..))

data Block h era
  = Block' !h !(Era.TxSeq era) BSL.ByteString
  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
$cto :: forall h era x. Rep (Block h era) x -> Block h era
$cfrom :: forall h era x. Block h era -> Rep (Block h era) x
Generic)

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

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

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

pattern Block ::
  ( Era era,
    ToCBORGroup (Era.TxSeq era),
    ToCBOR h
  ) =>
  h ->
  Era.TxSeq era ->
  Block h era
pattern $bBlock :: h -> TxSeq era -> Block h era
$mBlock :: forall r era h.
(Era era, ToCBORGroup (TxSeq era), ToCBOR h) =>
Block h era -> (h -> TxSeq era -> r) -> (Void# -> r) -> r
Block h txns <-
  Block' h txns _
  where
    Block h
h TxSeq era
txns =
      let bytes :: LByteString
bytes =
            Encoding -> LByteString
serializeEncoding (Encoding -> LByteString) -> Encoding -> LByteString
forall a b. (a -> b) -> a -> b
$
              Word -> Encoding
encodeListLen (Word
1 Word -> Word -> Word
forall a. Num a => a -> a -> a
+ TxSeq era -> Word
forall a. ToCBORGroup a => a -> Word
listLen TxSeq era
txns) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> h -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR h
h Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> TxSeq era -> Encoding
forall a. ToCBORGroup a => a -> Encoding
toCBORGroup TxSeq era
txns
       in h -> TxSeq era -> LByteString -> Block h era
forall h era. h -> TxSeq era -> LByteString -> Block h era
Block' h
h TxSeq era
txns LByteString
bytes

{-# COMPLETE Block #-}

-- | Access a block without its serialised bytes. This is often useful when
-- we're using a 'BHeaderView' in place of the concrete header.
pattern UnserialisedBlock ::
  h ->
  Era.TxSeq era ->
  Block h era
pattern $mUnserialisedBlock :: forall r h era.
Block h era -> (h -> TxSeq era -> r) -> (Void# -> r) -> r
UnserialisedBlock h txns <- Block' h txns _

{-# COMPLETE UnserialisedBlock #-}

-- | Unsafely construct a block without the ability to serialise its bytes.
--
--   Anyone calling this pattern must ensure that the resulting block is never
--   serialised. Any uses of this pattern outside of testing code should be
--   regarded with suspicion.
pattern UnsafeUnserialisedBlock ::
  h ->
  Era.TxSeq era ->
  Block h era
pattern $bUnsafeUnserialisedBlock :: h -> TxSeq era -> Block h era
$mUnsafeUnserialisedBlock :: forall r h era.
Block h era -> (h -> TxSeq era -> r) -> (Void# -> r) -> r
UnsafeUnserialisedBlock h txns <-
  Block' h txns _
  where
    UnsafeUnserialisedBlock h
h TxSeq era
txns =
      let bytes :: a
bytes = String -> a
forall a. HasCallStack => String -> a
error String
"`UnsafeUnserialisedBlock` used to construct a block which was later serialised."
       in h -> TxSeq era -> LByteString -> Block h era
forall h era. h -> TxSeq era -> LByteString -> Block h era
Block' h
h TxSeq era
txns LByteString
forall a. a
bytes

{-# COMPLETE UnsafeUnserialisedBlock #-}

instance
  (Era era, Typeable h) =>
  ToCBOR (Block h era)
  where
  toCBOR :: Block h era -> Encoding
toCBOR (Block' h
_ TxSeq era
_ LByteString
blockBytes) = ByteString -> Encoding
encodePreEncoded (ByteString -> Encoding) -> ByteString -> Encoding
forall a b. (a -> b) -> a -> b
$ LByteString -> ByteString
BSL.toStrict LByteString
blockBytes

type BlockAnn era =
  ( FromCBOR (Annotator (Core.TxBody era)),
    FromCBOR (Annotator (Core.AuxiliaryData era)),
    FromCBOR (Annotator (Core.Witnesses era)),
    ToCBOR (Core.TxBody era),
    ToCBOR (Core.AuxiliaryData era),
    ToCBOR (Core.Witnesses era)
  )

instance
  forall h era.
  ( BlockAnn era,
    ValidateScript era,
    Era.SupportsSegWit era,
    FromCBOR (Annotator (Era.TxSeq era)),
    FromCBOR (Annotator h),
    Typeable h
  ) =>
  FromCBOR (Annotator (Block h era))
  where
  fromCBOR :: Decoder s (Annotator (Block h era))
fromCBOR = Decoder s (Annotator (LByteString -> Block h era))
-> Decoder s (Annotator (Block h era))
forall s a.
Decoder s (Annotator (LByteString -> a)) -> Decoder s (Annotator a)
annotatorSlice (Decoder s (Annotator (LByteString -> Block h era))
 -> Decoder s (Annotator (Block h era)))
-> Decoder s (Annotator (LByteString -> Block h era))
-> Decoder s (Annotator (Block h era))
forall a b. (a -> b) -> a -> b
$
    Text
-> (Annotator (LByteString -> Block h era) -> Int)
-> Decoder s (Annotator (LByteString -> Block h era))
-> Decoder s (Annotator (LByteString -> Block h era))
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"Block" (Int -> Annotator (LByteString -> Block h era) -> Int
forall a b. a -> b -> a
const Int
blockSize) (Decoder s (Annotator (LByteString -> Block h era))
 -> Decoder s (Annotator (LByteString -> Block h era)))
-> Decoder s (Annotator (LByteString -> Block h era))
-> Decoder s (Annotator (LByteString -> Block h era))
forall a b. (a -> b) -> a -> b
$ do
      Annotator h
header <- Decoder s (Annotator h)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Annotator (TxSeq era)
txns <- Decoder s (Annotator (TxSeq era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Annotator (LByteString -> Block h era)
-> Decoder s (Annotator (LByteString -> Block h era))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotator (LByteString -> Block h era)
 -> Decoder s (Annotator (LByteString -> Block h era)))
-> Annotator (LByteString -> Block h era)
-> Decoder s (Annotator (LByteString -> Block h era))
forall a b. (a -> b) -> a -> b
$ h -> TxSeq era -> LByteString -> Block h era
forall h era. h -> TxSeq era -> LByteString -> Block h era
Block' (h -> TxSeq era -> LByteString -> Block h era)
-> Annotator h
-> Annotator (TxSeq era -> LByteString -> Block h era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator h
header Annotator (TxSeq era -> LByteString -> Block h era)
-> Annotator (TxSeq era) -> Annotator (LByteString -> Block h era)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator (TxSeq era)
txns
    where
      blockSize :: Int
blockSize =
        Int
1 -- header
          Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SupportsSegWit era => Word64
forall era. SupportsSegWit era => Word64
Era.numSegComponents @era)

bheader ::
  Block h era ->
  h
bheader :: Block h era -> h
bheader (Block' h
bh TxSeq era
_ LByteString
_) = h
bh

bbody :: Block h era -> Era.TxSeq era
bbody :: Block h era -> TxSeq era
bbody (Block' h
_ TxSeq era
txs LByteString
_) = 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 ::
  Era era =>
  Block h era ->
  Set (TxIn (Crypto era))
neededTxInsForBlock :: Block h era -> Set (TxIn (Crypto era))
neededTxInsForBlock (Block' h
_ TxSeq era
txsSeq LByteString
_) = (TxIn (Crypto era) -> Bool)
-> Set (TxIn (Crypto era)) -> Set (TxIn (Crypto era))
forall a. (a -> Bool) -> Set a -> Set a
Set.filter TxIn (Crypto era) -> Bool
isNotNewInput Set (TxIn (Crypto era))
allTxIns
  where
    txBodies :: [TxBody era]
txBodies = (Tx era -> TxBody era) -> [Tx era] -> [TxBody era]
forall a b. (a -> b) -> [a] -> [b]
map (forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "body" r a => r -> a
getField @"body") ([Tx era] -> [TxBody era]) -> [Tx era] -> [TxBody era]
forall a b. (a -> b) -> a -> b
$ StrictSeq (Tx era) -> [Tx era]
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. SupportsSegWit era => TxSeq era -> StrictSeq (Tx era)
Era.fromTxSeq TxSeq era
txsSeq
    allTxIns :: Set (TxIn (Crypto era))
allTxIns = [Set (TxIn (Crypto era))] -> Set (TxIn (Crypto era))
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set (TxIn (Crypto era))] -> Set (TxIn (Crypto era)))
-> [Set (TxIn (Crypto era))] -> Set (TxIn (Crypto era))
forall a b. (a -> b) -> a -> b
$ (TxBody era -> Set (TxIn (Crypto era)))
-> [TxBody era] -> [Set (TxIn (Crypto era))]
forall a b. (a -> b) -> [a] -> [b]
map TxBody era -> Set (TxIn (Crypto era))
forall e. Era e => TxBody e -> Set (TxIn (Crypto e))
getAllTxInputs [TxBody era]
txBodies
    newTxIds :: Set (TxId (Crypto era))
newTxIds = [TxId (Crypto era)] -> Set (TxId (Crypto era))
forall a. Ord a => [a] -> Set a
Set.fromList ([TxId (Crypto era)] -> Set (TxId (Crypto era)))
-> [TxId (Crypto era)] -> Set (TxId (Crypto era))
forall a b. (a -> b) -> a -> b
$ (TxBody era -> TxId (Crypto era))
-> [TxBody era] -> [TxId (Crypto era)]
forall a b. (a -> b) -> [a] -> [b]
map TxBody era -> TxId (Crypto era)
forall era c.
(HashAlgorithm (HASH c),
 HashAnnotated (TxBody era) EraIndependentTxBody c) =>
TxBody era -> TxId c
txid [TxBody era]
txBodies
    isNotNewInput :: TxIn (Crypto era) -> Bool
isNotNewInput (TxIn TxId (Crypto era)
txID TxIx
_) = TxId (Crypto era)
txID TxId (Crypto era) -> Set (TxId (Crypto era)) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (TxId (Crypto era))
newTxIds