CLI deployment of Wst using Blockfrost

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)

src/lib/Wst/Offchain/BuildTx/TransferLogic.hs

@@ -9,6 +9,7 @@ module Wst.Offchain.BuildTx.TransferLogic
     seizeSmartTokens,
     initBlacklist,
     insertBlacklistNode,
+    spendBlacklistOutput,
     paySmartTokensToDestination,
     registerTransferScripts,
   )
@@ -17,6 +18,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 +46,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 +93,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)
@@ -102,7 +104,6 @@ insertBlacklistNode cred blacklistNodes = Utils.inBabbage @era $ do
   mintPlutus mintingScript () newAssetName quantity
 
   let
-
       -- find the node to insert on
       UTxODat {uIn = prevNodeRef,uOut = (C.TxOut prevAddr prevVal _ _),  uDatum = prevNode} =
         maximumBy (compare `on` (blnKey . uDatum)) $
@@ -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 ()
@@ -131,6 +135,13 @@ insertBlacklistNode cred blacklistNodes = Utils.inBabbage @era $ do
   opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv)
   addRequiredSignature opPkh
 
+spendBlacklistOutput :: 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.TxIn -> m ()
+spendBlacklistOutput txin = Utils.inBabbage @era $ do
+  spendingScript <- asks (Env.tleBlacklistSpendingScript . Env.transferLogicEnv)
+  spendPlutusInlineDatum txin spendingScript ()
+  opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv)
+  addRequiredSignature opPkh
+
 {-| Add a smart token output that locks the given value,
 addressed to the payment credential
 -}
@@ -330,6 +341,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 +350,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

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

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)

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,17 +261,24 @@ 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
 
       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