{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# 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.UTxO (
  -- * Primitives
  UTxO (..),
  EraUTxO (..),
  ScriptsProvided (..),

  -- * Functions
  txins,
  txinLookup,
  txInsFilter,
  txouts,
  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 (..),
  decodeMap,
 )
import Cardano.Ledger.CertState (CertState)
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.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 Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks (..))
import Quiet (Quiet (Quiet))

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

-- | 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
forall era. UTxO era
forall a. a -> Default a
def :: UTxO era
$cdef :: forall era. UTxO era
Default, 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
$cto :: forall era x. Rep (UTxO era) x -> UTxO era
$cfrom :: forall era x. UTxO era -> Rep (UTxO era) x
Generic, NonEmpty (UTxO era) -> UTxO era
UTxO era -> UTxO era -> 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
stimes :: forall b. Integral b => b -> UTxO era -> UTxO era
$cstimes :: forall era b. Integral b => b -> UTxO era -> UTxO era
sconcat :: NonEmpty (UTxO era) -> UTxO era
$csconcat :: forall era. NonEmpty (UTxO era) -> UTxO era
<> :: UTxO era -> UTxO era -> UTxO era
$c<> :: forall era. UTxO era -> 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 =
    forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> forall k s v.
Ord k =>
Decoder s k -> Decoder s v -> Decoder s (Map k v)
decodeMap forall a s. DecCBOR a => Decoder s a
decCBOR (forall a s. DecShareCBOR a => Share a -> Decoder s a
decShareCBOR 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 = (forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => 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 =
  forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    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) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL) [forall a. Bounded a => a
minBound ..]
      ]
  where
    transId :: TxId
transId = 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') = 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 = forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut era)
utxo' forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set TxIn
txIns)

-- | Verify a transaction body witness
verifyWitVKey ::
  Typeable kr =>
  Hash HASH EraIndependentTxBody ->
  WitVKey kr ->
  Bool
verifyWitVKey :: forall (kr :: KeyRole).
Typeable kr =>
Hash HASH EraIndependentTxBody -> WitVKey kr -> Bool
verifyWitVKey Hash HASH EraIndependentTxBody
txbodyHash (WitVKey VKey kr
vkey SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
sig) = forall a (kd :: KeyRole).
Signable DSIGN a =>
VKey kd -> a -> SignedDSIGN DSIGN a -> Bool
verifySignedDSIGN VKey kr
vkey Hash HASH EraIndependentTxBody
txbodyHash (coerce :: 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.
balance :: EraTxOut era => UTxO era -> Value era
balance :: forall era. EraTxOut era => UTxO era -> Value era
balance = forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Value era
sumAllValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO
{-# INLINE balance #-}

-- | Determine the total Ada only balance contained in the UTxO. This is
-- equivalent to `coin . balance`, but it will be more efficient
coinBalance :: EraTxOut era => UTxO era -> Coin
coinBalance :: forall era. EraTxOut era => UTxO era -> Coin
coinBalance = forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Coin
sumAllCoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO
{-# INLINE coinBalance #-}

-- | 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 = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL)
{-# INLINE sumAllValue #-}

-- | Sum all the 'Coin's in any Foldable with with 'TxOut's. 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 = forall a. Compactible a => CompactForm a -> a
fromCompact forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> CompactForm Coin
CompactCoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sum a -> a
getSum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' forall {era}. EraTxOut era => TxOut era -> Sum Word64
getCoinWord64
  where
    getCoinWord64 :: TxOut era -> Sum Word64
getCoinWord64 TxOut era
txOut =
      case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
(HasCallStack, EraTxOut era) =>
Lens' (TxOut era) (CompactForm Coin)
compactCoinTxOutL of
        CompactCoin Word64
w64 -> 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => 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
_) = forall a. a -> Maybe a
Just ScriptHash
hs
getScriptHash Addr
_ = 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 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
$cto :: forall era x. Rep (ScriptsProvided era) x -> ScriptsProvided era
$cfrom :: forall era x. ScriptsProvided era -> Rep (ScriptsProvided era) x
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

  -- | 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