Smart token transfer unit test flow

src/lib/SmartTokens/Contracts/ExampleTransferLogic.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE OverloadedRecordDot  #-}
 {-# LANGUAGE QualifiedDo #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TemplateHaskell       #-}
 
 module SmartTokens.Contracts.ExampleTransferLogic (
   mkPermissionedTransfer,
@@ -32,11 +33,16 @@ 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)
 
 data BlacklistProof
   = NonmembershipProof Integer
   deriving stock (Show, Eq, Generic)
-  deriving anyclass (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+
+PlutusTx.makeIsDataIndexed ''BlacklistProof
+  [('NonmembershipProof, 0)]
+
 
 deriving via
   (DerivePConstantViaData BlacklistProof PBlacklistProof)
@@ -180,5 +186,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
     ]

src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE OverloadedRecordDot   #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE QualifiedDo           #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
@@ -41,12 +42,14 @@ 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 (:-->), (#$), (#), (#||))
+                         ptraceInfo, type (:-->), (#$), (#), (#||), ptraceInfoError, ptraceDebugError)
 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)
@@ -67,7 +70,9 @@ data TokenProof
   = TokenExists Integer
   | TokenDoesNotExist Integer
   deriving stock (Show, Eq, Generic)
-  deriving anyclass (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+
+PlutusTx.makeIsDataIndexed ''TokenProof
+  [('TokenExists, 0), ('TokenDoesNotExist, 1)]
 
 deriving via
   (DerivePConstantViaData TokenProof PTokenProof)
@@ -87,7 +92,7 @@ data PTokenProof (s :: S)
           )
       )
   deriving stock (Generic)
-  deriving anyclass (PlutusType, PIsData, PEq)
+  deriving anyclass (PlutusType, PIsData, PEq, PShow)
 
 instance DerivePlutusType PTokenProof where
   type DPTStrat _ = PlutusTypeData
@@ -109,7 +114,7 @@ pvalueFromCred = phoistAcyclic $ plam $ \cred sigs scripts inputs ->
         self
           # pletFields @'["address", "value"] (pfield @"resolved" # txIn) (\txInF ->
               plet txInF.address $ \addr ->
-                pif (pfield @"credential" # addr #== cred)
+                pif ((pfield @"credential" # addr) #== cred)
                     (
                       pmatch (pfield @"stakingCredential" # addr) $ \case
                         PDJust ((pfield @"_0" #) -> stakingCred) ->
@@ -309,7 +314,10 @@ data ProgrammableLogicGlobalRedeemer
         plgrDirectoryNodeIdx :: Integer
       }
   deriving (Show, Eq, Generic)
-  deriving anyclass (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+
+PlutusTx.makeIsDataIndexed ''ProgrammableLogicGlobalRedeemer
+  [('TransferAct, 0), ('SeizeAct, 1)]
+
 
 deriving via
   (DerivePConstantViaData ProgrammableLogicGlobalRedeemer PProgrammableLogicGlobalRedeemer)
@@ -346,6 +354,7 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do
   referenceInputs <- plet $ pfromData infoF.referenceInputs
   -- Extract protocol parameter UTxO
   ptraceInfo "Extracting protocol parameter UTxO"
+
   let paramUTxO =
         pfield @"resolved" #$
           pmustFind @PBuiltinList
@@ -377,15 +386,15 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do
                 # infoF.signatories
                 # invokedScripts
                 # infoF.inputs
-      ptraceInfo "PTransferAct checkTransferLogicAndGetProgrammableValue"
       totalProgTokenValue_ <-
         plet $ pcheckTransferLogicAndGetProgrammableValue
                 # protocolParamsF.directoryNodeCS
                 # referenceInputs
                 # pfromData proofs
                 # invokedScripts
                 # totalProgTokenValue
-      ptraceInfo "PTransferAct validateConditions"
+
+      -- ptraceInfo "PTransferAct validateConditions"
       pvalidateConditions
           [ pisRewarding ctxF.scriptInfo
           , pcheckTransferLogic

src/lib/SmartTokens/Types/PTokenDirectory.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE QualifiedDo           #-}
 {-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module SmartTokens.Types.PTokenDirectory (
   DirectorySetNode (..),
@@ -46,20 +47,69 @@ 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 {
-    blnKey :: Credential,
-    blnNext :: Credential
+    blnKey :: BuiltinByteString,
+    blnNext :: BuiltinByteString
   }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (SOP.Generic)
   deriving
     (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) via (ProductIsData BlacklistNode)
 
+-- instance PlutusTx.ToData BlacklistNode where
+--   toBuiltinData BlacklistNode{blnKey, blnNext} =
+--     let blnKeyBstr = head $ snd $ BI.unsafeDataAsConstr (toBuiltinData blnKey)
+--         blnNextBstr = head $ snd $ BI.unsafeDataAsConstr (toBuiltinData blnNext)
+--      in BI.mkList [blnKeyBstr,  blnNextBstr]
+-- 
+-- instance PlutusTx.FromData BlacklistNode where
+--   fromBuiltinData builtinData =
+--     let fields = BI.unsafeDataAsList builtinData
+--         key = head fields
+--         fields1 = tail fields
+--         next = head fields1
+--      in Just $ undefined -- Don't know how to determine whether credential is pub key or script
+
+
 deriving via (DerivePConstantViaData BlacklistNode PBlacklistNode)
   instance (PConstantDecl BlacklistNode)
 
+{- 
+>>> _printTerm $ unsafeEvalTerm NoTracing (mkRecordConstr PBlacklistNode (#blnKey .= pconstant "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff" .& #blnNext .=  pconstant ""))
+No instance for `IsString (PAsDataLifted PByteString)'
+  arising from the literal `"ffffffffffffffffffffffffffffffffffffffffffffffffffffffff"'
+In the first argument of `pconstant', namely
+  `"ffffffffffffffffffffffffffffffffffffffffffffffffffffffff"'
+In the second argument of `(.=)', namely
+  `pconstant
+     "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff"'
+In the first argument of `(.&)', namely
+  `#blnKey
+     .=
+       pconstant
+         "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff"'
+-}
 newtype PBlacklistNode (s :: S)
   = PBlacklistNode
       ( Term

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

@@ -141,16 +141,16 @@ issueProgrammableToken paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, i
    programmable logic payment credential (even in the case of non-programmable
    tokens) otherwise the transaction will fail onchain validation.
 -}
-transferProgrammableToken :: forall env era m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => [C.TxIn] -> CurrencySymbol -> [UTxODat era DirectorySetNode] -> m ()
-transferProgrammableToken _ _ [] = error "directory list not initialised"
-transferProgrammableToken tokenTxIns programmableTokenSymbol directoryList = Utils.inBabbage @era $ do
+transferProgrammableToken :: forall 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 ->  [C.TxIn] -> CurrencySymbol -> [UTxODat era DirectorySetNode] -> m ()
+transferProgrammableToken _ _ _ [] = error "directory list not initialised"
+transferProgrammableToken paramsTxIn tokenTxIns programmableTokenSymbol 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
+  baseSpendingScript <- asks (Env.dsProgrammableLogicBaseScript . Env.directoryEnv)
+  globalStakeScript <- asks (Env.dsProgrammableLogicGlobalScript . Env.directoryEnv)
+
+
+  let globalStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 globalStakeScript
 
       -- Finds the directory node with the highest key that is less than or equal
       -- to the programmable token symbol
@@ -173,7 +173,7 @@ transferProgrammableToken tokenTxIns programmableTokenSymbol directoryList = Uti
 
       programmableGlobalWitness txBody = buildScriptWitness globalStakeScript C.NoScriptDatumForStake (programmableLogicGlobalRedeemer txBody)
 
-  addReference paramsTxIn -- Protocol Params TxIn
+  addReference (uIn paramsTxIn) -- Protocol Params TxIn
   addReference dirNodeRef -- Directory Node TxIn
   traverse_ (\tin -> spendPlutusInlineDatum tin baseSpendingScript ()) tokenTxIns
   addWithdrawalWithTxBody -- Add the global script witness to the transaction