{-# 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,
)
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
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
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
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: "
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
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
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
,
ledgerIx :: TxIx
Ledger.ledgerIx = TxIx
forall a. Bounded a => a
minBound
,
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
}
fromChainSlot :: ChainSlot -> SlotNo
fromChainSlot :: ChainSlot -> SlotNo
fromChainSlot (ChainSlot Natural
s) = Natural -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
s
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
mkSimpleTx ::
(TxIn, TxOut CtxUTxO) ->
(AddressInEra, Value) ->
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
mkRangedTx ::
(TxIn, TxOut CtxUTxO) ->
(AddressInEra, Value) ->
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
}
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
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
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)
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