Sulkta-OSS/agora
3
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity Actions

add shared Sample values module

Browse source 
- add Proposal validator testing
- add some Agora.Record improvements
This commit is contained in:
Emily Martins 2022-04-20 16:39:03 +02:00
parent 1e972f1402
commit 4ea9255a6b
11 changed files with 367 additions and 270 deletions
Download patch file Download diff file Expand all files Collapse all files

57
agora-test/Spec/Proposal.hs
View file

@ -11,8 +11,6 @@ module Spec.Proposal (tests) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
--------------------------------------------------------------------------------
import Agora.Proposal ( import Agora.Proposal (
ProposalDatum (ProposalDatum), ProposalDatum (ProposalDatum),
ProposalId (ProposalId), ProposalId (ProposalId),
@ -29,9 +27,13 @@ import Agora.Proposal (
thresholds, thresholds,
votes, votes,
) )
import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (WitnessStake), stakeValidator)
import Plutarch.SafeMoney (Tagged (Tagged))
import Plutus.V1.Ledger.Api (ScriptContext (..), ScriptPurpose (..))
import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.AssocMap qualified as AssocMap
import Spec.Sample.Proposal (propThresholds, signer, signer2)
import Spec.Sample.Proposal qualified as Proposal import Spec.Sample.Proposal qualified as Proposal
import Spec.Sample.Shared (signer, signer2)
import Spec.Sample.Shared qualified as Shared
import Spec.Util (policySucceedsWith, validatorSucceedsWith) import Spec.Util (policySucceedsWith, validatorSucceedsWith)
import Test.Tasty (TestTree, testGroup) import Test.Tasty (TestTree, testGroup)
@ -47,30 +49,39 @@ tests =
[ testGroup [ testGroup
"policy" "policy"
[ policySucceedsWith [ policySucceedsWith
"stakeCreation" "proposalCreation"
(proposalPolicy Proposal.proposal) (proposalPolicy Shared.proposal)
() ()
Proposal.proposalCreation Proposal.proposalCreation
] ]
, testGroup , testGroup
"validator" "validator"
[ validatorSucceedsWith [ testGroup
"stakeCreation" "cosignature"
(proposalValidator Proposal.proposal) [ validatorSucceedsWith
( ProposalDatum "proposal"
{ proposalId = ProposalId 0 (proposalValidator Shared.proposal)
, effects = ( ProposalDatum
AssocMap.fromList { proposalId = ProposalId 0
[ (ResultTag 0, []) , effects =
, (ResultTag 1, []) AssocMap.fromList
] [ (ResultTag 0, [])
, status = Draft , (ResultTag 1, [])
, cosigners = [signer] ]
, thresholds = propThresholds , status = Draft
, votes = ProposalVotes AssocMap.empty , cosigners = [signer]
} , thresholds = Shared.defaultProposalThresholds
) , votes = ProposalVotes AssocMap.empty
(Cosign [signer2]) }
(Proposal.cosignProposal [signer2]) )
(Cosign [signer2])
(ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.proposalRef))
, validatorSucceedsWith
"stake"
(stakeValidator Shared.stake)
(StakeDatum (Tagged 50_000_000) signer2 [])
WitnessStake
(ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.stakeRef))
]
] ]
] ]

218
agora-test/Spec/Sample/Proposal.hs
View file

@ -6,31 +6,21 @@ Description: Sample based testing for Proposal utxos
This module tests primarily the happy path for Proposal interactions This module tests primarily the happy path for Proposal interactions
-} -}
module Spec.Sample.Proposal ( module Spec.Sample.Proposal (
proposal,
propPolicy,
propPolicySymbol,
propThresholds,
signer,
signer2,
-- * Script contexts -- * Script contexts
proposalCreation, proposalCreation,
cosignProposal, cosignProposal,
proposalRef,
stakeRef,
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
mintingPolicySymbol,
mkMintingPolicy,
mkValidator,
validatorHash, validatorHash,
) )
import Plutus.V1.Ledger.Api ( import Plutus.V1.Ledger.Api (
Address (Address), Address (Address),
Credential (ScriptCredential), Credential (ScriptCredential),
CurrencySymbol,
Datum (Datum), Datum (Datum),
MintingPolicy (..),
PubKeyHash, PubKeyHash,
ScriptContext (..), ScriptContext (..),
ScriptPurpose (..), ScriptPurpose (..),
@ -41,105 +31,33 @@ import Plutus.V1.Ledger.Api (
TxOutRef (TxOutRef), TxOutRef (TxOutRef),
) )
import Plutus.V1.Ledger.Interval qualified as Interval import Plutus.V1.Ledger.Interval qualified as Interval
import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash)
import Plutus.V1.Ledger.Value qualified as Value import Plutus.V1.Ledger.Value qualified as Value
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Agora.Governor ( import Agora.Governor (
Governor (Governor),
GovernorDatum (GovernorDatum, nextProposalId, proposalThresholds), GovernorDatum (GovernorDatum, nextProposalId, proposalThresholds),
governorPolicy,
governorValidator,
) )
import Agora.Proposal ( import Agora.Proposal (
Proposal (..), Proposal (..),
ProposalDatum (..), ProposalDatum (..),
ProposalId (..), ProposalId (..),
ProposalStatus (..), ProposalStatus (..),
ProposalThresholds (..),
ProposalVotes (..), ProposalVotes (..),
ResultTag (..), ResultTag (..),
proposalPolicy,
proposalValidator,
) )
import Agora.Stake (Stake (..), stakePolicy) import Agora.Stake (Stake (..), StakeDatum (StakeDatum))
import Plutarch.SafeMoney import Plutarch.SafeMoney (Tagged (Tagged), untag)
import Plutus.V1.Ledger.Address (scriptHashAddress)
import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.AssocMap qualified as AssocMap
import Spec.Sample.Shared
import Spec.Util (datumPair, toDatumHash) import Spec.Util (datumPair, toDatumHash)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
stake :: Stake
stake =
Stake
{ gtClassRef = Tagged $ Value.assetClass govSymbol ""
, proposalSTClass = Value.assetClass propPolicySymbol ""
}
stakeSymbol :: CurrencySymbol
stakeSymbol = mintingPolicySymbol $ mkMintingPolicy $ stakePolicy stake.gtClassRef
governor :: Governor
governor = Governor
govPolicy :: MintingPolicy
govPolicy = mkMintingPolicy (governorPolicy governor)
govValidator :: Validator
govValidator = mkValidator (governorValidator governor)
govSymbol :: CurrencySymbol
govSymbol = mintingPolicySymbol govPolicy
proposal :: Proposal
proposal =
Proposal
{ governorSTAssetClass =
-- TODO: if we had a governor here
Value.assetClass govSymbol ""
, stakeSTAssetClass =
Value.assetClass stakeSymbol ""
}
-- | 'Proposal' policy instance.
propPolicy :: MintingPolicy
propPolicy = mkMintingPolicy (proposalPolicy proposal)
propPolicySymbol :: CurrencySymbol
propPolicySymbol = mintingPolicySymbol propPolicy
-- | A sample 'PubKeyHash'.
signer :: PubKeyHash
signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
-- | Another sample 'PubKeyHash'.
signer2 :: PubKeyHash
signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
-- | 'Proposal' validator instance.
propValidator :: Validator
propValidator = mkValidator (proposalValidator proposal)
propValidatorHash :: ValidatorHash
propValidatorHash = validatorHash propValidator
propValidatorAddress :: Address
propValidatorAddress = scriptHashAddress propValidatorHash
propThresholds :: ProposalThresholds
propThresholds =
ProposalThresholds
{ countVoting = Tagged 1000
, create = Tagged 1
, vote = Tagged 10
}
-- | This script context should be a valid transaction. -- | This script context should be a valid transaction.
proposalCreation :: ScriptContext proposalCreation :: ScriptContext
proposalCreation = proposalCreation =
let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
proposalDatum :: Datum proposalDatum :: Datum
proposalDatum = proposalDatum =
Datum Datum
@ -153,7 +71,7 @@ proposalCreation =
] ]
, status = Draft , status = Draft
, cosigners = [signer] , cosigners = [signer]
, thresholds = propThresholds , thresholds = defaultProposalThresholds
, votes = ProposalVotes AssocMap.empty , votes = ProposalVotes AssocMap.empty
} }
) )
@ -163,7 +81,7 @@ proposalCreation =
Datum Datum
( toBuiltinData $ ( toBuiltinData $
GovernorDatum GovernorDatum
{ proposalThresholds = propThresholds { proposalThresholds = defaultProposalThresholds
, nextProposalId = ProposalId 0 , nextProposalId = ProposalId 0
} }
) )
@ -172,7 +90,7 @@ proposalCreation =
Datum Datum
( toBuiltinData $ ( toBuiltinData $
GovernorDatum GovernorDatum
{ proposalThresholds = propThresholds { proposalThresholds = defaultProposalThresholds
, nextProposalId = ProposalId 1 , nextProposalId = ProposalId 1
} }
) )
@ -190,7 +108,7 @@ proposalCreation =
] ]
, txInfoOutputs = , txInfoOutputs =
[ TxOut [ TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing { txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing
, txOutValue = , txOutValue =
mconcat mconcat
[ st [ st
@ -221,13 +139,19 @@ proposalCreation =
] ]
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
} }
, scriptContextPurpose = Minting propPolicySymbol , scriptContextPurpose = Minting proposalPolicySymbol
} }
proposalRef :: TxOutRef
proposalRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1
stakeRef :: TxOutRef
stakeRef = TxOutRef "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15" 0
-- | This script context should be a valid transaction. -- | This script context should be a valid transaction.
cosignProposal :: [PubKeyHash] -> ScriptContext cosignProposal :: [PubKeyHash] -> TxInfo
cosignProposal newSigners = cosignProposal newSigners =
let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
proposalBefore :: ProposalDatum proposalBefore :: ProposalDatum
proposalBefore = proposalBefore =
ProposalDatum ProposalDatum
@ -239,50 +163,70 @@ cosignProposal newSigners =
] ]
, status = Draft , status = Draft
, cosigners = [signer] , cosigners = [signer]
, thresholds = propThresholds , thresholds = defaultProposalThresholds
, votes = ProposalVotes AssocMap.empty , votes = ProposalVotes AssocMap.empty
} }
stakeDatum :: StakeDatum
stakeDatum = StakeDatum (Tagged 50_000_000) signer2 []
proposalAfter :: ProposalDatum proposalAfter :: ProposalDatum
proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners} proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners}
proposalRef = (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) in TxInfo
in ScriptContext { txInfoInputs =
{ scriptContextTxInfo = [ TxInInfo
TxInfo proposalRef
{ txInfoInputs = TxOut
[ TxInInfo { txOutAddress = proposalValidatorAddress
proposalRef , txOutValue =
TxOut mconcat
{ txOutAddress = propValidatorAddress [ st
, txOutValue = , Value.singleton "" "" 10_000_000
mconcat ]
[ st , txOutDatumHash = Just (toDatumHash proposalBefore)
, Value.singleton "" "" 10_000_000 }
] , TxInInfo
, txOutDatumHash = Just (toDatumHash proposalBefore) stakeRef
} TxOut
] { txOutAddress = stakeAddress
, txInfoOutputs = , txOutValue =
[ TxOut mconcat
{ txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing [ Value.singleton "" "" 10_000_000
, txOutValue = , Value.assetClassValue (untag stake.gtClassRef) 50_000_000
mconcat , Value.singleton stakeSymbol "" 1
[ st ]
, Value.singleton "" "" 10_000_000 , txOutDatumHash = Just (toDatumHash stakeDatum)
] }
, txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter) ]
} , txInfoOutputs =
] [ TxOut
, txInfoFee = Value.singleton "" "" 2 { txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing
, txInfoMint = st , txOutValue =
, txInfoDCert = [] mconcat
, txInfoWdrl = [] [ st
, txInfoValidRange = Interval.always , Value.singleton "" "" 10_000_000
, txInfoSignatories = newSigners ]
, txInfoData = , txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter)
[ datumPair . Datum $ toBuiltinData proposalBefore }
, datumPair . Datum $ toBuiltinData proposalAfter , TxOut
] { txOutAddress = stakeAddress
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" , txOutValue =
} mconcat
, scriptContextPurpose = Spending proposalRef [ Value.singleton "" "" 10_000_000
, Value.assetClassValue (untag stake.gtClassRef) 50_000_000
, Value.singleton stakeSymbol "" 1
]
, txOutDatumHash = Just (toDatumHash stakeDatum)
}
]
, txInfoFee = Value.singleton "" "" 2
, txInfoMint = st
, txInfoDCert = []
, txInfoWdrl = []
, txInfoValidRange = Interval.always
, txInfoSignatories = newSigners
, txInfoData =
[ datumPair . Datum $ toBuiltinData proposalBefore
, datumPair . Datum $ toBuiltinData proposalAfter
, datumPair . Datum $ toBuiltinData stakeDatum
]
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
} }

132
agora-test/Spec/Sample/Shared.hs Normal file
View file

@ -0,0 +1,132 @@
{- |
Module : Spec.Sample.Shared
Maintainer : emi@haskell.fyi
Description: Shared useful values for creating Samples for testing.
Shared useful values for creating Samples for testing.
-}
module Spec.Sample.Shared (
-- * Misc
signer,
signer2,
-- * Components
-- ** Stake
stake,
stakeSymbol,
stakeValidatorHash,
stakeAddress,
-- ** Governor
governor,
govPolicy,
govValidator,
govSymbol,
-- ** Proposal
defaultProposalThresholds,
proposal,
proposalPolicySymbol,
proposalValidatorHash,
proposalValidatorAddress,
) where
import Agora.Governor (
Governor (Governor),
governorPolicy,
governorValidator,
)
import Agora.Proposal (
Proposal (..),
ProposalThresholds (..),
proposalPolicy,
proposalValidator,
)
import Agora.Stake (Stake (..), stakePolicy, stakeValidator)
import Plutarch.Api.V1 (
mintingPolicySymbol,
mkMintingPolicy,
mkValidator,
validatorHash,
)
import Plutarch.SafeMoney
import Plutus.V1.Ledger.Address (scriptHashAddress)
import Plutus.V1.Ledger.Api (
Address (Address),
Credential (ScriptCredential),
CurrencySymbol,
MintingPolicy (..),
PubKeyHash,
)
import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash)
import Plutus.V1.Ledger.Value qualified as Value
--------------------------------------------------------------------------------
stake :: Stake
stake =
Stake
{ gtClassRef =
Tagged $
Value.assetClass
"da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
"LQ"
, proposalSTClass = Value.assetClass proposalPolicySymbol ""
}
stakeSymbol :: CurrencySymbol
stakeSymbol = mintingPolicySymbol $ mkMintingPolicy $ stakePolicy stake.gtClassRef
stakeValidatorHash :: ValidatorHash
stakeValidatorHash = validatorHash $ mkValidator (stakeValidator stake)
stakeAddress :: Address
stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing
governor :: Governor
governor = Governor
govPolicy :: MintingPolicy
govPolicy = mkMintingPolicy (governorPolicy governor)
govValidator :: Validator
govValidator = mkValidator (governorValidator governor)
govSymbol :: CurrencySymbol
govSymbol = mintingPolicySymbol govPolicy
proposal :: Proposal
proposal =
Proposal
{ governorSTAssetClass =
-- TODO: if we had a governor here
Value.assetClass govSymbol ""
, stakeSTAssetClass =
Value.assetClass stakeSymbol ""
}
proposalPolicySymbol :: CurrencySymbol
proposalPolicySymbol = mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal)
-- | A sample 'PubKeyHash'.
signer :: PubKeyHash
signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
-- | Another sample 'PubKeyHash'.
signer2 :: PubKeyHash
signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
proposalValidatorHash :: ValidatorHash
proposalValidatorHash = validatorHash (mkValidator $ proposalValidator proposal)
proposalValidatorAddress :: Address
proposalValidatorAddress = scriptHashAddress proposalValidatorHash
defaultProposalThresholds :: ProposalThresholds
defaultProposalThresholds =
ProposalThresholds
{ countVoting = Tagged 1000
, create = Tagged 1
, vote = Tagged 10
}

59
agora-test/Spec/Sample/Stake.hs
View file

@ -7,8 +7,7 @@ This module tests primarily the happy path for Stake creation
-} -}
module Spec.Sample.Stake ( module Spec.Sample.Stake (
stake, stake,
policy, stakeSymbol,
policySymbol,
validatorHashTN, validatorHashTN,
signer, signer,
@ -22,19 +21,14 @@ module Spec.Sample.Stake (
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
mintingPolicySymbol,
mkMintingPolicy,
mkValidator, mkValidator,
validatorHash, validatorHash,
) )
import Plutus.V1.Ledger.Api ( import Plutus.V1.Ledger.Api (
Address (Address), Address (Address),
Credential (ScriptCredential), Credential (ScriptCredential),
CurrencySymbol,
Datum (Datum), Datum (Datum),
DatumHash (DatumHash), DatumHash (DatumHash),
MintingPolicy (..),
PubKeyHash,
ScriptContext (..), ScriptContext (..),
ScriptPurpose (..), ScriptPurpose (..),
ToData (toBuiltinData), ToData (toBuiltinData),
@ -45,8 +39,7 @@ import Plutus.V1.Ledger.Api (
) )
import Plutus.V1.Ledger.Contexts (TxOut (TxOut), TxOutRef (TxOutRef)) import Plutus.V1.Ledger.Contexts (TxOut (TxOut), TxOutRef (TxOutRef))
import Plutus.V1.Ledger.Interval qualified as Interval import Plutus.V1.Ledger.Interval qualified as Interval
import Plutus.V1.Ledger.Scripts (Validator) import Plutus.V1.Ledger.Value (TokenName (TokenName))
import Plutus.V1.Ledger.Value (AssetClass (AssetClass), TokenName (TokenName))
import Plutus.V1.Ledger.Value qualified as Value import Plutus.V1.Ledger.Value qualified as Value
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -54,47 +47,19 @@ import Plutus.V1.Ledger.Value qualified as Value
import Agora.SafeMoney (GTTag) import Agora.SafeMoney (GTTag)
import Agora.Stake import Agora.Stake
import Plutarch.SafeMoney import Plutarch.SafeMoney
import Spec.Sample.Shared
import Spec.Util (datumPair, toDatumHash) import Spec.Util (datumPair, toDatumHash)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | 'Stake' parameters for 'LQ'.
stake :: Stake
stake =
Stake
{ gtClassRef =
Tagged
( AssetClass
( "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
, "LQ"
)
)
, proposalSTClass = AssetClass ("", "")
}
-- | 'Stake' policy instance.
policy :: MintingPolicy
policy = mkMintingPolicy (stakePolicy stake.gtClassRef)
policySymbol :: CurrencySymbol
policySymbol = mintingPolicySymbol policy
-- | A sample 'PubKeyHash'.
signer :: PubKeyHash
signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
-- | 'Stake' validator instance.
validator :: Validator
validator = mkValidator (stakeValidator stake)
-- | 'TokenName' that represents the hash of the 'Stake' validator. -- | 'TokenName' that represents the hash of the 'Stake' validator.
validatorHashTN :: TokenName validatorHashTN :: TokenName
validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh validatorHashTN = let ValidatorHash vh = validatorHash (mkValidator $ stakeValidator stake) in TokenName vh
-- | This script context should be a valid transaction. -- | This script context should be a valid transaction.
stakeCreation :: ScriptContext stakeCreation :: ScriptContext
stakeCreation = stakeCreation =
let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST
datum :: Datum datum :: Datum
datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer []) datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer [])
in ScriptContext in ScriptContext
@ -103,7 +68,7 @@ stakeCreation =
{ txInfoInputs = [] { txInfoInputs = []
, txInfoOutputs = , txInfoOutputs =
[ TxOut [ TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
, txOutValue = st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242 , txOutValue = st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242
, txOutDatumHash = Just (DatumHash "") , txOutDatumHash = Just (DatumHash "")
} }
@ -117,7 +82,7 @@ stakeCreation =
, txInfoData = [("", datum)] , txInfoData = [("", datum)]
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
} }
, scriptContextPurpose = Minting policySymbol , scriptContextPurpose = Minting stakeSymbol
} }
-- | This ScriptContext should fail because the datum has too much GT. -- | This ScriptContext should fail because the datum has too much GT.
@ -127,7 +92,7 @@ stakeCreationWrongDatum =
datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT
in ScriptContext in ScriptContext
{ scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]} { scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
, scriptContextPurpose = Minting policySymbol , scriptContextPurpose = Minting stakeSymbol
} }
-- | This ScriptContext should fail because the datum has too much GT. -- | This ScriptContext should fail because the datum has too much GT.
@ -138,7 +103,7 @@ stakeCreationUnsigned =
stakeCreation.scriptContextTxInfo stakeCreation.scriptContextTxInfo
{ txInfoSignatories = [] { txInfoSignatories = []
} }
, scriptContextPurpose = Minting policySymbol , scriptContextPurpose = Minting stakeSymbol
} }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -154,7 +119,7 @@ data DepositWithdrawExample = DepositWithdrawExample
-- | Create a ScriptContext that deposits or withdraws, given the config for it. -- | Create a ScriptContext that deposits or withdraws, given the config for it.
stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
stakeDepositWithdraw config = stakeDepositWithdraw config =
let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST
stakeBefore :: StakeDatum stakeBefore :: StakeDatum
stakeBefore = StakeDatum config.startAmount signer [] stakeBefore = StakeDatum config.startAmount signer []
@ -167,7 +132,7 @@ stakeDepositWithdraw config =
[ TxInInfo [ TxInInfo
(TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
TxOut TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
, txOutValue = , txOutValue =
st st
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount) <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)
@ -176,7 +141,7 @@ stakeDepositWithdraw config =
] ]
, txInfoOutputs = , txInfoOutputs =
[ TxOut [ TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
, txOutValue = , txOutValue =
st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount) st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
, txOutDatumHash = Just (toDatumHash stakeAfter) , txOutDatumHash = Just (toDatumHash stakeAfter)

9
agora-test/Spec/Util.hs
View file

@ -90,6 +90,7 @@ policyFailsWith tag policy redeemer scriptContext =
-- | Check that a validator script succeeds, given a name and arguments. -- | Check that a validator script succeeds, given a name and arguments.
validatorSucceedsWith :: validatorSucceedsWith ::
( PLift datum ( PLift datum
, Show (PLifted datum)
, PlutusTx.ToData (PLifted datum) , PlutusTx.ToData (PLifted datum)
, PLift redeemer , PLift redeemer
, PlutusTx.ToData (PLifted redeemer) , PlutusTx.ToData (PLifted redeemer)
@ -100,10 +101,10 @@ validatorSucceedsWith ::
PLifted redeemer -> PLifted redeemer ->
ScriptContext -> ScriptContext ->
TestTree TestTree
validatorSucceedsWith tag policy datum redeemer scriptContext = validatorSucceedsWith tag validator datum redeemer scriptContext =
scriptSucceeds tag $ scriptSucceeds tag $
compile compile
( policy ( validator
# pforgetData (pconstantData datum) # pforgetData (pconstantData datum)
# pforgetData (pconstantData redeemer) # pforgetData (pconstantData redeemer)
# pconstant scriptContext # pconstant scriptContext
@ -122,10 +123,10 @@ validatorFailsWith ::
PLifted redeemer -> PLifted redeemer ->
ScriptContext -> ScriptContext ->
TestTree TestTree
validatorFailsWith tag policy datum redeemer scriptContext = validatorFailsWith tag validator datum redeemer scriptContext =
scriptFails tag $ scriptFails tag $
compile compile
( policy ( validator
# pforgetData (pconstantData datum) # pforgetData (pconstantData datum)
# pforgetData (pconstantData redeemer) # pforgetData (pconstantData redeemer)
# pconstant scriptContext # pconstant scriptContext

1
agora.cabal
View file

@ -162,6 +162,7 @@ test-suite agora-test
Spec.Proposal Spec.Proposal
Spec.Sample.Effect.TreasuryWithdrawal Spec.Sample.Effect.TreasuryWithdrawal
Spec.Sample.Proposal Spec.Sample.Proposal
Spec.Sample.Shared
Spec.Sample.Stake Spec.Sample.Stake
Spec.Stake Spec.Stake
Spec.Util Spec.Util

1
agora/Agora/AuthorityToken.hs
View file

@ -18,6 +18,7 @@ import Plutarch.Api.V1 (
PCurrencySymbol (..), PCurrencySymbol (..),
PScriptContext (..), PScriptContext (..),
PScriptPurpose (..), PScriptPurpose (..),
PTxInInfo (PTxInInfo),
PTxInfo (..), PTxInfo (..),
PTxOut (..), PTxOut (..),
) )

51
agora/Agora/Proposal.hs
View file

@ -58,7 +58,7 @@ import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.AssocMap qualified as AssocMap
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Agora.Record (mkRecordConstr, (.&), (.=))
import Agora.SafeMoney (GTTag) import Agora.SafeMoney (GTTag)
import Agora.Utils ( import Agora.Utils (
anyOutput, anyOutput,
@ -354,7 +354,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum
Term Term
s s
( PDataRecord ( PDataRecord
'[ "id" ':= PProposalId '[ "proposalId" ':= PProposalId
, "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash) , "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
, "status" ':= PProposalStatus , "status" ':= PProposalStatus
, "cosigners" ':= PBuiltinList (PAsData PPubKeyHash) , "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
@ -438,7 +438,7 @@ proposalValidator proposal =
PScriptContext ctx' <- pmatch ctx' PScriptContext ctx' <- pmatch ctx'
ctx <- pletFields @'["txInfo", "purpose"] ctx' ctx <- pletFields @'["txInfo", "purpose"] ctx'
txInfo <- plet $ pfromData ctx.txInfo txInfo <- plet $ pfromData ctx.txInfo
PTxInfo txInfo' <- pmatch $ txInfo PTxInfo txInfo' <- pmatch txInfo
txInfoF <- pletFields @'["inputs", "mint"] txInfo' txInfoF <- pletFields @'["inputs", "mint"] txInfo'
PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
@ -452,7 +452,7 @@ proposalValidator proposal =
proposalF <- proposalF <-
pletFields pletFields
@'[ "id" @'[ "proposalId"
, "effects" , "effects"
, "status" , "status"
, "cosigners" , "cosigners"
@ -464,7 +464,10 @@ proposalValidator proposal =
ownAddress <- plet $ txOutF.address ownAddress <- plet $ txOutF.address
stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal) stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal)
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs valueSpent <- plet $ pvalueSpent # txInfoF.inputs
spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
spentStakeST <- plet $ passetClassValueOf # valueSpent # (passetClass # pconstant stakeSym # pconstant stakeTn)
pmatch proposalRedeemer $ \case pmatch proposalRedeemer $ \case
PVote _r -> P.do PVote _r -> P.do
@ -482,37 +485,33 @@ proposalValidator proposal =
passert "Signed by all new cosigners" $ passert "Signed by all new cosigners" $
pall # plam (\sig -> ptxSignedBy # ctx.txInfo # sig) # newSigs pall # plam (\sig -> ptxSignedBy # ctx.txInfo # sig) # newSigs
passert "As many new cosigners as Stake datums" $
spentStakeST #== plength # newSigs
passert "Signatures are correctly added to cosignature list" $ passert "Signatures are correctly added to cosignature list" $
anyOutput @PProposalDatum # ctx.txInfo anyOutput @PProposalDatum # ctx.txInfo
#$ plam #$ plam
$ \newValue address newProposalDatum -> P.do $ \newValue address newProposalDatum -> P.do
newProposalF <-
pletFields
@'[ "id"
, "effects"
, "status"
, "cosigners"
, "thresholds"
, "votes"
]
newProposalDatum
-- This is a little sad. Can we do better by -- This is a little sad. Can we do better by
-- building a new ProposalDatum and then comparing? -- building a new ProposalDatum and then comparing?
let correctDatum = let correctDatum =
foldr1 pdata newProposalDatum
(#&&) #== pdata
[ newProposalF.cosigners #== pconcat # newSigs # proposalF.cosigners ( mkRecordConstr
, newProposalF.id #== proposalF.id PProposalDatum
, newProposalF.effects #== proposalF.effects ( #proposalId .= proposalF.proposalId
, newProposalF.status #== proposalF.status .& #effects .= proposalF.effects
, newProposalF.thresholds #== proposalF.thresholds .& #status .= proposalF.status
, newProposalF.votes #== proposalF.votes .& #cosigners .= pdata (pconcat # newSigs # proposalF.cosigners)
] .& #thresholds .= proposalF.thresholds
.& #votes .= proposalF.votes
)
)
foldr1 foldr1
(#&&) (#&&)
[ ptraceIfFalse "Datum must be correct" $ correctDatum [ pcon PTrue
, ptraceIfFalse "Datum must be correct" correctDatum
, ptraceIfFalse "Value should be correct" $ pdata txOutF.value #== pdata newValue , ptraceIfFalse "Value should be correct" $ pdata txOutF.value #== pdata newValue
, ptraceIfFalse "Must be sent to Proposal's address" $ ownAddress #== pdata address , ptraceIfFalse "Must be sent to Proposal's address" $ ownAddress #== pdata address
] ]

33
agora/Agora/Proposal/Time.hs
View file

@ -24,7 +24,7 @@ module Agora.Proposal.Time (
isDraftRange, isDraftRange,
) where ) where
import Agora.Record (build, (.&), (.=)) import Agora.Record (mkRecordConstr, (.&), (.=))
import GHC.Generics qualified as GHC import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I)) import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PMaybeData (PDJust, PDNothing), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound)) import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PMaybeData (PDJust, PDNothing), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound))
@ -149,23 +149,20 @@ currentProposalTime = phoistAcyclic $
PUpperBound ub <- pmatch ivf.to PUpperBound ub <- pmatch ivf.to
lbf <- pletFields @'["_0", "_1"] lb lbf <- pletFields @'["_0", "_1"] lb
ubf <- pletFields @'["_0", "_1"] ub ubf <- pletFields @'["_0", "_1"] ub
pcon mkRecordConstr PProposalTime $
( PProposalTime $ #lowerBound
build $ .= pdata
#lowerBound ( pmatch lbf._0 $
.= pdata \case
( pmatch lbf._0 $ PFinite d -> pcon (PDJust d)
\case _ -> pcon (PDNothing pdnil)
PFinite d -> pcon (PDJust d) )
_ -> pcon (PDNothing pdnil) .& #upperBound
) .= pdata
.& #upperBound ( pmatch ubf._0 $ \case
.= pdata PFinite d -> pcon (PDJust d)
( pmatch ubf._0 $ \case _ -> pcon (PDNothing pdnil)
PFinite d -> pcon (PDJust d) )
_ -> pcon (PDNothing pdnil)
)
)
-- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive. -- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
proposalTimeWithin :: Term s (PPOSIXTime :--> PPOSIXTime :--> PProposalTime :--> PBool) proposalTimeWithin :: Term s (PPOSIXTime :--> PPOSIXTime :--> PProposalTime :--> PBool)

59
agora/Agora/Record.hs
View file

@ -3,9 +3,16 @@ Module : Agora.Record
Maintainer : emi@haskell.fyi Maintainer : emi@haskell.fyi
Description: PDataRecord helper functions. Description: PDataRecord helper functions.
PDataRecord helper functions. 'PDataRecord' helper functions.
-} -}
module Agora.Record (build, (.=), (.&)) where module Agora.Record (
mkRecord,
mkRecordConstr,
(.=),
(.&),
RecordMorphism,
FieldName,
) where
import Control.Category (Category (..)) import Control.Category (Category (..))
import Data.Coerce (coerce) import Data.Coerce (coerce)
@ -20,17 +27,47 @@ data FieldName (sym :: Symbol) = FieldName
{- | The use of two different 'Symbol's here allows unification to happen, {- | The use of two different 'Symbol's here allows unification to happen,
ensuring 'FieldName' has a fully inferred 'Symbol'. ensuring 'FieldName' has a fully inferred 'Symbol'.
For example, @'build' (#foo .= 'pconstantData' (42 :: 'Integer'))@ gets For example, @'mkRecord' (#foo .= 'pconstantData' (42 :: 'Integer'))@ gets
the correct type. Namely, @'Term' s ('PDataRecord' '["foo" ':= 'PInteger'])@. the correct type. Namely, @'Term' s ('PDataRecord' '["foo" ':= 'PInteger'])@.
-} -}
instance forall (sym :: Symbol) (sym' :: Symbol). sym ~ sym' => IsLabel sym (FieldName sym') where instance forall (sym :: Symbol) (sym' :: Symbol). sym ~ sym' => IsLabel sym (FieldName sym) where
fromLabel = FieldName fromLabel = FieldName
-- | Turn a builder into a fully built 'PDataRecord'. -- | Turn a constant 'RecordMorphism' into a fully built 'PDataRecord'.
build :: forall (s :: S) (r :: [PLabeledType]). RecordMorphism s '[] r -> Term s (PDataRecord r) mkRecord :: forall (r :: [PLabeledType]) (s :: S). RecordMorphism s '[] r -> Term s (PDataRecord r)
build f = coerce f pdnil mkRecord f = f.runRecordMorphism pdnil
-- | A morphism from one PDataRecord to another, representing some sort of consing of data. {- | 'mkRecord' but for known data-types.
This allows you to dynamically construct a record type constructor.
=== Example:
@
'mkRecordConstr'
'Agora.Stake.PStakeDatum'
( #stakedAmount '.=' 'pconstantData' ('Plutarch.SafeMoney.Tagged' @GTTag 42)
'.&' #owner '.=' 'pconstantData' "aabbcc"
'.&' #lockedBy '.=' 'pdata' pnil
)
@
Is the same as
@
'pconstant' ('Agora.Stake.StakeDatum' ('Plutarch.SafeMoney.Tagged' 42) "aabbcc" [])
@
-}
mkRecordConstr ::
forall (r :: [PLabeledType]) (s :: S) (pt :: PType).
PlutusType pt =>
-- | The constructor. This is just the Haskell-level constructor for the type.
-- For 'PMaybeData', this could be 'PDJust', or 'PNothing'.
(forall s'. Term s' (PDataRecord r) -> pt s') ->
-- | The morphism that builds the record.
RecordMorphism s '[] r ->
Term s pt
mkRecordConstr ctr = pcon . ctr . mkRecord
-- | A morphism from one 'PDataRecord' to another, representing some sort of consing of data.
newtype RecordMorphism (s :: S) (as :: [PLabeledType]) (bs :: [PLabeledType]) = RecordMorphism newtype RecordMorphism (s :: S) (as :: [PLabeledType]) (bs :: [PLabeledType]) = RecordMorphism
{ runRecordMorphism :: { runRecordMorphism ::
Term s (PDataRecord as) -> Term s (PDataRecord as) ->
@ -46,14 +83,18 @@ infix 7 .=
-- | Cons a labeled type as a 'RecordMorphism'. -- | Cons a labeled type as a 'RecordMorphism'.
(.=) :: (.=) ::
forall (sym :: Symbol) (a :: PType) (as :: [PLabeledType]) (s :: S). forall (sym :: Symbol) (a :: PType) (as :: [PLabeledType]) (s :: S).
-- | The field name. You can use @-XOverloadedLabels@ to enable the syntax:
-- @#hello ~ 'FieldName' "hello"@
FieldName sym -> FieldName sym ->
-- | The value at that field. This must be 'PAsData', because the underlying
-- type is @'Constr' 'Integer' ['Data']@.
Term s (PAsData a) -> Term s (PAsData a) ->
RecordMorphism s as ((sym ':= a) ': as) RecordMorphism s as ((sym ':= a) ': as)
_ .= x = RecordMorphism $ pcon . PDCons x _ .= x = RecordMorphism $ pcon . PDCons x
infixr 6 .& infixr 6 .&
-- | Compose two morphisms between records. -- | Compose two 'RecordMorphism's.
(.&) :: (.&) ::
forall forall
(s :: S) (s :: S)

17
agora/Agora/Stake.hs
View file

@ -441,15 +441,20 @@ stakeValidator stake =
anyOutput @PStakeDatum # txInfo anyOutput @PStakeDatum # txInfo
#$ plam #$ plam
$ \value address newStakeDatum' -> P.do $ \value address newStakeDatum' -> P.do
PStakeDatum newStakeDatum <- pmatch newStakeDatum'
newStakeDatumF <- pletFields @'["stakedAmount"] newStakeDatum
let isScriptAddress = pdata address #== ownAddress let isScriptAddress = pdata address #== ownAddress
let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum' let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
let valueCorrect = pdata continuingValue #== pdata value let valueCorrect = pdata continuingValue #== pdata value
foldr1 pif
(#&&) isScriptAddress
[ ptraceIfFalse "isScriptAddress" isScriptAddress ( foldl1
, ptraceIfFalse "correctOutputDatum" correctOutputDatum (#&&)
, ptraceIfFalse "valueCorrect" valueCorrect [ ptraceIfFalse "valueCorrect" valueCorrect
] , ptraceIfFalse "correctOutputDatum" correctOutputDatum
]
)
(pcon PFalse)
popaque (pconstant ()) popaque (pconstant ())
PDepositWithdraw r -> P.do PDepositWithdraw r -> P.do
passert "ST at inputs must be 1" $ passert "ST at inputs must be 1" $