{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.Shelley.UTxO
  ( -- * Primitives
    UTxO (..),

    -- * Functions
    txins,
    txinLookup,
    txouts,
    txup,
    balance,
    sumAllValue,
    totalDeposits,
    makeWitnessVKey,
    makeWitnessesVKey,
    makeWitnessesFromScriptKeys,
    verifyWitVKey,
    getScriptHash,
    scriptsNeeded,
    scriptCred,
    scriptStakeCred,

    -- * Utilities
    TransUTxO,
  )
where

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import qualified Cardano.Crypto.Hash as CH
import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.BaseTypes (StrictMaybe, strictMaybeToMaybe)
import Cardano.Ledger.Coin (Coin (..))
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Credential (Credential (..))
import qualified Cardano.Ledger.Crypto as CC (Crypto, HASH)
import Cardano.Ledger.Era
import Cardano.Ledger.Keys
  ( DSignable,
    Hash,
    KeyHash (..),
    KeyPair (..),
    KeyRole (..),
    asWitness,
    signedDSIGN,
    verifySignedDSIGN,
  )
import Cardano.Ledger.SafeHash (SafeHash, extractHash)
import Cardano.Ledger.Shelley.Delegation.Certificates
  ( DCert (..),
    isRegKey,
    requiresVKeyWitness,
  )
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Scripts
import Cardano.Ledger.Shelley.TxBody
  ( EraIndependentTxBody,
    PoolCert (..),
    PoolParams (..),
    TransTxId,
    Wdrl (..),
    WitVKey (..),
    getRwdCred,
    pattern DeRegKey,
    pattern Delegate,
    pattern Delegation,
  )
import Cardano.Ledger.TxIn (TxIn (..))
import qualified Cardano.Ledger.TxIn as Core (txid)
import Cardano.Ledger.Val ((<+>), (<×>))
import Control.DeepSeq (NFData)
import Control.Monad ((<$!>))
import Data.Coders (decodeMapNoDuplicates, encodeMap)
import Data.Coerce (coerce)
import Data.Constraint (Constraint)
import Data.Default.Class (Default)
import Data.Foldable (foldMap', toList)
import Data.Kind (Type)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Sharing
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import GHC.Records (HasField (..))
import NoThunks.Class (NoThunks (..))
import Quiet

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

-- | The unspent transaction outputs.
newtype UTxO era = UTxO {UTxO era -> Map (TxIn (Crypto era)) (TxOut era)
unUTxO :: Map.Map (TxIn (Crypto era)) (Core.TxOut era)}
  deriving (UTxO era
UTxO era -> Default (UTxO era)
forall era. UTxO era
forall a. a -> Default a
def :: UTxO era
$cdef :: forall era. 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
$cto :: forall era x. Rep (UTxO era) x -> UTxO era
$cfrom :: forall era x. UTxO era -> Rep (UTxO era) x
Generic, b -> UTxO era -> UTxO era
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
stimes :: 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)

type TransUTxO (c :: Type -> Constraint) era = (c (Core.TxOut era), TransTxId c era)

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

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

deriving newtype instance
  (Eq (Core.TxOut era), CC.Crypto (Crypto era)) => Eq (UTxO era)

deriving newtype instance CC.Crypto (Crypto era) => Monoid (UTxO era)

instance (Era era, ToCBOR (Core.TxOut era)) => ToCBOR (UTxO era) where
  toCBOR :: UTxO era -> Encoding
toCBOR = (TxIn (Crypto era) -> Encoding)
-> (TxOut era -> Encoding)
-> Map (TxIn (Crypto era)) (TxOut era)
-> Encoding
forall a b.
(a -> Encoding) -> (b -> Encoding) -> Map a b -> Encoding
encodeMap TxIn (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR TxOut era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Map (TxIn (Crypto era)) (TxOut era) -> Encoding)
-> (UTxO era -> Map (TxIn (Crypto era)) (TxOut era))
-> UTxO era
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO era -> Map (TxIn (Crypto era)) (TxOut era)
forall era. UTxO era -> Map (TxIn (Crypto era)) (TxOut era)
unUTxO

instance
  ( CC.Crypto (Crypto era),
    FromSharedCBOR (Core.TxOut era),
    Share (Core.TxOut era) ~ Interns (Credential 'Staking (Crypto era))
  ) =>
  FromSharedCBOR (UTxO era)
  where
  type
    Share (UTxO era) =
      Interns (Credential 'Staking (Crypto era))
  fromSharedCBOR :: Share (UTxO era) -> Decoder s (UTxO era)
fromSharedCBOR Share (UTxO era)
credsInterns =
    Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO (Map (TxIn (Crypto era)) (TxOut era) -> UTxO era)
-> Decoder s (Map (TxIn (Crypto era)) (TxOut era))
-> Decoder s (UTxO era)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Decoder s (TxIn (Crypto era))
-> Decoder s (TxOut era)
-> Decoder s (Map (TxIn (Crypto era)) (TxOut era))
forall a s b.
Ord a =>
Decoder s a -> Decoder s b -> Decoder s (Map a b)
decodeMapNoDuplicates Decoder s (TxIn (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR (Share (TxOut era) -> Decoder s (TxOut era)
forall a s. FromSharedCBOR a => Share a -> Decoder s a
fromSharedCBOR Share (TxOut era)
Share (UTxO era)
credsInterns)

instance
  ( FromCBOR (Core.TxOut era),
    Era era
  ) =>
  FromCBOR (UTxO era)
  where
  fromCBOR :: Decoder s (UTxO era)
fromCBOR = Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO (Map (TxIn (Crypto era)) (TxOut era) -> UTxO era)
-> Decoder s (Map (TxIn (Crypto era)) (TxOut era))
-> Decoder s (UTxO era)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Decoder s (TxIn (Crypto era))
-> Decoder s (TxOut era)
-> Decoder s (Map (TxIn (Crypto era)) (TxOut era))
forall a s b.
Ord a =>
Decoder s a -> Decoder s b -> Decoder s (Map a b)
decodeMapNoDuplicates Decoder s (TxIn (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (TxOut era)
forall a s. FromCBOR a => Decoder s a
fromCBOR

deriving via
  Quiet (UTxO era)
  instance
    (Show (Core.TxOut era), CC.Crypto (Crypto era)) => Show (UTxO era)

-- | Compute the UTxO inputs of a transaction.
-- txins has the same problems as txouts, see notes below.
txins ::
  ( HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era)))
  ) =>
  Core.TxBody era ->
  Set (TxIn (Crypto era))
txins :: TxBody era -> Set (TxIn (Crypto era))
txins = forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "inputs" r a => r -> a
getField @"inputs"

-- | Compute the transaction outputs of a transaction.
txouts ::
  forall era.
  Era era =>
  Core.TxBody era ->
  UTxO era
txouts :: TxBody era -> UTxO era
txouts TxBody era
txBody =
  Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO (Map (TxIn (Crypto era)) (TxOut era) -> UTxO era)
-> Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$
    [(TxIn (Crypto era), TxOut era)]
-> Map (TxIn (Crypto era)) (TxOut era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (TxId (Crypto era) -> TxIx -> TxIn (Crypto era)
forall crypto. TxId crypto -> TxIx -> TxIn crypto
TxIn TxId (Crypto era)
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 (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 -> StrictSeq (TxOut era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"outputs" TxBody era
txBody) [TxIx
forall a. Bounded a => a
minBound ..]
      ]
  where
    transId :: TxId (Crypto era)
transId = TxBody era -> TxId (Crypto era)
forall era c.
(HashAlgorithm (HASH c),
 HashAnnotated (TxBody era) EraIndependentTxBody c) =>
TxBody era -> TxId c
Core.txid TxBody era
txBody

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

-- | Verify a transaction body witness
verifyWitVKey ::
  ( Typeable kr,
    CC.Crypto crypto,
    DSignable crypto (Hash crypto EraIndependentTxBody)
  ) =>
  Hash crypto EraIndependentTxBody ->
  WitVKey kr crypto ->
  Bool
verifyWitVKey :: Hash crypto EraIndependentTxBody -> WitVKey kr crypto -> Bool
verifyWitVKey Hash crypto EraIndependentTxBody
txbodyHash (WitVKey VKey kr crypto
vkey SignedDSIGN crypto (Hash crypto EraIndependentTxBody)
sig) = VKey kr crypto
-> Hash crypto EraIndependentTxBody
-> SignedDSIGN crypto (Hash crypto EraIndependentTxBody)
-> Bool
forall crypto a (kd :: KeyRole).
(Crypto crypto, Signable (DSIGN crypto) a) =>
VKey kd crypto -> a -> SignedDSIGN crypto a -> Bool
verifySignedDSIGN VKey kr crypto
vkey Hash crypto EraIndependentTxBody
txbodyHash (SignedDSIGN crypto (Hash crypto EraIndependentTxBody)
-> SignedDSIGN crypto (Hash crypto EraIndependentTxBody)
coerce SignedDSIGN crypto (Hash crypto EraIndependentTxBody)
sig)

-- | Create a witness for transaction
makeWitnessVKey ::
  forall c kr.
  ( CC.Crypto c,
    DSignable c (CH.Hash (CC.HASH c) EraIndependentTxBody)
  ) =>
  SafeHash c EraIndependentTxBody ->
  KeyPair kr c ->
  WitVKey 'Witness c
makeWitnessVKey :: SafeHash c EraIndependentTxBody
-> KeyPair kr c -> WitVKey 'Witness c
makeWitnessVKey SafeHash c EraIndependentTxBody
safe KeyPair kr c
keys =
  VKey 'Witness c
-> SignedDSIGN c (Hash c EraIndependentTxBody)
-> WitVKey 'Witness c
forall (kr :: KeyRole) crypto.
(Typeable kr, Crypto crypto) =>
VKey kr crypto
-> SignedDSIGN crypto (Hash crypto EraIndependentTxBody)
-> WitVKey kr crypto
WitVKey (VKey kr c -> VKey 'Witness c
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness (VKey kr c -> VKey 'Witness c) -> VKey kr c -> VKey 'Witness c
forall a b. (a -> b) -> a -> b
$ KeyPair kr c -> VKey kr c
forall (kd :: KeyRole) crypto. KeyPair kd crypto -> VKey kd crypto
vKey KeyPair kr c
keys) (SignedDSIGN c (Hash c EraIndependentTxBody)
-> SignedDSIGN c (Hash c EraIndependentTxBody)
coerce (SignedDSIGN c (Hash c EraIndependentTxBody)
 -> SignedDSIGN c (Hash c EraIndependentTxBody))
-> SignedDSIGN c (Hash c EraIndependentTxBody)
-> SignedDSIGN c (Hash c EraIndependentTxBody)
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN (DSIGN c)
-> Hash c EraIndependentTxBody
-> SignedDSIGN c (Hash c EraIndependentTxBody)
forall crypto a.
(Crypto crypto, Signable (DSIGN crypto) a) =>
SignKeyDSIGN (DSIGN crypto) -> a -> SignedDSIGN crypto a
signedDSIGN @c (KeyPair kr c -> SignKeyDSIGN (DSIGN c)
forall (kd :: KeyRole) crypto.
KeyPair kd crypto -> SignKeyDSIGN (DSIGN crypto)
sKey KeyPair kr c
keys) (SafeHash c EraIndependentTxBody -> Hash c EraIndependentTxBody
forall crypto i. SafeHash crypto i -> Hash (HASH crypto) i
extractHash SafeHash c EraIndependentTxBody
safe))

-- | Create witnesses for transaction
makeWitnessesVKey ::
  forall c kr.
  ( CC.Crypto c,
    DSignable c (CH.Hash (CC.HASH c) EraIndependentTxBody)
  ) =>
  SafeHash c EraIndependentTxBody ->
  [KeyPair kr c] ->
  Set (WitVKey 'Witness c)
makeWitnessesVKey :: SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
makeWitnessesVKey SafeHash c EraIndependentTxBody
safe [KeyPair kr c]
xs = [WitVKey 'Witness c] -> Set (WitVKey 'Witness c)
forall a. Ord a => [a] -> Set a
Set.fromList ((KeyPair kr c -> WitVKey 'Witness c)
-> [KeyPair kr c] -> [WitVKey 'Witness c]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SafeHash c EraIndependentTxBody
-> KeyPair kr c -> WitVKey 'Witness c
forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> KeyPair kr c -> WitVKey 'Witness c
makeWitnessVKey SafeHash c EraIndependentTxBody
safe) [KeyPair kr c]
xs)

-- | From a list of key pairs and a set of key hashes required for a multi-sig
-- scripts, return the set of required keys.
makeWitnessesFromScriptKeys ::
  ( CC.Crypto crypto,
    DSignable crypto (Hash crypto EraIndependentTxBody)
  ) =>
  SafeHash crypto EraIndependentTxBody ->
  Map (KeyHash kr crypto) (KeyPair kr crypto) ->
  Set (KeyHash kr crypto) ->
  Set (WitVKey 'Witness crypto)
makeWitnessesFromScriptKeys :: SafeHash crypto EraIndependentTxBody
-> Map (KeyHash kr crypto) (KeyPair kr crypto)
-> Set (KeyHash kr crypto)
-> Set (WitVKey 'Witness crypto)
makeWitnessesFromScriptKeys SafeHash crypto EraIndependentTxBody
txbodyHash Map (KeyHash kr crypto) (KeyPair kr crypto)
hashKeyMap Set (KeyHash kr crypto)
scriptHashes =
  let witKeys :: Map (KeyHash kr crypto) (KeyPair kr crypto)
witKeys = Map (KeyHash kr crypto) (KeyPair kr crypto)
-> Set (KeyHash kr crypto)
-> Map (KeyHash kr crypto) (KeyPair kr crypto)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map (KeyHash kr crypto) (KeyPair kr crypto)
hashKeyMap Set (KeyHash kr crypto)
scriptHashes
   in SafeHash crypto EraIndependentTxBody
-> [KeyPair kr crypto] -> Set (WitVKey 'Witness crypto)
forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
makeWitnessesVKey SafeHash crypto EraIndependentTxBody
txbodyHash (Map (KeyHash kr crypto) (KeyPair kr crypto) -> [KeyPair kr crypto]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash kr crypto) (KeyPair kr crypto)
witKeys)

-- | Determine the total balance contained in the UTxO.
balance ::
  forall era.
  Era era =>
  UTxO era ->
  Core.Value era
balance :: UTxO era -> Value era
balance = forall era tx (f :: * -> *).
(Foldable f, HasField "value" tx (Value era),
 Monoid (Value era)) =>
f tx -> Value era
forall tx (f :: * -> *).
(Foldable f, HasField "value" tx (Value era),
 Monoid (Value era)) =>
f tx -> Value era
sumAllValue @era (Map (TxIn (Crypto era)) (TxOut era) -> Value era)
-> (UTxO era -> Map (TxIn (Crypto era)) (TxOut era))
-> UTxO era
-> Value era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO era -> Map (TxIn (Crypto era)) (TxOut era)
forall era. UTxO era -> Map (TxIn (Crypto era)) (TxOut era)
unUTxO
{-# INLINE balance #-}

-- | Sum all the value in any Foldable with elements that have a field "value"
sumAllValue ::
  forall era tx f.
  (Foldable f, HasField "value" tx (Core.Value era), Monoid (Core.Value era)) =>
  f tx ->
  Core.Value era
sumAllValue :: f tx -> Value era
sumAllValue = (tx -> Value era) -> f tx -> Value era
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "value" r a => r -> a
getField @"value")
{-# INLINE sumAllValue #-}

-- | Determine the total deposit amount needed.
-- The block may (legitimately) contain multiple registration certificates
-- for the same pool, where the first will be treated as a registration and
-- any subsequent ones as re-registration. As such, we must only take a
-- deposit for the first such registration.
--
-- Note that this is not an issue for key registrations since subsequent
-- registration certificates would be invalid.
totalDeposits ::
  ( HasField "_poolDeposit" pp Coin,
    HasField "_keyDeposit" pp Coin
  ) =>
  pp ->
  (KeyHash 'StakePool crypto -> Bool) ->
  [DCert crypto] ->
  Coin
totalDeposits :: pp -> (KeyHash 'StakePool crypto -> Bool) -> [DCert crypto] -> Coin
totalDeposits pp
pp KeyHash 'StakePool crypto -> Bool
isNewPool [DCert crypto]
certs =
  (Int
numKeys Int -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> pp -> Coin
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_keyDeposit" pp
pp)
    Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> (Int
numNewPools Int -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> pp -> Coin
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_poolDeposit" pp
pp)
  where
    numKeys :: Int
numKeys = [DCert crypto] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([DCert crypto] -> Int) -> [DCert crypto] -> Int
forall a b. (a -> b) -> a -> b
$ (DCert crypto -> Bool) -> [DCert crypto] -> [DCert crypto]
forall a. (a -> Bool) -> [a] -> [a]
filter DCert crypto -> Bool
forall crypto. DCert crypto -> Bool
isRegKey [DCert crypto]
certs
    pools :: Set (KeyHash 'StakePool crypto)
pools = [KeyHash 'StakePool crypto] -> Set (KeyHash 'StakePool crypto)
forall a. Ord a => [a] -> Set a
Set.fromList ([KeyHash 'StakePool crypto] -> Set (KeyHash 'StakePool crypto))
-> [KeyHash 'StakePool crypto] -> Set (KeyHash 'StakePool crypto)
forall a b. (a -> b) -> a -> b
$ (DCert crypto -> Maybe (KeyHash 'StakePool crypto))
-> [DCert crypto] -> [KeyHash 'StakePool crypto]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe DCert crypto -> Maybe (KeyHash 'StakePool crypto)
forall crypto. DCert crypto -> Maybe (KeyHash 'StakePool crypto)
getKeyHashFromRegPool [DCert crypto]
certs
    numNewPools :: Int
numNewPools = Set (KeyHash 'StakePool crypto) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Set (KeyHash 'StakePool crypto) -> Int)
-> Set (KeyHash 'StakePool crypto) -> Int
forall a b. (a -> b) -> a -> b
$ (KeyHash 'StakePool crypto -> Bool)
-> Set (KeyHash 'StakePool crypto)
-> Set (KeyHash 'StakePool crypto)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter KeyHash 'StakePool crypto -> Bool
isNewPool Set (KeyHash 'StakePool crypto)
pools

getKeyHashFromRegPool :: DCert crypto -> Maybe (KeyHash 'StakePool crypto)
getKeyHashFromRegPool :: DCert crypto -> Maybe (KeyHash 'StakePool crypto)
getKeyHashFromRegPool (DCertPool (RegPool PoolParams crypto
p)) = KeyHash 'StakePool crypto -> Maybe (KeyHash 'StakePool crypto)
forall a. a -> Maybe a
Just (KeyHash 'StakePool crypto -> Maybe (KeyHash 'StakePool crypto))
-> (PoolParams crypto -> KeyHash 'StakePool crypto)
-> PoolParams crypto
-> Maybe (KeyHash 'StakePool crypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolParams crypto -> KeyHash 'StakePool crypto
forall crypto. PoolParams crypto -> KeyHash 'StakePool crypto
_poolId (PoolParams crypto -> Maybe (KeyHash 'StakePool crypto))
-> PoolParams crypto -> Maybe (KeyHash 'StakePool crypto)
forall a b. (a -> b) -> a -> b
$ PoolParams crypto
p
getKeyHashFromRegPool DCert crypto
_ = Maybe (KeyHash 'StakePool crypto)
forall a. Maybe a
Nothing

txup ::
  forall era tx.
  ( HasField "update" (Core.TxBody era) (StrictMaybe (Update era)),
    HasField "body" tx (Core.TxBody era)
  ) =>
  tx ->
  Maybe (Update era)
txup :: tx -> Maybe (Update era)
txup tx
tx = StrictMaybe (Update era) -> Maybe (Update era)
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe (TxBody era -> StrictMaybe (Update era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"update" TxBody era
txbody)
  where
    txbody :: Core.TxBody era
    txbody :: TxBody era
txbody = tx -> TxBody era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"body" tx
tx

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

scriptStakeCred ::
  DCert crypto ->
  Maybe (ScriptHash crypto)
scriptStakeCred :: DCert crypto -> Maybe (ScriptHash crypto)
scriptStakeCred (DCertDeleg (DeRegKey (KeyHashObj KeyHash 'Staking crypto
_))) = Maybe (ScriptHash crypto)
forall a. Maybe a
Nothing
scriptStakeCred (DCertDeleg (DeRegKey (ScriptHashObj ScriptHash crypto
hs))) = ScriptHash crypto -> Maybe (ScriptHash crypto)
forall a. a -> Maybe a
Just ScriptHash crypto
hs
scriptStakeCred (DCertDeleg (Delegate (Delegation (KeyHashObj KeyHash 'Staking crypto
_) KeyHash 'StakePool crypto
_))) = Maybe (ScriptHash crypto)
forall a. Maybe a
Nothing
scriptStakeCred (DCertDeleg (Delegate (Delegation (ScriptHashObj ScriptHash crypto
hs) KeyHash 'StakePool crypto
_))) = ScriptHash crypto -> Maybe (ScriptHash crypto)
forall a. a -> Maybe a
Just ScriptHash crypto
hs
scriptStakeCred DCert crypto
_ = Maybe (ScriptHash crypto)
forall a. Maybe a
Nothing

scriptCred ::
  Credential kr crypto ->
  Maybe (ScriptHash crypto)
scriptCred :: Credential kr crypto -> Maybe (ScriptHash crypto)
scriptCred (KeyHashObj KeyHash kr crypto
_) = Maybe (ScriptHash crypto)
forall a. Maybe a
Nothing
scriptCred (ScriptHashObj ScriptHash crypto
hs) = ScriptHash crypto -> Maybe (ScriptHash crypto)
forall a. a -> Maybe a
Just ScriptHash crypto
hs

-- | Computes the set of script hashes required to unlock the transcation inputs
-- and the withdrawals.
scriptsNeeded ::
  forall era tx.
  ( Era era,
    HasField "body" tx (Core.TxBody era),
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era)))
  ) =>
  UTxO era ->
  tx ->
  Set (ScriptHash (Crypto era))
scriptsNeeded :: UTxO era -> tx -> Set (ScriptHash (Crypto era))
scriptsNeeded UTxO era
u tx
tx =
  Set (ScriptHash (Crypto era))
scriptHashes
    Set (ScriptHash (Crypto era))
-> Set (ScriptHash (Crypto era)) -> Set (ScriptHash (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [ScriptHash (Crypto era)] -> Set (ScriptHash (Crypto era))
forall a. Ord a => [a] -> Set a
Set.fromList
      [ScriptHash (Crypto era)
sh | RewardAcnt (Crypto era)
w <- [RewardAcnt (Crypto era)]
withdrawals, Just ScriptHash (Crypto era)
sh <- [Credential 'Staking (Crypto era) -> Maybe (ScriptHash (Crypto era))
forall (kr :: KeyRole) crypto.
Credential kr crypto -> Maybe (ScriptHash crypto)
scriptCred (RewardAcnt (Crypto era) -> Credential 'Staking (Crypto era)
forall crypto. RewardAcnt crypto -> Credential 'Staking crypto
getRwdCred RewardAcnt (Crypto era)
w)]]
    Set (ScriptHash (Crypto era))
-> Set (ScriptHash (Crypto era)) -> Set (ScriptHash (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [ScriptHash (Crypto era)] -> Set (ScriptHash (Crypto era))
forall a. Ord a => [a] -> Set a
Set.fromList
      [ScriptHash (Crypto era)
sh | DCert (Crypto era)
c <- [DCert (Crypto era)]
certificates, DCert (Crypto era) -> Bool
forall crypto. DCert crypto -> Bool
requiresVKeyWitness DCert (Crypto era)
c, Just ScriptHash (Crypto era)
sh <- [DCert (Crypto era) -> Maybe (ScriptHash (Crypto era))
forall crypto. DCert crypto -> Maybe (ScriptHash crypto)
scriptStakeCred DCert (Crypto era)
c]]
    Set (ScriptHash (Crypto era))
-> Set (ScriptHash (Crypto era)) -> Set (ScriptHash (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` TxBody era -> Set (ScriptHash (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"minted" TxBody era
txbody -- This might be Set.empty in some Eras.
  where
    txbody :: TxBody era
txbody = tx -> TxBody era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"body" tx
tx
    withdrawals :: [RewardAcnt (Crypto era)]
withdrawals = Map (RewardAcnt (Crypto era)) Coin -> [RewardAcnt (Crypto era)]
forall k a. Map k a -> [k]
Map.keys (Wdrl (Crypto era) -> Map (RewardAcnt (Crypto era)) Coin
forall crypto. Wdrl crypto -> Map (RewardAcnt crypto) Coin
unWdrl (TxBody era -> Wdrl (Crypto era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"wdrls" TxBody era
txbody))
    scriptHashes :: Set (ScriptHash (Crypto era))
scriptHashes = Set (TxIn (Crypto era))
-> UTxO era -> Set (ScriptHash (Crypto era))
forall era.
Era era =>
Set (TxIn (Crypto era))
-> UTxO era -> Set (ScriptHash (Crypto era))
txinsScriptHashes (TxBody era -> Set (TxIn (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"inputs" TxBody era
txbody) UTxO era
u
    certificates :: [DCert (Crypto era)]
certificates = StrictSeq (DCert (Crypto era)) -> [DCert (Crypto era)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (TxBody era -> StrictSeq (DCert (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" TxBody era
txbody)

-- | Compute the subset of inputs of the set 'txInps' for which each input is
-- locked by a script in the UTxO 'u'.
txinsScriptHashes ::
  Era era =>
  Set (TxIn (Crypto era)) ->
  UTxO era ->
  Set (ScriptHash (Crypto era))
txinsScriptHashes :: Set (TxIn (Crypto era))
-> UTxO era -> Set (ScriptHash (Crypto era))
txinsScriptHashes Set (TxIn (Crypto era))
txInps (UTxO Map (TxIn (Crypto era)) (TxOut era)
u) = (TxIn (Crypto era)
 -> Set (ScriptHash (Crypto era)) -> Set (ScriptHash (Crypto era)))
-> Set (ScriptHash (Crypto era))
-> Set (TxIn (Crypto era))
-> Set (ScriptHash (Crypto era))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TxIn (Crypto era)
-> Set (ScriptHash (Crypto era)) -> Set (ScriptHash (Crypto era))
add Set (ScriptHash (Crypto era))
forall a. Set a
Set.empty Set (TxIn (Crypto era))
txInps
  where
    -- to get subset, start with empty, and only insert those inputs in txInps
    -- that are locked in u
    add :: TxIn (Crypto era)
-> Set (ScriptHash (Crypto era)) -> Set (ScriptHash (Crypto era))
add TxIn (Crypto era)
input Set (ScriptHash (Crypto era))
ans = case TxIn (Crypto era)
-> Map (TxIn (Crypto era)) (TxOut era) -> Maybe (TxOut era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn (Crypto era)
input Map (TxIn (Crypto era)) (TxOut era)
u of
      Just TxOut era
out -> case TxOut era -> Addr (Crypto era)
forall e. Era e => TxOut e -> Addr (Crypto e)
getTxOutAddr TxOut era
out of
        Addr Network
_ (ScriptHashObj ScriptHash (Crypto era)
h) StakeReference (Crypto era)
_ -> ScriptHash (Crypto era)
-> Set (ScriptHash (Crypto era)) -> Set (ScriptHash (Crypto era))
forall a. Ord a => a -> Set a -> Set a
Set.insert ScriptHash (Crypto era)
h Set (ScriptHash (Crypto era))
ans
        Addr (Crypto era)
_ -> Set (ScriptHash (Crypto era))
ans
      Maybe (TxOut era)
Nothing -> Set (ScriptHash (Crypto era))
ans