{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Cardano.Ledger.State.UTxO (
  CanGetUTxO (..),
  CanSetUTxO (..),

  -- * Primitives
  UTxO (..),
  EraUTxO (..),
  ScriptsProvided (..),

  -- * Functions
  txins,
  txinLookup,
  txInsFilter,
  txouts,
  sumUTxO,
  sumCoinUTxO,
  balance,
  coinBalance,
  sumAllValue,
  sumAllCoin,
  areAllAdaOnly,
  verifyWitVKey,
  getScriptHash,
) where

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Binary (
  DecCBOR (..),
  DecShareCBOR (Share, decShareCBOR),
  EncCBOR (..),
  FromCBOR (..),
  Interns,
  ToCBOR (..),
  decNoShareCBOR,
  decodeMap,
 )
import Cardano.Ledger.Coin (Coin, CompactForm (CompactCoin))
import Cardano.Ledger.Compactible (Compactible (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Keys (verifySignedDSIGN)
import Cardano.Ledger.Keys.WitVKey (WitVKey (..))
import Cardano.Ledger.State.CertState (CertState)
import Cardano.Ledger.TxIn (TxIn (..))
import Control.DeepSeq (NFData)
import Control.Monad ((<$!>))
import Data.Aeson (ToJSON)
import Data.Coerce (coerce)
import Data.Default (Default)
import Data.Foldable (foldMap', toList)
import Data.Kind (Type)
import qualified Data.Map.Strict as Map
import Data.Monoid (Sum (..))
import Data.Set (Set)
import GHC.Generics (Generic)
import Lens.Micro (Lens', SimpleGetter, (^.))
import NoThunks.Class (NoThunks (..))
import Quiet (Quiet (Quiet))

-- ===============================================

class CanGetUTxO t where
  utxoG :: SimpleGetter (t era) (UTxO era)
  default utxoG :: CanSetUTxO t => SimpleGetter (t era) (UTxO era)
  utxoG = (UTxO era -> Const r (UTxO era)) -> t era -> Const r (t era)
forall era. Lens' (t era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
utxoL
  {-# INLINE utxoG #-}

class CanGetUTxO t => CanSetUTxO t where
  utxoL :: Lens' (t era) (UTxO era)

instance CanGetUTxO UTxO

instance CanSetUTxO UTxO where
  utxoL :: forall era. Lens' (UTxO era) (UTxO era)
utxoL = (UTxO era -> f (UTxO era)) -> UTxO era -> f (UTxO era)
forall a. a -> a
id

-- | The unspent transaction outputs.
newtype UTxO era = UTxO {forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO :: Map.Map TxIn (TxOut era)}
  deriving (UTxO era
UTxO era -> Default (UTxO era)
forall era. UTxO era
forall a. a -> Default a
$cdef :: forall era. UTxO era
def :: UTxO era
Default, (forall x. UTxO era -> Rep (UTxO era) x)
-> (forall x. Rep (UTxO era) x -> UTxO era) -> Generic (UTxO era)
forall x. Rep (UTxO era) x -> UTxO era
forall x. UTxO era -> Rep (UTxO era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (UTxO era) x -> UTxO era
forall era x. UTxO era -> Rep (UTxO era) x
$cfrom :: forall era x. UTxO era -> Rep (UTxO era) x
from :: forall x. UTxO era -> Rep (UTxO era) x
$cto :: forall era x. Rep (UTxO era) x -> UTxO era
to :: forall x. Rep (UTxO era) x -> UTxO era
Generic, NonEmpty (UTxO era) -> UTxO era
UTxO era -> UTxO era -> UTxO era
(UTxO era -> UTxO era -> UTxO era)
-> (NonEmpty (UTxO era) -> UTxO era)
-> (forall b. Integral b => b -> UTxO era -> UTxO era)
-> Semigroup (UTxO era)
forall b. Integral b => b -> UTxO era -> UTxO era
forall era. NonEmpty (UTxO era) -> UTxO era
forall era. UTxO era -> UTxO era -> UTxO era
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall era b. Integral b => b -> UTxO era -> UTxO era
$c<> :: forall era. UTxO era -> UTxO era -> UTxO era
<> :: UTxO era -> UTxO era -> UTxO era
$csconcat :: forall era. NonEmpty (UTxO era) -> UTxO era
sconcat :: NonEmpty (UTxO era) -> UTxO era
$cstimes :: forall era b. Integral b => b -> UTxO era -> UTxO era
stimes :: forall b. Integral b => b -> UTxO era -> UTxO era
Semigroup)

instance (EncCBOR (TxOut era), Era era) => ToCBOR (UTxO era) where
  toCBOR :: UTxO era -> Encoding
toCBOR = forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @era

instance (DecCBOR (TxOut era), Era era) => FromCBOR (UTxO era) where
  fromCBOR :: forall s. Decoder s (UTxO era)
fromCBOR = forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @era

deriving instance NoThunks (TxOut era) => NoThunks (UTxO era)

deriving instance (Era era, NFData (TxOut era)) => NFData (UTxO era)

deriving newtype instance (Era era, Eq (TxOut era)) => Eq (UTxO era)

deriving newtype instance Era era => Monoid (UTxO era)

deriving newtype instance (Era era, EncCBOR (TxOut era)) => EncCBOR (UTxO era)

deriving newtype instance (Era era, DecCBOR (TxOut era)) => DecCBOR (UTxO era)

instance
  ( DecShareCBOR (TxOut era)
  , Share (TxOut era) ~ Interns (Credential 'Staking)
  ) =>
  DecShareCBOR (UTxO era)
  where
  type Share (UTxO era) = Interns (Credential 'Staking)
  decShareCBOR :: forall s. Share (UTxO era) -> Decoder s (UTxO era)
decShareCBOR Share (UTxO era)
credsInterns =
    Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut era) -> UTxO era)
-> Decoder s (Map TxIn (TxOut era)) -> Decoder s (UTxO era)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Decoder s TxIn
-> Decoder s (TxOut era) -> Decoder s (Map TxIn (TxOut era))
forall k s v.
Ord k =>
Decoder s k -> Decoder s v -> Decoder s (Map k v)
decodeMap Decoder s TxIn
forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR (Share (TxOut era) -> Decoder s (TxOut era)
forall a s. DecShareCBOR a => Share a -> Decoder s a
forall s. Share (TxOut era) -> Decoder s (TxOut era)
decShareCBOR Share (TxOut era)
Share (UTxO era)
credsInterns)

deriving via
  Quiet (UTxO era)
  instance
    Show (TxOut era) => Show (UTxO era)

deriving newtype instance ToJSON (TxOut era) => ToJSON (UTxO era)

-- | Compute the UTxO inputs of a transaction.
-- txins has the same problems as txouts, see notes below.
txins ::
  EraTxBody era =>
  TxBody era ->
  Set TxIn
txins :: forall era. EraTxBody era => TxBody era -> Set TxIn
txins = (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 => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL)

-- | Compute the transaction outputs of a transaction.
txouts ::
  forall era.
  EraTxBody era =>
  TxBody era ->
  UTxO era
txouts :: forall era. EraTxBody era => TxBody era -> UTxO era
txouts TxBody era
txBody =
  Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut era) -> UTxO era)
-> Map TxIn (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$
    [(TxIn, TxOut era)] -> Map TxIn (TxOut era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (TxId -> TxIx -> TxIn
TxIn TxId
transId TxIx
idx, TxOut era
out)
      | (TxOut era
out, TxIx
idx) <- [TxOut era] -> [TxIx] -> [(TxOut era, TxIx)]
forall a b. [a] -> [b] -> [(a, b)]
zip (StrictSeq (TxOut era) -> [TxOut era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (TxOut era) -> [TxOut era])
-> StrictSeq (TxOut era) -> [TxOut era]
forall a b. (a -> b) -> a -> b
$ TxBody era
txBody TxBody era
-> Getting
     (StrictSeq (TxOut era)) (TxBody era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxOut era)) (TxBody era) (StrictSeq (TxOut era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL) [TxIx
forall a. Bounded a => a
minBound ..]
      ]
  where
    transId :: TxId
transId = TxBody era -> TxId
forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody era
txBody

-- | Lookup a txin for a given UTxO collection
txinLookup ::
  TxIn ->
  UTxO era ->
  Maybe (TxOut era)
txinLookup :: forall era. TxIn -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn
txin (UTxO Map TxIn (TxOut era)
utxo') = TxIn -> Map TxIn (TxOut era) -> Maybe (TxOut era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
txin Map TxIn (TxOut era)
utxo'

-- | Filter out TxIn's from the `UTxO` map
txInsFilter ::
  -- | Source `UTxO`
  UTxO era ->
  -- | Which of the `TxIn`s you would like to keep.
  Set TxIn ->
  UTxO era
txInsFilter :: forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter (UTxO Map TxIn (TxOut era)
utxo') Set TxIn
txIns = Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut era)
utxo' Map TxIn (TxOut era) -> Set TxIn -> Map TxIn (TxOut era)
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set TxIn
txIns)

-- | Verify a transaction body witness
verifyWitVKey ::
  Hash HASH EraIndependentTxBody ->
  WitVKey kr ->
  Bool
verifyWitVKey :: forall (kr :: KeyRole).
Hash HASH EraIndependentTxBody -> WitVKey kr -> Bool
verifyWitVKey Hash HASH EraIndependentTxBody
txbodyHash (WitVKey VKey kr
vkey SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
sig) = VKey kr
-> Hash HASH EraIndependentTxBody
-> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
-> Bool
forall a (kd :: KeyRole).
Signable DSIGN a =>
VKey kd -> a -> SignedDSIGN DSIGN a -> Bool
verifySignedDSIGN VKey kr
vkey Hash HASH EraIndependentTxBody
txbodyHash (SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
-> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
forall a b. Coercible a b => a -> b
coerce SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
sig)
{-# INLINE verifyWitVKey #-}

-- | Determine the total balance contained in the UTxO.
sumUTxO :: EraTxOut era => UTxO era -> Value era
sumUTxO :: forall era. EraTxOut era => UTxO era -> Value era
sumUTxO = Map TxIn (TxOut era) -> Value era
forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Value era
sumAllValue (Map TxIn (TxOut era) -> Value era)
-> (UTxO era -> Map TxIn (TxOut era)) -> UTxO era -> Value era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO
{-# INLINE sumUTxO #-}

balance :: EraTxOut era => UTxO era -> Value era
balance :: forall era. EraTxOut era => UTxO era -> Value era
balance = UTxO era -> Value era
forall era. EraTxOut era => UTxO era -> Value era
sumUTxO
{-# DEPRECATED balance "In favor of `sumUTxO`" #-}

-- | Determine the total Ada only balance contained in the UTxO. This is
-- equivalent to `coin` . `sumUTxO`, but it will be more efficient.
--
-- /Warning/ - This function cannot be applied to an untrusted `UTxO`, since it is susceptible to
-- overflow
sumCoinUTxO :: EraTxOut era => UTxO era -> Coin
sumCoinUTxO :: forall era. EraTxOut era => UTxO era -> Coin
sumCoinUTxO = Map TxIn (TxOut era) -> Coin
forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Coin
sumAllCoin (Map TxIn (TxOut era) -> Coin)
-> (UTxO era -> Map TxIn (TxOut era)) -> UTxO era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO
{-# INLINE sumCoinUTxO #-}

coinBalance :: EraTxOut era => UTxO era -> Coin
coinBalance :: forall era. EraTxOut era => UTxO era -> Coin
coinBalance = UTxO era -> Coin
forall era. EraTxOut era => UTxO era -> Coin
sumCoinUTxO
{-# DEPRECATED coinBalance "In favor of `sumCoinUTxO`" #-}

-- | Sum all the value in any Foldable with 'TxOut's
sumAllValue :: (EraTxOut era, Foldable f) => f (TxOut era) -> Value era
sumAllValue :: forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Value era
sumAllValue = (TxOut era -> Value era) -> f (TxOut era) -> Value era
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (TxOut era
-> Getting (Value era) (TxOut era) (Value era) -> Value era
forall s a. s -> Getting a s a -> a
^. Getting (Value era) (TxOut era) (Value era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL)
{-# INLINE sumAllValue #-}

-- | Sum all the 'Coin's in any Foldable with with 'TxOut's.
--
-- /Warning/ - Care should be taken since it is susceptible to integer overflow, therefore make sure
-- this function is not applied to unvalidated 'TxOut's
sumAllCoin :: (EraTxOut era, Foldable f) => f (TxOut era) -> Coin
sumAllCoin :: forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Coin
sumAllCoin = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin)
-> (f (TxOut era) -> CompactForm Coin) -> f (TxOut era) -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> CompactForm Coin
CompactCoin (Word64 -> CompactForm Coin)
-> (f (TxOut era) -> Word64) -> f (TxOut era) -> CompactForm Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum Word64 -> Word64
forall a. Sum a -> a
getSum (Sum Word64 -> Word64)
-> (f (TxOut era) -> Sum Word64) -> f (TxOut era) -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut era -> Sum Word64) -> f (TxOut era) -> Sum Word64
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' TxOut era -> Sum Word64
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era) =>
TxOut era -> Sum Word64
getCoinWord64
  where
    getCoinWord64 :: TxOut era -> Sum Word64
getCoinWord64 TxOut era
txOut =
      case TxOut era
txOut TxOut era
-> Getting (CompactForm Coin) (TxOut era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (TxOut era) (CompactForm Coin)
forall era.
(HasCallStack, EraTxOut era) =>
Lens' (TxOut era) (CompactForm Coin)
Lens' (TxOut era) (CompactForm Coin)
compactCoinTxOutL of
        CompactCoin Word64
w64 -> Word64 -> Sum Word64
forall a. a -> Sum a
Sum Word64
w64
{-# INLINE sumAllCoin #-}

-- | Check whether any of the supplied 'TxOut's contain any MultiAssets. Returns
-- True if non of them do.
areAllAdaOnly :: (EraTxOut era, Foldable f) => f (TxOut era) -> Bool
areAllAdaOnly :: forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Bool
areAllAdaOnly = (TxOut era -> Bool) -> f (TxOut era) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TxOut era -> Getting Bool (TxOut era) Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool (TxOut era) Bool
forall era. EraTxOut era => SimpleGetter (TxOut era) Bool
SimpleGetter (TxOut era) Bool
isAdaOnlyTxOutF)
{-# INLINE areAllAdaOnly #-}

-- | Extract script hash from value address with script.
getScriptHash :: Addr -> Maybe ScriptHash
getScriptHash :: Addr -> Maybe ScriptHash
getScriptHash (Addr Network
_ (ScriptHashObj ScriptHash
hs) StakeReference
_) = ScriptHash -> Maybe ScriptHash
forall a. a -> Maybe a
Just ScriptHash
hs
getScriptHash Addr
_ = Maybe ScriptHash
forall a. Maybe a
Nothing

-- | The only reason it is a newtype instead of just a Map is becuase for later eras is
-- expensive to compute the actual map, so we want to use the type safety guidance to
-- avoid redundant work.
newtype ScriptsProvided era = ScriptsProvided
  { forall era. ScriptsProvided era -> Map ScriptHash (Script era)
unScriptsProvided :: Map.Map ScriptHash (Script era)
  }
  deriving ((forall x. ScriptsProvided era -> Rep (ScriptsProvided era) x)
-> (forall x. Rep (ScriptsProvided era) x -> ScriptsProvided era)
-> Generic (ScriptsProvided era)
forall x. Rep (ScriptsProvided era) x -> ScriptsProvided era
forall x. ScriptsProvided era -> Rep (ScriptsProvided era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ScriptsProvided era) x -> ScriptsProvided era
forall era x. ScriptsProvided era -> Rep (ScriptsProvided era) x
$cfrom :: forall era x. ScriptsProvided era -> Rep (ScriptsProvided era) x
from :: forall x. ScriptsProvided era -> Rep (ScriptsProvided era) x
$cto :: forall era x. Rep (ScriptsProvided era) x -> ScriptsProvided era
to :: forall x. Rep (ScriptsProvided era) x -> ScriptsProvided era
Generic)

deriving instance (Era era, Eq (Script era)) => Eq (ScriptsProvided era)

deriving instance (Era era, Ord (Script era)) => Ord (ScriptsProvided era)

deriving instance (Era era, Show (Script era)) => Show (ScriptsProvided era)

deriving instance (Era era, NFData (Script era)) => NFData (ScriptsProvided era)

class EraTx era => EraUTxO era where
  -- | A customizable type on per era basis for the information required to find all
  -- scripts needed for the transaction.
  type ScriptsNeeded era = (r :: Type) | r -> era

  consumed :: PParams era -> CertState era -> UTxO era -> TxBody era -> Value era

  -- | Calculate all the value that is being consumed by the transaction.
  getConsumedValue ::
    PParams era ->
    -- | Function that can lookup current delegation deposits
    (Credential 'Staking -> Maybe Coin) ->
    -- | Function that can lookup current drep deposits
    (Credential 'DRepRole -> Maybe Coin) ->
    UTxO era ->
    TxBody era ->
    Value era

  getProducedValue ::
    PParams era ->
    -- | Check whether a pool with a supplied PoolStakeId is already registered.
    (KeyHash 'StakePool -> Bool) ->
    TxBody era ->
    Value era

  -- | Initial eras will look into witness set to find all of the available scripts, but
  -- starting with Babbage we can look for available scripts in the UTxO using reference
  -- inputs.
  getScriptsProvided ::
    -- | For some era it is necessary to look into the UTxO to find all of the available
    -- scripts for the transaction
    UTxO era ->
    Tx era ->
    ScriptsProvided era

  -- | Produce all the information required for figuring out which scripts are required
  -- for the transaction to be valid, once those scripts are evaluated
  getScriptsNeeded :: UTxO era -> TxBody era -> ScriptsNeeded era

  -- | Extract the set of all script hashes that are needed for script validation.
  getScriptsHashesNeeded :: ScriptsNeeded era -> Set ScriptHash

  -- | Extract all of the KeyHash witnesses that are required for validating the transaction
  getWitsVKeyNeeded ::
    CertState era -> UTxO era -> TxBody era -> Set (KeyHash 'Witness)

  -- | Minimum fee computation, excluding witnesses and including ref scripts size
  getMinFeeTxUtxo :: PParams era -> Tx era -> UTxO era -> Coin