Created
July 20, 2021 08:32
-
-
Save v0d1ch/afc53e96d8fe2bbdd248f8ab93f12baf to your computer and use it in GitHub Desktop.
Plutus contract (payout not working)
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
| {-# LANGUAGE DataKinds #-} | |
| {-# LANGUAGE DeriveAnyClass #-} | |
| {-# LANGUAGE DeriveGeneric #-} | |
| {-# LANGUAGE DerivingStrategies #-} | |
| {-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
| {-# LANGUAGE MultiParamTypeClasses #-} | |
| {-# LANGUAGE NamedFieldPuns #-} | |
| {-# LANGUAGE OverloadedStrings #-} | |
| {-# LANGUAGE RecordWildCards #-} | |
| {-# LANGUAGE ScopedTypeVariables #-} | |
| {-# LANGUAGE TemplateHaskell #-} | |
| {-# LANGUAGE TypeApplications #-} | |
| {-# LANGUAGE TypeFamilies #-} | |
| {-# LANGUAGE TypeOperators #-} | |
| module Test where | |
| import qualified Control.Monad.Freer.Extras as Extras | |
| import Control.Monad (void) | |
| import Data.Text (Text, unpack) | |
| import Ledger hiding (singleton) | |
| import Ledger.Ada (lovelaceOf, toValue) | |
| import Ledger.Constraints as Constraints | |
| import qualified Ledger.Typed.Scripts as Scripts | |
| import Playground.Contract | |
| import Plutus.Trace.Emulator as Emulator hiding (throwError) | |
| import Plutus.Contract | |
| import qualified PlutusTx | |
| import PlutusTx.Prelude hiding (Applicative (..), Semigroup (..)) | |
| import Prelude (Semigroup (..)) | |
| import qualified Prelude as Haskell | |
| import Wallet.Emulator (walletPubKey) | |
| data D = | |
| D | |
| { datumDonationAddress :: !PubKeyHash | |
| , datumDonorAddress :: !PubKeyHash | |
| , datumAmt :: !Integer | |
| } deriving stock (Haskell.Eq, Show, Generic) | |
| deriving anyclass (ToJSON, FromJSON, ToSchema) | |
| PlutusTx.unstableMakeIsData ''D | |
| PlutusTx.makeLift ''D | |
| data X | |
| instance Scripts.ValidatorTypes X where | |
| type instance RedeemerType X = () | |
| type instance DatumType X = D | |
| donationValidator :: Scripts.TypedValidator X | |
| donationValidator = Scripts.mkTypedValidator @X | |
| $$(PlutusTx.compile [|| mkDonationValidator ||]) | |
| $$(PlutusTx.compile [|| wrap ||]) | |
| where | |
| wrap = Scripts.wrapValidator | |
| {-# INLINABLE mkDonationValidator #-} | |
| mkDonationValidator :: D -> () -> ScriptContext -> Bool | |
| mkDonationValidator dat _ scr = | |
| validateDonation dat () (scriptContextTxInfo scr) | |
| validateDonation :: D -> () -> TxInfo -> Bool | |
| validateDonation _dat _ _txinfo = True | |
| validator :: Validator | |
| validator = Scripts.validatorScript donationValidator | |
| valHash :: Ledger.ValidatorHash | |
| valHash = Scripts.validatorHash donationValidator | |
| scrAddress :: Ledger.Address | |
| scrAddress = scriptAddress validator | |
| percentageToTake :: Haskell.Float | |
| percentageToTake = 10 | |
| data DonateParams = | |
| DonateParams | |
| { donateParamsAmt :: !Integer | |
| , donateParamsDonationAddress :: !PubKeyHash | |
| } deriving (Generic, ToJSON, FromJSON, ToSchema) | |
| donateEndpoint :: DonateParams -> Contract () Schema e () | |
| donateEndpoint DonateParams {..} = handleError (\err -> logError $ "Caught error: " ++ unpack err) $ do | |
| pkh <- pubKeyHash <$> ownPubKey | |
| let | |
| (donationAmt, bondingAmt) = (donateParamsAmt - 100, 100) | |
| dat = | |
| D | |
| { datumDonationAddress = donateParamsDonationAddress | |
| , datumDonorAddress = pkh | |
| , datumAmt = donationAmt | |
| } | |
| tx = | |
| Constraints.mustPayToPubKey donateParamsDonationAddress (toValue $ lovelaceOf donationAmt) <> | |
| Constraints.mustPayToTheScript dat (toValue $ lovelaceOf bondingAmt) | |
| ledgerTx <- submitTxConstraints donationValidator tx | |
| void $ awaitTxConfirmed (txId ledgerTx) | |
| payoutEndpoint :: Contract () Schema Text () | |
| payoutEndpoint = handleError (\err -> logError $ "Caught error: " ++ unpack err) $ do | |
| pkh <- pubKeyHash <$> ownPubKey | |
| utxos <- utxoAt scrAddress | |
| let tx = | |
| collectFromScript utxos () <> | |
| Constraints.mustPayToPubKey pkh (toValue $ lovelaceOf 10) | |
| ledgerTx <- submitTxConstraintsSpending donationValidator utxos tx | |
| void $ awaitTxConfirmed $ txId ledgerTx | |
| type Schema = | |
| Endpoint "donate" DonateParams | |
| .\/ Endpoint "payout" () | |
| endpoints :: Contract () Schema Text () | |
| endpoints = | |
| (endpoint @"donate" >>= donateEndpoint) >> | |
| (endpoint @"payout" >> payoutEndpoint) >> | |
| endpoints | |
| mkSchemaDefinitions ''Schema | |
| mkKnownCurrencies [] | |
| donateTrace :: Integer -> EmulatorTrace () | |
| donateTrace x = do | |
| h <- activateContractWallet (Wallet 1) endpoints | |
| let | |
| recipient = pubKeyHash $ walletPubKey $ Wallet 2 | |
| toDonate = | |
| DonateParams | |
| { donateParamsAmt = x | |
| , donateParamsDonationAddress = recipient | |
| } | |
| callEndpoint @"donate" h toDonate | |
| void $ Emulator.waitNSlots 1 | |
| xs <- observableState h | |
| Extras.logInfo $ Haskell.show ("=====================" :: Text) | |
| Extras.logInfo $ Haskell.show xs | |
| payoutTrace :: EmulatorTrace () | |
| payoutTrace = do | |
| h <- activateContractWallet (Wallet 1) endpoints | |
| callEndpoint @"payout" h () | |
| void $ Emulator.waitNSlots 1 | |
| xs <- observableState h | |
| Extras.logInfo $ Haskell.show ("=====================" :: Text) | |
| Extras.logInfo $ Haskell.show xs | |
| test :: IO () | |
| test = runEmulatorTraceIO $ do | |
| donateTrace 1000 | |
| void $ Emulator.waitNSlots 10 | |
| payoutTrace | |
| void $ Emulator.waitNSlots 10 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment