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

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

import Cardano.Ledger.Binary (
  Annotator (..),
  DecCBOR (decCBOR),
  EncCBOR (..),
  EncCBORGroup (..),
  annotatorSlice,
  decodeRecordNamed,
  encodeListLen,
  serialize,
 )
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Core
import Cardano.Ledger.TxIn (TxIn (..))
import qualified Data.ByteString.Lazy as BSL
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' !h !(TxSeq era) BSL.ByteString
  deriving (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 (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)

pattern Block ::
  forall era h.
  ( Era era
  , EncCBORGroup (TxSeq era)
  , EncCBOR h
  ) =>
  h ->
  TxSeq era ->
  Block h era
pattern $bBlock :: forall era h.
(Era era, EncCBORGroup (TxSeq era), EncCBOR h) =>
h -> TxSeq era -> Block h era
$mBlock :: forall {r} {era} {h}.
(Era era, EncCBORGroup (TxSeq era), EncCBOR h) =>
Block h era -> (h -> TxSeq era -> r) -> ((# #) -> r) -> r
Block h txns <-
  Block' h txns _
  where
    Block h
h TxSeq era
txns =
      let bytes :: ByteString
bytes =
            forall a. EncCBOR a => Version -> a -> ByteString
serialize (forall era. Era era => Version
eraProtVerLow @era) forall a b. (a -> b) -> a -> b
$
              Word -> Encoding
encodeListLen (Word
1 forall a. Num a => a -> a -> a
+ forall a. EncCBORGroup a => a -> Word
listLen TxSeq era
txns) forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR h
h forall a. Semigroup a => a -> a -> a
<> forall a. EncCBORGroup a => a -> Encoding
encCBORGroup TxSeq era
txns
       in forall h era. h -> TxSeq era -> ByteString -> Block h era
Block' h
h TxSeq era
txns ByteString
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 ->
  TxSeq era ->
  Block h era
pattern $mUnserialisedBlock :: forall {r} {h} {era}.
Block h era -> (h -> TxSeq era -> r) -> ((# #) -> 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 ->
  TxSeq era ->
  Block h era
pattern $bUnsafeUnserialisedBlock :: forall h era. h -> TxSeq era -> Block h era
$mUnsafeUnserialisedBlock :: forall {r} {h} {era}.
Block h era -> (h -> TxSeq era -> r) -> ((# #) -> r) -> r
UnsafeUnserialisedBlock h txns <-
  Block' h txns _
  where
    UnsafeUnserialisedBlock h
h TxSeq era
txns =
      let bytes :: a
bytes = forall a. HasCallStack => String -> a
error String
"`UnsafeUnserialisedBlock` used to construct a block which was later serialised."
       in forall h era. h -> TxSeq era -> ByteString -> Block h era
Block' h
h TxSeq era
txns forall {a}. a
bytes

{-# COMPLETE UnsafeUnserialisedBlock #-}

instance (EraTx era, Typeable h) => EncCBOR (Block h era)

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

instance
  forall h era.
  ( EraSegWits era
  , DecCBOR (Annotator h)
  , Typeable h
  ) =>
  DecCBOR (Annotator (Block h era))
  where
  decCBOR :: forall s. Decoder s (Annotator (Block h era))
decCBOR = forall s a.
Decoder s (Annotator (ByteString -> a)) -> Decoder s (Annotator a)
annotatorSlice forall a b. (a -> b) -> a -> b
$
    forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"Block" (forall a b. a -> b -> a
const Int
blockSize) forall a b. (a -> b) -> a -> b
$ do
      Annotator h
header <- forall a s. DecCBOR a => Decoder s a
decCBOR
      Annotator (TxSeq era)
txns <- forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall h era. h -> TxSeq era -> ByteString -> Block h era
Block' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator h
header forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator (TxSeq era)
txns
    where
      blockSize :: Int
blockSize =
        Int
1 -- header
          forall a. Num a => a -> a -> a
+ 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
_ ByteString
_) = h
bh

bbody :: Block h era -> TxSeq era
bbody :: forall h era. Block h era -> TxSeq era
bbody (Block' h
_ TxSeq era
txs ByteString
_) = 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 (EraCrypto era))
neededTxInsForBlock :: forall h era.
EraSegWits era =>
Block h era -> Set (TxIn (EraCrypto era))
neededTxInsForBlock (Block' h
_ TxSeq era
txsSeq ByteString
_) = forall a. (a -> Bool) -> Set a -> Set a
Set.filter TxIn (EraCrypto era) -> Bool
isNotNewInput Set (TxIn (EraCrypto era))
allTxIns
  where
    txBodies :: [TxBody era]
txBodies = forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall era. EraSegWits era => TxSeq era -> StrictSeq (Tx era)
fromTxSeq TxSeq era
txsSeq
    allTxIns :: Set (TxIn (EraCrypto era))
allTxIns = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
SimpleGetter (TxBody era) (Set (TxIn (EraCrypto era)))
allInputsTxBodyF) [TxBody era]
txBodies
    newTxIds :: Set (TxId (EraCrypto era))
newTxIds = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall era. EraTxBody era => TxBody era -> TxId (EraCrypto era)
txIdTxBody [TxBody era]
txBodies
    isNotNewInput :: TxIn (EraCrypto era) -> Bool
isNotNewInput (TxIn TxId (EraCrypto era)
txID TxIx
_) = TxId (EraCrypto era)
txID forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (TxId (EraCrypto era))
newTxIds