Add seizeStablecoins tx builder

nix/project.nix

@@ -2,7 +2,7 @@
 
 let
   sha256map = {
-    "https://github.com/j-mueller/sc-tools"."956eb259e22d5a73fa5f67bc8aceec5df144d170" = "sha256-nhlXl/WCQDq3o9gwFRFu0FsOtySDZBjXKmkUHGxXSyI=";
+    "https://github.com/j-mueller/sc-tools"."956eb259e22d5a73fa5f67bc8aceec5df144d170" = "sha256-5qc4MbB6GuQyjA+Y+tlqixf6UvhyDgEBgj23aKgpSAg=";
     "https://github.com/colll78/plutarch-plutus"."b2379767c7f1c70acf28206bf922f128adc02f28" = "sha256-mhuW2CHxnc6FDWuMcjW/51PKuPOdYc4yxz+W5RmlQew=";
     "https://github.com/input-output-hk/catalyst-onchain-libs"."650a3435f8efbd4bf36e58768fac266ba5beede4" = "sha256-NUh+l97+eO27Ppd8Bx0yMl0E5EV+p7+7GuFun1B8gRc=";
   };

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

@@ -148,25 +148,28 @@ 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
       baseSpendingScript = programmableLogicBaseScript globalStakeCred
 
   -- 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 _)) =

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

@@ -1,73 +1,58 @@
 {-# LANGUAGE NamedFieldPuns   #-}
 {-# LANGUAGE TypeApplications #-}
 {-# 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, addWithdrawalWithTxBody,
+                       buildScriptWitness, findIndexReference, payToAddress)
 import Convex.CardanoApi.Lenses as L
 import Convex.Class (MonadBlockchain (queryNetworkId))
 import Convex.PlutusLedger.V1 (transCredential, transPolicyId,
-                               unTransCredential, unTransPolicyId,
                                unTransStakeCredential)
-import Convex.Scripts (fromHashableScriptData)
 import Convex.Utils qualified as Utils
 import Convex.Utxos (UtxoSet (UtxoSet))
 import Convex.Wallet (selectMixedInputsCovering)
 import Convex.Wallet.Operator (Operator (..), verificationKey)
-import Data.Either (fromRight)
-import Data.Foldable (find, maximumBy)
+import Data.Foldable (maximumBy)
 import Data.Function (on)
-import Data.Maybe (fromJust)
+import Data.Monoid (Last (..))
 import GHC.Exts (IsList (..))
-import PlutusLedgerApi.V3 (CurrencySymbol (..))
-import PlutusTx qualified
 import SmartTokens.Contracts.ExampleTransferLogic (BlacklistProof (..))
-import SmartTokens.Contracts.Issuance (SmartTokenMintingAction (MintPToken, RegisterPToken))
-import SmartTokens.Contracts.ProgrammableLogicBase (ProgrammableLogicGlobalRedeemer (..),
-                                                    TokenProof (..))
 import SmartTokens.Types.ProtocolParams
 import SmartTokens.Types.PTokenDirectory (BlacklistNode (..),
                                           DirectorySetNode (..))
-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.HasTransferLogicEnv env, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m, Env.HasOperatorEnv era env) => 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
 
   directoryEnv <- asks Env.directoryEnv
-  let txIn = Env.dsTxIn directoryEnv
-      progLogicBaseCred = Env.programmableLogicBaseCredential directoryEnv
-
-  opVerKey <- asks (verificationKey . oPaymentKey . Env.bteOperator . Env.operatorEnv)
-  let opPkh = C.verificationKeyHash opVerKey
-  addIssueWitness opPkh
+  let progLogicBaseCred = Env.programmableLogicBaseCredential directoryEnv
 
   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 +61,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 +79,45 @@ 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 Last maybeProgAsset = case uOut seizingTxo of
+        (C.TxOut _a v _d _r) ->
+          foldMap
+            ( \case
+                (C.AssetId pid an, q) -> Last (Just (pid, an, q))
+                (C.AdaAssetId, _q) -> Last Nothing
+            )
+            (toList $ C.txOutValueToValue v)
+
+  (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 +126,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, uDatum = blnNodeDatum} =
         maximumBy (compare `on` (blnKey . uDatum)) $
           filter ((<= transCredential clientCred) . blnKey . uDatum) blacklistNodes
 
@@ -139,17 +151,10 @@ 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 _)) =
-  case dat of
-    C.TxOutDatumInline C.BabbageEraOnwardsConway (fromHashableScriptData -> Just d) -> Just d
-    _ -> Nothing
-getDatumInline _ = Nothing