Sezing endpoint/unit test & fixes to transfer

input-output-hk · Dec 25, 2024 · c0e3f28 · c0e3f28
1 parent e790d33
commit c0e3f28
Show file tree

Hide file tree

Showing 10 changed files with 265 additions and 183 deletions.
diff --git a/src/lib/SmartTokens/Contracts/ExampleTransferLogic.hs b/src/lib/SmartTokens/Contracts/ExampleTransferLogic.hs
@@ -33,22 +33,23 @@ import SmartTokens.Types.PTokenDirectory ( PBlacklistNode, pletFieldsBlacklistNo
 import qualified PlutusTx
 import Plutarch.DataRepr (DerivePConstantViaData (..))
 import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
-import qualified Generics.SOP as SOP
-import Plutarch.Core.PlutusDataList (ProductIsData)
 
+-- >>> _printTerm $ unsafeEvalTerm NoTracing (pconstant $ NonmembershipProof 1)
+-- "program 1.0.0 (Constr 0 [I 1])"
 data BlacklistProof
   = NonmembershipProof Integer
   deriving stock (Show, Eq, Generic)
 
 PlutusTx.makeIsDataIndexed ''BlacklistProof
   [('NonmembershipProof, 0)]
 
-
 deriving via
   (DerivePConstantViaData BlacklistProof PBlacklistProof)
   instance
     (PConstantDecl BlacklistProof)
 
+-- >>> _printTerm $ unsafeEvalTerm NoTracing (mkRecordConstr PNonmembershipProof ( #nodeIdx .= pdata (pconstant 1)))
+-- "program 1.0.0 (Constr 0 [I 1])"
 data PBlacklistProof (s :: S)
   = PNonmembershipProof
       ( Term
@@ -59,7 +60,7 @@ data PBlacklistProof (s :: S)
           )
       )
   deriving stock (Generic)
-  deriving anyclass (PlutusType, PIsData, PEq)
+  deriving anyclass (PlutusType, PIsData, PEq, PShow)
 
 instance DerivePlutusType PBlacklistProof where
   type DPTStrat _ = PlutusTypeData
@@ -111,7 +112,7 @@ mkPermissionedTransfer = plam $ \permissionedCred ctx ->
       first node and lexographically less than the key of the second node (and thus if it was in the blacklist those two nodes 
       would not be adjacent).
     - Confirms the legitimacy of both directory entries by checking the presence of the directory node currency symbol.
-  - For 'PNonmembershipProofTail':
+  - For 'PNonmembershipProofTail': FIXME: outdated
     - Ensures that the witness key is greater than the tail node key in the blacklist.
     - Confirms the legitimacy of the directory entry by checking the presence of the directory node currency symbol.
 
@@ -138,7 +139,7 @@ pvalidateWitnesses = phoistAcyclic $ plam $ \blacklistNodeCS proofs refInputs wi
                       -- the currency symbol is not in the blacklist
                       nodeKey #< witnessKey
                       , witnessKey #< nodeNext #|| nodeNext #== pconstant ""
-                      -- both directory entries are legitimate, this is proven by the 
+                      -- directory entries are legitimate, this is proven by the 
                       -- presence of the directory node currency symbol.
                       , phasDataCS # blacklistNodeCS # pfromData prevNodeUTxOF.value
                       ]
@@ -186,5 +187,5 @@ mkFreezeAndSeizeTransfer = plam $ \blacklistNodeCS ctx -> P.do
             ) # pto (pfromData infoF.wdrl)
   pvalidateConditions
     [ pisRewarding ctxF.scriptInfo
-    -- , pvalidateWitnesses # blacklistNodeCS # red # infoF.referenceInputs # txWitnesses
+    , pvalidateWitnesses # blacklistNodeCS # red # infoF.referenceInputs # txWitnesses
     ]
diff --git a/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs b/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs
@@ -42,14 +42,12 @@ import Plutarch.Prelude (ClosedTerm, DerivePlutusType (..), Generic, PAsData,
                          S, Term, pcon, pconstant, pdata, pelem, perror, pfield,
                          pfix, pfromData, pfstBuiltin, phoistAcyclic, pif, plam,
                          plet, pletFields, pmap, pmatch, pnot, psndBuiltin, pto,
-                         ptraceInfo, type (:-->), (#$), (#), (#||), ptraceInfoError, ptraceDebugError)
+                         ptraceInfo, type (:-->), (#$), (#), (#||), PShow)
 import Plutarch.Unsafe (punsafeCoerce)
 import PlutusLedgerApi.V1.Value (Value)
 import PlutusTx qualified
 import SmartTokens.Types.ProtocolParams (PProgrammableLogicGlobalParams)
 import SmartTokens.Types.PTokenDirectory (PDirectorySetNode)
-import Plutarch.Show (pshow)
-import Plutarch.Prelude (PShow, plength)
 
 -- | Strip Ada from a ledger value
 -- Importantly this function assumes that the Value is provided by the ledger (i.e. via the ScriptContext)
@@ -369,7 +367,7 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do
   progLogicCred <- plet protocolParamsF.progLogicCred
 
   ptraceInfo "Extracting invoked scripts"
-  let invokedScripts =
+  invokedScripts <- plet $ 
         pmap @PBuiltinList
           # plam (\wdrlPair ->
                     let cred = pfstBuiltin # wdrlPair
@@ -379,7 +377,6 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do
 
   pmatch red $ \case
     PTransferAct ((pfield @"proofs" #) -> proofs) -> P.do
-      ptraceInfo "PTransferAct valueFromCred"
       totalProgTokenValue <-
         plet $ pvalueFromCred
                 # progLogicCred
@@ -394,7 +391,6 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do
                 # invokedScripts
                 # totalProgTokenValue
 
-      -- ptraceInfo "PTransferAct validateConditions"
       pvalidateConditions
           [ pisRewarding ctxF.scriptInfo
           , pcheckTransferLogic
@@ -417,13 +413,13 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do
           directoryNodeUTxO = pelemAtFast @PBuiltinList # referenceInputs # pfromData seizeActF.directoryNodeIdx
       seizeDirectoryNode <- pletFields @'["value", "datum"] (pfield @"resolved" # directoryNodeUTxO)
       POutputDatum ((pfield @"outputDatum" #) -> seizeDat') <- pmatch seizeDirectoryNode.datum
-      directoryNodeDatumF <- pletFields @'["key", "next", "transferLogicScript", "issuerLogicScript"] (punsafeCoerce @_ @_ @PDirectorySetNode (pto seizeDat'))
+      directoryNodeDatumF <- pletFields @'["key", "next", "transferLogicScript", "issuerLogicScript"] (punsafeCoerce @_ @_ @(PAsData PDirectorySetNode) (pto seizeDat'))
 
       seizeInputF <- pletFields @'["address", "value", "datum"] seizeInput
       seizeInputAddress <- plet seizeInputF.address
 
       seizeInputValue <- plet $ pfromData seizeInputF.value
-      seizeOutputValue <- plet $ pfilterCSFromValue # seizeInputValue # directoryNodeDatumF.key
+      expectedSeizeOutputValue <- plet $ pfilterCSFromValue # seizeInputValue # directoryNodeDatumF.key
 
       let expectedSeizeOutput =
             pdata $
@@ -432,7 +428,7 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do
                 ( #address
                     .= seizeInputF.address
                     .& #value
-                    .= pdata seizeOutputValue
+                    .= pdata expectedSeizeOutputValue
                     .& #datum
                     .= seizeInputF.datum
                     .& #referenceScript
@@ -452,7 +448,7 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do
           -- back to the mkProgrammableLogicBase script without modifying it (thus preventing any others from spending
           -- that UTxO in that block). Or using it to repeatedly spend a programmable token UTxO that does have the programmable token back back to
           -- the mkProgrammableLogicBase script without removing the programmable token associated with the `issuerLogicCredential`.
-          , pnot # (pdata seizeInputValue #== pdata seizeOutputValue)
+          , pnot # (pdata seizeInputValue #== pdata expectedSeizeOutputValue)
           ]
 
 

diff --git a/src/lib/SmartTokens/Types/PTokenDirectory.hs b/src/lib/SmartTokens/Types/PTokenDirectory.hs
@@ -25,47 +25,22 @@ module SmartTokens.Types.PTokenDirectory (
   BlacklistNode(..),
 ) where
 
-import Data.Text qualified as T
 import Generics.SOP qualified as SOP
-import GHC.Stack (HasCallStack)
 import Plutarch (Config (NoTracing))
 import Plutarch.Builtin (pasByteStr, pasConstr, pasList, pforgetData, plistData)
 import Plutarch.Core.PlutusDataList (DerivePConstantViaDataList (..),
                                      PlutusTypeDataList, ProductIsData (..))
 import Plutarch.Core.Utils (pcond, pheadSingleton, pmkBuiltinList)
 import Plutarch.DataRepr (PDataFields)
-import Plutarch.DataRepr.Internal (DerivePConstantViaData (..), PDataRecord,
-                                   PLabeledType ((:=)), PlutusTypeData)
+import Plutarch.DataRepr.Internal (DerivePConstantViaData (..))
 import Plutarch.DataRepr.Internal.Field (HRec (..), Labeled (Labeled))
 import Plutarch.Evaluate (unsafeEvalTerm)
-import Plutarch.Internal qualified as PI
-import Plutarch.Internal.Other (printScript)
 import Plutarch.LedgerApi.V3 (PCredential, PCurrencySymbol)
 import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
 import Plutarch.Prelude
 import Plutarch.Unsafe (punsafeCoerce)
 import PlutusLedgerApi.V3 (BuiltinByteString, Credential, CurrencySymbol)
 import PlutusTx (Data (B, Constr), FromData, ToData, UnsafeFromData)
-import SmartTokens.CodeLens (_printTerm)
-import PlutusLedgerApi.Data.V3 (Credential(PubKeyCredential))
-import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
-import qualified Data.Tuple as BI
-import PlutusTx.IsData.Class (ToData(toBuiltinData))
-import qualified PlutusTx.Builtins as BI
-import PlutusLedgerApi.V1 (FromData(fromBuiltinData), PubKeyHash (..))
-import PlutusTx.Builtins.HasOpaque (stringToBuiltinByteString)
-
-{- 
->>> _printTerm $ unsafeEvalTerm NoTracing (pconstant blacklistInitialNode)
-"program\n  1.0.0\n  (List [B #, B #ffffffffffffffffffffffffffffffffffffffffffffffffffffffff])"
--}
-blacklistInitialNode :: BlacklistNode
-blacklistInitialNode = 
-  BlacklistNode 
-    -- FIXME: fix this hacky bstr
-    { blnNext= case PubKeyCredential  "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff" of
-                  PubKeyCredential (PubKeyHash bstr) -> bstr
-    , blnKey= ""}
 
 data BlacklistNode =
   BlacklistNode {

diff --git a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs
@@ -18,20 +18,20 @@ where
 
 import Cardano.Api qualified as C
 import Cardano.Api.Shelley qualified as C
-import Control.Lens (over, (^.))
+import Control.Lens ((^.))
 import Control.Monad.Reader (MonadReader, asks)
-import Convex.BuildTx (MonadBuildTx, addBtx, addReference,
-                       addWithdrawalWithTxBody, buildScriptWitness,
-                       findIndexReference, findIndexSpending, mintPlutus,
-                       prependTxOut, spendPlutusInlineDatum)
+import Convex.BuildTx (MonadBuildTx, addReference, addWithdrawalWithTxBody,
+                       buildScriptWitness, findIndexReference,
+                       findIndexSpending, mintPlutus, prependTxOut,
+                       spendPlutusInlineDatum)
 import Convex.CardanoApi.Lenses as L
 import Convex.Class (MonadBlockchain (queryNetworkId))
 import Convex.PlutusLedger.V1 (transPolicyId, unTransCredential,
                                unTransPolicyId)
-import Convex.Scripts (toHashableScriptData)
 import Convex.Utils qualified as Utils
 import Data.Foldable (find, maximumBy, traverse_)
 import Data.Function (on)
+import Data.List (partition)
 import Data.Maybe (fromJust)
 import GHC.Exts (IsList (..))
 import PlutusLedgerApi.V3 (CurrencySymbol (..))
@@ -42,11 +42,10 @@ import SmartTokens.Types.ProtocolParams
 import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..))
 import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (..),
                                           insertDirectoryNode)
-import Wst.Offchain.Env (DirectoryEnv (..), TransferLogicEnv (..))
+import Wst.Offchain.Env (TransferLogicEnv (..))
 import Wst.Offchain.Env qualified as Env
 import Wst.Offchain.Query (UTxODat (..))
-import Wst.Offchain.Scripts (alwaysSucceedsScript, programmableLogicBaseScript,
-                             programmableLogicGlobalScript,
+import Wst.Offchain.Scripts (alwaysSucceedsScript,
                              programmableLogicMintingScript)
 
 data IssueNewTokenArgs = IssueNewTokenArgs
@@ -86,10 +85,7 @@ issueProgrammableToken paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, i
 
   progLogicScriptCredential <- either (const $ error "could not parse protocol params") pure $ unTransCredential progLogicCred
   directoryNodeSymbol <- either (const $ error "could not parse protocol params") pure $ unTransPolicyId directoryNodeCS
-  --
-  -- DirectoryEnv{dsProgrammableLogicBaseScript} <- asks Env.directoryEnv
 
-  -- TODO: maybe move programmableLogicMintingScript to DirectoryEnv
   let mintingScript = programmableLogicMintingScript progLogicScriptCredential (C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaMintingLogic) directoryNodeSymbol
       issuedPolicyId = C.scriptPolicyId $ C.PlutusScript C.PlutusScriptV3 mintingScript
       issuedSymbol = transPolicyId issuedPolicyId
@@ -98,18 +94,6 @@ issueProgrammableToken paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, i
         maximumBy (compare `on` (key . uDatum)) $
           filter ((<= issuedSymbol) . key . uDatum) directoryList
 
-      -- receivingAddress =
-      --   C.makeShelleyAddressInEra
-      --     C.shelleyBasedEra
-      --     netId
-      --     (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion dsProgrammableLogicBaseScript)
-      --     C.NoStakeAddress -- FIXME: use owner credential
-
-      -- receivingVal = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra
-      --   $ fromList [(C.AssetId issuedPolicyId an, q)]
-
-      -- dat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData () -- TODO: What should the datum be?
-
   if key dirNodeData == issuedSymbol
     then
       mintPlutus mintingScript MintPToken an q
@@ -124,9 +108,6 @@ issueProgrammableToken paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, i
       mintPlutus mintingScript RegisterPToken an q
       insertDirectoryNode paramsTxOut udat nodeArgs
 
-      -- add programmable logic output
-      -- prependTxOut $ C.TxOut receivingAddress receivingVal dat C.ReferenceScriptNone
-
   pure issuedPolicyId
 
 {- User facing transfer of programmable tokens from one address to another.
@@ -193,65 +174,67 @@ transferProgrammableToken paramsTxIn tokenTxIns programmableTokenSymbol director
    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 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
+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 ProgrammableLogicGlobalParams -> UTxODat era a -> C.PolicyId -> [UTxODat era DirectorySetNode] -> m ()
+seizeProgrammableToken UTxODat{uIn = paramsTxIn} UTxODat{uIn = seizingTxIn, uOut = seizingTxOut} seizingTokenPolicyId directoryList = Utils.inBabbage @era $ do
   nid <- queryNetworkId
-  paramsPolId <- asks (Env.protocolParamsPolicyId . Env.directoryEnv)
-  paramsTxIn <- asks (Env.dsTxIn . Env.directoryEnv)
+  globalStakeScript <- asks (Env.dsProgrammableLogicGlobalScript . Env.directoryEnv)
+  baseSpendingScript <- asks (Env.dsProgrammableLogicBaseScript . Env.directoryEnv)
 
-  let globalStakeScript = programmableLogicGlobalScript paramsPolId
-      globalStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 globalStakeScript
-      baseSpendingScript = programmableLogicBaseScript globalStakeCred
+  let globalStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 globalStakeScript
 
   -- 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 . uIn) $
       find (isNodeWithProgrammableSymbol (transPolicyId seizingTokenPolicyId)) directoryList
 
-  checkIssuerAddressIsProgLogicCred (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 baseSpendingScript) issuerTxOut
+  -- destStakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential seizeDestinationCred
+  let
+      -- issuerDestinationAddress = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue destStakeCred)
 
-  let seizedValue = case seizingTxOut of
-        (C.TxOut _ v _ _) ->
-          C.filterValue
-            ( \case
-                C.AdaAssetId -> True
-                C.AssetId a _ -> a == seizingTokenPolicyId
-            )
-            $ C.txOutValueToValue v
+      (seizedAddr, remainingValue) = case seizingTxOut of
+        (C.TxOut a v _ _) ->
+          let (seized, other) =
+                  partition
+                    ( \case
+                        (C.AdaAssetId, _q) -> False
+                        (C.AssetId a _, _q) -> a == seizingTokenPolicyId
+                    )
+                    $ toList $ C.txOutValueToValue v
+          in (a, fromList other)
 
-      (issuerOutAddr, issuerOutVal) = case issuerTxOut of
-        (C.TxOut a (C.txOutValueToValue -> v) _ _) ->
-          (a, C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra (v <> seizedValue))
+      remainingTxOutValue = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra remainingValue
 
-      seizedIssuerOutput = C.TxOut issuerOutAddr issuerOutVal C.TxOutDatumNone C.ReferenceScriptNone
+      seizedOutput = C.TxOut seizedAddr remainingTxOutValue 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
+      seizingInputIndex txBody =
+        fromIntegral @Int @Integer $ findIndexSpending seizingTxIn 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)
+      seizingOutputIndex txBody =
+        fromIntegral @Int @Integer $ fst $ fromJust (find ((== seizedOutput) . snd ) $ zip [0 ..] $ txBody ^. L.txOuts)
 
       -- The seizing redeemer for the global script
       programmableLogicGlobalRedeemer txBody =
         SeizeAct
-          { plgrSeizeInputIdx = issuerInputIndex txBody,
-            plgrSeizeOutputIdx = issueOutputIndex txBody,
+          { plgrSeizeInputIdx = seizingInputIndex txBody,
+            plgrSeizeOutputIdx = seizingOutputIndex txBody,
             plgrDirectoryNodeIdx = directoryNodeReferenceIndex txBody
           }
 
       programmableGlobalWitness txBody = buildScriptWitness globalStakeScript C.NoScriptDatumForStake (programmableLogicGlobalRedeemer txBody)
 
+  prependTxOut seizedOutput
   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
+  -- QUESTION: why do we have to spend an issuer output?
+  -- spendPlutusInlineDatum issuerTxIn baseSpendingScript () -- Redeemer is ignored in programmableLogicBase
   addWithdrawalWithTxBody -- Add the global script witness to the transaction
     (C.makeStakeAddress nid globalStakeCred)
     (C.Quantity 0)