diff --git a/src/lib/Wst/AppError.hs b/src/lib/Wst/AppError.hs index c2f80ff..fce9105 100644 --- a/src/lib/Wst/AppError.hs +++ b/src/lib/Wst/AppError.hs @@ -14,6 +14,8 @@ data AppError era = | GlobalParamsNodeNotFound -- ^ The node with the global parameters was not found | BalancingError (CoinSelection.BalanceTxError era) | BlockfrostErr BlockfrostError + | NoTokensToSeize -- ^ No tokens to seize + | DuplicateBlacklistNode -- ^ Attempting to add a duplicate blacklist node | TransferBlacklistedCredential Credential -- ^ Attempting to transfer funds from a blacklisted address | SubmitError (ValidationError era) deriving stock (Show) diff --git a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs index 48f2ca4..76fd44c 100644 --- a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs +++ b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs @@ -17,6 +17,7 @@ where import Cardano.Api qualified as C import Cardano.Api.Shelley qualified as C import Control.Lens (over, (^.)) +import Control.Monad (when) import Control.Monad.Except (MonadError (throwError)) import Control.Monad.Reader (MonadReader, asks) import Convex.BuildTx (MonadBuildTx (addTxBuilder), TxBuilder (TxBuilder), @@ -44,7 +45,7 @@ import SmartTokens.Contracts.ExampleTransferLogic (BlacklistProof (..)) import SmartTokens.Types.ProtocolParams import SmartTokens.Types.PTokenDirectory (BlacklistNode (..), DirectorySetNode (..)) -import Wst.AppError (AppError (TransferBlacklistedCredential)) +import Wst.AppError (AppError (DuplicateBlacklistNode, TransferBlacklistedCredential)) import Wst.Offchain.BuildTx.ProgrammableLogic (issueProgrammableToken, seizeProgrammableToken, transferProgrammableToken) @@ -91,7 +92,7 @@ initBlacklist = Utils.inBabbage @era $ do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) addRequiredSignature opPkh -insertBlacklistNode :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.PaymentCredential -> [UTxODat era BlacklistNode]-> m () +insertBlacklistNode :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m, MonadError (AppError era) m) => C.PaymentCredential -> [UTxODat era BlacklistNode]-> m () insertBlacklistNode cred blacklistNodes = Utils.inBabbage @era $ do -- mint new blacklist token mintingScript <- asks (Env.tleBlacklistMintingScript . Env.transferLogicEnv) @@ -119,6 +120,9 @@ insertBlacklistNode cred blacklistNodes = Utils.inBabbage @era $ do newPrevNodeDatum = C.TxOutDatumInline C.babbageBasedEra $ C.toHashableScriptData newPrevNode newPrevNodeOutput = C.TxOut prevAddr prevVal newPrevNodeDatum C.ReferenceScriptNone + when (blnKey prevNode == blnKey newNode) + $ throwError DuplicateBlacklistNode + -- spend previous node spendingScript <- asks (Env.tleBlacklistSpendingScript . Env.transferLogicEnv) spendPlutusInlineDatum prevNodeRef spendingScript () @@ -330,6 +334,7 @@ registerTransferScripts = case C.babbageBasedEra @era of C.BabbageEraOnwardsConway -> Utils.inConway @era $ do transferMintingScript <- asks (Env.tleMintingScript . Env.transferLogicEnv) transferSpendingScript <- asks (Env.tleTransferScript . Env.transferLogicEnv) + transferSeizeSpendingScript <- asks (Env.tleIssuerScript . Env.transferLogicEnv) let hshMinting = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferMintingScript @@ -338,5 +343,9 @@ registerTransferScripts = case C.babbageBasedEra @era of hshSpending = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferSpendingScript credSpending = C.StakeCredentialByScript hshSpending + hshSeizeSpending = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferSeizeSpendingScript + credSeizeSpending = C.StakeCredentialByScript hshSeizeSpending + addConwayStakeCredentialCertificate credMinting addConwayStakeCredentialCertificate credSpending + addConwayStakeCredentialCertificate credSeizeSpending diff --git a/src/lib/Wst/Offchain/Endpoints/Deployment.hs b/src/lib/Wst/Offchain/Endpoints/Deployment.hs index 3ce6681..69ee25f 100644 --- a/src/lib/Wst/Offchain/Endpoints/Deployment.hs +++ b/src/lib/Wst/Offchain/Endpoints/Deployment.hs @@ -17,16 +17,17 @@ module Wst.Offchain.Endpoints.Deployment( import Cardano.Api (Quantity) import Cardano.Api.Shelley qualified as C import Control.Monad (when) -import Control.Monad.Except (MonadError) +import Control.Monad.Except (MonadError (..)) import Control.Monad.Reader (MonadReader, asks) import Convex.BuildTx qualified as BuildTx import Convex.Class (MonadBlockchain, MonadUtxoQuery) import Convex.CoinSelection qualified import Data.Foldable (maximumBy) import Data.Function (on) +import GHC.IsList (IsList (..)) import SmartTokens.Core.Scripts (ScriptTarget (..)) import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..)) -import Wst.AppError (AppError) +import Wst.AppError (AppError (NoTokensToSeize)) import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (inaNewKey)) import Wst.Offchain.BuildTx.DirectorySet qualified as BuildTx import Wst.Offchain.BuildTx.ProgrammableLogic qualified as BuildTx @@ -38,7 +39,6 @@ import Wst.Offchain.Query (UTxODat (..)) import Wst.Offchain.Query qualified as Query - {-| Build a transaction that deploys the directory and global params. Returns the transaction and the 'TxIn' that was selected for the one-shot NFTs. -} @@ -216,7 +216,17 @@ seizeCredentialAssetsTx :: forall era env m. seizeCredentialAssetsTx sanctionedCred = do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) directory <- Query.registryNodes @era - seizeTxo <- head <$> Query.userProgrammableOutputs sanctionedCred + let getTxOutValue (C.TxOut _a v _d _r) = v + -- simple fold to choose the UTxO with the most total assets + nonAda v = foldl (\acc -> \case + (C.AdaAssetId, _) -> acc + (_aid, q) -> acc + q + ) 0 $ toList v + + getNonAdaTokens = nonAda . C.txOutValueToValue . getTxOutValue . uOut + seizeTxo <- maximumBy (compare `on` getNonAdaTokens) <$> Query.userProgrammableOutputs sanctionedCred + when (getNonAdaTokens seizeTxo == 0) $ + throwError NoTokensToSeize paramsTxIn <- Query.globalParamsNode @era (tx, _) <- Env.balanceTxEnv_ $ do BuildTx.seizeSmartTokens paramsTxIn seizeTxo (C.PaymentCredentialByKey opPkh) directory diff --git a/src/lib/Wst/Server.hs b/src/lib/Wst/Server.hs index 3dd87a8..61e8790 100644 --- a/src/lib/Wst/Server.hs +++ b/src/lib/Wst/Server.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-| servant server for stablecoin POC -} @@ -130,7 +131,8 @@ queryBlacklistedNodes _ (SerialiseAddress addr) = do . P.fromBuiltin . blnKey . uDatum - Env.withEnv $ Env.withTransfer transferLogic (fmap (fmap getHash) (Query.blacklistNodes @era)) + nonHeadNodes (P.fromBuiltin . blnKey . uDatum -> hsh) = hsh /= "" + Env.withEnv $ Env.withTransfer transferLogic (fmap getHash . filter nonHeadNodes <$> (Query.blacklistNodes @era)) txOutValue :: C.IsMaryBasedEra era => C.TxOut C.CtxUTxO era -> C.Value txOutValue = L.view (L._TxOut . L._2 . L._TxOutValue) diff --git a/src/test/unit/Wst/Test/UnitTest.hs b/src/test/unit/Wst/Test/UnitTest.hs index 55fb245..03f9042 100644 --- a/src/test/unit/Wst/Test/UnitTest.hs +++ b/src/test/unit/Wst/Test/UnitTest.hs @@ -86,11 +86,10 @@ deployDirectorySet = do pure scriptRoot insertDirectoryNode :: (MonadUtxoQuery m, MonadBlockchain C.ConwayEra m, MonadFail m) => DirectoryScriptRoot -> m () -insertDirectoryNode scriptRoot = failOnError $ Env.withEnv $ do - asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ do - Endpoints.insertNodeTx dummyNodeArgs >>= void . sendTx . signTxOperator admin - Query.registryNodes @C.ConwayEra - >>= void . expectN 2 "registry outputs" +insertDirectoryNode scriptRoot = failOnError $ Env.withEnv $ asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ do + Endpoints.insertNodeTx dummyNodeArgs >>= void . sendTx . signTxOperator admin + Query.registryNodes @C.ConwayEra + >>= void . expectN 2 "registry outputs" {-| Issue some tokens with the "always succeeds" validator -} @@ -190,9 +189,8 @@ blacklistTransfer = failOnError $ Env.withEnv $ do aid <- issueTransferLogicProgrammableToken scriptRoot - asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do - Endpoints.deployBlacklistTx - >>= void . sendTx . signTxOperator admin + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ Endpoints.deployBlacklistTx + >>= void . sendTx . signTxOperator admin opPkh <- asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) @@ -202,13 +200,11 @@ blacklistTransfer = failOnError $ Env.withEnv $ do transferLogic <- Env.withDirectoryFor scriptRoot $ Env.transferLogicForDirectory (C.verificationKeyHash . Operator.verificationKey . Operator.oPaymentKey $ admin) - asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do - Endpoints.blacklistCredentialTx userPaymentCred - >>= void . sendTx . signTxOperator admin + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ Endpoints.blacklistCredentialTx userPaymentCred + >>= void . sendTx . signTxOperator admin - asWallet Wallet.w2 $ Env.withDirectoryFor scriptRoot $ Env.withTransfer transferLogic $ do - Endpoints.transferSmartTokensTx aid 30 (C.PaymentCredentialByKey opPkh) - >>= void . sendTx . signTxOperator (user Wallet.w2) + asWallet Wallet.w2 $ Env.withDirectoryFor scriptRoot $ Env.withTransfer transferLogic $ Endpoints.transferSmartTokensTx aid 30 (C.PaymentCredentialByKey opPkh) + >>= void . sendTx . signTxOperator (user Wallet.w2) seizeUserOutput :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => DirectoryScriptRoot -> m () seizeUserOutput scriptRoot = failOnError $ Env.withEnv $ do @@ -217,9 +213,8 @@ seizeUserOutput scriptRoot = failOnError $ Env.withEnv $ do aid <- issueTransferLogicProgrammableToken scriptRoot - asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do - Endpoints.deployBlacklistTx - >>= void . sendTx . signTxOperator admin + asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ Endpoints.deployBlacklistTx + >>= void . sendTx . signTxOperator admin asAdmin @C.ConwayEra $ Env.withDirectoryFor scriptRoot $ Env.withTransferFromOperator $ do Endpoints.transferSmartTokensTx aid 50 (C.PaymentCredentialByKey userPkh) @@ -240,7 +235,6 @@ seizeUserOutput scriptRoot = failOnError $ Env.withEnv $ do Query.userProgrammableOutputs (C.PaymentCredentialByKey opPkh) >>= void . expectN 2 "user programmable outputs" - dummyNodeArgs :: InsertNodeArgs dummyNodeArgs = InsertNodeArgs @@ -267,6 +261,8 @@ registerTransferScripts :: (MonadFail m, MonadReader env m, Env.HasTransferLogic registerTransferScripts pkh = failOnError $ do transferMintingScript <- asks (Env.tleMintingScript . Env.transferLogicEnv) transferSpendingScript <- asks (Env.tleTransferScript . Env.transferLogicEnv) + transferSeizeSpendingScript <- asks (Env.tleIssuerScript . Env.transferLogicEnv) + let hshMinting = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferMintingScript credMinting = C.StakeCredentialByScript hshMinting @@ -274,10 +270,15 @@ registerTransferScripts pkh = failOnError $ do hshSpending = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferSpendingScript credSpending = C.StakeCredentialByScript hshSpending + hshSeizeSpending = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferSeizeSpendingScript + credSeizeSpending = C.StakeCredentialByScript hshSeizeSpending + + txBody <- BuildTx.execBuildTxT $ do addConwayStakeCredentialCertificate credSpending addConwayStakeCredentialCertificate credMinting + addConwayStakeCredentialCertificate credSeizeSpending BuildTx.addRequiredSignature pkh