diff --git a/src/Fundraising/Create.purs b/src/Fundraising/Create.purs index 5625ca8..2e9da57 100644 --- a/src/Fundraising/Create.purs +++ b/src/Fundraising/Create.purs @@ -10,6 +10,7 @@ import Contract.Log (logInfo') import Contract.Monad (Contract, liftContractM, liftedE) import Contract.PlutusData (Redeemer(Redeemer), Datum(Datum), toData) import Contract.ScriptLookups as Lookups +import Contract.Scripts (MintingPolicyHash, mintingPolicyHash) import Contract.Time (POSIXTime(..)) import Contract.Transaction (awaitTxConfirmed, balanceTxWithConstraints, signTransaction, submit) import Contract.TxConstraints as Constraints @@ -65,6 +66,9 @@ contract protocolData (CreateFundraisingParams { title, amount, duration }) = do verTokenMp /\ verTokenCs <- mkCurrencySymbol (VerToken.mintingPolicy protocol) verTn <- VerToken.verTokenName + let + verTokenPolicyHash :: MintingPolicyHash + verTokenPolicyHash = mintingPolicyHash verTokenMp let minAmount = view _minAmount protocolInfo.pDatum @@ -130,13 +134,16 @@ contract protocolData (CreateFundraisingParams { title, amount, duration }) = do <> Constraints.mustMintValueWithRedeemer (Redeemer $ toData $ PMintNft nftTn) nftValue - <> Constraints.mustMintValueWithRedeemer + <> Constraints.mustMintCurrencyWithRedeemerUsingScriptRef + verTokenPolicyHash (Redeemer $ toData $ PMintVerToken verTn) - verTokenValue + verTn + one + protocolInfo.references.verTokenInput <> Constraints.mustSpendScriptOutputUsingScriptRef (fst protocolInfo.pUtxo) protocolRedeemer - protocolInfo.pRefScriptInput + protocolInfo.references.pRefScriptInput <> Constraints.mustPayToScriptAddress protocolInfo.pValidatorHash (ScriptCredential protocolInfo.pValidatorHash) @@ -150,12 +157,12 @@ contract protocolData (CreateFundraisingParams { title, amount, duration }) = do Constraints.DatumInline paymentToFr <> Constraints.mustBeSignedBy creds.ownPkh - <> Constraints.mustReferenceOutput (fst protocolInfo.pScriptRef) + <> Constraints.mustReferenceOutput (fst protocolInfo.references.pScriptRef) + <> Constraints.mustReferenceOutput (fst protocolInfo.references.verTokenRef) lookups :: Lookups.ScriptLookups Void lookups = Lookups.mintingPolicy nftMp - <> Lookups.mintingPolicy verTokenMp <> Lookups.unspentOutputs creds.ownUtxos <> Lookups.unspentOutputs protocolInfo.pUtxos diff --git a/src/Fundraising/ReceiveFunds.purs b/src/Fundraising/ReceiveFunds.purs index f08e366..034fced 100644 --- a/src/Fundraising/ReceiveFunds.purs +++ b/src/Fundraising/ReceiveFunds.purs @@ -11,6 +11,7 @@ import Contract.Log (logInfo') import Contract.Monad (Contract, liftedE, liftContractM) import Contract.PlutusData (Redeemer(Redeemer), toData) import Contract.ScriptLookups as Lookups +import Contract.Scripts (MintingPolicyHash, mintingPolicyHash) import Contract.Transaction (awaitTxConfirmed, balanceTxWithConstraints, signTransaction, submit) import Contract.TxConstraints as Constraints import Contract.Value as Value @@ -28,6 +29,8 @@ import Fundraising.UserData (FundraisingData(..)) import MintingPolicy.NftMinting as NFT import MintingPolicy.NftRedeemer (PNftRedeemer(..)) import MintingPolicy.VerTokenMinting as VerToken +import MintingPolicy.VerTokenRedeemers (PVerTokenRedeemer(..)) +import Protocol.ProtocolScriptInfo (ProtocolScriptInfo(..), getProtocolScriptInfo) import Protocol.UserData (ProtocolData, dataToProtocol) import Shared.MinAda (minAda) import Shared.NetworkData (NetworkParams) @@ -64,13 +67,17 @@ contract pData (FundraisingData fundraisingData) = do let receiveFundsRedeemer = toData >>> Redeemer $ PReceiveFunds threadTokenCurrency threadTokenName - let verTokenToBurnValue = Value.singleton fr.verTokenCurrency fr.verTokenName (fromInt (-1)) let threadTokenToBurnValue = Value.singleton threadTokenCurrency threadTokenName (fromInt (-1)) threadTokenMintingPolicy <- NFT.mintingPolicy currentDatum.tokenOrigin verTokenMintingPolicy <- VerToken.mintingPolicy protocol feeByFundraising <- liftContractM "Can't create BigInt after round" $ calcFee currentDatum.frFee donatedAmount - let amountToReceiver = Value.lovelaceValueOf $ (Value.valueOf currentFunds adaSymbol adaToken - feeByFundraising) + let + amountToReceiver = Value.lovelaceValueOf $ (Value.valueOf currentFunds adaSymbol adaToken - feeByFundraising) + + verTokenPolicyHash :: MintingPolicyHash + verTokenPolicyHash = mintingPolicyHash verTokenMintingPolicy + (ProtocolScriptInfo protocolInfo) <- getProtocolScriptInfo protocol let constraints :: Constraints.TxConstraints Void Void constraints = @@ -82,19 +89,22 @@ contract pData (FundraisingData fundraisingData) = do <> Constraints.mustMintValueWithRedeemer (Redeemer $ toData $ PBurnNft threadTokenName) threadTokenToBurnValue - <> Constraints.mustMintValueWithRedeemer - (Redeemer $ toData $ PBurnNft fr.verTokenName) - verTokenToBurnValue + <> Constraints.mustMintCurrencyWithRedeemerUsingScriptRef + verTokenPolicyHash + (Redeemer $ toData $ PBurnVerToken fr.verTokenName) + fr.verTokenName + (fromInt (-1)) + protocolInfo.references.verTokenInput <> Constraints.mustPayToPubKeyAddress creds.ownPkh creds.ownSkh amountToReceiver <> Constraints.mustPayToPubKeyAddress managerPkh managerSkh (Value.lovelaceValueOf feeByFundraising) <> Constraints.mustValidateIn (from now) <> Constraints.mustReferenceOutput (fst frInfo.frScriptRef) + <> Constraints.mustReferenceOutput (fst protocolInfo.references.verTokenRef) let lookups :: Lookups.ScriptLookups Void lookups = Lookups.mintingPolicy threadTokenMintingPolicy - <> Lookups.mintingPolicy verTokenMintingPolicy <> Lookups.unspentOutputs frInfo.frUtxos unbalancedTx <- liftedE $ Lookups.mkUnbalancedTx lookups constraints diff --git a/src/Protocol/CloseProtocol.purs b/src/Protocol/CloseProtocol.purs index 5ab390e..134b658 100644 --- a/src/Protocol/CloseProtocol.purs +++ b/src/Protocol/CloseProtocol.purs @@ -50,7 +50,7 @@ contract protocolData = do Constraints.mustSpendScriptOutputUsingScriptRef (fst protocolInfo.pUtxo) protocolRedeemer - protocolInfo.pRefScriptInput + protocolInfo.references.pRefScriptInput <> Constraints.mustMintValueWithRedeemer (Redeemer $ toData $ PBurnNft protocolTokenName) nftToBurnValue @@ -59,7 +59,7 @@ contract protocolData = do creds.ownSkh (Value.lovelaceValueOf (fromInt 2000000)) <> Constraints.mustBeSignedBy creds.ownPkh - <> Constraints.mustReferenceOutput (fst protocolInfo.pScriptRef) + <> Constraints.mustReferenceOutput (fst protocolInfo.references.pScriptRef) lookups :: Lookups.ScriptLookups Void lookups = diff --git a/src/Protocol/ProtocolScriptInfo.purs b/src/Protocol/ProtocolScriptInfo.purs index 217a30c..a08962c 100644 --- a/src/Protocol/ProtocolScriptInfo.purs +++ b/src/Protocol/ProtocolScriptInfo.purs @@ -4,6 +4,7 @@ import Contract.Prelude import Contract.Address (Address, getNetworkId, validatorHashBaseAddress) import Contract.Monad (Contract, liftContractM) +import Contract.Scripts (MintingPolicy(..)) import Contract.Transaction (ScriptRef(..), TransactionInput, TransactionOutputWithRefScript, mkTxUnspentOut) import Contract.TxConstraints (InputWithScriptRef) import Contract.TxConstraints as Constraints @@ -11,22 +12,30 @@ import Contract.Utxos (utxosAt) import Contract.Value as Value import Ctl.Internal.Types.Scripts (Validator, ValidatorHash) import Data.Map (Map) +import Effect.Exception (throw) import Info.AppInfo (getProtocolUtxo) +import MintingPolicy.VerTokenMinting as VerToken import Protocol.Datum (PProtocolDatum) import Protocol.Models (Protocol) import Protocol.ProtocolScript (getProtocolValidatorHash, protocolValidatorScript) import Shared.Utxo (extractDatumFromUTxO, extractValueFromUTxO, getUtxoByScriptRef) +type References = + { pScriptRef :: Tuple TransactionInput TransactionOutputWithRefScript + , pRefScriptInput :: InputWithScriptRef + , verTokenRef :: Tuple TransactionInput TransactionOutputWithRefScript + , verTokenInput :: InputWithScriptRef + } + newtype ProtocolScriptInfo = ProtocolScriptInfo { pValidator :: Validator , pValidatorHash :: ValidatorHash , pAddress :: Address , pUtxos :: Map TransactionInput TransactionOutputWithRefScript - , pUtxo :: (Tuple TransactionInput TransactionOutputWithRefScript) + , pUtxo :: Tuple TransactionInput TransactionOutputWithRefScript , pDatum :: PProtocolDatum , pValue :: Value.Value - , pScriptRef :: (Tuple TransactionInput TransactionOutputWithRefScript) - , pRefScriptInput :: InputWithScriptRef + , references :: References } getProtocolScriptInfo :: Protocol -> Contract ProtocolScriptInfo @@ -45,6 +54,20 @@ getProtocolScriptInfo protocol = do refScriptUtxo <- getUtxoByScriptRef "Protocol" scriptRef utxos let refScriptInput = Constraints.RefInput $ mkTxUnspentOut (fst refScriptUtxo) (snd refScriptUtxo) + managerUtxos <- utxosAt (unwrap currentDatum).managerAddress + verTokenMpWrapped <- VerToken.mintingPolicy protocol + policyRef <- case verTokenMpWrapped of + PlutusMintingPolicy policy -> pure $ PlutusScriptRef policy + _ -> liftEffect $ throw "Unexpected Minting Policy script type" + policyRefUtxo <- getUtxoByScriptRef "VerTokenPolicy" policyRef managerUtxos + let policyRefInput = Constraints.RefInput $ mkTxUnspentOut (fst policyRefUtxo) (snd policyRefUtxo) + let + refs = + { pScriptRef: refScriptUtxo + , pRefScriptInput: refScriptInput + , verTokenRef: policyRefUtxo + , verTokenInput: policyRefInput + } pure $ ProtocolScriptInfo { pValidator: protocolValidator , pValidatorHash: protocolValidatorHash @@ -53,6 +76,5 @@ getProtocolScriptInfo protocol = do , pUtxo: protocolUtxo , pDatum: currentDatum , pValue: value - , pScriptRef: refScriptUtxo - , pRefScriptInput: refScriptInput + , references: refs } diff --git a/src/Protocol/StartProtocol.purs b/src/Protocol/StartProtocol.purs index bb0470f..1669378 100644 --- a/src/Protocol/StartProtocol.purs +++ b/src/Protocol/StartProtocol.purs @@ -27,7 +27,7 @@ import Protocol.ProtocolScript (getProtocolValidatorHash, protocolTokenName, pro import Protocol.UserData (ProtocolConfigParams(..), ProtocolData, protocolToData) import Shared.Config (mapFromProtocolConfigParams, writeDonatPoolConfig) import Shared.KeyWalletConfig (testnetKeyWalletConfig) -import Shared.ScriptRef (mkFundraisingRefScript, mkProtocolRefScript) +import Shared.ScriptRef (mkFundraisingRefScript, mkProtocolRefScript, mkVerTokenPolicyRef) import Shared.Utxo (filterNonCollateral) initialProtocolConfigParams ∷ ProtocolConfigParams @@ -48,6 +48,7 @@ startSystem params = do protocolData <- startProtocol params mkProtocolRefScript protocolData mkFundraisingRefScript protocolData + mkVerTokenPolicyRef protocolData pure protocolData startProtocol :: ProtocolConfigParams -> Contract ProtocolData diff --git a/src/Protocol/UpdateProtocol.purs b/src/Protocol/UpdateProtocol.purs index 84170bc..6682afd 100644 --- a/src/Protocol/UpdateProtocol.purs +++ b/src/Protocol/UpdateProtocol.purs @@ -63,14 +63,14 @@ contract protocolData protocolConfigParams = do Constraints.mustSpendScriptOutputUsingScriptRef (fst protocolInfo.pUtxo) updateProtocolRedeemer - protocolInfo.pRefScriptInput + protocolInfo.references.pRefScriptInput <> Constraints.mustPayToScriptAddress protocolInfo.pValidatorHash (ScriptCredential protocolInfo.pValidatorHash) newPDatum Constraints.DatumInline protocolInfo.pValue - <> Constraints.mustReferenceOutput (fst protocolInfo.pScriptRef) + <> Constraints.mustReferenceOutput (fst protocolInfo.references.pScriptRef) <> Constraints.mustBeSignedBy ownPkh let lookups :: Lookups.ScriptLookups Void diff --git a/src/Shared/ScriptRef.purs b/src/Shared/ScriptRef.purs index 57f3b8f..76f65b5 100644 --- a/src/Shared/ScriptRef.purs +++ b/src/Shared/ScriptRef.purs @@ -2,21 +2,21 @@ module Shared.ScriptRef where import Contract.Prelude -import Contract.Address (getWalletAddressesWithNetworkTag) import Contract.BalanceTxConstraints (BalanceTxConstraintsBuilder, mustSendChangeToAddress) import Contract.Credential (Credential(..)) import Contract.Log (logInfo') -import Contract.Monad (Contract, liftedE, liftedM) +import Contract.Monad (Contract, liftedE) import Contract.PlutusData (PlutusData, unitDatum) import Contract.ScriptLookups as Lookups +import Contract.Scripts (MintingPolicy(..), Validator, ValidatorHash) import Contract.Transaction (ScriptRef(..), awaitTxConfirmed, balanceTxWithConstraints, signTransaction, submit) import Contract.TxConstraints as Constraints import Contract.Value as Value -import Ctl.Internal.Types.Scripts (Validator, ValidatorHash) -import Data.Array (head) as Array import Data.BigInt (fromInt) +import Effect.Exception (throw) import Fundraising.FundraisingScript (fundraisingValidatorScript, getFundraisingValidatorHash) import Fundraising.FundraisingScriptInfo (makeFundraising) +import MintingPolicy.VerTokenMinting as VerToken import Protocol.ProtocolScript (getProtocolValidatorHash, protocolValidatorScript) import Protocol.UserData (ProtocolData, dataToProtocol) import Shared.MinAda (minAda) @@ -39,17 +39,13 @@ createRefScriptUtxo scriptName validatorHash validator = do sevenMinAdaValue lookups :: Lookups.ScriptLookups PlutusData - lookups = Lookups.unspentOutputs creds.ownUtxos + lookups = mempty unbalancedTx <- liftedE $ Lookups.mkUnbalancedTx lookups constraints - addressWithNetworkTag <- - liftedM "Failed to get own address with Network Tag" - $ Array.head - <$> getWalletAddressesWithNetworkTag let balanceTxConstraints :: BalanceTxConstraintsBuilder - balanceTxConstraints = mustSendChangeToAddress addressWithNetworkTag + balanceTxConstraints = mustSendChangeToAddress creds.ownAddressWithNetworkTag balancedTx <- liftedE $ balanceTxWithConstraints unbalancedTx balanceTxConstraints balancedSignedTx <- signTransaction balancedTx txId <- submit balancedSignedTx @@ -71,3 +67,35 @@ mkFundraisingRefScript protocolData = do frValidator <- fundraisingValidatorScript fundraising frValidatorHash <- getFundraisingValidatorHash fundraising createRefScriptUtxo "Fundraising" frValidatorHash frValidator + +createPolicyRefUtxo :: String -> MintingPolicy → Contract Unit +createPolicyRefUtxo _ (NativeMintingPolicy _) = liftEffect $ throw "Unexpected minting policy type" +createPolicyRefUtxo mpName (PlutusMintingPolicy policy) = do + logInfo' $ "Creating UTxO with " <> mpName <> " minting policy name" + (OwnCredentials creds) <- getOwnCreds + let + scriptRef = PlutusScriptRef policy + sevenMinAdaValue = Value.lovelaceValueOf (minAda * (fromInt 7)) + + constraints :: Constraints.TxConstraints Unit Unit + constraints = + Constraints.mustPayToPubKeyAddressWithScriptRef creds.ownPkh creds.ownSkh scriptRef sevenMinAdaValue + + lookups :: Lookups.ScriptLookups PlutusData + lookups = mempty + + unbalancedTx <- liftedE $ Lookups.mkUnbalancedTx lookups constraints + let + balanceTxConstraints :: BalanceTxConstraintsBuilder + balanceTxConstraints = mustSendChangeToAddress creds.ownAddressWithNetworkTag + balancedTx <- liftedE $ balanceTxWithConstraints unbalancedTx balanceTxConstraints + balancedSignedTx <- signTransaction balancedTx + txId <- submit balancedSignedTx + awaitTxConfirmed txId + logInfo' $ "UTxO with " <> mpName <> " minting policy reference created" + +mkVerTokenPolicyRef :: ProtocolData -> Contract Unit +mkVerTokenPolicyRef protocolData = do + protocol <- dataToProtocol protocolData + policy <- VerToken.mintingPolicy protocol + createPolicyRefUtxo "VerToken" policy