Skip to content

Commit afd27f3

Browse files
bladyjokerbladyjoker
committed
Scafolded the Consumer example
1 parent cf3b945 commit afd27f3

File tree

6 files changed

+114
-7
lines changed

6 files changed

+114
-7
lines changed

‎coop-plutus/coop-plutus.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -130,6 +130,7 @@ test-suite coop-plutus-tests
130130

131131
build-depends:
132132
, base
133+
, bytestring
133134
, containers
134135
, coop-hs-types
135136
, coop-plutus
@@ -139,4 +140,5 @@ test-suite coop-plutus-tests
139140
, plutus-ledger-api
140141
, plutus-tx
141142
, QuickCheck
143+
, serialise
142144
, text

‎coop-plutus/resources/sample.json‎

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
{
2+
"array": [
3+
1,
4+
2,
5+
3
6+
],
7+
"boolean": true,
8+
"null": null,
9+
"integer": 123,
10+
"big_integer": 12300000000000000000000000,
11+
"real": 123.123,
12+
"big_real": 12300000000000000000000000.123,
13+
"object": {
14+
"a": "b",
15+
"c": "d"
16+
},
17+
"string": "Hello World"
18+
}

‎coop-plutus/resources/sample.pd.cbor‎

149 Bytes
Binary file not shown.

‎coop-plutus/src/Coop/Plutus.hs‎

Lines changed: 42 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ module Coop.Plutus (
88
certV,
99
mkCertMp,
1010
pmustSpendAtLeastAa,
11+
exampleConsumer,
1112
) where
1213

1314
import Coop.Plutus.Aux (pcurrencyTokenQuantity, pcurrencyValue, pdatumFromTxOut, pdjust, pdnothing, pfindMap, pfoldTxInputs, pfoldTxOutputs, pfoldTxRefs, phasCurrency, pmaybeData, pmustBeSignedBy, pmustBurnOwnSingletonValue, pmustMintCurrency, pmustPayCurrencyWithDatumTo, pmustSpendAtLeast, pmustValidateAfter, pownCurrencySymbol, ptryFromData, punit)
@@ -34,7 +35,7 @@ import Plutarch.Crypto (pblake2b_256)
3435
import Plutarch.Extra.Interval (pcontains)
3536
import Plutarch.Monadic qualified as P
3637
import Plutarch.Num (PNum (pnegate, (#+)))
37-
import Plutarch.Prelude (ClosedTerm, PAsData, PBuiltinList, PByteString, PEq ((#==)), PInteger, PListLike (pcons, pnil), PPair (PPair), PPartialOrd ((#<), (#<=)), Term, pcon, pconsBS, pfield, pfoldl, pfromData, phoistAcyclic, plam, plet, pletFields, ptrace, ptraceError, (#), (#$), type (:-->))
38+
import Plutarch.Prelude (ClosedTerm, PAsData, PBuiltinList, PByteString, PEq ((#==)), PInteger, PListLike (pcons, phead, pnil), PPair (PPair), PPartialOrd ((#<), (#<=)), Term, pcon, pconsBS, pfield, pfoldl, pfromData, phoistAcyclic, plam, plet, pletFields, ptrace, ptraceError, (#), (#$), type (:-->))
3839
import PlutusTx.Prelude (Group (inv))
3940
import Prelude (Monoid (mempty), Semigroup ((<>)), ($))
4041

@@ -598,3 +599,43 @@ pmustSpendAtLeastAa = phoistAcyclic $
598599
(atLeastAaQ #<= aaTokensSpent)
599600
(ptrace "pmustSpendAtLeastAa: Spent at least the specified amount of AA tokens" $ pblake2b_256 # tnBytes)
600601
(ptraceError "pmustSpendAtLeastAa: Must spend at least the specified amount of AA tokens")
602+
603+
exampleConsumer :: ClosedTerm (PCurrencySymbol :--> PValidator)
604+
exampleConsumer = phoistAcyclic $
605+
plam $ \trustedCs _ _ ctx -> ptrace "exampleConsumer" P.do
606+
ctx' <- pletFields @'["txInfo"] ctx
607+
txInfo <- pletFields @'["referenceInputs"] ctx'.txInfo
608+
609+
ptrace "exampleConsumer: Looking for a Fact Statement reference input from a trusted COOP Oracle"
610+
refInput <- pletFields @'["resolved"] $ phead # pfromData txInfo.referenceInputs
611+
refInVal <- plet $ pfield @"value" # refInput.resolved
612+
613+
ptrace "exampleConsumer: Looking for a Fact Statement reference input from a trusted COOP Oracle"
614+
pif
615+
(phasCurrency # trustedCs # refInVal)
616+
( ptrace
617+
"exampleConsumer: Found an authentic Fact Statement reference input from a trusted COOP Oracle"
618+
P.do
619+
fsDatum <- pletFields @'["fd'fs", "fd'submitter", "fd'gcAfter", "fd'fsId"] $ pdatumFromTxOut @PFsDatum # ctx # refInput.resolved
620+
fs <- plet $ pfromData $ fsDatum.fd'fs
621+
ptrace "FsMpBurn: Valid FsDatum attached"
622+
623+
ptrace "exampleConsumer: Must have a Fact Statement reference input from a trusted COOP Oracle" $ popaque punit
624+
)
625+
(ptraceError "exampleConsumer: Must have a Fact Statement reference input from a trusted COOP Oracle")
626+
627+
-- -- | Parses a datum from a TxOut or fails hard
628+
-- pdatumFromTxOut :: forall a (s :: S). (PIsData a, PTryFrom PData (PAsData a)) => Term s (PScriptContext :--> PTxOut :--> a)
629+
-- pdatumFromTxOut = phoistAcyclic $
630+
-- plam $ \ctx txOut -> ptrace "pdatumFromTxOut" P.do
631+
-- datum <- plet $ pmatch (pfield @"datum" # txOut) \case
632+
-- PNoOutputDatum _ -> ptraceError "pDatumFromTxOut: Must have a datum present in the output"
633+
-- POutputDatumHash r -> ptrace "pDatumFromTxOut: Got a datum hash" P.do
634+
-- ctx' <- pletFields @'["txInfo"] ctx
635+
-- txInfo <- pletFields @'["datums"] ctx'.txInfo
636+
-- pmatch (plookup # pfromData (pfield @"datumHash" # r) # txInfo.datums) \case
637+
-- PNothing -> ptraceError "pDatumFromTxOut: Datum with a given hash must be present in the transaction datums"
638+
-- PJust datum -> ptrace "pDatumFromTxOut: Found a datum" datum
639+
-- POutputDatum r -> ptrace "pDatumFromTxOut: Got an inline datum" $ pfield @"outputDatum" # r
640+
641+
-- pfromData (ptryFromData @a (pto datum))

‎coop-plutus/test/Coop/Plutus/Test.hs‎

Lines changed: 27 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,26 +1,30 @@
11
module Coop.Plutus.Test (spec) where
22

33
import Plutarch.Prelude (ClosedTerm, PBool (PTrue), PEq ((#==)), pconstant, pconstantData, (#))
4-
import Test.Hspec (Expectation, Spec, describe, shouldBe)
4+
import Test.Hspec (Expectation, Spec, describe, runIO, shouldBe)
55
import Test.Hspec.QuickCheck (prop)
66
import Test.QuickCheck (NonEmptyList (getNonEmpty), Positive (getPositive), choose, forAll, generate)
77

8-
import Coop.Plutus (certV, fsV, mkAuthMp, mkCertMp, mkFsMp, pmustSpendAtLeastAa)
8+
import Codec.Serialise (deserialiseOrFail)
9+
import Coop.Plutus (certV, exampleConsumer, fsV, mkAuthMp, mkCertMp, mkFsMp, pmustSpendAtLeastAa)
910
import Coop.Plutus.Aux (hashTxInputs, pmustBurnOwnSingletonValue)
10-
import Coop.Plutus.Test.Generators (distribute, genAaInputs, genCertRdmrAc, genCorrectAuthMpBurningCtx, genCorrectAuthMpMintingCtx, genCorrectCertMpBurningCtx, genCorrectCertMpMintingCtx, genCorrectCertVSpendingCtx, genCorrectFsMpBurningCtx, genCorrectFsMpMintingCtx, genCorrectFsVSpendingCtx, genCorrectMustBurnOwnSingletonValueCtx, genCorruptAuthMpBurningCtx, genCorruptAuthMpMintingCtx, genCorruptCertMpBurningCtx, genCorruptCertMpMintingCtx, genCorruptCertVSpendingCtx, genCorruptFsMpBurningCtx, genCorruptFsMpMintingCtx, genCorruptFsVSpendingCtx, genCorruptMustBurnOwnSingletonValueCtx, mkScriptContext)
11+
import Coop.Plutus.Test.Generators (distribute, genAaInputs, genCertRdmrAc, genCorrectAuthMpBurningCtx, genCorrectAuthMpMintingCtx, genCorrectCertMpBurningCtx, genCorrectCertMpMintingCtx, genCorrectCertVSpendingCtx, genCorrectConsumerCtx, genCorrectFsMpBurningCtx, genCorrectFsMpMintingCtx, genCorrectFsVSpendingCtx, genCorrectMustBurnOwnSingletonValueCtx, genCorruptAuthMpBurningCtx, genCorruptAuthMpMintingCtx, genCorruptCertMpBurningCtx, genCorruptCertMpMintingCtx, genCorruptCertVSpendingCtx, genCorruptFsMpBurningCtx, genCorruptFsMpMintingCtx, genCorruptFsVSpendingCtx, genCorruptMustBurnOwnSingletonValueCtx, mkScriptContext)
1112
import Coop.Plutus.Types (PAuthMpParams, PCertMpParams, PFsMpParams)
1213
import Coop.Types (AuthMpParams (AuthMpParams), AuthMpRedeemer (AuthMpBurn, AuthMpMint), AuthParams (AuthParams), CertMpParams (CertMpParams), CertMpRedeemer (CertMpBurn, CertMpMint), FsMpParams (FsMpParams), FsMpRedeemer (FsMpBurn, FsMpMint))
14+
import Data.ByteString.Lazy qualified as LB
1315
import Data.Foldable (Foldable (fold))
1416
import Data.Map qualified as Map
1517
import Data.Set qualified as Set
1618
import Data.Text (Text, unpack)
1719
import Plutarch (Config (Config, tracingMode), TracingMode (DetTracing), compile, pcon, printScript)
20+
import Plutarch.Api.V1 (PCurrencySymbol)
1821
import Plutarch.Builtin (PIsData (pdataImpl))
1922
import Plutarch.Evaluate (evalScript)
2023
import Plutarch.Test (pfails, psucceeds)
2124
import PlutusLedgerApi.V1.Address (scriptHashAddress)
2225
import PlutusLedgerApi.V1.Value (AssetClass, TokenName (TokenName), assetClass, currencySymbol)
23-
import PlutusLedgerApi.V2 (Address, CurrencySymbol, Script, ScriptPurpose (Minting), ValidatorHash (ValidatorHash), toData)
26+
import PlutusLedgerApi.V2 (Address, CurrencySymbol, Script, ScriptPurpose (Minting), ValidatorHash (ValidatorHash), dataToBuiltinData, toData)
27+
import PlutusTx (Data)
2428
import PlutusTx.Builtins.Class (stringToBuiltinByteString)
2529

2630
coopAc :: AssetClass
@@ -265,6 +269,19 @@ spec = do
265269
# pconstant (toData ())
266270
# pconstant ctx
267271
)
272+
describe "@Consumer" $ do
273+
samplePd <- runIO $ readPlutusDataCbor "resources/sample.pd.cbor"
274+
describe "should-succeed" $ do
275+
prop "reference a fact statement" $
276+
forAll (genCorrectConsumerCtx fsCs (dataToBuiltinData samplePd)) $
277+
\ctx ->
278+
psucceeds
279+
( exampleConsumer
280+
# pconstant @PCurrencySymbol fsCs
281+
# pconstant (toData ())
282+
# pconstant (toData ())
283+
# pconstant ctx
284+
)
268285

269286
_plog :: ClosedTerm a -> Expectation
270287
_plog p = _ptraces' p id []
@@ -298,3 +315,9 @@ pshouldBe x y = do
298315
pscriptShouldBe :: Script -> Script -> Expectation
299316
pscriptShouldBe x y =
300317
printScript x `shouldBe` printScript y
318+
319+
readPlutusDataCbor :: FilePath -> IO Data
320+
readPlutusDataCbor fname = do
321+
cborBytes <- LB.readFile fname
322+
let errOrDecoded = deserialiseOrFail @Data cborBytes
323+
either (\err -> error $ "File " <> fname <> " can't be parsed into PlutusData CBOR: " <> show err) return errOrDecoded

‎coop-plutus/test/Coop/Plutus/Test/Generators.hs‎

Lines changed: 25 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
module Coop.Plutus.Test.Generators (mkScriptContext, mkTxInfo, genCertRdmrAc, distribute, genCorruptCertMpMintingCtx, genAaInputs, genCorrectCertMpMintingCtx, genCorrectAuthMpMintingCtx, genCorruptAuthMpMintingCtx, genCorrectCertMpBurningCtx, genCorruptCertMpBurningCtx, normalizeValue, genCorrectAuthMpBurningCtx, genCorruptAuthMpBurningCtx, genCorrectCertVSpendingCtx, genCorruptCertVSpendingCtx, genCorrectMustBurnOwnSingletonValueCtx, genCorruptMustBurnOwnSingletonValueCtx, genCorrectFsMpMintingCtx, genCorruptFsMpMintingCtx, genCorrectFsMpBurningCtx, genCorruptFsMpBurningCtx, genCorrectFsVSpendingCtx, genCorruptFsVSpendingCtx) where
1+
module Coop.Plutus.Test.Generators (mkScriptContext, mkTxInfo, genCertRdmrAc, distribute, genCorruptCertMpMintingCtx, genAaInputs, genCorrectCertMpMintingCtx, genCorrectAuthMpMintingCtx, genCorruptAuthMpMintingCtx, genCorrectCertMpBurningCtx, genCorruptCertMpBurningCtx, normalizeValue, genCorrectAuthMpBurningCtx, genCorruptAuthMpBurningCtx, genCorrectCertVSpendingCtx, genCorruptCertVSpendingCtx, genCorrectMustBurnOwnSingletonValueCtx, genCorruptMustBurnOwnSingletonValueCtx, genCorrectFsMpMintingCtx, genCorruptFsMpMintingCtx, genCorrectFsMpBurningCtx, genCorruptFsMpBurningCtx, genCorrectFsVSpendingCtx, genCorruptFsVSpendingCtx, genCorrectConsumerCtx) where
22

33
import Test.QuickCheck (Arbitrary (arbitrary), Gen, choose, chooseAny, chooseEnum, chooseInt, chooseInteger, sublistOf, suchThat, vectorOf)
44

@@ -17,7 +17,7 @@ import PlutusLedgerApi.V2 (Address, BuiltinByteString, Datum (Datum), Extended (
1717
import PlutusTx.AssocMap qualified as AssocMap
1818
import PlutusTx.Builtins.Class (stringToBuiltinByteString)
1919

20-
import Coop.Types (AuthMpParams (amp'authAuthorityAc, amp'requiredAtLeastAaQ), AuthParams (ap'authTokenCs, ap'certTokenCs), CertDatum (CertDatum), CertMpParams (cmp'authAuthorityAc, cmp'certVAddress, cmp'requiredAtLeastAaQ), FsDatum (FsDatum, fs'gcAfter, fs'submitter), FsMpParams (fmp'authParams, fmp'fsVAddress))
20+
import Coop.Types (AuthMpParams (amp'authAuthorityAc, amp'requiredAtLeastAaQ), AuthParams (ap'authTokenCs, ap'certTokenCs), CertDatum (CertDatum), CertMpParams (cmp'authAuthorityAc, cmp'certVAddress, cmp'requiredAtLeastAaQ), FactStatement, FsDatum (FsDatum, fs'gcAfter, fs'submitter), FsMpParams (fmp'authParams, fmp'fsVAddress))
2121
import PlutusLedgerApi.V1.Interval (interval)
2222
import PlutusLedgerApi.V2 qualified as Value
2323
import PlutusTx.Prelude (Group (inv))
@@ -464,6 +464,29 @@ genCorruptFsVSpendingCtx = do
464464

465465
return $ corrupt ctx
466466

467+
genFsRefInput :: CurrencySymbol -> FactStatement -> Gen TxInInfo
468+
genFsRefInput fsCs fs = do
469+
addr <- genAddress
470+
fsTn <- genTokenName
471+
fsId <- genBuiltinByteString "fsid" 5
472+
submitter <- genPubKeyHash
473+
return $
474+
TxInInfo
475+
(TxOutRef (TxId fsId) 0)
476+
( TxOut
477+
addr
478+
(Value.singleton fsCs fsTn 1)
479+
(toOutputDatum $ FsDatum fs (LedgerBytes fsId) PosInf submitter)
480+
Nothing
481+
)
482+
483+
genCorrectConsumerCtx :: CurrencySymbol -> FactStatement -> Gen ScriptContext
484+
genCorrectConsumerCtx fsCs fs = do
485+
spendingIn <- genInput
486+
fsRefIn <- genFsRefInput fsCs fs
487+
488+
return $ mkScriptContext (Spending (txInInfoOutRef spendingIn)) [spendingIn] [fsRefIn] mempty [] []
489+
467490
genInput :: Gen TxInInfo
468491
genInput = (\outRef val addr -> TxInInfo outRef (TxOut addr val NoOutputDatum Nothing)) <$> genTxOutRef <*> genSingletonValue <*> genAddress
469492

0 commit comments

Comments
 (0)