Skip to content

Commit e7e2ee2

Browse files
colll78colll78
committed
add ref utxo with the prefix and postfix cborhex of the issuance script
1 parent f950f62 commit e7e2ee2

File tree

12 files changed

+280
-20
lines changed

12 files changed

+280
-20
lines changed

‎src/programmable-tokens/lib/SmartTokens/Contracts/IssuanceCborHex.hs‎

Lines changed: 78 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,78 @@
1+
{-# LANGUAGE ImpredicativeTypes #-}
2+
{-# LANGUAGE NamedFieldPuns #-}
3+
{-# LANGUAGE PartialTypeSignatures #-}
4+
{-# LANGUAGE QualifiedDo #-}
5+
{-# LANGUAGE UndecidableInstances #-}
6+
7+
module SmartTokens.Contracts.IssuanceCborHex (
8+
IssuanceCborHex (..),
9+
PIssuanceCborHex (..),
10+
mkIssuanceCborHexMinting,
11+
) where
12+
13+
import Generics.SOP qualified as SOP
14+
import GHC.Generics (Generic)
15+
import Plutarch.Core.List
16+
import Plutarch.Core.Utils
17+
import Plutarch.Core.ValidationLogic
18+
import Plutarch.Core.Value
19+
import Plutarch.LedgerApi.V3
20+
import Plutarch.Monadic qualified as P
21+
import Plutarch.Prelude
22+
import Plutarch.Repr.Data
23+
import PlutusLedgerApi.V3 (BuiltinByteString)
24+
import PlutusTx qualified
25+
import PlutusTx.Builtins.Internal qualified as BI
26+
import PlutusTx.Prelude qualified as PlutusTx
27+
import SmartTokens.Types.Constants (pissuanceCborHexTokenData)
28+
29+
data IssuanceCborHex =
30+
IssuanceCborHex {
31+
prefixCborHex :: BuiltinByteString,
32+
postfixCborHex :: BuiltinByteString
33+
}
34+
deriving stock (Show, Eq, Generic)
35+
deriving anyclass (SOP.Generic)
36+
37+
instance PlutusTx.ToData IssuanceCborHex where
38+
toBuiltinData IssuanceCborHex{prefixCborHex, postfixCborHex} = PlutusTx.toBuiltinData [prefixCborHex, postfixCborHex]
39+
40+
instance PlutusTx.FromData IssuanceCborHex where
41+
fromBuiltinData builtinData = do
42+
xs <- BI.chooseData builtinData Nothing Nothing (Just $ BI.unsafeDataAsList builtinData) Nothing Nothing
43+
prefixCborHex_ <- PlutusTx.fromBuiltinData $ BI.head xs
44+
let tail_ = BI.tail xs
45+
postfixCborHex_ <- PlutusTx.fromBuiltinData $ BI.head tail_
46+
PlutusTx.pure PlutusTx.$ IssuanceCborHex prefixCborHex_ postfixCborHex_
47+
48+
49+
data PIssuanceCborHex (s :: S)
50+
= PIssuanceCborHex
51+
{ pprefixCborHex :: Term s (PAsData PByteString)
52+
, ppostfixCborHex :: Term s (PAsData PByteString)
53+
}
54+
deriving stock (Generic)
55+
deriving anyclass (SOP.Generic, PIsData, PShow, PEq)
56+
deriving (PlutusType) via (DeriveAsDataRec PIssuanceCborHex)
57+
58+
deriving via DeriveDataPLiftable (PAsData PIssuanceCborHex) IssuanceCborHex
59+
instance PLiftable PIssuanceCborHex
60+
61+
mkIssuanceCborHexMinting :: ClosedTerm (PAsData PTxOutRef :--> PScriptContext :--> PUnit)
62+
mkIssuanceCborHexMinting = plam $ \oref ctx -> P.do
63+
PScriptContext {pscriptContext'txInfo, pscriptContext'scriptInfo} <- pmatch ctx
64+
PTxInfo {ptxInfo'inputs, ptxInfo'mint} <- pmatch pscriptContext'txInfo
65+
PMintingScript ownCS <- pmatch pscriptContext'scriptInfo
66+
67+
mintedValue <- plet $ pfromData ptxInfo'mint
68+
let ownTkPairs = ptryLookupValue # ownCS # mintedValue
69+
70+
-- Enforce that only a single token name is minted for this policy
71+
ownTkPair <- plet (pheadSingleton # ownTkPairs)
72+
ownTokenName <- plet (pfstBuiltin # ownTkPair)
73+
ownNumMinted <- plet (psndBuiltin # ownTkPair)
74+
pvalidateConditions
75+
[ ownTokenName #== pissuanceCborHexTokenData
76+
, ownNumMinted #== pconstant 1
77+
, phasUTxO # pfromData oref # pfromData ptxInfo'inputs
78+
]

‎src/programmable-tokens/lib/SmartTokens/Types/Constants.hs‎

Lines changed: 16 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,12 @@ module SmartTokens.Types.Constants(
88
-- * Directory node token name
99
directoryNodeToken,
1010
pdirectoryNodeToken,
11-
pdirectoryNodeTokenData
11+
pdirectoryNodeTokenData,
12+
13+
-- * Issuance cbor hex token name
14+
issuanceCborHexToken,
15+
pissuanceCborHexToken,
16+
pissuanceCborHexTokenData,
1217
) where
1318

1419
import Plutarch.LedgerApi.V1 (PTokenName (..))
@@ -33,3 +38,13 @@ pdirectoryNodeToken = pconstant directoryNodeToken
3338

3439
pdirectoryNodeTokenData :: ClosedTerm (PAsData PTokenName)
3540
pdirectoryNodeTokenData = pconstant directoryNodeToken
41+
42+
issuanceCborHexToken :: TokenName
43+
issuanceCborHexToken = TokenName (stringToBuiltinByteString "IssuanceCborHex")
44+
45+
pissuanceCborHexToken :: ClosedTerm PTokenName
46+
pissuanceCborHexToken = pconstant issuanceCborHexToken
47+
48+
pissuanceCborHexTokenData :: ClosedTerm (PAsData PTokenName)
49+
pissuanceCborHexTokenData = pconstant issuanceCborHexToken
50+

‎src/programmable-tokens/programmable-tokens.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -58,6 +58,7 @@ library
5858
SmartTokens.Contracts.AlwaysYields
5959
SmartTokens.Contracts.ExampleTransferLogic
6060
SmartTokens.Contracts.Issuance
61+
SmartTokens.Contracts.IssuanceCborHex
6162
SmartTokens.Contracts.ProgrammableLogicBase
6263
SmartTokens.Contracts.ProtocolParams
6364
SmartTokens.Core.Scripts

‎src/regulated-stablecoin/exe/export-smart-tokens/Main.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -25,7 +25,7 @@ import Options.Applicative (Parser, argument, customExecParser, disambiguate,
2525
optional, prefs, showHelpOnEmpty, showHelpOnError,
2626
strArgument)
2727
import Options.Applicative.Builder (ReadM)
28-
import Plutarch.Evaluate (applyArguments, evalScript, unsafeEvalTerm)
28+
import Plutarch.Evaluate (applyArguments, evalScript)
2929
import Plutarch.Internal.Term (Config (..), LogLevel (LogInfo), Script,
3030
TracingMode (DoTracing, DoTracingAndBinds),
3131
compile)
@@ -146,11 +146,11 @@ runMain =
146146
>>= runExportCommand
147147

148148
writeAppliedScripts :: FilePath -> AppliedScriptArgs -> IO ()
149-
writeAppliedScripts baseFolder AppliedScriptArgs{asaTxIn, asaIssuerAddress=SerialiseAddress issuerAddr} = do
149+
writeAppliedScripts baseFolder AppliedScriptArgs{asaTxIn, asaIssuerCborHexTxIn, asaIssuerAddress=SerialiseAddress issuerAddr} = do
150150
let opkh = case issuerAddr of
151151
(C.ShelleyAddress _ntw (C.fromShelleyPaymentCredential -> C.PaymentCredentialByKey pmt) _stakeRef) -> pmt
152152
_ -> error "Expected public key address" -- FIXME: proper error
153-
dirRoot = DirectoryScriptRoot asaTxIn Production
153+
dirRoot = DirectoryScriptRoot asaTxIn asaIssuerCborHexTxIn Production
154154
blacklistTransferRoot = BlacklistTransferLogicScriptRoot Production (mkDirectoryEnv dirRoot) opkh
155155
putStrLn "Writing applied Plutus scripts to files"
156156
createDirectoryIfMissing True baseFolder
@@ -256,6 +256,7 @@ exportUnapplied fp = do
256256
data AppliedScriptArgs =
257257
AppliedScriptArgs
258258
{ asaTxIn :: C.TxIn
259+
, asaIssuerCborHexTxIn :: C.TxIn
259260
, asaIssuerAddress :: SerialiseAddress (C.Address C.ShelleyAddr)
260261
}
261262

@@ -271,7 +272,7 @@ parseExportCommand =
271272
<*> optional parseAppliedScriptArgs
272273

273274
parseAppliedScriptArgs :: Parser AppliedScriptArgs
274-
parseAppliedScriptArgs = AppliedScriptArgs <$> parseTxIn <*> parseAddress
275+
parseAppliedScriptArgs = AppliedScriptArgs <$> parseTxIn <*> parseTxIn <*> parseAddress
275276

276277
parseAddress :: Parser (SerialiseAddress (C.Address C.ShelleyAddr))
277278
parseAddress = argument (eitherReader (eitherDecode . LBS8.pack)) (help "The address to use for the issuer" <> metavar "ISSUER_ADDRESS")

‎src/regulated-stablecoin/lib/Wst/Cli.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -44,8 +44,8 @@ runCommand com = do
4444
env <- Env.addRuntimeEnv <$> Env.loadRuntimeEnv <*> pure Env.empty
4545
result <- case com of
4646
Deploy config -> runWstApp env (deploy config)
47-
Manage txIn com_ -> do
48-
let env' = Env.addDirectoryEnvFor (Env.DirectoryScriptRoot txIn Production) env
47+
Manage txIn issuanceCborHexTxIn com_ -> do
48+
let env' = Env.addDirectoryEnvFor (Env.DirectoryScriptRoot txIn issuanceCborHexTxIn Production) env
4949
runWstApp env' $ case com_ of
5050
Status -> do
5151
-- TODO: status check (call the query endpoints and print out a summary of the results)

‎src/regulated-stablecoin/lib/Wst/Cli/Command.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -29,7 +29,7 @@ parseCommand =
2929

3030
data Command =
3131
Deploy OperatorConfigSigning
32-
| Manage TxIn ManageCommand
32+
| Manage TxIn TxIn ManageCommand
3333
deriving Show
3434

3535
-- | Commands that require a deployed system
@@ -46,7 +46,7 @@ parseDeploy =
4646
parseManage :: Mod CommandFields Command
4747
parseManage =
4848
command "manage" $
49-
info (Manage <$> parseTxIn <*> parseManageCommand) (fullDesc <> progDesc "Manage a deployed system")
49+
info (Manage <$> parseTxIn <*> parseTxIn <*> parseManageCommand) (fullDesc <> progDesc "Manage a deployed system")
5050

5151
parseManageCommand :: Parser ManageCommand
5252
parseManageCommand = subparser $ mconcat [parseStatus, parseStartServer]

‎src/regulated-stablecoin/lib/Wst/Offchain/BuildTx/IssuanceCborHexRef.hs‎

Lines changed: 94 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,94 @@
1+
{-# LANGUAGE NamedFieldPuns #-}
2+
module Wst.Offchain.BuildTx.IssuanceCborHexRef (
3+
mintIssuanceCborHexNFT,
4+
getCborHexInline,
5+
) where
6+
7+
import Cardano.Api qualified as C
8+
import Cardano.Api.Shelley qualified as C
9+
import Control.Monad.Reader (MonadReader, asks)
10+
import Convex.BuildTx (MonadBuildTx, mintPlutus, prependTxOut,
11+
spendPublicKeyOutput)
12+
import Convex.Class (MonadBlockchain (..))
13+
import Convex.PlutusLedger.V1 (unTransAssetName)
14+
import Convex.Scripts (fromHashableScriptData, toHashableScriptData)
15+
import Convex.Utils qualified as Utils
16+
import Data.ByteString qualified as BS
17+
import Data.ByteString.Char8 qualified as BSC
18+
import Data.ByteString.Short qualified as SBS
19+
import GHC.Exts (IsList (..))
20+
import Plutarch.Evaluate (applyArguments)
21+
import Plutarch.Internal.Term (Config (..), compile)
22+
import Plutarch.Prelude (pconstant, (#))
23+
import Plutarch.Script (Script (..))
24+
import PlutusLedgerApi.Common (serialiseUPLC, toBuiltin, toData)
25+
import PlutusLedgerApi.V3 qualified as V3
26+
import PlutusTx.Builtins.HasOpaque (stringToBuiltinByteStringHex)
27+
import SmartTokens.Contracts.Issuance (mkProgrammableLogicMinting)
28+
import SmartTokens.Contracts.IssuanceCborHex (IssuanceCborHex (IssuanceCborHex))
29+
import SmartTokens.Types.Constants (issuanceCborHexToken)
30+
import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams (..))
31+
import Wst.Offchain.Env (DirectoryEnv (..), globalParams)
32+
import Wst.Offchain.Env qualified as Env
33+
import Wst.Offchain.Scripts (scriptPolicyIdV3)
34+
35+
issuerPrefixPostfixBytes :: V3.Credential -> (BS.ByteString, BS.ByteString)
36+
issuerPrefixPostfixBytes progLogicCred =
37+
let
38+
dummyHex = BSC.pack "deadbeefcafebabe" -- Use ByteString for the dummy hex
39+
placeholderMintingLogic = V3.ScriptHash $ stringToBuiltinByteStringHex "deadbeefcafebabe"
40+
issuerScriptBase =
41+
case compile NoTracing (mkProgrammableLogicMinting # pconstant progLogicCred) of
42+
Right compiledScript -> compiledScript
43+
Left err -> error $ "Failed to compile issuer script: " <> show err
44+
dummyIssuerInstanceCborHex = SBS.fromShort . serialiseUPLC . unScript $ applyArguments issuerScriptBase [toData placeholderMintingLogic]
45+
in breakCborHexBS dummyHex dummyIssuerInstanceCborHex
46+
47+
breakCborHexBS :: BS.ByteString -> BS.ByteString -> (BS.ByteString, BS.ByteString)
48+
breakCborHexBS toSplitOn cborHex =
49+
case BSC.breakSubstring toSplitOn cborHex of
50+
(before, after)
51+
| not (BS.null after) -> (before, BS.drop (BS.length toSplitOn) after)
52+
| otherwise -> error $ "breakCborHexBS: Failed to split on " <> show toSplitOn <> " in " <> show cborHex
53+
54+
issuanceCborHexTokenC :: C.AssetName
55+
issuanceCborHexTokenC = unTransAssetName issuanceCborHexToken
56+
57+
{-| Mint the issuance cbor hex NFT and place it in the output locked by 'alwaysFailsScript'
58+
-}
59+
mintIssuanceCborHexNFT :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBuildTx era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBlockchain era m) => m ()
60+
mintIssuanceCborHexNFT = Utils.inBabbage @era $ do
61+
txIn <- asks (Env.issuanceCborHexTxIn . Env.dsScriptRoot . Env.directoryEnv)
62+
netId <- queryNetworkId
63+
dir@DirectoryEnv{dsProtocolParamsMintingScript, dsProtocolParamsSpendingScript} <- asks Env.directoryEnv
64+
let ProgrammableLogicGlobalParams {progLogicCred} = globalParams dir
65+
(toBuiltin -> prefixCborHex, toBuiltin -> postfixCborHex) = issuerPrefixPostfixBytes progLogicCred
66+
issuanceCborHexDatum = IssuanceCborHex prefixCborHex postfixCborHex
67+
68+
let policyId = scriptPolicyIdV3 dsProtocolParamsMintingScript
69+
70+
val = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra
71+
$ fromList [(C.AssetId policyId issuanceCborHexTokenC, 1)]
72+
73+
addr =
74+
C.makeShelleyAddressInEra
75+
C.shelleyBasedEra
76+
netId
77+
(C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 dsProtocolParamsSpendingScript)
78+
C.NoStakeAddress
79+
80+
-- prefix and postfix bytes of issuance script.
81+
dat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData issuanceCborHexDatum
82+
83+
output :: C.TxOut C.CtxTx era
84+
output = C.TxOut addr val dat C.ReferenceScriptNone
85+
86+
spendPublicKeyOutput txIn
87+
mintPlutus dsProtocolParamsMintingScript () issuanceCborHexTokenC 1
88+
prependTxOut output
89+
90+
getCborHexInline :: C.InAnyCardanoEra (C.TxOut C.CtxTx) -> Maybe ProgrammableLogicGlobalParams
91+
getCborHexInline (C.InAnyCardanoEra _ (C.TxOut _ _ dat _)) =
92+
case dat of
93+
C.TxOutDatumInline _era (fromHashableScriptData -> Just d) -> Just d
94+
_ -> Nothing

‎src/regulated-stablecoin/lib/Wst/Offchain/Endpoints/Deployment.hs‎

Lines changed: 24 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ module Wst.Offchain.Endpoints.Deployment(
1212
insertBlacklistNodeTx,
1313
removeBlacklistNodeTx,
1414
seizeCredentialAssetsTx,
15+
deployIssuanceCborHex,
1516
) where
1617

1718
import Cardano.Api (Quantity)
@@ -32,6 +33,7 @@ import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (inaNewKey))
3233
import Wst.Offchain.BuildTx.DirectorySet qualified as BuildTx
3334
import Wst.Offchain.BuildTx.Failing (BlacklistedTransferPolicy,
3435
balanceTxEnvFailing)
36+
import Wst.Offchain.BuildTx.IssuanceCborHexRef qualified as BuildTx
3537
import Wst.Offchain.BuildTx.ProgrammableLogic qualified as BuildTx
3638
import Wst.Offchain.BuildTx.ProtocolParams qualified as BuildTx
3739
import Wst.Offchain.BuildTx.TransferLogic (BlacklistReason)
@@ -46,11 +48,11 @@ transaction and the 'TxIn' that was selected for the one-shot NFTs.
4648
-}
4749
deployTx :: (MonadReader env m, Env.HasOperatorEnv era env, MonadBlockchain era m, MonadError (AppError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era) => ScriptTarget -> m (C.Tx era, DirectoryScriptRoot)
4850
deployTx target = do
49-
(txi, _) <- Env.selectOperatorOutput
51+
((txi, _), (issuanceCborHexTxIn, _)) <- Env.selectTwoOperatorOutputs
5052
opEnv <- asks Env.operatorEnv
51-
let root = DirectoryScriptRoot txi target
53+
let root = DirectoryScriptRoot txi issuanceCborHexTxIn target
5254
(tx, _) <- Env.withEnv $ Env.withOperator opEnv $ Env.withDirectoryFor root
53-
$ Env.balanceTxEnv_
55+
$ Env.balanceDeployTxEnv_
5456
$ BuildTx.mintProtocolParams
5557
>> BuildTx.initDirectorySet
5658
>> BuildTx.registerProgrammableGlobalScript
@@ -62,11 +64,11 @@ transaction and the 'TxIn' that was selected for the one-shot NFTs.
6264
-}
6365
deployFullTx :: (MonadReader env m, Env.HasOperatorEnv era env, MonadBlockchain era m, MonadError (AppError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era) => ScriptTarget -> m (C.Tx era, DirectoryScriptRoot)
6466
deployFullTx target = do
65-
(txi, _) <- Env.selectOperatorOutput
67+
((txi, _), (issuanceCborHexTxIn, _)) <- Env.selectTwoOperatorOutputs
6668
opEnv <- asks Env.operatorEnv
67-
let root = DirectoryScriptRoot txi target
69+
let root = DirectoryScriptRoot txi issuanceCborHexTxIn target
6870
(tx, _) <- Env.withEnv $ Env.withOperator opEnv $ Env.withDirectoryFor root $ Env.withTransferFromOperator
69-
$ Env.balanceTxEnv_
71+
$ Env.balanceDeployTxEnv_
7072
$ BuildTx.mintProtocolParams
7173
>> BuildTx.initDirectorySet
7274
>> BuildTx.initBlacklist
@@ -75,6 +77,22 @@ deployFullTx target = do
7577

7678
pure (Convex.CoinSelection.signBalancedTxBody [] tx, root)
7779

80+
deployIssuanceCborHex :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasDirectoryEnv env, MonadBlockchain era m, MonadError (AppError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era) => m (C.Tx era)
81+
deployIssuanceCborHex = do
82+
opEnv <- asks Env.operatorEnv
83+
dirEnv <- asks Env.directoryEnv
84+
(tx, _) <- Env.withEnv $ Env.withOperator opEnv $ Env.withDirectory dirEnv $ Env.withTransferFromOperator
85+
$ Env.balanceTxEnv_ BuildTx.mintIssuanceCborHexNFT
86+
pure (Convex.CoinSelection.signBalancedTxBody [] tx)
87+
-- let root = DirectoryScriptRoot txi issuanceCborHexTxIn target
88+
-- (tx, _) <- Env.withEnv $ Env.withOperator opEnv $ Env.withDirectoryFor root
89+
-- $ Env.balanceDeployTxEnv_
90+
-- $ BuildTx.mintProtocolParams
91+
-- >> BuildTx.initDirectorySet
92+
-- >> BuildTx.registerProgrammableGlobalScript
93+
-- >> BuildTx.mintIssuanceCborHexNFT
94+
-- pure (Convex.CoinSelection.signBalancedTxBody [] tx, root)
95+
7896
{-| Build a transaction that inserts a node into the directory
7997
-}
8098
insertNodeTx :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasDirectoryEnv env, MonadBlockchain era m, MonadError (AppError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadUtxoQuery m) => InsertNodeArgs -> m (C.Tx era)

0 commit comments

Comments
 (0)