{-# 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.BaseTypes qualified as Ledger
import Cardano.Ledger.Credential qualified as Ledger
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 Control.Monad (foldM)
import Data.ByteString qualified as BS
import Data.Default (def)
import Hydra.Chain.ChainState (ChainSlot (..))
import Hydra.Ledger (Ledger (..), ValidationError (..))
import Hydra.Tx (IsTx (..))
import Hydra.Tx.Utils (adaOnly)
import Test.Cardano.Ledger.Babbage.Arbitrary ()
import Test.Cardano.Ledger.Conway.Arbitrary ()
import Test.Hydra.Tx.Gen (genKeyPair, genOneUTxOFor, genValue)
import Test.QuickCheck (
  choose,
  getSize,
  oneof,
  suchThat,
  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' (TxOut CtxUTxO)
-> [Tx]
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO))
applyTransactions :: ChainSlot
-> UTxO' (TxOut CtxUTxO)
-> [Tx]
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO))
$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' (TxOut CtxUTxO)
-> [Tx]
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO))
applyTransactions ChainSlot
slot UTxO' (TxOut CtxUTxO)
utxo = \case
    [] -> UTxO' (TxOut CtxUTxO)
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO))
forall a b. b -> Either a b
Right UTxO' (TxOut CtxUTxO)
utxo
    (Tx
tx : [Tx]
txs) -> do
      UTxO' (TxOut CtxUTxO)
utxo' <- ChainSlot
-> UTxO' (TxOut CtxUTxO)
-> Tx
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO))
applyTx ChainSlot
slot UTxO' (TxOut CtxUTxO)
utxo Tx
tx
      ChainSlot
-> UTxO' (TxOut CtxUTxO)
-> [Tx]
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO))
applyTransactions ChainSlot
slot UTxO' (TxOut CtxUTxO)
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' (TxOut CtxUTxO)
-> Tx
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO))
applyTx (ChainSlot Natural
slot) UTxO' (TxOut CtxUTxO)
utxo Tx
tx =
    case Globals
-> MempoolEnv (ConwayEra StandardCrypto)
-> MempoolState (ConwayEra StandardCrypto)
-> Tx (ConwayEra StandardCrypto)
-> Either
     (ApplyTxError (ConwayEra StandardCrypto))
     (MempoolState (ConwayEra StandardCrypto),
      Validated (Tx (ConwayEra StandardCrypto)))
forall era (m :: * -> *).
(ApplyTx era, MonadError (ApplyTxError era) m) =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> m (MempoolState era, Validated (Tx era))
forall (m :: * -> *).
MonadError (ApplyTxError (ConwayEra StandardCrypto)) m =>
Globals
-> MempoolEnv (ConwayEra StandardCrypto)
-> MempoolState (ConwayEra StandardCrypto)
-> Tx (ConwayEra StandardCrypto)
-> m (MempoolState (ConwayEra StandardCrypto),
      Validated (Tx (ConwayEra StandardCrypto)))
Ledger.applyTx Globals
globals MempoolEnv (ConwayEra StandardCrypto)
env' MempoolState (ConwayEra StandardCrypto)
memPoolState (Tx -> Tx LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx) of
      Left ApplyTxError (ConwayEra StandardCrypto)
err ->
        (Tx, ValidationError)
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO))
forall a b. a -> Either a b
Left (Tx
tx, ApplyTxError (ConwayEra StandardCrypto) -> ValidationError
toValidationError ApplyTxError (ConwayEra StandardCrypto)
err)
      Right (Ledger.LedgerState{lsUTxOState :: forall era. LedgerState era -> UTxOState era
Ledger.lsUTxOState = UTxOState (ConwayEra StandardCrypto)
us}, Validated (AlonzoTx (ConwayEra StandardCrypto))
_validatedTx) ->
        UTxO' (TxOut CtxUTxO)
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO))
forall a b. b -> Either a b
Right (UTxO' (TxOut CtxUTxO)
 -> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO)))
-> (UTxO (ConwayEra StandardCrypto) -> UTxO' (TxOut CtxUTxO))
-> UTxO (ConwayEra StandardCrypto)
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO (ConwayEra StandardCrypto) -> UTxO' (TxOut CtxUTxO)
UTxO LedgerEra -> UTxO' (TxOut CtxUTxO)
fromLedgerUTxO (UTxO (ConwayEra StandardCrypto)
 -> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO)))
-> UTxO (ConwayEra StandardCrypto)
-> Either (Tx, ValidationError) (UTxO' (TxOut CtxUTxO))
forall a b. (a -> b) -> a -> b
$ UTxOState (ConwayEra StandardCrypto)
-> UTxO (ConwayEra StandardCrypto)
forall era. UTxOState era -> UTxO era
Ledger.utxosUtxo UTxOState (ConwayEra StandardCrypto)
us
   where
    toValidationError :: ApplyTxError (ConwayEra StandardCrypto) -> ValidationError
toValidationError = Text -> ValidationError
ValidationError (Text -> ValidationError)
-> (ApplyTxError (ConwayEra StandardCrypto) -> Text)
-> ApplyTxError (ConwayEra StandardCrypto)
-> ValidationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplyTxError (ConwayEra StandardCrypto) -> Text
forall b a. (Show a, IsString b) => a -> b
show

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

    memPoolState :: MempoolState (ConwayEra StandardCrypto)
memPoolState =
      Ledger.LedgerState
        { lsUTxOState :: UTxOState (ConwayEra StandardCrypto)
Ledger.lsUTxOState = UTxOState (ConwayEra StandardCrypto)
forall a. Default a => a
def{Ledger.utxosUtxo = toLedgerUTxO utxo}
        , lsCertState :: CertState (ConwayEra StandardCrypto)
Ledger.lsCertState = CertState (ConwayEra StandardCrypto)
forall a. Default a => a
def
        }

-- * 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 StandardCrypto)
Ledger.ledgerPp = PParams (ConwayEra StandardCrypto)
PParams LedgerEra
protocolParams
    }

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

-- | Create a zero-fee, payment cardano transaction.
mkSimpleTx ::
  (TxIn, TxOut CtxUTxO) ->
  -- | Recipient address and amount.
  (AddressInEra, Value) ->
  -- | Sender's signing key.
  SigningKey PaymentKey ->
  Either TxBodyError Tx
mkSimpleTx :: (TxIn, TxOut CtxUTxO)
-> (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
emptyTxBody
      { 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]
: [ forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut @CtxTx
          AddressInEra
owner
          (Value
valueIn Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
negateValue Value
valueOut)
          (TxOutDatum CtxUTxO -> TxOutDatum CtxTx
forall era. TxOutDatum CtxUTxO era -> TxOutDatum CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext 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)
-> (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
emptyTxBody
      { txIns = [(txin, BuildTxWith $ KeyWitness KeyWitnessForSpending)]
      , txOuts =
          TxOut @CtxTx recipient valueOut TxOutDatumNone ReferenceScriptNone
            : [ TxOut @CtxTx
                owner
                (valueIn <> negateValue valueOut)
                (toTxContext 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' (TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO)
adjustUTxO Tx
tx UTxO' (TxOut CtxUTxO)
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' (TxOut CtxUTxO)
produced =
        TxOut CtxTx -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext
          (TxOut CtxTx -> TxOut CtxUTxO)
-> UTxO' (TxOut CtxTx) -> UTxO' (TxOut CtxUTxO)
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' (TxOut CtxUTxO)
utxo' = [(TxIn, TxOut CtxUTxO)] -> UTxO' (TxOut CtxUTxO)
forall out. [(TxIn, out)] -> UTxO' out
fromPairs ([(TxIn, TxOut CtxUTxO)] -> UTxO' (TxOut CtxUTxO))
-> [(TxIn, TxOut CtxUTxO)] -> UTxO' (TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$ ((TxIn, TxOut CtxUTxO) -> Bool)
-> [(TxIn, TxOut CtxUTxO)] -> [(TxIn, TxOut CtxUTxO)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TxIn
txin, TxOut CtxUTxO
_) -> TxIn
txin TxIn -> [TxIn] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [TxIn]
consumed) ([(TxIn, TxOut CtxUTxO)] -> [(TxIn, TxOut CtxUTxO)])
-> [(TxIn, TxOut CtxUTxO)] -> [(TxIn, TxOut CtxUTxO)]
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO) -> [(TxIn, TxOut CtxUTxO)]
forall out. UTxO' out -> [(TxIn, out)]
pairs UTxO' (TxOut CtxUTxO)
utxo
   in UTxO' (TxOut CtxUTxO)
utxo' UTxO' (TxOut CtxUTxO)
-> UTxO' (TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO)
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO)
produced

-- * Generators

-- | Generates a sequence of simple "transfer" transactions for a single key.
-- The kind of transactions produced by this generator is very limited, see `generateOneTransfer`.
genSequenceOfSimplePaymentTransactions :: Gen (UTxO, [Tx])
genSequenceOfSimplePaymentTransactions :: Gen (UTxO' (TxOut CtxUTxO), [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' (TxOut CtxUTxO), [Tx])
genFixedSizeSequenceOfSimplePaymentTransactions Int
numTxs

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

generateOneRandomTransfer ::
  NetworkId ->
  (UTxO, SigningKey PaymentKey, [Tx]) ->
  Int ->
  Gen (UTxO, SigningKey PaymentKey, [Tx])
generateOneRandomTransfer :: NetworkId
-> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
-> Int
-> Gen (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
generateOneRandomTransfer NetworkId
networkId (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
senderUtxO Int
nbrTx = do
  (VerificationKey PaymentKey, SigningKey PaymentKey)
recipient <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
  (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
-> Gen (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
 -> Gen (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx]))
-> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
-> Gen (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
forall a b. (a -> b) -> a -> b
$ NetworkId
-> SigningKey PaymentKey
-> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
-> Int
-> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
mkOneTransfer NetworkId
networkId ((VerificationKey PaymentKey, SigningKey PaymentKey)
-> SigningKey PaymentKey
forall a b. (a, b) -> b
snd (VerificationKey PaymentKey, SigningKey PaymentKey)
recipient) (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
senderUtxO Int
nbrTx

generateOneSelfTransfer ::
  NetworkId ->
  (UTxO, SigningKey PaymentKey, [Tx]) ->
  Int ->
  Gen (UTxO, SigningKey PaymentKey, [Tx])
generateOneSelfTransfer :: NetworkId
-> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
-> Int
-> Gen (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
generateOneSelfTransfer NetworkId
networkId (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
senderUtxO Int
nbrTx = do
  let (UTxO' (TxOut CtxUTxO)
_, SigningKey PaymentKey
recipientSk, [Tx]
_) = (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
senderUtxO
  (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
-> Gen (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
 -> Gen (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx]))
-> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
-> Gen (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
forall a b. (a -> b) -> a -> b
$ NetworkId
-> SigningKey PaymentKey
-> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
-> Int
-> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
mkOneTransfer NetworkId
networkId SigningKey PaymentKey
recipientSk (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
senderUtxO Int
nbrTx

mkOneTransfer ::
  NetworkId ->
  SigningKey PaymentKey ->
  (UTxO, SigningKey PaymentKey, [Tx]) ->
  Int ->
  (UTxO, SigningKey PaymentKey, [Tx])
mkOneTransfer :: NetworkId
-> SigningKey PaymentKey
-> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
-> Int
-> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
mkOneTransfer NetworkId
networkId SigningKey PaymentKey
recipientSk (UTxO' (TxOut CtxUTxO)
utxo, SigningKey PaymentKey
sender, [Tx]
txs) Int
_ = do
  let recipientVk :: VerificationKey PaymentKey
recipientVk = SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
recipientSk
  -- NOTE(AB): elements is partial, it crashes if given an empty list, We don't expect
  -- this function to be ever used in production, and crash will be caught in tests
  case UTxO' (TxOut CtxUTxO) -> [(TxIn, TxOut CtxUTxO)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO' (TxOut CtxUTxO)
utxo of
    [(TxIn, TxOut CtxUTxO)
txin] ->
      case (TxIn, TxOut CtxUTxO)
-> (AddressInEra, Value)
-> SigningKey PaymentKey
-> Either TxBodyError Tx
mkSimpleTx (TxIn, TxOut CtxUTxO)
txin (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
recipientVk, forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance @Tx UTxOType Tx
UTxO' (TxOut CtxUTxO)
utxo) SigningKey PaymentKey
sender of
        Left TxBodyError
e -> Text -> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx]))
-> Text -> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
forall a b. (a -> b) -> a -> b
$ Text
"Tx construction failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxBodyError -> Text
forall b a. (Show a, IsString b) => a -> b
show TxBodyError
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", utxo: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO) -> Text
forall b a. (Show a, IsString b) => a -> b
show UTxO' (TxOut CtxUTxO)
utxo
        Right Tx
tx -> (Tx -> UTxOType Tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx Tx
tx, SigningKey PaymentKey
recipientSk, Tx
tx Tx -> [Tx] -> [Tx]
forall a. a -> [a] -> [a]
: [Tx]
txs)
    [(TxIn, TxOut CtxUTxO)]
_ ->
      Text -> (UTxO' (TxOut CtxUTxO), SigningKey PaymentKey, [Tx])
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Couldn't generate transaction sequence: need exactly one UTXO."

-- | Generate a 'Babbage' era 'TxOut', which may contain arbitrary assets
-- addressed to public keys and scripts, as well as datums.
--
-- NOTE: This generator does
--  * not produce byron addresses as most of the cardano ecosystem dropped support for that (including plutus),
--  * not produce reference scripts as they are not fully "visible" from plutus,
--  * replace stake pointers with null references as nobody uses that.
genTxOut :: Gen (TxOut ctx)
genTxOut :: forall ctx. Gen (TxOut ctx)
genTxOut =
  (TxOut ctx -> TxOut ctx
forall {ctx}. TxOut ctx -> TxOut ctx
noRefScripts (TxOut ctx -> TxOut ctx)
-> (TxOut ctx -> TxOut ctx) -> TxOut ctx -> TxOut ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut ctx -> TxOut ctx
forall {ctx}. TxOut ctx -> TxOut ctx
noStakeRefPtr (TxOut ctx -> TxOut ctx) -> Gen (TxOut ctx) -> Gen (TxOut ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (TxOut ctx)
gen)
    Gen (TxOut ctx) -> (TxOut ctx -> Bool) -> Gen (TxOut ctx)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` TxOut ctx -> Bool
forall {ctx}. TxOut ctx -> Bool
notByronAddress
 where
  gen :: Gen (TxOut ctx)
gen =
    (Value -> Value) -> TxOut ctx -> TxOut ctx
forall era ctx.
(IsMaryBasedEra era, IsShelleyBasedEra era) =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> (Coin -> Value
lovelaceToValue (Coin -> Value) -> Coin -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
10_000_000))
      (TxOut ctx -> TxOut ctx) -> Gen (TxOut ctx) -> Gen (TxOut ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen (TxOut ctx)] -> Gen (TxOut ctx)
forall a. [Gen a] -> Gen a
oneof
        [ TxOut LedgerEra -> TxOut ctx
BabbageTxOut (ConwayEra StandardCrypto) -> TxOut ctx
forall era ctx.
IsShelleyBasedEra era =>
TxOut (ShelleyLedgerEra era) -> TxOut ctx era
fromLedgerTxOut (BabbageTxOut (ConwayEra StandardCrypto) -> TxOut ctx)
-> Gen (BabbageTxOut (ConwayEra StandardCrypto)) -> Gen (TxOut ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (BabbageTxOut (ConwayEra StandardCrypto))
forall a. Arbitrary a => Gen a
arbitrary
        , TxOut ctx -> TxOut ctx
forall {ctx}. TxOut ctx -> TxOut ctx
notMultiAsset (TxOut ctx -> TxOut ctx)
-> (BabbageTxOut (ConwayEra StandardCrypto) -> TxOut ctx)
-> BabbageTxOut (ConwayEra StandardCrypto)
-> TxOut ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut LedgerEra -> TxOut ctx
BabbageTxOut (ConwayEra StandardCrypto) -> TxOut ctx
forall era ctx.
IsShelleyBasedEra era =>
TxOut (ShelleyLedgerEra era) -> TxOut ctx era
fromLedgerTxOut (BabbageTxOut (ConwayEra StandardCrypto) -> TxOut ctx)
-> Gen (BabbageTxOut (ConwayEra StandardCrypto)) -> Gen (TxOut ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (BabbageTxOut (ConwayEra StandardCrypto))
forall a. Arbitrary a => Gen a
arbitrary
        ]
  notMultiAsset :: TxOut ctx Era -> TxOut ctx Era
notMultiAsset =
    (Value -> Value) -> TxOut ctx Era -> TxOut ctx Era
forall era ctx.
(IsMaryBasedEra era, IsShelleyBasedEra era) =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Coin -> Value
lovelaceToValue (Coin -> Value) -> (Value -> Coin) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Coin
selectLovelace)

  notByronAddress :: TxOut ctx -> Bool
notByronAddress (TxOut AddressInEra
addr Value
_ TxOutDatum ctx
_ ReferenceScript
_) = case AddressInEra
addr of
    ByronAddressInEra{} -> Bool
False
    AddressInEra
_ -> Bool
True

  noStakeRefPtr :: TxOut ctx -> TxOut ctx
noStakeRefPtr out :: TxOut ctx
out@(TxOut AddressInEra
addr Value
val TxOutDatum ctx
dat ReferenceScript
refScript) = case AddressInEra
addr of
    ShelleyAddressInEra (ShelleyAddress Network
_ PaymentCredential StandardCrypto
cre StakeReference StandardCrypto
sr) ->
      case StakeReference StandardCrypto
sr of
        Ledger.StakeRefPtr Ptr
_ ->
          AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut (Address ShelleyAddr -> AddressInEra
ShelleyAddressInEra (Network
-> PaymentCredential StandardCrypto
-> StakeReference StandardCrypto
-> Address ShelleyAddr
ShelleyAddress Network
Ledger.Testnet PaymentCredential StandardCrypto
cre StakeReference StandardCrypto
forall c. StakeReference c
Ledger.StakeRefNull)) Value
val TxOutDatum ctx
dat ReferenceScript
refScript
        StakeReference StandardCrypto
_ ->
          AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut (Address ShelleyAddr -> AddressInEra
ShelleyAddressInEra (Network
-> PaymentCredential StandardCrypto
-> StakeReference StandardCrypto
-> Address ShelleyAddr
ShelleyAddress Network
Ledger.Testnet PaymentCredential StandardCrypto
cre StakeReference StandardCrypto
sr)) Value
val TxOutDatum ctx
dat ReferenceScript
refScript
    AddressInEra
_ -> TxOut ctx
out

  noRefScripts :: TxOut ctx -> TxOut ctx
noRefScripts TxOut ctx
out =
    TxOut ctx
out{txOutReferenceScript = ReferenceScriptNone}

-- | Generate a 'TxOut' with a byron address. This is usually not supported by
-- Hydra or Plutus.
genTxOutByron :: Gen (TxOut ctx)
genTxOutByron :: forall ctx. Gen (TxOut ctx)
genTxOutByron = do
  AddressInEra
addr <- Address ByronAddr -> AddressInEra
ByronAddressInEra (Address ByronAddr -> AddressInEra)
-> Gen (Address ByronAddr) -> Gen AddressInEra
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Address ByronAddr)
forall a. Arbitrary a => Gen a
arbitrary
  Value
value <- Gen Value
genValue
  TxOut ctx -> Gen (TxOut ctx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut ctx -> Gen (TxOut ctx)) -> TxOut ctx -> Gen (TxOut ctx)
forall a b. (a -> b) -> a -> b
$ AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
addr Value
value TxOutDatum ctx
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone

-- | Generate UTXO entries that do not contain any assets. Useful to test /
-- measure cases where
genAdaOnlyUTxO :: Gen UTxO
genAdaOnlyUTxO :: Gen (UTxO' (TxOut CtxUTxO))
genAdaOnlyUTxO = (TxOut CtxUTxO -> TxOut CtxUTxO)
-> UTxO' (TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO)
forall a b. (a -> b) -> UTxO' a -> UTxO' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut CtxUTxO -> TxOut CtxUTxO
adaOnly (UTxO' (TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO))
-> Gen (UTxO' (TxOut CtxUTxO)) -> Gen (UTxO' (TxOut CtxUTxO))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (UTxO' (TxOut CtxUTxO))
forall a. Arbitrary a => Gen a
arbitrary

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