{-# 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.Crypto (Crypto)
import Cardano.Ledger.Keys (
  DSignable,
  Hash,
  KeyHash,
  KeyRole (..),
  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.Class (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 (EraCrypto era)) (TxOut era)
unUTxO :: Map.Map (TxIn (EraCrypto era)) (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
  ( Crypto (EraCrypto era)
  , DecShareCBOR (TxOut era)
  , Share (TxOut era) ~ Interns (Credential 'Staking (EraCrypto era))
  ) =>
  DecShareCBOR (UTxO era)
  where
  type
    Share (UTxO era) =
      Interns (Credential 'Staking (EraCrypto era))
  decShareCBOR :: forall s. Share (UTxO era) -> Decoder s (UTxO era)
decShareCBOR Share (UTxO era)
credsInterns =
    forall era. Map (TxIn (EraCrypto era)) (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), Crypto (EraCrypto era)) => Show (UTxO era)

deriving newtype instance (Era era, 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 (EraCrypto era))
txins :: forall era.
EraTxBody era =>
TxBody era -> Set (TxIn (EraCrypto era))
txins = (forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
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 (EraCrypto era)) (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (forall c. TxId c -> TxIx -> TxIn c
TxIn TxId (EraCrypto era)
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 (EraCrypto era)
transId = forall era. EraTxBody era => TxBody era -> TxId (EraCrypto era)
txIdTxBody TxBody era
txBody

-- | Lookup a txin for a given UTxO collection
txinLookup ::
  TxIn (EraCrypto era) ->
  UTxO era ->
  Maybe (TxOut era)
txinLookup :: forall era. TxIn (EraCrypto era) -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn (EraCrypto era)
txin (UTxO Map (TxIn (EraCrypto era)) (TxOut era)
utxo') = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn (EraCrypto era)
txin Map (TxIn (EraCrypto era)) (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 (EraCrypto era)) ->
  UTxO era
txInsFilter :: forall era. UTxO era -> Set (TxIn (EraCrypto era)) -> UTxO era
txInsFilter (UTxO Map (TxIn (EraCrypto era)) (TxOut era)
utxo') Set (TxIn (EraCrypto era))
txIns = forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO (Map (TxIn (EraCrypto era)) (TxOut era)
utxo' forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set (TxIn (EraCrypto era))
txIns)

-- | Verify a transaction body witness
verifyWitVKey ::
  ( Typeable kr
  , Crypto c
  , DSignable c (Hash c EraIndependentTxBody)
  ) =>
  Hash c EraIndependentTxBody ->
  WitVKey kr c ->
  Bool
verifyWitVKey :: forall (kr :: KeyRole) c.
(Typeable kr, Crypto c,
 DSignable c (Hash c EraIndependentTxBody)) =>
Hash c EraIndependentTxBody -> WitVKey kr c -> Bool
verifyWitVKey Hash c EraIndependentTxBody
txbodyHash (WitVKey VKey kr c
vkey SignedDSIGN (DSIGN c) (Hash c EraIndependentTxBody)
sig) = forall c a (kd :: KeyRole).
(Crypto c, Signable (DSIGN c) a) =>
VKey kd c -> a -> SignedDSIGN c a -> Bool
verifySignedDSIGN VKey kr c
vkey Hash c EraIndependentTxBody
txbodyHash (coerce :: forall a b. Coercible a b => a -> b
coerce SignedDSIGN (DSIGN c) (Hash c 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 (EraCrypto era)) (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 (EraCrypto era)) (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 c -> Maybe (ScriptHash c)
getScriptHash :: forall c. Addr c -> Maybe (ScriptHash c)
getScriptHash (Addr Network
_ (ScriptHashObj ScriptHash c
hs) StakeReference c
_) = forall a. a -> Maybe a
Just ScriptHash c
hs
getScriptHash Addr c
_ = 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 (EraCrypto era)) (Script era)
unScriptsProvided :: Map.Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era) -> Maybe Coin) ->
    -- | Function that can lookup current drep deposits
    (Credential 'DRepRole (EraCrypto era) -> Maybe Coin) ->
    UTxO era ->
    TxBody era ->
    Value era

  getProducedValue ::
    PParams era ->
    -- | Check whether a pool with a supplied PoolStakeId is already registered.
    (KeyHash 'StakePool (EraCrypto era) -> 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 (EraCrypto era))

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

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