diff --git a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs index f9f46a8..37c9e89 100644 --- a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs @@ -148,10 +148,15 @@ transferProgrammableToken tokenTxIns programmableTokenSymbol directoryList = Uti IMPORTANT: It is the caller's responsibility to ensure that the specific issuer logic stake script witness is included in the final transaction. + + NOTE: Seems the issuer is only able to seize 1 UTxO at a time. + In the future we should allow multiple UTxOs in 1 Tx. -} -seizeProgrammableToken :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => (C.TxIn, C.PolicyId) -> (C.TxIn, C.TxOut C.CtxTx era) -> (C.TxIn, C.TxOut C.CtxTx era) -> CurrencySymbol -> [(C.TxIn, C.InAnyCardanoEra (C.TxOut C.CtxTx))] -> m () -seizeProgrammableToken (paramsTxIn, paramsPolId) (seizingTxIn, seizingOutput) (issuerTxIn, issuerTxOut) seizingTokenSymbol directoryList = Utils.inBabbage @era $ do +seizeProgrammableToken :: forall a env era m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era a -> UTxODat era a -> C.PolicyId -> [UTxODat era DirectorySetNode] -> m () +seizeProgrammableToken UTxODat{uIn = seizingTxIn, uOut = seizingTxOut} UTxODat{uIn = issuerTxIn, uOut = issuerTxOut} seizingTokenPolicyId directoryList = Utils.inBabbage @era $ do nid <- queryNetworkId + paramsPolId <- asks (Env.protocolParamsPolicyId . Env.directoryEnv) + paramsTxIn <- asks (Env.dsTxIn . Env.directoryEnv) let globalStakeScript = programmableLogicGlobalScript paramsPolId globalStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 globalStakeScript @@ -159,14 +164,12 @@ seizeProgrammableToken (paramsTxIn, paramsPolId) (seizingTxIn, seizingOutput) (i -- Finds the directory node entry that references the programmable token symbol dirNodeRef <- - maybe (error "Cannot seize non-programmable token. Entry does not exist in directoryList") (pure . fst) $ - find (isNodeWithProgrammableSymbol seizingTokenSymbol) directoryList - - seizingTokenPolicyId <- either (error . show) pure $ unTransPolicyId seizingTokenSymbol + maybe (error "Cannot seize non-programmable token. Entry does not exist in directoryList") (pure . uIn) $ + find (isNodeWithProgrammableSymbol (transPolicyId seizingTokenPolicyId)) directoryList checkIssuerAddressIsProgLogicCred (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 baseSpendingScript) issuerTxOut - let seizedValue = case seizingOutput of + let seizedValue = case seizingTxOut of (C.TxOut _ v _ _) -> C.filterValue ( \case @@ -214,16 +217,13 @@ seizeProgrammableToken (paramsTxIn, paramsPolId) (seizingTxIn, seizingOutput) (i $ C.ScriptWitness C.ScriptWitnessForStakeAddr . programmableGlobalWitness -- TODO: check that the issuerTxOut is at a programmable logic payment credential -checkIssuerAddressIsProgLogicCred :: forall era m. ( MonadBuildTx era m) => C.PaymentCredential -> C.TxOut C.CtxTx era -> m () +checkIssuerAddressIsProgLogicCred :: forall era ctx m. ( MonadBuildTx era m) => C.PaymentCredential -> C.TxOut ctx era -> m () checkIssuerAddressIsProgLogicCred _progLogicCred (C.TxOut (C.AddressInEra _ (C.ShelleyAddress _ _pcred _stakeRef)) _ _ C.ReferenceScriptNone) = pure () checkIssuerAddressIsProgLogicCred _ _ = error "Issuer address is not a programmable logic credential" -isNodeWithProgrammableSymbol :: CurrencySymbol -> (C.TxIn, C.InAnyCardanoEra (C.TxOut C.CtxTx)) -> Bool -isNodeWithProgrammableSymbol programmableTokenSymbol (_, dn) = - case getDirectoryNodeInline dn of - Just d -> key d == programmableTokenSymbol - _ -> False +isNodeWithProgrammableSymbol :: forall era. CurrencySymbol -> UTxODat era DirectorySetNode -> Bool +isNodeWithProgrammableSymbol programmableTokenSymbol (uDatum -> dat) = key dat == programmableTokenSymbol getDirectoryNodeInline :: C.InAnyCardanoEra (C.TxOut C.CtxTx) -> Maybe DirectorySetNode getDirectoryNodeInline (C.InAnyCardanoEra C.ConwayEra (C.TxOut _ _ dat _)) = diff --git a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs index 5ef0435..6f7939f 100644 --- a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs @@ -3,21 +3,23 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -module Wst.Offchain.BuildTx.TransferLogic ( - transferStablecoins, - issueStablecoins, - ) where +module Wst.Offchain.BuildTx.TransferLogic + ( transferStablecoins, + issueStablecoins, + seizeStablecoins, + ) +where import Cardano.Api qualified as C import Cardano.Api.Ledger (hashKey) import Cardano.Api.Shelley qualified as C import Control.Lens (over) import Control.Monad.Reader (MonadReader, asks) -import Convex.BuildTx (MonadBuildTx, addBtx, addReference, addScriptWithdrawal, - addStakeWitness, addWithdrawalWithTxBody, - buildScriptWitness, findIndexReference, - findIndexSpending, mintPlutus, payToAddress, - spendPlutusInlineDatum) +import Convex.BuildTx (MonadBuildTx, addBtx, addReference, addRequiredSignature, + addScriptWithdrawal, addStakeWitness, + addWithdrawalWithTxBody, buildScriptWitness, + findIndexReference, findIndexSpending, mintPlutus, + payToAddress, spendPlutusInlineDatum) import Convex.CardanoApi.Lenses as L import Convex.Class (MonadBlockchain (queryNetworkId)) import Convex.PlutusLedger.V1 (transCredential, transPolicyId, @@ -45,12 +47,13 @@ import SmartTokens.Types.PTokenDirectory (BlacklistNode (..), import Wst.Offchain.BuildTx.DirectorySet (insertDirectoryNode) import Wst.Offchain.BuildTx.ProgrammableLogic (IssueNewTokenArgs, issueProgrammableToken, + seizeProgrammableToken, transferProgrammableToken) import Wst.Offchain.BuildTx.ProtocolParams (getProtocolParamsGlobalInline) import Wst.Offchain.Env qualified as Env import Wst.Offchain.Query (UTxODat (..)) -issueStablecoins :: forall era env m. (MonadReader env m, Env.HasTransferLogicEnv env, Env.HasDirectoryEnv env, Env.HasOperatorEnv era env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> IssueNewTokenArgs -> [UTxODat era DirectorySetNode] -> C.PaymentCredential -> m () +issueStablecoins :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, Env.HasDirectoryEnv env, Env.HasOperatorEnv era env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> IssueNewTokenArgs -> [UTxODat era DirectorySetNode] -> C.PaymentCredential -> m () issueStablecoins paramsTxOut (an, q) inta directoryList destinationCred = Utils.inBabbage @era $ do nid <- queryNetworkId @@ -58,16 +61,13 @@ issueStablecoins paramsTxOut (an, q) inta directoryList destinationCred = Utils. let txIn = Env.dsTxIn directoryEnv progLogicBaseCred = Env.programmableLogicBaseCredential directoryEnv - opVerKey <- asks (verificationKey . oPaymentKey . Env.bteOperator . Env.operatorEnv) - let opPkh = C.verificationKeyHash opVerKey - addIssueWitness opPkh - issuedPolicyId <- issueProgrammableToken paramsTxOut (an, q) inta directoryList -- TODO: check if there is a better way to achieve: C.PaymentCredential -> C.StakeCredential stakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential destinationCred let value = fromList [(C.AssetId issuedPolicyId an, q)] addr = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue stakeCred) + addIssueWitness payToAddress addr value transferStablecoins :: forall env era a m. (MonadReader env m, Env.HasTransferLogicEnv env, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.PaymentCredential -> [UTxODat era BlacklistNode] -> [UTxODat era DirectorySetNode] -> [UTxODat era a] -> (C.AssetId, C.Quantity) -> C.PaymentCredential -> m () @@ -76,7 +76,7 @@ transferStablecoins userCred blacklistNodes directoryList spendingUserOutputs (a progLogicBaseCred <- asks (Env.programmableLogicBaseCredential . Env.directoryEnv) -- Find sufficient inputs to cover the transfer - let userOutputsMap = fromList $ map (\UTxODat{uIn, uOut, uDatum} -> (uIn, (C.inAnyCardanoEra (C.cardanoEra @era) uOut, uDatum))) spendingUserOutputs + let userOutputsMap = fromList $ map (\UTxODat {uIn, uOut, uDatum} -> (uIn, (C.inAnyCardanoEra (C.cardanoEra @era) uOut, uDatum))) spendingUserOutputs (totalVal, txins) <- maybe (error "insufficient funds for transfer") pure $ selectMixedInputsCovering (UtxoSet userOutputsMap) [(assetId, q)] -- Spend the outputs via programmableLogicBaseScript @@ -94,18 +94,48 @@ transferStablecoins userCred blacklistNodes directoryList spendingUserOutputs (a payToAddress destinationAddress destinationVal -- Return change to the spendingUserOutputs address - let returnVal = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra - $ fromList [(assetId, C.selectAsset totalVal assetId - q)] + let returnVal = + C.TxOutValueShelleyBased C.shelleyBasedEra $ + C.toLedgerValue @era C.maryBasedEra $ + fromList [(assetId, C.selectAsset totalVal assetId - q)] returnAddr = undefined returnOutput = C.TxOut returnAddr returnVal C.TxOutDatumNone C.ReferenceScriptNone addBtx (over L.txOuts (returnOutput :)) -- Add the seized output to the transaction -seizeStablecoins = undefined - -addIssueWitness :: forall era env m. (MonadReader env m, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.Hash C.PaymentKey -> m () -addIssueWitness issuerPubKeyHash = Utils.inBabbage @era $ do +seizeStablecoins :: forall env era a m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era a -> UTxODat era a -> [UTxODat era DirectorySetNode] -> C.PaymentCredential -> m () +seizeStablecoins seizingTxo issuerTxo directoryList destinationCred = Utils.inBabbage @era $ do + -- Add issuer and programmableLogic witnesses + let maybeProgAsset = case uOut seizingTxo of + (C.TxOut _a v _d _r) -> + find + ( \case + ((C.AssetId _ _), _q) -> True + (C.AdaAssetId, _q) -> False + ) + (toList $ C.txOutValueToValue v) + >>= ( \case + (C.AssetId pid an, q) -> Just (pid, an, q) + _ -> Nothing + ) + (progTokenPolId, an, q) <- maybe (error "No programmable token found in seizing transaction") pure maybeProgAsset + + seizeProgrammableToken seizingTxo issuerTxo progTokenPolId directoryList + addSeizeWitness + + -- Send seized funds to destinationCred + let -- NOTE: Assumes only a single programmable token per UTxO is allowed + seizedVal = fromList [(C.AssetId progTokenPolId an, q)] + issuerAddr = case uOut issuerTxo of + (C.TxOut a _v _d _r) -> a + + payToAddress issuerAddr seizedVal + +addIssueWitness :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => m () +addIssueWitness = Utils.inBabbage @era $ do + opPkh <- asks (C.verificationKeyHash . verificationKey . oPaymentKey . Env.bteOperator . Env.operatorEnv) mintingScript <- asks (Env.tleMintingScript . Env.transferLogicEnv) let sh = C.hashScript $ C.PlutusScript C.PlutusScriptV3 mintingScript + addRequiredSignature opPkh addScriptWithdrawal sh 0 $ buildScriptWitness mintingScript C.NoScriptDatumForStake () addTransferWitness :: forall env era m. (MonadReader env m, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => [UTxODat era BlacklistNode] -> C.PaymentCredential -> m () @@ -114,7 +144,7 @@ addTransferWitness blacklistNodes clientCred = Utils.inBabbage @era $ do transferScript <- asks (Env.tleTransferScript . Env.transferLogicEnv) let transferStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 transferScript - UTxODat{uIn = blnNodeRef, uOut = blnNodeOut, uDatum = blnNodeDatum} = + UTxODat {uIn = blnNodeRef, uOut = blnNodeOut, uDatum = blnNodeDatum} = maximumBy (compare `on` (blnKey . uDatum)) $ filter ((<= transCredential clientCred) . blnKey . uDatum) blacklistNodes @@ -139,13 +169,14 @@ addTransferWitness blacklistNodes clientCred = Utils.inBabbage @era $ do (C.Quantity 0) $ C.ScriptWitness C.ScriptWitnessForStakeAddr . transferWitness -addSeizeWitness :: forall env era m. (MonadReader env m, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.Hash C.PaymentKey -> m () -addSeizeWitness issuerPubKeyHash = Utils.inBabbage @era $ do +addSeizeWitness :: forall env era m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => m () +addSeizeWitness = Utils.inBabbage @era $ do + opPkh <- asks (C.verificationKeyHash . verificationKey . oPaymentKey . Env.bteOperator . Env.operatorEnv) seizeScript <- asks (Env.tleIssuerScript . Env.transferLogicEnv) let sh = C.hashScript $ C.PlutusScript C.PlutusScriptV3 seizeScript + addRequiredSignature opPkh addScriptWithdrawal sh 0 $ buildScriptWitness seizeScript C.NoScriptDatumForStake () - -- TODO: move to separate utils module getDatumInline :: forall a. (PlutusTx.FromData a) => C.InAnyCardanoEra (C.TxOut C.CtxTx) -> Maybe a getDatumInline (C.InAnyCardanoEra C.ConwayEra (C.TxOut _ _ dat _)) =