-
Notifications
You must be signed in to change notification settings - Fork 52
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge branch 'dshuiski/blockfrost-additional-utxos' into dshuiski/pur…
…s15/blockfrost-additional-utxos
- Loading branch information
Showing
22 changed files
with
545 additions
and
117 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,133 @@ | ||
| module Ctl.Examples.AdditionalUtxos | ||
| ( contract | ||
| , main | ||
| ) where | ||
|
|
||
| import Contract.Prelude | ||
|
|
||
| import Contract.Address (scriptHashAddress) | ||
| import Contract.BalanceTxConstraints (BalanceTxConstraintsBuilder) | ||
| import Contract.BalanceTxConstraints (mustUseAdditionalUtxos) as BalancerConstraints | ||
| import Contract.Config (ContractParams, testnetNamiConfig) | ||
| import Contract.Log (logInfo') | ||
| import Contract.Monad (Contract, launchAff_, liftedE, runContract) | ||
| import Contract.PlutusData (Datum, PlutusData(Integer), unitRedeemer) | ||
| import Contract.ScriptLookups (ScriptLookups, UnbalancedTx, mkUnbalancedTx) | ||
| import Contract.ScriptLookups (datum, unspentOutputs, validator) as Lookups | ||
| import Contract.Scripts (Validator, ValidatorHash, validatorHash) | ||
| import Contract.Sync (withoutSync) | ||
| import Contract.Transaction | ||
| ( ScriptRef(NativeScriptRef) | ||
| , TransactionInput | ||
| , awaitTxConfirmed | ||
| , balanceTxWithConstraints | ||
| , createAdditionalUtxos | ||
| , signTransaction | ||
| , submit | ||
| , withBalancedTx | ||
| ) | ||
| import Contract.TxConstraints | ||
| ( DatumPresence(DatumInline, DatumWitness) | ||
| , TxConstraints | ||
| ) | ||
| import Contract.TxConstraints | ||
| ( mustPayToScript | ||
| , mustPayToScriptWithScriptRef | ||
| , mustSpendPubKeyOutput | ||
| , mustSpendScriptOutput | ||
| ) as Constraints | ||
| import Contract.Utxos (UtxoMap) | ||
| import Contract.Value (Value) | ||
| import Contract.Value (lovelaceValueOf) as Value | ||
| import Ctl.Examples.PlutusV2.Scripts.AlwaysSucceeds (alwaysSucceedsScriptV2) | ||
| import Data.Array (fromFoldable) as Array | ||
| import Data.BigInt (fromInt) as BigInt | ||
| import Data.Map (difference, filter, keys) as Map | ||
| import Test.QuickCheck (arbitrary) | ||
| import Test.QuickCheck.Gen (randomSampleOne) | ||
|
|
||
| main :: Effect Unit | ||
| main = example testnetNamiConfig | ||
|
|
||
| example :: ContractParams -> Effect Unit | ||
| example contractParams = | ||
| launchAff_ $ runContract contractParams $ contract false | ||
|
|
||
| contract :: Boolean -> Contract Unit | ||
| contract testAdditionalUtxoOverlap = withoutSync do | ||
| logInfo' "Running Examples.AdditionalUtxos" | ||
| validator <- alwaysSucceedsScriptV2 | ||
| let vhash = validatorHash validator | ||
| { unbalancedTx, datum } <- payToValidator vhash | ||
| withBalancedTx unbalancedTx \balancedTx -> do | ||
| balancedSignedTx <- signTransaction balancedTx | ||
| txHash <- submit balancedSignedTx | ||
| when testAdditionalUtxoOverlap $ awaitTxConfirmed txHash | ||
| logInfo' "Successfully locked two outputs at the validator address." | ||
|
|
||
| additionalUtxos <- createAdditionalUtxos balancedSignedTx | ||
| spendFromValidator validator additionalUtxos datum | ||
|
|
||
| payToValidator | ||
| :: ValidatorHash -> Contract { unbalancedTx :: UnbalancedTx, datum :: Datum } | ||
| payToValidator vhash = do | ||
| scriptRef <- liftEffect (NativeScriptRef <$> randomSampleOne arbitrary) | ||
| let | ||
| value :: Value | ||
| value = Value.lovelaceValueOf $ BigInt.fromInt 2_000_000 | ||
|
|
||
| datum :: Datum | ||
| datum = wrap $ Integer $ BigInt.fromInt 42 | ||
|
|
||
| constraints :: TxConstraints Unit Unit | ||
| constraints = | ||
| Constraints.mustPayToScript vhash datum DatumWitness value | ||
| <> Constraints.mustPayToScriptWithScriptRef vhash datum DatumInline | ||
| scriptRef | ||
| value | ||
|
|
||
| lookups :: ScriptLookups PlutusData | ||
| lookups = Lookups.datum datum | ||
|
|
||
| unbalancedTx <- liftedE $ mkUnbalancedTx lookups constraints | ||
| pure { unbalancedTx, datum } | ||
|
|
||
| spendFromValidator :: Validator -> UtxoMap -> Datum -> Contract Unit | ||
| spendFromValidator validator additionalUtxos datum = do | ||
| let | ||
| scriptUtxos :: UtxoMap | ||
| scriptUtxos = | ||
| additionalUtxos # Map.filter \out -> | ||
| (unwrap (unwrap out).output).address | ||
| == scriptHashAddress (validatorHash validator) Nothing | ||
|
|
||
| scriptOrefs :: Array TransactionInput | ||
| scriptOrefs = Array.fromFoldable $ Map.keys scriptUtxos | ||
|
|
||
| pubKeyOrefs :: Array TransactionInput | ||
| pubKeyOrefs = | ||
| Array.fromFoldable $ Map.keys $ Map.difference additionalUtxos scriptUtxos | ||
|
|
||
| constraints :: TxConstraints Unit Unit | ||
| constraints = | ||
| foldMap (flip Constraints.mustSpendScriptOutput unitRedeemer) scriptOrefs | ||
| <> foldMap Constraints.mustSpendPubKeyOutput pubKeyOrefs | ||
|
|
||
| lookups :: ScriptLookups PlutusData | ||
| lookups = | ||
| Lookups.validator validator | ||
| <> Lookups.unspentOutputs additionalUtxos | ||
| <> Lookups.datum datum | ||
|
|
||
| balancerConstraints :: BalanceTxConstraintsBuilder | ||
| balancerConstraints = | ||
| BalancerConstraints.mustUseAdditionalUtxos additionalUtxos | ||
|
|
||
| unbalancedTx <- liftedE $ mkUnbalancedTx lookups constraints | ||
| balancedTx <- liftedE $ balanceTxWithConstraints unbalancedTx | ||
| balancerConstraints | ||
| balancedSignedTx <- signTransaction balancedTx | ||
| txHash <- submit balancedSignedTx | ||
|
|
||
| awaitTxConfirmed txHash | ||
| logInfo' "Successfully spent additional utxos from the validator address." |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,77 @@ | ||
| module Ctl.Examples.ChangeGeneration (checkChangeOutputsDistribution) where | ||
|
|
||
| import Prelude | ||
|
|
||
| import Contract.BalanceTxConstraints (mustSendChangeWithDatum) | ||
| import Contract.Monad (Contract, liftedE) | ||
| import Contract.PlutusData | ||
| ( Datum(Datum) | ||
| , OutputDatum(OutputDatum) | ||
| , PlutusData(Integer) | ||
| , unitDatum | ||
| ) | ||
| import Contract.ScriptLookups as Lookups | ||
| import Contract.Scripts (validatorHash) | ||
| import Contract.Transaction | ||
| ( _body | ||
| , _outputs | ||
| , awaitTxConfirmed | ||
| , balanceTxWithConstraints | ||
| , signTransaction | ||
| , submit | ||
| ) | ||
| import Contract.TxConstraints (TxConstraints) | ||
| import Contract.TxConstraints as Constraints | ||
| import Contract.UnbalancedTx (mkUnbalancedTx) | ||
| import Contract.Value as Value | ||
| import Contract.Wallet (ownPaymentPubKeyHashes, ownStakePubKeyHashes) | ||
| import Ctl.Examples.AlwaysSucceeds as AlwaysSucceeds | ||
| import Data.Array (fold, length, replicate, take, zip) | ||
| import Data.BigInt (fromInt) as BigInt | ||
| import Data.Lens (to, (^.)) | ||
| import Data.Maybe (Maybe(Just, Nothing)) | ||
| import Data.Newtype (unwrap) | ||
| import Data.Tuple (Tuple(Tuple)) | ||
| import Test.Spec.Assertions (shouldEqual) | ||
|
|
||
| -- | A contract that creates `outputsToScript` number of outputs at a script address, | ||
| -- | `outputsToSelf` outputs going to own address, and asserts that the number of change | ||
| -- | outputs is equal to `expectedOutputs`. | ||
| checkChangeOutputsDistribution :: Int -> Int -> Int -> Contract Unit | ||
| checkChangeOutputsDistribution outputsToScript outputsToSelf expectedOutputs = | ||
| do | ||
| pkhs <- ownPaymentPubKeyHashes | ||
| skhs <- ownStakePubKeyHashes | ||
| validator <- AlwaysSucceeds.alwaysSucceedsScript | ||
| let | ||
| vhash = validatorHash validator | ||
| value = Value.lovelaceValueOf $ BigInt.fromInt 1000001 | ||
|
|
||
| constraintsToSelf :: TxConstraints Unit Unit | ||
| constraintsToSelf = fold <<< take outputsToSelf <<< fold | ||
| $ replicate outputsToSelf | ||
| $ zip pkhs skhs <#> \(Tuple pkh mbSkh) -> case mbSkh of | ||
| Nothing -> Constraints.mustPayToPubKey pkh value | ||
| Just skh -> Constraints.mustPayToPubKeyAddress pkh skh value | ||
|
|
||
| constraintsToScripts :: TxConstraints Unit Unit | ||
| constraintsToScripts = fold $ replicate outputsToScript | ||
| $ Constraints.mustPayToScript vhash unitDatum | ||
| Constraints.DatumWitness | ||
| value | ||
|
|
||
| constraints = constraintsToSelf <> constraintsToScripts | ||
|
|
||
| lookups :: Lookups.ScriptLookups PlutusData | ||
| lookups = mempty | ||
| unbalancedTx <- liftedE $ mkUnbalancedTx lookups constraints | ||
| balancedTx <- liftedE $ balanceTxWithConstraints unbalancedTx | ||
| -- just to check that attaching datums works | ||
| ( mustSendChangeWithDatum $ OutputDatum $ Datum $ Integer $ BigInt.fromInt | ||
| 1000 | ||
| ) | ||
| balancedSignedTx <- signTransaction balancedTx | ||
| let outputs = balancedTx ^. to unwrap <<< _body <<< _outputs | ||
| length outputs `shouldEqual` expectedOutputs | ||
| txHash <- submit balancedSignedTx | ||
| awaitTxConfirmed txHash |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.
Oops, something went wrong.
Oops, something went wrong.