{-# 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.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 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 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
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 -> Either (Tx, ValidationError) UTxO
forall a b. b -> Either a b
Right (UTxO -> Either (Tx, ValidationError) UTxO)
-> (UTxO (ConwayEra StandardCrypto) -> UTxO)
-> UTxO (ConwayEra StandardCrypto)
-> Either (Tx, ValidationError) UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO (ConwayEra StandardCrypto) -> UTxO
UTxO LedgerEra -> UTxO
fromLedgerUTxO (UTxO (ConwayEra StandardCrypto)
 -> Either (Tx, ValidationError) UTxO)
-> UTxO (ConwayEra StandardCrypto)
-> Either (Tx, ValidationError) UTxO
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

-- | 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) -> UTxO -> Value
forall m a. Monoid m => (a -> m) -> UTxO' a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue UTxO
utxo) 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
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 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
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 -> 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
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext
          (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