{-# OPTIONS_GHC -Wno-orphans #-}

module Hydra.Ledger.Cardano (
  module Hydra.Ledger.Cardano,
  module Hydra.Ledger.Cardano.Builder,
  Ledger.ShelleyGenesis (..),
  Ledger.Globals,
  Ledger.LedgerEnv,
  Tx,
) where

import Hydra.Prelude

import Hydra.Cardano.Api hiding (initialLedgerState, utxoFromTx)
import Hydra.Ledger.Cardano.Builder

import Cardano.Api.UTxO (fromPairs, pairs)
import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Alonzo.Rules (
  FailureDescription (..),
  TagMismatchDescription (FailedUnexpectedly),
 )
import Cardano.Ledger.Api (bodyTxL, raCredential, unWithdrawals, withdrawalsTxBodyL)
import Cardano.Ledger.BaseTypes qualified as Ledger
import Cardano.Ledger.CertState (dsUnifiedL)
import Cardano.Ledger.Conway.Rules (
  ConwayLedgerPredFailure (ConwayUtxowFailure),
  ConwayUtxoPredFailure (UtxosFailure),
  ConwayUtxosPredFailure (ValidationTagMismatch),
  ConwayUtxowPredFailure (UtxoFailure),
 )
import Cardano.Ledger.Plutus (PlutusDebugOverrides (..), debugPlutus)
import Cardano.Ledger.Shelley.API.Mempool qualified as Ledger
import Cardano.Ledger.Shelley.Genesis qualified as Ledger
import Cardano.Ledger.Shelley.LedgerState qualified as Ledger
import Cardano.Ledger.Shelley.Rules qualified as Ledger
import Cardano.Ledger.UMap qualified as UM
import Control.Lens ((%~), (.~), (^.))
import Control.Monad (foldM)
import Data.ByteString qualified as BS
import Data.Default (def)
import Data.Map qualified as Map
import Data.Set qualified as Set
import Hydra.Chain.ChainState (ChainSlot (..))
import Hydra.Ledger (Ledger (..), ValidationError (..))
import Hydra.Tx (IsTx (..))
import System.IO.Unsafe (unsafeDupablePerformIO)
import Test.Cardano.Ledger.Babbage.Arbitrary ()
import Test.Cardano.Ledger.Conway.Arbitrary ()
import Test.Hydra.Tx.Gen (genKeyPair, genOneUTxOFor)
import Test.QuickCheck (
  choose,
  getSize,
  vectorOf,
 )

-- * Ledger

-- | Use the cardano-ledger as an in-hydra 'Ledger'.
cardanoLedger :: Ledger.Globals -> Ledger.LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger :: Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
globals LedgerEnv LedgerEra
ledgerEnv =
  Ledger{ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
applyTransactions :: ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
$sel:applyTransactions:Ledger :: ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
applyTransactions}
 where
  -- NOTE(SN): See full note on 'applyTx' why we only have a single transaction
  -- application here.
  applyTransactions :: ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
applyTransactions ChainSlot
slot UTxO
utxo = \case
    [] -> UTxO -> Either (Tx, ValidationError) UTxO
forall a b. b -> Either a b
Right UTxO
utxo
    (Tx
tx : [Tx]
txs) -> do
      UTxO
utxo' <- ChainSlot -> UTxO -> Tx -> Either (Tx, ValidationError) UTxO
applyTx ChainSlot
slot UTxO
utxo Tx
tx
      ChainSlot -> UTxO -> [Tx] -> Either (Tx, ValidationError) UTxO
applyTransactions ChainSlot
slot UTxO
utxo' [Tx]
txs

  -- TODO(SN): Pre-validate transactions to get less confusing errors on
  -- transactions which are not expected to work on a layer-2
  -- NOTE(SN): This is will fail on any transaction requiring the 'DPState' to be
  -- in a certain state as we do throw away the resulting 'DPState' and only take
  -- the ledger's 'UTxO' forward.
  --
  -- We came to this signature of only applying a single transaction because we
  -- got confused why a sequence of transactions worked but sequentially applying
  -- single transactions didn't. This was because of this not-keeping the'DPState'
  -- as described above.
  applyTx :: ChainSlot -> UTxO -> Tx -> Either (Tx, ValidationError) UTxO
applyTx (ChainSlot Natural
slot) UTxO
utxo Tx
tx =
    case Globals
-> MempoolEnv ConwayEra
-> LedgerState ConwayEra
-> Tx ConwayEra
-> Either
     (ApplyTxError ConwayEra)
     (LedgerState ConwayEra, Validated (Tx ConwayEra))
forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
Ledger.applyTx Globals
globals MempoolEnv ConwayEra
env' LedgerState ConwayEra
memPoolState (Tx -> Tx LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx) of
      Left ApplyTxError ConwayEra
err ->
        (Tx, ValidationError) -> Either (Tx, ValidationError) UTxO
forall a b. a -> Either a b
Left (Tx
tx, ApplyTxError ConwayEra -> ValidationError
forall {era} {era} {era} {era} {era}.
(PredicateFailure (EraRule "LEDGER" era)
 ~ ConwayLedgerPredFailure era,
 PredicateFailure (EraRule "UTXO" era) ~ ConwayUtxoPredFailure era,
 PredicateFailure (EraRule "UTXOW" era)
 ~ ConwayUtxowPredFailure era,
 PredicateFailure (EraRule "UTXOS" era)
 ~ ConwayUtxosPredFailure era,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ConwayEraScript era, ConwayEraScript era, EraTxOut era, Era era,
 Era era, Show (TxCert era), Show (ContextError era),
 Show (GovState era), Show (InstantStake era),
 Show (PredicateFailure (EraRule "CERTS" era)),
 Show (PredicateFailure (EraRule "GOV" era)), Show (Value era),
 Show (TxOut era), Show (Script era)) =>
ApplyTxError era -> ValidationError
toValidationError ApplyTxError ConwayEra
err)
      Right (Ledger.LedgerState{lsUTxOState :: forall era. LedgerState era -> UTxOState era
Ledger.lsUTxOState = UTxOState ConwayEra
us}, Validated (Tx ConwayEra)
_validatedTx) ->
        UTxO -> Either (Tx, ValidationError) UTxO
forall a b. b -> Either a b
Right (UTxO -> Either (Tx, ValidationError) UTxO)
-> (UTxO ConwayEra -> UTxO)
-> UTxO ConwayEra
-> Either (Tx, ValidationError) UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO ConwayEra -> UTxO
UTxO LedgerEra -> UTxO
fromLedgerUTxO (UTxO ConwayEra -> Either (Tx, ValidationError) UTxO)
-> UTxO ConwayEra -> Either (Tx, ValidationError) UTxO
forall a b. (a -> b) -> a -> b
$ UTxOState ConwayEra -> UTxO ConwayEra
forall era. UTxOState era -> UTxO era
Ledger.utxosUtxo UTxOState ConwayEra
us
   where
    -- As we use applyTx we only expect one ledger rule to run and one tx to
    -- fail validation, hence using the heads of non empty lists is fine.
    toValidationError :: ApplyTxError era -> ValidationError
toValidationError (Ledger.ApplyTxError (PredicateFailure (EraRule "LEDGER" era)
e :| [PredicateFailure (EraRule "LEDGER" era)]
_)) = case PredicateFailure (EraRule "LEDGER" era)
e of
      (ConwayUtxowFailure (UtxoFailure (UtxosFailure (ValidationTagMismatch IsValid
_ (FailedUnexpectedly (PlutusFailure Text
msg ByteString
ctx :| [FailureDescription]
_)))))) ->
        Text -> ValidationError
ValidationError (Text -> ValidationError) -> Text -> ValidationError
forall a b. (a -> b) -> a -> b
$
          Text
"Plutus validation failed: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Debug info: "
            -- NOTE: There is not a clear reason why 'debugPlutus' is an IO
            -- action. It only re-evaluates the script and does not have any
            -- side-effects.
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PlutusDebugInfo -> Text
forall b a. (Show a, IsString b) => a -> b
show (IO PlutusDebugInfo -> PlutusDebugInfo
forall a. IO a -> a
unsafeDupablePerformIO (IO PlutusDebugInfo -> PlutusDebugInfo)
-> IO PlutusDebugInfo -> PlutusDebugInfo
forall a b. (a -> b) -> a -> b
$ String -> PlutusDebugOverrides -> IO PlutusDebugInfo
debugPlutus (ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
ctx) (PlutusDebugOverrides -> IO PlutusDebugInfo)
-> PlutusDebugOverrides -> IO PlutusDebugInfo
forall a b. (a -> b) -> a -> b
$ Maybe ByteString
-> Maybe Version
-> Maybe Language
-> Maybe [Int64]
-> Maybe Natural
-> Maybe Natural
-> PlutusDebugOverrides
PlutusDebugOverrides Maybe ByteString
forall a. Maybe a
Nothing Maybe Version
forall a. Maybe a
Nothing Maybe Language
forall a. Maybe a
Nothing Maybe [Int64]
forall a. Maybe a
Nothing Maybe Natural
forall a. Maybe a
Nothing Maybe Natural
forall a. Maybe a
Nothing)
      PredicateFailure (EraRule "LEDGER" era)
_ -> Text -> ValidationError
ValidationError (Text -> ValidationError) -> Text -> ValidationError
forall a b. (a -> b) -> a -> b
$ ConwayLedgerPredFailure era -> Text
forall b a. (Show a, IsString b) => a -> b
show PredicateFailure (EraRule "LEDGER" era)
ConwayLedgerPredFailure era
e

    env' :: MempoolEnv ConwayEra
env' = LedgerEnv LedgerEra
ledgerEnv{Ledger.ledgerSlotNo = fromIntegral slot}

    memPoolState :: LedgerState ConwayEra
memPoolState =
      LedgerState ConwayEra
forall a. Default a => a
def
        LedgerState ConwayEra
-> (LedgerState ConwayEra -> LedgerState ConwayEra)
-> LedgerState ConwayEra
forall a b. a -> (a -> b) -> b
& (UTxOState ConwayEra -> Identity (UTxOState ConwayEra))
-> LedgerState ConwayEra -> Identity (LedgerState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
Ledger.lsUTxOStateL ((UTxOState ConwayEra -> Identity (UTxOState ConwayEra))
 -> LedgerState ConwayEra -> Identity (LedgerState ConwayEra))
-> ((UTxO ConwayEra -> Identity (UTxO ConwayEra))
    -> UTxOState ConwayEra -> Identity (UTxOState ConwayEra))
-> (UTxO ConwayEra -> Identity (UTxO ConwayEra))
-> LedgerState ConwayEra
-> Identity (LedgerState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxO ConwayEra -> Identity (UTxO ConwayEra))
-> UTxOState ConwayEra -> Identity (UTxOState ConwayEra)
forall era. Lens' (UTxOState era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
Ledger.utxoL ((UTxO ConwayEra -> Identity (UTxO ConwayEra))
 -> LedgerState ConwayEra -> Identity (LedgerState ConwayEra))
-> UTxO ConwayEra -> LedgerState ConwayEra -> LedgerState ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UTxO -> UTxO LedgerEra
toLedgerUTxO UTxO
utxo
        LedgerState ConwayEra
-> (LedgerState ConwayEra -> LedgerState ConwayEra)
-> LedgerState ConwayEra
forall a b. a -> (a -> b) -> b
& (ShelleyCertState ConwayEra
 -> Identity (ShelleyCertState ConwayEra))
-> LedgerState ConwayEra -> Identity (LedgerState ConwayEra)
(CertState ConwayEra -> Identity (CertState ConwayEra))
-> LedgerState ConwayEra -> Identity (LedgerState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
Ledger.lsCertStateL ((ShelleyCertState ConwayEra
  -> Identity (ShelleyCertState ConwayEra))
 -> LedgerState ConwayEra -> Identity (LedgerState ConwayEra))
-> ((DState ConwayEra -> Identity (DState ConwayEra))
    -> ShelleyCertState ConwayEra
    -> Identity (ShelleyCertState ConwayEra))
-> (DState ConwayEra -> Identity (DState ConwayEra))
-> LedgerState ConwayEra
-> Identity (LedgerState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState ConwayEra -> Identity (DState ConwayEra))
-> ShelleyCertState ConwayEra
-> Identity (ShelleyCertState ConwayEra)
(DState ConwayEra -> Identity (DState ConwayEra))
-> CertState ConwayEra -> Identity (CertState ConwayEra)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState ConwayEra) (DState ConwayEra)
Ledger.certDStateL ((DState ConwayEra -> Identity (DState ConwayEra))
 -> LedgerState ConwayEra -> Identity (LedgerState ConwayEra))
-> (DState ConwayEra -> DState ConwayEra)
-> LedgerState ConwayEra
-> LedgerState ConwayEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ DState ConwayEra -> DState ConwayEra
mockCertState

    -- NOTE: Mocked certificate state that simulates any reward accounts for any
    -- withdraw-zero scripts included in the transaction.
    mockCertState :: DState ConwayEra -> DState ConwayEra
mockCertState = (UMap -> Identity UMap)
-> DState ConwayEra -> Identity (DState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL ((UMap -> Identity UMap)
 -> DState ConwayEra -> Identity (DState ConwayEra))
-> (UMap -> UMap) -> DState ConwayEra -> DState ConwayEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (\UMap
umap -> (UMap -> Credential 'Staking -> UMap)
-> UMap -> Set (Credential 'Staking) -> UMap
forall b a. (b -> a -> b) -> b -> Set a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UMap -> Credential 'Staking -> UMap
register UMap
umap Set (Credential 'Staking)
withdrawZeroCredentials)

    register :: UMap -> Credential 'Staking -> UMap
register UMap
umap Credential 'Staking
hk = UMap -> UView (Credential 'Staking) RDPair
UM.RewDepUView UMap
umap UView (Credential 'Staking) RDPair
-> (Credential 'Staking, RDPair) -> UMap
forall k v. UView k v -> (k, v) -> UMap
UM.∪ (Credential 'Staking
hk, CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (Word64 -> CompactForm Coin
UM.CompactCoin Word64
0) (Word64 -> CompactForm Coin
UM.CompactCoin Word64
0))

    withdrawZeroCredentials :: Set (Credential 'Staking)
withdrawZeroCredentials =
      Tx -> Tx LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx AlonzoTx ConwayEra
-> Getting Withdrawals (AlonzoTx ConwayEra) Withdrawals
-> Withdrawals
forall s a. s -> Getting a s a -> a
^. (TxBody ConwayEra -> Const Withdrawals (TxBody ConwayEra))
-> Tx ConwayEra -> Const Withdrawals (Tx ConwayEra)
(TxBody ConwayEra -> Const Withdrawals (TxBody ConwayEra))
-> AlonzoTx ConwayEra -> Const Withdrawals (AlonzoTx ConwayEra)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx ConwayEra) (TxBody ConwayEra)
bodyTxL ((TxBody ConwayEra -> Const Withdrawals (TxBody ConwayEra))
 -> AlonzoTx ConwayEra -> Const Withdrawals (AlonzoTx ConwayEra))
-> ((Withdrawals -> Const Withdrawals Withdrawals)
    -> TxBody ConwayEra -> Const Withdrawals (TxBody ConwayEra))
-> Getting Withdrawals (AlonzoTx ConwayEra) Withdrawals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Withdrawals -> Const Withdrawals Withdrawals)
-> TxBody ConwayEra -> Const Withdrawals (TxBody ConwayEra)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody ConwayEra) Withdrawals
withdrawalsTxBodyL
        Withdrawals
-> (Withdrawals -> Map RewardAccount Coin)
-> Map RewardAccount Coin
forall a b. a -> (a -> b) -> b
& Withdrawals -> Map RewardAccount Coin
unWithdrawals
        Map RewardAccount Coin
-> (Map RewardAccount Coin -> Map RewardAccount Coin)
-> Map RewardAccount Coin
forall a b. a -> (a -> b) -> b
& (Coin -> Bool) -> Map RewardAccount Coin -> Map RewardAccount Coin
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Coin
Coin Integer
0)
        Map RewardAccount Coin
-> (Map RewardAccount Coin -> Set RewardAccount)
-> Set RewardAccount
forall a b. a -> (a -> b) -> b
& Map RewardAccount Coin -> Set RewardAccount
forall k a. Map k a -> Set k
Map.keysSet
        Set RewardAccount
-> (Set RewardAccount -> Set (Credential 'Staking))
-> Set (Credential 'Staking)
forall a b. a -> (a -> b) -> b
& (RewardAccount -> Credential 'Staking)
-> Set RewardAccount -> Set (Credential 'Staking)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map RewardAccount -> Credential 'Staking
raCredential

-- * LedgerEnv

-- | Create a new ledger env from given protocol parameters.
newLedgerEnv :: PParams LedgerEra -> Ledger.LedgerEnv LedgerEra
newLedgerEnv :: PParams LedgerEra -> LedgerEnv LedgerEra
newLedgerEnv PParams LedgerEra
protocolParams =
  Ledger.LedgerEnv
    { ledgerSlotNo :: SlotNo
Ledger.ledgerSlotNo = Word64 -> SlotNo
SlotNo Word64
0
    , -- NOTE: This can probably stay at 0 forever. This is used internally by the
      -- node's mempool to keep track of transaction seen from peers. Transactions
      -- in Hydra do not go through the node's mempool and follow a different
      -- consensus path so this will remain unused.
      ledgerIx :: TxIx
Ledger.ledgerIx = TxIx
forall a. Bounded a => a
minBound
    , -- NOTE: This keeps track of the ledger's treasury and reserve which are
      -- both unused in Hydra. There might be room for interesting features in the
      -- future with these two but for now, we'll consider them empty.
      ledgerAccount :: AccountState
Ledger.ledgerAccount = Coin -> Coin -> AccountState
Ledger.AccountState Coin
forall a. Monoid a => a
mempty Coin
forall a. Monoid a => a
mempty
    , ledgerPp :: PParams ConwayEra
Ledger.ledgerPp = PParams ConwayEra
PParams LedgerEra
protocolParams
    , ledgerEpochNo :: Maybe EpochNo
Ledger.ledgerEpochNo = Maybe EpochNo
forall a. Maybe a
Nothing
    }

-- * Conversions and utilities

-- | Simple conversion from a generic slot to a specific local one.
fromChainSlot :: ChainSlot -> SlotNo
fromChainSlot :: ChainSlot -> SlotNo
fromChainSlot (ChainSlot Natural
s) = Natural -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
s

-- | Build a zero-fee transaction which spends the first output owned by given
-- signing key and transfers it in full to given verification key.
mkTransferTx ::
  MonadFail m =>
  NetworkId ->
  UTxO ->
  SigningKey PaymentKey ->
  VerificationKey PaymentKey ->
  m Tx
mkTransferTx :: forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
networkId UTxO
utxo SigningKey PaymentKey
sender VerificationKey PaymentKey
recipient =
  case (TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (VerificationKey PaymentKey -> TxOut CtxUTxO Era -> Bool
forall ctx era. VerificationKey PaymentKey -> TxOut ctx era -> Bool
isVkTxOut (VerificationKey PaymentKey -> TxOut CtxUTxO Era -> Bool)
-> VerificationKey PaymentKey -> TxOut CtxUTxO Era -> Bool
forall a b. (a -> b) -> a -> b
$ SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
sender) UTxO
utxo of
    Maybe (TxIn, TxOut CtxUTxO Era)
Nothing -> String -> m Tx
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no utxo left to spend"
    Just (TxIn
txIn, TxOut CtxUTxO Era
txOut) ->
      case (TxIn, TxOut CtxUTxO Era)
-> (AddressInEra, Value)
-> SigningKey PaymentKey
-> Either TxBodyError Tx
mkSimpleTx (TxIn
txIn, TxOut CtxUTxO Era
txOut) (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
recipient, TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO Era
txOut) SigningKey PaymentKey
sender of
        Left TxBodyError
err ->
          String -> m Tx
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Tx) -> String -> m Tx
forall a b. (a -> b) -> a -> b
$ String
"mkSimpleTx failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxBodyError -> String
forall b a. (Show a, IsString b) => a -> b
show TxBodyError
err
        Right Tx
tx ->
          Tx -> m Tx
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
tx

-- | Build a zero-fee payment transaction.
mkSimpleTx ::
  (TxIn, TxOut CtxUTxO) ->
  -- | Recipient address and amount.
  (AddressInEra, Value) ->
  -- | Sender's signing key.
  SigningKey PaymentKey ->
  Either TxBodyError Tx
mkSimpleTx :: (TxIn, TxOut CtxUTxO Era)
-> (AddressInEra, Value)
-> SigningKey PaymentKey
-> Either TxBodyError Tx
mkSimpleTx (TxIn
txin, TxOut AddressInEra
owner Value
valueIn TxOutDatum CtxUTxO
datum ReferenceScript
refScript) (AddressInEra
recipient, Value
valueOut) SigningKey PaymentKey
sk = do
  TxBody
body <- TxBodyContent BuildTx -> Either TxBodyError TxBody
createAndValidateTransactionBody TxBodyContent BuildTx
bodyContent
  let witnesses :: [KeyWitness]
witnesses = [TxBody -> ShelleyWitnessSigningKey -> KeyWitness
makeShelleyKeyWitness TxBody
body (SigningKey PaymentKey -> ShelleyWitnessSigningKey
WitnessPaymentKey SigningKey PaymentKey
sk)]
  Tx -> Either TxBodyError Tx
forall a. a -> Either TxBodyError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either TxBodyError Tx) -> Tx -> Either TxBodyError Tx
forall a b. (a -> b) -> a -> b
$ [KeyWitness] -> TxBody -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [KeyWitness]
witnesses TxBody
body
 where
  bodyContent :: TxBodyContent BuildTx
bodyContent =
    TxBodyContent BuildTx
defaultTxBodyContent
      { txIns = [(txin, BuildTxWith $ KeyWitness KeyWitnessForSpending)]
      , txOuts = outs
      , txFee = TxFeeExplicit fee
      }

  outs :: [TxOut CtxTx]
outs =
    forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut @CtxTx AddressInEra
recipient Value
valueOut TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone
      TxOut CtxTx -> [TxOut CtxTx] -> [TxOut CtxTx]
forall a. a -> [a] -> [a]
: [ TxOut CtxUTxO Era -> TxOut CtxTx
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut (TxOut CtxUTxO Era -> TxOut CtxTx)
-> TxOut CtxUTxO Era -> TxOut CtxTx
forall a b. (a -> b) -> a -> b
$
            AddressInEra
-> Value
-> TxOutDatum CtxUTxO
-> ReferenceScript
-> TxOut CtxUTxO Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
              AddressInEra
owner
              (Value
valueIn Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
negateValue Value
valueOut)
              TxOutDatum CtxUTxO
datum
              ReferenceScript
refScript
        | Value
valueOut Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
valueIn
        ]

  fee :: Coin
fee = Integer -> Coin
Coin Integer
0

-- | Create a zero-fee, payment cardano transaction with validity range.
mkRangedTx ::
  (TxIn, TxOut CtxUTxO) ->
  -- | Recipient address and amount.
  (AddressInEra, Value) ->
  -- | Sender's signing key.
  SigningKey PaymentKey ->
  (Maybe TxValidityLowerBound, Maybe TxValidityUpperBound) ->
  Either TxBodyError Tx
mkRangedTx :: (TxIn, TxOut CtxUTxO Era)
-> (AddressInEra, Value)
-> SigningKey PaymentKey
-> (Maybe TxValidityLowerBound, Maybe TxValidityUpperBound)
-> Either TxBodyError Tx
mkRangedTx (TxIn
txin, TxOut AddressInEra
owner Value
valueIn TxOutDatum CtxUTxO
datum ReferenceScript
refScript) (AddressInEra
recipient, Value
valueOut) SigningKey PaymentKey
sk (Maybe TxValidityLowerBound
validityLowerBound, Maybe TxValidityUpperBound
validityUpperBound) = do
  TxBody
body <- TxBodyContent BuildTx -> Either TxBodyError TxBody
createAndValidateTransactionBody TxBodyContent BuildTx
bodyContent
  let witnesses :: [KeyWitness]
witnesses = [TxBody -> ShelleyWitnessSigningKey -> KeyWitness
makeShelleyKeyWitness TxBody
body (SigningKey PaymentKey -> ShelleyWitnessSigningKey
WitnessPaymentKey SigningKey PaymentKey
sk)]
  Tx -> Either TxBodyError Tx
forall a. a -> Either TxBodyError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either TxBodyError Tx) -> Tx -> Either TxBodyError Tx
forall a b. (a -> b) -> a -> b
$ [KeyWitness] -> TxBody -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [KeyWitness]
witnesses TxBody
body
 where
  bodyContent :: TxBodyContent BuildTx
bodyContent =
    TxBodyContent BuildTx
defaultTxBodyContent
      { txIns = [(txin, BuildTxWith $ KeyWitness KeyWitnessForSpending)]
      , txOuts =
          TxOut @CtxTx recipient valueOut TxOutDatumNone ReferenceScriptNone
            : [ fromCtxUTxOTxOut $
                  TxOut
                    owner
                    (valueIn <> negateValue valueOut)
                    datum
                    refScript
              | valueOut /= valueIn
              ]
      , txFee = TxFeeExplicit $ Coin 0
      , txValidityLowerBound = fromMaybe TxValidityNoLowerBound validityLowerBound
      , txValidityUpperBound = fromMaybe TxValidityNoUpperBound validityUpperBound
      }

-- | Utility function to "adjust" a `UTxO` set given a `Tx`
--
--  The inputs from the `Tx` are removed from the internal map of the `UTxO` and
--  the outputs added, correctly indexed by the `TxIn`. This function is useful
--  to manually maintain a `UTxO` set without caring too much about the `Ledger`
--  rules.
adjustUTxO :: Tx -> UTxO -> UTxO
adjustUTxO :: Tx -> UTxO -> UTxO
adjustUTxO Tx
tx UTxO
utxo =
  let txid :: TxIdType Tx
txid = Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx
      consumed :: [TxIn]
consumed = Tx -> [TxIn]
forall era. Tx era -> [TxIn]
txIns' Tx
tx
      produced :: UTxO
produced =
        TxOut CtxTx -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut
          (TxOut CtxTx -> TxOut CtxUTxO Era) -> UTxO' (TxOut CtxTx) -> UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxIn, TxOut CtxTx)] -> UTxO' (TxOut CtxTx)
forall out. [(TxIn, out)] -> UTxO' out
fromPairs ((\(TxOut CtxTx
txout, Word
ix) -> (TxId -> TxIx -> TxIn
TxIn TxIdType Tx
TxId
txid (Word -> TxIx
TxIx Word
ix), TxOut CtxTx
txout)) ((TxOut CtxTx, Word) -> (TxIn, TxOut CtxTx))
-> [(TxOut CtxTx, Word)] -> [(TxIn, TxOut CtxTx)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxOut CtxTx] -> [Word] -> [(TxOut CtxTx, Word)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Tx -> [TxOut CtxTx]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx) [Word
0 ..])
      utxo' :: UTxO
utxo' = [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall out. [(TxIn, out)] -> UTxO' out
fromPairs ([(TxIn, TxOut CtxUTxO Era)] -> UTxO)
-> [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall a b. (a -> b) -> a -> b
$ ((TxIn, TxOut CtxUTxO Era) -> Bool)
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TxIn
txin, TxOut CtxUTxO Era
_) -> TxIn
txin TxIn -> [TxIn] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [TxIn]
consumed) ([(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)])
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a b. (a -> b) -> a -> b
$ UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
pairs UTxO
utxo
   in UTxO
utxo' UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
produced

-- * Generators

-- | Generates a sequence of simple "transfer" transactions for a single key.
genSequenceOfSimplePaymentTransactions :: Gen (UTxO, [Tx])
genSequenceOfSimplePaymentTransactions :: Gen (UTxO, [Tx])
genSequenceOfSimplePaymentTransactions = do
  Int
n <- Gen Int
getSize
  Int
numTxs <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
n)
  Int -> Gen (UTxO, [Tx])
genFixedSizeSequenceOfSimplePaymentTransactions Int
numTxs

genFixedSizeSequenceOfSimplePaymentTransactions :: Int -> Gen (UTxO, [Tx])
genFixedSizeSequenceOfSimplePaymentTransactions :: Int -> Gen (UTxO, [Tx])
genFixedSizeSequenceOfSimplePaymentTransactions Int
numTxs = do
  (VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
  UTxO
utxo <- VerificationKey PaymentKey -> Gen UTxO
genOneUTxOFor VerificationKey PaymentKey
vk
  (UTxO
_, [Tx]
txs) <- ((UTxO, [Tx]) -> Int -> Gen (UTxO, [Tx]))
-> (UTxO, [Tx]) -> [Int] -> Gen (UTxO, [Tx])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (SigningKey PaymentKey -> (UTxO, [Tx]) -> Int -> Gen (UTxO, [Tx])
forall {f :: * -> *} {p}.
Applicative f =>
SigningKey PaymentKey -> (UTxO, [Tx]) -> p -> f (UTxO, [Tx])
go SigningKey PaymentKey
sk) (UTxO
utxo, []) [Int
1 .. Int
numTxs]
  (UTxO, [Tx]) -> Gen (UTxO, [Tx])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO
utxo, [Tx] -> [Tx]
forall a. [a] -> [a]
reverse [Tx]
txs)
 where
  -- Magic number is irrelevant.
  testNetworkId :: NetworkId
testNetworkId = NetworkMagic -> NetworkId
Testnet (NetworkMagic -> NetworkId) -> NetworkMagic -> NetworkId
forall a b. (a -> b) -> a -> b
$ Word32 -> NetworkMagic
NetworkMagic Word32
42

  go :: SigningKey PaymentKey -> (UTxO, [Tx]) -> p -> f (UTxO, [Tx])
go SigningKey PaymentKey
sk (UTxO
utxo, [Tx]
txs) p
_ = do
    case NetworkId
-> UTxO
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> Either Text Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
testNetworkId UTxO
utxo SigningKey PaymentKey
sk (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
sk) of
      Left Text
err -> Text -> f (UTxO, [Tx])
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> f (UTxO, [Tx])) -> Text -> f (UTxO, [Tx])
forall a b. (a -> b) -> a -> b
$ Text
"mkTransferTx failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
      Right Tx
tx -> (UTxO, [Tx]) -> f (UTxO, [Tx])
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> UTxOType Tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx Tx
tx, Tx
tx Tx -> [Tx] -> [Tx]
forall a. a -> [a] -> [a]
: [Tx]
txs)

-- * Orphans

instance Arbitrary (Hash PaymentKey) where
  arbitrary :: Gen (Hash PaymentKey)
arbitrary = HasCallStack => ByteString -> Hash PaymentKey
ByteString -> Hash PaymentKey
unsafePaymentKeyHashFromBytes (ByteString -> Hash PaymentKey)
-> ([Word8] -> ByteString) -> [Word8] -> Hash PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack ([Word8] -> Hash PaymentKey)
-> Gen [Word8] -> Gen (Hash PaymentKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Word8 -> Gen [Word8]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
28 Gen Word8
forall a. Arbitrary a => Gen a
arbitrary