Seizing tx builder

src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs

@@ -6,9 +6,13 @@
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE QualifiedDo           #-}
+{-# LANGUAGE UndecidableInstances #-}
+
 module SmartTokens.Contracts.ProgrammableLogicBase (
+  TokenProof (..),
+  ProgrammableLogicGlobalRedeemer (..),
   mkProgrammableLogicBase,
-  mkProgrammableLogicGlobal
+  mkProgrammableLogicGlobal,
 ) where
 
 import Plutarch.Builtin (pasByteStr, pasConstr, pforgetData)
@@ -40,6 +44,9 @@ import Plutarch.Unsafe (punsafeCoerce)
 import PlutusLedgerApi.V1.Value (Value)
 import SmartTokens.Types.ProtocolParams (PProgrammableLogicGlobalParams)
 import SmartTokens.Types.PTokenDirectory (PDirectorySetNode)
+import qualified PlutusTx
+import Plutarch.DataRepr (DerivePConstantViaData (..))
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
 
 -- | Strip Ada from a ledger value
 -- Importantly this function assumes that the Value is provided by the ledger (i.e. via the ScriptContext)
@@ -56,6 +63,17 @@ pstripAda = phoistAcyclic $
 -- The current implementation of the contracts in this module are not designed to be maximally efficient.
 -- In the future, this should be optimized to use the redeemer indexing design pattern to identify and validate
 -- the programmable inputs.
+data TokenProof 
+  = TokenExists Integer
+  | TokenDoesNotExist Integer
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+
+deriving via
+  (DerivePConstantViaData TokenProof PTokenProof)
+  instance
+    (PConstantDecl TokenProof)
+
 
 data PTokenProof (s :: S)
   = PTokenExists
@@ -74,6 +92,9 @@ data PTokenProof (s :: S)
 instance DerivePlutusType PTokenProof where
   type DPTStrat _ = PlutusTypeData
 
+instance PUnsafeLiftDecl PTokenProof where
+  type PLifted PTokenProof = TokenProof
+
 emptyValue :: Value
 emptyValue = mempty
 
@@ -279,9 +300,23 @@ pcheckTransferLogicAndGetProgrammableValue = plam $ \directoryNodeCS refInputs p
     -- drop the ada entry in the value before traversing the rest of the value entries
     in go # proofList # (ptail # mapInnerList) # pto (pto pemptyLedgerValue)
 
--- type ProgrammableLogicGlobalRedeemer = PBuiltinList (PAsData PTokenProof)
 
-data ProgrammableLogicGlobalRedeemer (s :: S)
+data ProgrammableLogicGlobalRedeemer 
+  = TransferAct [TokenProof]
+  | SeizeAct {
+        plgrSeizeInputIdx :: Integer,
+        plgrSeizeOutputIdx :: Integer,
+        plgrDirectoryNodeIdx :: Integer
+      }
+  deriving (Show, Eq, Generic)
+  deriving anyclass (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+
+deriving via
+  (DerivePConstantViaData ProgrammableLogicGlobalRedeemer PProgrammableLogicGlobalRedeemer)
+  instance
+    (PConstantDecl ProgrammableLogicGlobalRedeemer)
+
+data PProgrammableLogicGlobalRedeemer (s :: S)
   = PTransferAct
       ( Term s ( PDataRecord '[ "proofs" ':= PBuiltinList (PAsData PTokenProof) ] ) )
   | PSeizeAct
@@ -297,14 +332,17 @@ data ProgrammableLogicGlobalRedeemer (s :: S)
   deriving stock (Generic)
   deriving anyclass (PlutusType, PIsData, PEq)
 
-instance DerivePlutusType ProgrammableLogicGlobalRedeemer where
+instance DerivePlutusType PProgrammableLogicGlobalRedeemer where
   type DPTStrat _ = PlutusTypeData
 
+instance PUnsafeLiftDecl PProgrammableLogicGlobalRedeemer where
+  type PLifted PProgrammableLogicGlobalRedeemer = ProgrammableLogicGlobalRedeemer
+
 mkProgrammableLogicGlobal :: ClosedTerm (PAsData PCurrencySymbol :--> PScriptContext :--> PUnit)
 mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do
   ctxF <- pletFields @'["txInfo", "redeemer", "scriptInfo"] ctx
   infoF <- pletFields @'["inputs", "referenceInputs", "outputs", "signatories", "wdrl"] ctxF.txInfo
-  let red = pfromData $ punsafeCoerce @_ @_ @(PAsData ProgrammableLogicGlobalRedeemer) (pto ctxF.redeemer)
+  let red = pfromData $ punsafeCoerce @_ @_ @(PAsData PProgrammableLogicGlobalRedeemer) (pto ctxF.redeemer)
   referenceInputs <- plet $ pfromData infoF.referenceInputs
   -- Extract protocol parameter UTxO
   ptraceInfo "Extracting protocol parameter UTxO"

src/lib/SmartTokens/LinkedList/MintDirectory.hs

@@ -54,6 +54,11 @@ data DirectoryNodeAction
   deriving anyclass (SOP.Generic)
   deriving anyclass (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
 
+deriving via
+  (DerivePConstantViaData DirectoryNodeAction PDirectoryNodeAction)
+  instance
+    (PConstantDecl DirectoryNodeAction)
+
 data PDirectoryNodeAction (s :: S)
   = PInit (Term s (PDataRecord '[]))
   | PInsert (Term s (PDataRecord '["keyToInsert" ':= PByteString]))
@@ -65,10 +70,6 @@ instance PUnsafeLiftDecl PDirectoryNodeAction where
 
 instance DerivePlutusType PDirectoryNodeAction where type DPTStrat _ = PlutusTypeData
 
-deriving via
-  (DerivePConstantViaData DirectoryNodeAction PDirectoryNodeAction)
-  instance
-    (PConstantDecl DirectoryNodeAction)
 
 mkDirectoryNodeMP ::
   ClosedTerm

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

@@ -4,7 +4,6 @@
 {-# LANGUAGE ViewPatterns     #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
-{-# HLINT ignore "Redundant if" #-}
 {-# HLINT ignore "Use second" #-}
 module Wst.Offchain.BuildTx.ProgrammableLogic
   ( issueProgrammableToken,
@@ -15,21 +14,24 @@ where
 
 import Cardano.Api qualified as C
 import Cardano.Api.Shelley qualified as C
-import Convex.BuildTx (MonadBuildTx, addReference,
-                       addWithdrawZeroPlutusV2InTransaction, addWithdrawal,
+import Control.Lens (over, (^.))
+import Convex.BuildTx (MonadBuildTx, addBtx, addReference,
                        addWithdrawalWithTxBody, buildScriptWitness,
-                       findIndexReference, mintPlutus, spendPlutusInlineDatum)
+                       findIndexReference, findIndexSpending, mintPlutus,
+                       spendPlutusInlineDatum)
+import Convex.CardanoApi.Lenses as L
 import Convex.Class (MonadBlockchain (queryNetworkId))
 import Convex.PlutusLedger.V1 (transPolicyId, unTransCredential,
                                unTransPolicyId)
 import Convex.Scripts (fromHashableScriptData)
 import Convex.Utils qualified as Utils
-import Data.Bifunctor (Bifunctor (second))
 import Data.Foldable (find, maximumBy)
 import Data.Function (on)
 import Data.Maybe (fromJust)
-import PlutusLedgerApi.V3 (Credential (..), CurrencySymbol (..))
+import PlutusLedgerApi.V3 (CurrencySymbol (..))
 import SmartTokens.Contracts.Issuance (SmartTokenMintingAction (MintPToken, RegisterPToken))
+import SmartTokens.Contracts.ProgrammableLogicBase (ProgrammableLogicGlobalRedeemer (..),
+                                                    TokenProof (..))
 import SmartTokens.Types.ProtocolParams
 import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..))
 import Wst.Offchain.BuildTx.DirectorySet (insertDirectoryNode)
@@ -38,12 +40,15 @@ import Wst.Offchain.Scripts (programmableLogicBaseScript,
                              programmableLogicGlobalScript,
                              programmableLogicMintingScript)
 
--- Takes care of both registrations and token mints
-issueProgrammableToken :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.TxIn -> (C.PolicyId, C.TxOut C.CtxTx era) -> (C.AssetName, C.Quantity) -> (C.StakeCredential, C.StakeCredential, C.StakeCredential) -> [(C.TxIn, C.TxOut C.CtxTx era)]-> m CurrencySymbol
-issueProgrammableToken directoryInitialTxIn (paramsPolicyId, paramsTxOut) (an, q) (mintingCred, transferLogic, issuerLogic) directoryList = Utils.inBabbage @era $ do
-  netId <- queryNetworkId
 
-  ProgrammableLogicGlobalParams{directoryNodeCS, progLogicCred} <- maybe (error "could not parse protocol params") pure $ getProtocolParamsGlobalInline (C.inAnyCardanoEra (C.cardanoEra @era) paramsTxOut)
+{- Issue a programmable token and register it in the directory set if necessary. The caller should ensure that the specific
+   minting logic stake script witness is included in the final transaction.
+  - If the programmable token is not in the directory, then it is registered
+  - If the programmable token is in the directory, then it is minted
+-}
+issueProgrammableToken :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.TxIn -> (C.PolicyId, C.TxOut C.CtxTx era) -> (C.AssetName, C.Quantity) -> (C.StakeCredential, C.StakeCredential, C.StakeCredential) -> [(C.TxIn, C.TxOut C.CtxTx era)] -> m CurrencySymbol
+issueProgrammableToken directoryInitialTxIn (paramsPolicyId, paramsTxOut) (an, q) (mintingCred, transferLogic, issuerLogic) directoryList = Utils.inBabbage @era $ do
+  ProgrammableLogicGlobalParams {directoryNodeCS, progLogicCred} <- maybe (error "could not parse protocol params") pure $ getProtocolParamsGlobalInline (C.inAnyCardanoEra (C.cardanoEra @era) paramsTxOut)
 
   progLogicScriptCredential <- either (const $ error "could not parse protocol params") pure $ unTransCredential progLogicCred
   directoryNodeSymbol <- either (const $ error "could not parse protocol params") pure $ unTransPolicyId directoryNodeCS
@@ -62,29 +67,37 @@ issueProgrammableToken directoryInitialTxIn (paramsPolicyId, paramsTxOut) (an, q
       mintPlutus mintingScript MintPToken an q
     else
       mintPlutus mintingScript RegisterPToken an q
-      >> insertDirectoryNode paramsPolicyId directoryInitialTxIn (dirNodeRef, dirNodeOut) (policyId, transferLogic, issuerLogic)
+        >> insertDirectoryNode paramsPolicyId directoryInitialTxIn (dirNodeRef, dirNodeOut) (policyId, transferLogic, issuerLogic)
 
   pure policyId
 
-transferProgrammableToken :: (MonadBuildTx C.ConwayEra m) => C.NetworkId -> (C.TxIn, C.PolicyId) -> C.TxIn -> CurrencySymbol -> [(C.TxIn, C.InAnyCardanoEra (C.TxOut C.CtxTx))] -> m ()
-transferProgrammableToken nid paramsTxIn tokenTxIn programmableTokenSymbol [] = error "directory list empty"
-transferProgrammableToken nid (paramsTxIn, paramsPolId) tokenTxIn programmableTokenSymbol directoryList = do
+{- User facing transfer of programmable tokens from one address to another.
+   The caller should ensure that the specific transfer logic stake script
+   witness is included in the final transaction.
+
+   NOTE: If the token is not in the directory, then the function will
+   use a PDoesNotExist redeemer to prove that the token is not programmable
+
+   IMPORTANT: The caller should ensure that the destination address of the
+   programmable token(s) in this transaction all correspond to the same
+   programmable logic payment credential (even in the case of non-programmable
+   tokens) otherwise the transaction will fail onchain validation.
+-}
+transferProgrammableToken :: forall era m. (C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => (C.TxIn, C.PolicyId) -> C.TxIn -> CurrencySymbol -> [(C.TxIn, C.InAnyCardanoEra (C.TxOut C.CtxTx))] -> m ()
+transferProgrammableToken _ _ _ [] = error "directory list not initialised"
+transferProgrammableToken (paramsTxIn, paramsPolId) tokenTxIn programmableTokenSymbol directoryList = Utils.inBabbage @era $ do
+  nid <- queryNetworkId
 
-  let globalStakeScript = programmableLogicGlobalScript  paramsPolId
+  let globalStakeScript = programmableLogicGlobalScript paramsPolId
       globalStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 globalStakeScript
       baseSpendingScript = programmableLogicBaseScript globalStakeCred
 
-  addReference paramsTxIn
-  spendPlutusInlineDatum tokenTxIn baseSpendingScript ()
-
-  -- Finds the directory node with the highest key that is less than or equal
-  -- to the programmable token symbol
-  let (dirNodeRef, dirNodeOut) =
+      -- Finds the directory node with the highest key that is less than or equal
+      -- to the programmable token symbol
+      (dirNodeRef, dirNodeOut) =
         maximumBy (compare `on` (fmap key . getDirectoryNodeInline . snd)) $
           filter (maybe False ((<= programmableTokenSymbol) . key) . getDirectoryNodeInline . snd) directoryList
 
-  addReference dirNodeRef
-  let
       -- Finds the index of the directory node reference in the transaction ref
       -- inputs
       directoryNodeReferenceIndex txBody =
@@ -94,18 +107,98 @@ transferProgrammableToken nid (paramsTxIn, paramsPolId) tokenTxIn programmableTo
       -- exists with the programmable token symbol
       programmableLogicGlobalRedeemer txBody =
         if fmap key (getDirectoryNodeInline dirNodeOut) == Just programmableTokenSymbol
-          then directoryNodeReferenceIndex txBody -- TODO: wrap in PTokenExists
-          else directoryNodeReferenceIndex txBody -- TODO: wrap in PTokenNotExists
+          -- TODO: extend to allow multiple proofs, onchain allows it
+          then TransferAct [TokenExists $ directoryNodeReferenceIndex txBody]
+          else TransferAct [TokenDoesNotExist $ directoryNodeReferenceIndex txBody]
+
+      programmableGlobalWitness txBody = buildScriptWitness globalStakeScript C.NoScriptDatumForStake (programmableLogicGlobalRedeemer txBody)
+
+  addReference paramsTxIn -- Protocol Params TxIn
+  addReference dirNodeRef -- Directory Node TxIn
+  spendPlutusInlineDatum tokenTxIn baseSpendingScript () -- Redeemer is ignored in programmableLogicBase
+  addWithdrawalWithTxBody -- Add the global script witness to the transaction
+    (C.makeStakeAddress nid globalStakeCred)
+    (C.Quantity 0)
+    $ C.ScriptWitness C.ScriptWitnessForStakeAddr . programmableGlobalWitness
+
+{- Seize a programmable token from a user address to an issuer address. The
+   outputs address will be that of the issuer retrieved from @issuerTxOut@.
+   Throws if the payment credentials of the issuer output does not match the
+   programmable logic payment credential.
+
+   IMPORTANT: It is the caller's responsibility to
+   ensure that the specific issuer logic stake script witness is included in the
+   final transaction.
+-}
+seizePragrammableToken :: 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 ()
+seizePragrammableToken (paramsTxIn, paramsPolId) (seizingTxIn, seizingOutput) (issuerTxIn, issuerTxOut) seizingTokenSymbol directoryList = Utils.inBabbage @era $ do
+  nid <- queryNetworkId
+
+  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
+
+  checkIssuerAddressIsProgLogicCred (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 baseSpendingScript) issuerTxOut
+
+  let seizedValue = case seizingOutput of
+        (C.TxOut _ v _ _) ->
+          C.filterValue
+            ( \case
+                C.AdaAssetId -> True
+                C.AssetId a _ -> a == seizingTokenPolicyId
+            )
+            $ C.txOutValueToValue v
+
+      (issuerOutAddr, issuerOutVal) = case issuerTxOut of
+        (C.TxOut a (C.txOutValueToValue -> v) _ _) ->
+          (a, C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra (v <> seizedValue))
+
+      seizedIssuerOutput = C.TxOut issuerOutAddr issuerOutVal C.TxOutDatumNone C.ReferenceScriptNone
+
+      -- Finds the index of the directory node reference in the transaction ref
+      -- inputs
+      directoryNodeReferenceIndex txBody =
+        fromIntegral @Int @Integer $ findIndexReference dirNodeRef txBody
+
+      -- Finds the index of the issuer input in the transaction body
+      issuerInputIndex txBody =
+        fromIntegral @Int @Integer $ findIndexSpending issuerTxIn txBody
+
+      -- Finds the index of the issuer seized output in the transaction body
+      issueOutputIndex txBody =
+        fromIntegral @Int @Integer $ fst $ fromJust (find ((== seizedIssuerOutput) . snd) $ zip [0 ..] $ txBody ^. L.txOuts)
+
+      -- The seizing redeemer for the global script
+      programmableLogicGlobalRedeemer txBody =
+        SeizeAct
+          { plgrSeizeInputIdx = issuerInputIndex txBody,
+            plgrSeizeOutputIdx = issueOutputIndex txBody,
+            plgrDirectoryNodeIdx = directoryNodeReferenceIndex txBody
+          }
 
       programmableGlobalWitness txBody = buildScriptWitness globalStakeScript C.NoScriptDatumForStake (programmableLogicGlobalRedeemer txBody)
 
-  addWithdrawalWithTxBody
+  addReference paramsTxIn -- Protocol Params TxIn
+  addReference dirNodeRef -- Directory Node TxIn
+  spendPlutusInlineDatum seizingTxIn baseSpendingScript () -- Redeemer is ignored in programmableLogicBase
+  addBtx (over L.txOuts (seizedIssuerOutput :)) -- Add the seized output to the transaction
+  addWithdrawalWithTxBody -- Add the global script witness to the transaction
     (C.makeStakeAddress nid globalStakeCred)
     (C.Quantity 0)
     $ C.ScriptWitness C.ScriptWitnessForStakeAddr . programmableGlobalWitness
 
-seizePragrammableToken :: (MonadBuildTx C.ConwayEra m) => m ()
-seizePragrammableToken = pure ()
+  -- 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 _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) =
@@ -114,8 +207,8 @@ isNodeWithProgrammableSymbol programmableTokenSymbol (_, dn) =
     _ -> False
 
 getDirectoryNodeInline :: C.InAnyCardanoEra (C.TxOut C.CtxTx) -> Maybe DirectorySetNode
-getDirectoryNodeInline (C.InAnyCardanoEra C.ConwayEra (C.TxOut _ _ d _)) =
-  case d of
+getDirectoryNodeInline (C.InAnyCardanoEra C.ConwayEra (C.TxOut _ _ dat _)) =
+  case dat of
     C.TxOutDatumInline C.BabbageEraOnwardsConway (fromHashableScriptData -> Just d) -> Just d
     _ -> Nothing
 getDirectoryNodeInline _ = Nothing