{-# LANGUAGE BangPatterns #-}
{-# 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 #-}
{-# LANGUAGE ViewPatterns #-}
-- for the Relation instance
{-# OPTIONS_GHC -Wno-orphans #-}

-- |
-- Module      : UTxO
-- Description : Simple UTxO Ledger
--
-- This module defines the types and functions for a simple UTxO Ledger
-- as specified in /A Simplified Formal Specification of a UTxO Ledger/.
module Shelley.Spec.Ledger.UTxO
  ( -- * Primitives
    UTxO (..),

    -- * Functions
    txid,
    txins,
    txinLookup,
    txouts,
    txup,
    balance,
    totalDeposits,
    makeWitnessVKey,
    makeWitnessesVKey,
    makeWitnessesFromScriptKeys,
    verifyWitVKey,
    getScriptHash,
    scriptsNeeded,
    scriptCred,
    scriptStakeCred,
    txinsScript,
  )
where

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Era
import Cardano.Ledger.Shelley (ShelleyBased)
import qualified Cardano.Ledger.Shelley as Shelley
import Cardano.Ledger.Val ((<+>), (<×>))
import Control.DeepSeq (NFData)
import Control.Iterate.SetAlgebra
  ( BaseRep (MapR),
    Embed (..),
    Exp (Base),
    HasExp (toExp),
  )
import Data.Coerce (coerce)
import Data.Foldable (toList)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import Data.Relation (Relation (..))
import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import GHC.Records (HasField (..))
import NoThunks.Class (NoThunks (..))
import Quiet
import Shelley.Spec.Ledger.Address (Addr (..))
import Shelley.Spec.Ledger.BaseTypes (StrictMaybe, strictMaybeToMaybe)
import Shelley.Spec.Ledger.Coin (Coin (..))
import Shelley.Spec.Ledger.Credential (Credential (..))
import Shelley.Spec.Ledger.Delegation.Certificates
  ( DCert (..),
    isRegKey,
    requiresVKeyWitness,
  )
import Shelley.Spec.Ledger.Hashing (hashAnnotated)
import Shelley.Spec.Ledger.Keys
  ( DSignable,
    Hash,
    KeyHash (..),
    KeyPair (..),
    KeyRole (StakePool, Witness),
    asWitness,
    signedDSIGN,
    verifySignedDSIGN,
  )
import Shelley.Spec.Ledger.PParams (PParams, Update, _keyDeposit, _poolDeposit)
import Shelley.Spec.Ledger.Scripts
import Shelley.Spec.Ledger.Tx (Tx (..))
import Shelley.Spec.Ledger.TxBody
  ( EraIndependentTxBody,
    PoolCert (..),
    PoolParams (..),
    TxId (..),
    TxIn (..),
    TxOut (..),
    Wdrl (..),
    WitVKey (..),
    getRwdCred,
    pattern DeRegKey,
    pattern Delegate,
    pattern Delegation,
  )

instance HasExp (UTxO era) (Map (TxIn era) (TxOut era)) where
  toExp :: UTxO era -> Exp (Map (TxIn era) (TxOut era))
toExp (UTxO Map (TxIn era) (TxOut era)
x) = BaseRep Map (TxIn era) (TxOut era)
-> Map (TxIn era) (TxOut era) -> Exp (Map (TxIn era) (TxOut era))
forall k (f :: * -> * -> *) v.
(Ord k, Basic f) =>
BaseRep f k v -> f k v -> Exp (f k v)
Base BaseRep Map (TxIn era) (TxOut era)
forall k v. Basic Map => BaseRep Map k v
MapR Map (TxIn era) (TxOut era)
x

instance Embed (UTxO era) (Map (TxIn era) (TxOut era)) where
  toBase :: UTxO era -> Map (TxIn era) (TxOut era)
toBase (UTxO Map (TxIn era) (TxOut era)
x) = Map (TxIn era) (TxOut era)
x
  fromBase :: Map (TxIn era) (TxOut era) -> UTxO era
fromBase Map (TxIn era) (TxOut era)
x = (Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO Map (TxIn era) (TxOut era)
x)

-- | The unspent transaction outputs.
newtype UTxO era = UTxO {UTxO era -> Map (TxIn era) (TxOut era)
unUTxO :: Map (TxIn era) (TxOut era)}
  deriving (Context -> UTxO era -> IO (Maybe ThunkInfo)
Proxy (UTxO era) -> String
(Context -> UTxO era -> IO (Maybe ThunkInfo))
-> (Context -> UTxO era -> IO (Maybe ThunkInfo))
-> (Proxy (UTxO era) -> String)
-> NoThunks (UTxO era)
forall era. Context -> UTxO era -> IO (Maybe ThunkInfo)
forall era. Proxy (UTxO era) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (UTxO era) -> String
$cshowTypeOf :: forall era. Proxy (UTxO era) -> String
wNoThunks :: Context -> UTxO era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era. Context -> UTxO era -> IO (Maybe ThunkInfo)
noThunks :: Context -> UTxO era -> IO (Maybe ThunkInfo)
$cnoThunks :: forall era. Context -> UTxO era -> IO (Maybe ThunkInfo)
NoThunks, (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, UTxO era -> ()
(UTxO era -> ()) -> NFData (UTxO era)
forall era. Era era => UTxO era -> ()
forall a. (a -> ()) -> NFData a
rnf :: UTxO era -> ()
$crnf :: forall era. Era era => UTxO era -> ()
NFData)

deriving newtype instance
  ShelleyBased era =>
  Eq (UTxO era)

deriving newtype instance
  ShelleyBased era =>
  ToCBOR (UTxO era)

deriving newtype instance
  ShelleyBased era =>
  FromCBOR (UTxO era)

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

instance Relation (UTxO era) where
  type Domain (UTxO era) = TxIn era
  type Range (UTxO era) = TxOut era

  singleton :: Domain (UTxO era) -> Range (UTxO era) -> UTxO era
singleton Domain (UTxO era)
k Range (UTxO era)
v = Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO (Map (TxIn era) (TxOut era) -> UTxO era)
-> Map (TxIn era) (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$ TxIn era -> TxOut era -> Map (TxIn era) (TxOut era)
forall k a. k -> a -> Map k a
Map.singleton Domain (UTxO era)
TxIn era
k Range (UTxO era)
TxOut era
v

  dom :: UTxO era -> Set (Domain (UTxO era))
dom (UTxO Map (TxIn era) (TxOut era)
utxo) = Map (TxIn era) (TxOut era)
-> Set (Domain (Map (TxIn era) (TxOut era)))
forall m. (Relation m, Ord (Domain m)) => m -> Set (Domain m)
dom Map (TxIn era) (TxOut era)
utxo

  range :: UTxO era -> Set (Range (UTxO era))
range (UTxO Map (TxIn era) (TxOut era)
utxo) = Map (TxIn era) (TxOut era)
-> Set (Range (Map (TxIn era) (TxOut era)))
forall m. (Relation m, Ord (Range m)) => m -> Set (Range m)
range Map (TxIn era) (TxOut era)
utxo

  Set (Domain (UTxO era))
s ◁ :: Set (Domain (UTxO era)) -> UTxO era -> UTxO era
 (UTxO Map (TxIn era) (TxOut era)
utxo) = Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO (Map (TxIn era) (TxOut era) -> UTxO era)
-> Map (TxIn era) (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$ Set (Domain (Map (TxIn era) (TxOut era)))
Set (Domain (UTxO era))
s Set (Domain (Map (TxIn era) (TxOut era)))
-> Map (TxIn era) (TxOut era) -> Map (TxIn era) (TxOut era)
forall m. (Relation m, Ord (Domain m)) => Set (Domain m) -> m -> m
 Map (TxIn era) (TxOut era)
utxo

  Set (Domain (UTxO era))
s ⋪ :: Set (Domain (UTxO era)) -> UTxO era -> UTxO era
 (UTxO Map (TxIn era) (TxOut era)
utxo) = Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO (Map (TxIn era) (TxOut era) -> UTxO era)
-> Map (TxIn era) (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$ Set (Domain (Map (TxIn era) (TxOut era)))
Set (Domain (UTxO era))
s Set (Domain (Map (TxIn era) (TxOut era)))
-> Map (TxIn era) (TxOut era) -> Map (TxIn era) (TxOut era)
forall m. (Relation m, Ord (Domain m)) => Set (Domain m) -> m -> m
 Map (TxIn era) (TxOut era)
utxo

  (UTxO Map (TxIn era) (TxOut era)
utxo) ▷ :: UTxO era -> Set (Range (UTxO era)) -> UTxO era
 Set (Range (UTxO era))
s = Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO (Map (TxIn era) (TxOut era) -> UTxO era)
-> Map (TxIn era) (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$ Map (TxIn era) (TxOut era)
utxo Map (TxIn era) (TxOut era)
-> Set (Range (Map (TxIn era) (TxOut era)))
-> Map (TxIn era) (TxOut era)
forall m. (Relation m, Ord (Range m)) => m -> Set (Range m) -> m
 Set (Range (Map (TxIn era) (TxOut era)))
Set (Range (UTxO era))
s

  (UTxO Map (TxIn era) (TxOut era)
utxo) ⋫ :: UTxO era -> Set (Range (UTxO era)) -> UTxO era
 Set (Range (UTxO era))
s = Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO (Map (TxIn era) (TxOut era) -> UTxO era)
-> Map (TxIn era) (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$ Map (TxIn era) (TxOut era)
utxo Map (TxIn era) (TxOut era)
-> Set (Range (Map (TxIn era) (TxOut era)))
-> Map (TxIn era) (TxOut era)
forall m. (Relation m, Ord (Range m)) => m -> Set (Range m) -> m
 Set (Range (Map (TxIn era) (TxOut era)))
Set (Range (UTxO era))
s

  (UTxO Map (TxIn era) (TxOut era)
a) ∪ :: UTxO era -> UTxO era -> UTxO era
 (UTxO Map (TxIn era) (TxOut era)
b) = Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO (Map (TxIn era) (TxOut era) -> UTxO era)
-> Map (TxIn era) (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$ Map (TxIn era) (TxOut era)
a Map (TxIn era) (TxOut era)
-> Map (TxIn era) (TxOut era) -> Map (TxIn era) (TxOut era)
forall m.
(Relation m, Ord (Domain m), Ord (Range m)) =>
m -> m -> m
 Map (TxIn era) (TxOut era)
b

  (UTxO Map (TxIn era) (TxOut era)
a) ⨃ :: UTxO era -> UTxO era -> UTxO era
 (UTxO Map (TxIn era) (TxOut era)
b) = Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO (Map (TxIn era) (TxOut era) -> UTxO era)
-> Map (TxIn era) (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$ Map (TxIn era) (TxOut era)
a Map (TxIn era) (TxOut era)
-> Map (TxIn era) (TxOut era) -> Map (TxIn era) (TxOut era)
forall m.
(Relation m, Ord (Domain m), Ord (Range m)) =>
m -> m -> m
 Map (TxIn era) (TxOut era)
b

  size :: UTxO era -> n
size (UTxO Map (TxIn era) (TxOut era)
utxo) = Map (TxIn era) (TxOut era) -> n
forall m n. (Relation m, Integral n) => m -> n
size Map (TxIn era) (TxOut era)
utxo

  {-# INLINE haskey #-}
  haskey :: Domain (UTxO era) -> UTxO era -> Bool
haskey Domain (UTxO era)
k (UTxO Map (TxIn era) (TxOut era)
x) = case TxIn era -> Map (TxIn era) (TxOut era) -> Maybe (TxOut era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Domain (UTxO era)
TxIn era
k Map (TxIn era) (TxOut era)
x of Just TxOut era
_ -> Bool
True; Maybe (TxOut era)
Nothing -> Bool
False

  {-# INLINE addpair #-}
  addpair :: Domain (UTxO era) -> Range (UTxO era) -> UTxO era -> UTxO era
addpair Domain (UTxO era)
k Range (UTxO era)
v (UTxO Map (TxIn era) (TxOut era)
x) = Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO ((TxOut era -> TxOut era -> TxOut era)
-> TxIn era
-> TxOut era
-> Map (TxIn era) (TxOut era)
-> Map (TxIn era) (TxOut era)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\TxOut era
y TxOut era
_z -> TxOut era
y) Domain (UTxO era)
TxIn era
k Range (UTxO era)
TxOut era
v Map (TxIn era) (TxOut era)
x)

  {-# INLINE removekey #-}
  removekey :: Domain (UTxO era) -> UTxO era -> UTxO era
removekey Domain (UTxO era)
k (UTxO Map (TxIn era) (TxOut era)
m) = Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO (TxIn era
-> Map (TxIn era) (TxOut era) -> Map (TxIn era) (TxOut era)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Domain (UTxO era)
TxIn era
k Map (TxIn era) (TxOut era)
m)

-- | Compute the id of a transaction.
txid ::
  forall era.
  (Shelley.TxBodyConstraints era) =>
  Core.TxBody era ->
  TxId era
txid :: TxBody era -> TxId era
txid = Hash (HASH (Crypto era)) EraIndependentTxBody -> TxId era
forall era. Hash (Crypto era) EraIndependentTxBody -> TxId era
TxId (Hash (HASH (Crypto era)) EraIndependentTxBody -> TxId era)
-> (TxBody era -> Hash (HASH (Crypto era)) EraIndependentTxBody)
-> TxBody era
-> TxId era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashAnnotated (TxBody era) era =>
TxBody era -> Hash (HASH (Crypto era)) (HashIndex (TxBody era))
forall a e.
HashAnnotated a e =>
a -> Hash (HASH (Crypto e)) (HashIndex a)
hashAnnotated @(Core.TxBody era) @era

-- | Compute the UTxO inputs of a transaction.
txins ::
  ( HasField "inputs" (Core.TxBody era) (Set (TxIn era))
  ) =>
  Core.TxBody era ->
  Set (TxIn era)
txins :: TxBody era -> Set (TxIn 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 ::
  ( ShelleyBased era,
    HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era))
  ) =>
  Core.TxBody era ->
  UTxO era
txouts :: TxBody era -> UTxO era
txouts TxBody era
tx =
  Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO (Map (TxIn era) (TxOut era) -> UTxO era)
-> Map (TxIn era) (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$
    [(TxIn era, TxOut era)] -> Map (TxIn era) (TxOut era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (TxId era -> Natural -> TxIn era
forall era. Era era => TxId era -> Natural -> TxIn era
TxIn TxId era
transId Natural
idx, TxOut era
out)
        | (TxOut era
out, Natural
idx) <- [TxOut era] -> [Natural] -> [(TxOut era, Natural)]
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
tx) [Natural
0 ..]
      ]
  where
    transId :: TxId era
transId = TxBody era -> TxId era
forall era. TxBodyConstraints era => TxBody era -> TxId era
txid TxBody era
tx

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

-- | Verify a transaction body witness
verifyWitVKey ::
  ( Typeable kr,
    Era era,
    DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody)
  ) =>
  Hash (Crypto era) EraIndependentTxBody ->
  WitVKey kr era ->
  Bool
verifyWitVKey :: Hash (Crypto era) EraIndependentTxBody -> WitVKey kr era -> Bool
verifyWitVKey Hash (Crypto era) EraIndependentTxBody
txbodyHash (WitVKey VKey kr (Crypto era)
vkey SignedDSIGN (Crypto era) (Hash (Crypto era) EraIndependentTxBody)
sig) = VKey kr (Crypto era)
-> Hash (Crypto era) EraIndependentTxBody
-> SignedDSIGN
     (Crypto era) (Hash (Crypto era) 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 era)
vkey Hash (Crypto era) EraIndependentTxBody
txbodyHash (SignedDSIGN (Crypto era) (Hash (Crypto era) EraIndependentTxBody)
-> SignedDSIGN
     (Crypto era) (Hash (Crypto era) EraIndependentTxBody)
coerce SignedDSIGN (Crypto era) (Hash (Crypto era) EraIndependentTxBody)
sig)

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

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

-- | 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 ::
  ( Era era,
    DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody)
  ) =>
  Hash (Crypto era) EraIndependentTxBody ->
  Map (KeyHash kr (Crypto era)) (KeyPair kr (Crypto era)) ->
  Set (KeyHash kr (Crypto era)) ->
  Set (WitVKey 'Witness era)
makeWitnessesFromScriptKeys :: Hash (Crypto era) EraIndependentTxBody
-> Map (KeyHash kr (Crypto era)) (KeyPair kr (Crypto era))
-> Set (KeyHash kr (Crypto era))
-> Set (WitVKey 'Witness era)
makeWitnessesFromScriptKeys Hash (Crypto era) EraIndependentTxBody
txbodyHash Map (KeyHash kr (Crypto era)) (KeyPair kr (Crypto era))
hashKeyMap Set (KeyHash kr (Crypto era))
scriptHashes =
  let witKeys :: Map (KeyHash kr (Crypto era)) (KeyPair kr (Crypto era))
witKeys = Map (KeyHash kr (Crypto era)) (KeyPair kr (Crypto era))
-> Set (KeyHash kr (Crypto era))
-> Map (KeyHash kr (Crypto era)) (KeyPair kr (Crypto era))
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map (KeyHash kr (Crypto era)) (KeyPair kr (Crypto era))
hashKeyMap Set (KeyHash kr (Crypto era))
scriptHashes
   in Hash (Crypto era) EraIndependentTxBody
-> [KeyPair kr (Crypto era)] -> Set (WitVKey 'Witness era)
forall era (kr :: KeyRole).
(Era era,
 DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody)) =>
Hash (Crypto era) EraIndependentTxBody
-> [KeyPair kr (Crypto era)] -> Set (WitVKey 'Witness era)
makeWitnessesVKey Hash (Crypto era) EraIndependentTxBody
txbodyHash (Map (KeyHash kr (Crypto era)) (KeyPair kr (Crypto era))
-> [KeyPair kr (Crypto era)]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash kr (Crypto era)) (KeyPair kr (Crypto era))
witKeys)

-- | Determine the total balance contained in the UTxO.
balance ::
  ShelleyBased era =>
  UTxO era ->
  Core.Value era
balance :: UTxO era -> Value era
balance (UTxO Map (TxIn era) (TxOut era)
utxo) = (Value era -> TxOut era -> Value era)
-> Value era -> Map (TxIn era) (TxOut era) -> Value era
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' Value era -> TxOut era -> Value era
forall era.
(Torsor (Value era), Compactible (Value era),
 HashAnnotated (TxBody era) era, FromCBOR (Delta (Value era)),
 FromCBOR (Value era), FromCBOR (CompactForm (Value era)),
 FromCBOR (Annotator (TxBody era)),
 FromCBOR (Annotator (Script era)), ToCBOR (Delta (Value era)),
 ToCBOR (Value era), ToCBOR (TxBody era), ToCBOR (Script era),
 ToCBOR (CompactForm (Value era)), Val (Value era),
 Show (Delta (Value era)), Show (Value era), Show (TxBody era),
 Show (Script era), Eq (Delta (Value era)), Eq (TxBody era),
 Eq (Script era), NoThunks (Delta (Value era)),
 NoThunks (Value era), NoThunks (TxBody era), NoThunks (Script era),
 HashIndex (TxBody era) ~ EraIndependentTxBody) =>
Value era -> TxOut era -> Value era
addTxOuts Value era
forall a. Monoid a => a
mempty Map (TxIn era) (TxOut era)
utxo
  where
    addTxOuts :: Value era -> TxOut era -> Value era
addTxOuts !Value era
b (TxOut Addr era
_ Value era
a) = Value era
a Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<+> Value era
b

-- | 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 ::
  PParams era ->
  Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) ->
  [DCert era] ->
  Coin
totalDeposits :: PParams era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> [DCert era]
-> Coin
totalDeposits PParams era
pp Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
stpools [DCert era]
cs =
  (Int
numKeys Int -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> PParams era -> HKD Identity Coin
forall (f :: * -> *) era. PParams' f era -> HKD f Coin
_keyDeposit PParams era
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
<×> PParams era -> HKD Identity Coin
forall (f :: * -> *) era. PParams' f era -> HKD f Coin
_poolDeposit PParams era
pp)
  where
    numKeys :: Int
numKeys = [DCert era] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([DCert era] -> Int) -> [DCert era] -> Int
forall a b. (a -> b) -> a -> b
$ (DCert era -> Bool) -> [DCert era] -> [DCert era]
forall a. (a -> Bool) -> [a] -> [a]
filter DCert era -> Bool
forall era. DCert era -> Bool
isRegKey [DCert era]
cs
    pools :: Set (KeyHash 'StakePool (Crypto era))
pools = [KeyHash 'StakePool (Crypto era)]
-> Set (KeyHash 'StakePool (Crypto era))
forall a. Ord a => [a] -> Set a
Set.fromList ([KeyHash 'StakePool (Crypto era)]
 -> Set (KeyHash 'StakePool (Crypto era)))
-> ([Maybe (KeyHash 'StakePool (Crypto era))]
    -> [KeyHash 'StakePool (Crypto era)])
-> [Maybe (KeyHash 'StakePool (Crypto era))]
-> Set (KeyHash 'StakePool (Crypto era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (KeyHash 'StakePool (Crypto era))]
-> [KeyHash 'StakePool (Crypto era)]
forall a. [Maybe a] -> [a]
Maybe.catMaybes ([Maybe (KeyHash 'StakePool (Crypto era))]
 -> Set (KeyHash 'StakePool (Crypto era)))
-> [Maybe (KeyHash 'StakePool (Crypto era))]
-> Set (KeyHash 'StakePool (Crypto era))
forall a b. (a -> b) -> a -> b
$ (DCert era -> Maybe (KeyHash 'StakePool (Crypto era)))
-> [DCert era] -> [Maybe (KeyHash 'StakePool (Crypto era))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DCert era -> Maybe (KeyHash 'StakePool (Crypto era))
forall era. DCert era -> Maybe (KeyHash 'StakePool (Crypto era))
getKeyHashFromRegPool [DCert era]
cs
    numNewPools :: Int
numNewPools = Set (KeyHash 'StakePool (Crypto era)) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Set (KeyHash 'StakePool (Crypto era)) -> Int)
-> Set (KeyHash 'StakePool (Crypto era)) -> Int
forall a b. (a -> b) -> a -> b
$ Set (KeyHash 'StakePool (Crypto era))
pools Set (KeyHash 'StakePool (Crypto era))
-> Set (KeyHash 'StakePool (Crypto era))
-> Set (KeyHash 'StakePool (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` (Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Set (KeyHash 'StakePool (Crypto era))
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
stpools)

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

txup ::
  ( ShelleyBased era,
    HasField "update" (Core.TxBody era) (StrictMaybe (Update era))
  ) =>
  Tx era ->
  Maybe (Update era)
txup :: Tx era -> Maybe (Update era)
txup (Tx TxBody era
txbody WitnessSet era
_ StrictMaybe MetaData
_) = 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)

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

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

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

-- | Computes the set of script hashes required to unlock the transcation inputs
-- and the withdrawals.
scriptsNeeded ::
  ( ShelleyBased era,
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)),
    HasField "wdrls" (Core.TxBody era) (Wdrl era),
    HasField "inputs" (Core.TxBody era) (Set (TxIn era))
  ) =>
  UTxO era ->
  Tx era ->
  Set (ScriptHash era)
scriptsNeeded :: UTxO era -> Tx era -> Set (ScriptHash era)
scriptsNeeded UTxO era
u Tx era
tx =
  [ScriptHash era] -> Set (ScriptHash era)
forall a. Ord a => [a] -> Set a
Set.fromList (Map (TxIn era) (ScriptHash era) -> [ScriptHash era]
forall k a. Map k a -> [a]
Map.elems (Map (TxIn era) (ScriptHash era) -> [ScriptHash era])
-> Map (TxIn era) (ScriptHash era) -> [ScriptHash era]
forall a b. (a -> b) -> a -> b
$ (TxOut era -> Maybe (ScriptHash era))
-> Map (TxIn era) (TxOut era) -> Map (TxIn era) (ScriptHash era)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (Addr era -> Maybe (ScriptHash era)
forall era. Addr era -> Maybe (ScriptHash era)
getScriptHash (Addr era -> Maybe (ScriptHash era))
-> (TxOut era -> Addr era) -> TxOut era -> Maybe (ScriptHash era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut era -> Addr era
forall era.
(Torsor (Value era), Compactible (Value era), Val (Value era),
 HashAnnotated (TxBody era) era, FromCBOR (Delta (Value era)),
 FromCBOR (Value era), FromCBOR (CompactForm (Value era)),
 FromCBOR (Annotator (TxBody era)),
 FromCBOR (Annotator (Script era)), ToCBOR (Delta (Value era)),
 ToCBOR (Value era), ToCBOR (TxBody era), ToCBOR (Script era),
 ToCBOR (CompactForm (Value era)), Show (Delta (Value era)),
 Show (Value era), Show (TxBody era), Show (Script era),
 Eq (Delta (Value era)), Eq (TxBody era), Eq (Script era),
 NoThunks (Delta (Value era)), NoThunks (Value era),
 NoThunks (TxBody era), NoThunks (Script era),
 HashIndex (TxBody era) ~ EraIndependentTxBody) =>
TxOut era -> Addr era
unTxOut) Map (TxIn era) (TxOut era)
u'')
    Set (ScriptHash era)
-> Set (ScriptHash era) -> Set (ScriptHash era)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [ScriptHash era] -> Set (ScriptHash era)
forall a. Ord a => [a] -> Set a
Set.fromList
      ( (RewardAcnt era -> Maybe (ScriptHash era))
-> [RewardAcnt era] -> [ScriptHash era]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (Credential 'Staking era -> Maybe (ScriptHash era)
forall (kr :: KeyRole) era.
Credential kr era -> Maybe (ScriptHash era)
scriptCred (Credential 'Staking era -> Maybe (ScriptHash era))
-> (RewardAcnt era -> Credential 'Staking era)
-> RewardAcnt era
-> Maybe (ScriptHash era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RewardAcnt era -> Credential 'Staking era
forall era. RewardAcnt era -> Credential 'Staking era
getRwdCred) ([RewardAcnt era] -> [ScriptHash era])
-> [RewardAcnt era] -> [ScriptHash era]
forall a b. (a -> b) -> a -> b
$
          Map (RewardAcnt era) Coin -> [RewardAcnt era]
forall k a. Map k a -> [k]
Map.keys Map (RewardAcnt era) Coin
withdrawals
      )
    Set (ScriptHash era)
-> Set (ScriptHash era) -> Set (ScriptHash era)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [ScriptHash era] -> Set (ScriptHash era)
forall a. Ord a => [a] -> Set a
Set.fromList
      ( (DCert era -> Maybe (ScriptHash era))
-> [DCert era] -> [ScriptHash era]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe
          DCert era -> Maybe (ScriptHash era)
forall era. DCert era -> Maybe (ScriptHash era)
scriptStakeCred
          ((DCert era -> Bool) -> [DCert era] -> [DCert era]
forall a. (a -> Bool) -> [a] -> [a]
filter DCert era -> Bool
forall era. DCert era -> Bool
requiresVKeyWitness [DCert era]
certificates)
      )
  where
    unTxOut :: TxOut era -> Addr era
unTxOut (TxOut Addr era
a Value era
_) = Addr era
a
    withdrawals :: Map (RewardAcnt era) Coin
withdrawals = Wdrl era -> Map (RewardAcnt era) Coin
forall era. Wdrl era -> Map (RewardAcnt era) Coin
unWdrl (Wdrl era -> Map (RewardAcnt era) Coin)
-> Wdrl era -> Map (RewardAcnt era) Coin
forall a b. (a -> b) -> a -> b
$ forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "wdrls" r a => r -> a
getField @"wdrls" (TxBody era -> Wdrl era) -> TxBody era -> Wdrl era
forall a b. (a -> b) -> a -> b
$ Tx era -> TxBodyConstraints era => TxBody era
forall era. Tx era -> TxBodyConstraints era => TxBody era
_body Tx era
tx
    UTxO Map (TxIn era) (TxOut era)
u'' = (Set (TxIn era) -> UTxO era -> Set (TxIn era)
forall era.
ShelleyBased era =>
Set (TxIn era) -> UTxO era -> Set (TxIn era)
txinsScript (forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "inputs" r a => r -> a
getField @"inputs" (TxBody era -> Set (TxIn era)) -> TxBody era -> Set (TxIn era)
forall a b. (a -> b) -> a -> b
$ Tx era -> TxBodyConstraints era => TxBody era
forall era. Tx era -> TxBodyConstraints era => TxBody era
_body Tx era
tx) UTxO era
u) Set (Domain (UTxO era)) -> UTxO era -> UTxO era
forall m. (Relation m, Ord (Domain m)) => Set (Domain m) -> m -> m
 UTxO era
u
    -- u'' = Map.restrictKeys v (txinsScript (txins $ _body tx) u)  TODO
    certificates :: [DCert era]
certificates = (StrictSeq (DCert era) -> [DCert era]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (DCert era) -> [DCert era])
-> (Tx era -> StrictSeq (DCert era)) -> Tx era -> [DCert era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "certs" r a => r -> a
getField @"certs" (TxBody era -> StrictSeq (DCert era))
-> (Tx era -> TxBody era) -> Tx era -> StrictSeq (DCert era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx era -> TxBody era
forall era. Tx era -> TxBodyConstraints era => TxBody era
_body) Tx era
tx

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