Sulkta-Coop/agora
2
0
Fork 0
Code Issues 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 18df6ead55
commit eb4dc2c654
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 (
ProposalDatum (ProposalDatum),
ProposalId (ProposalId),
@ -29,9 +27,13 @@ import Agora.Proposal (
thresholds,
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 Spec.Sample.Proposal (propThresholds, signer, signer2)
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 Test.Tasty (TestTree, testGroup)
@ -47,30 +49,39 @@ tests =
[ testGroup
"policy"
[ policySucceedsWith
"stakeCreation"
(proposalPolicy Proposal.proposal)
"proposalCreation"
(proposalPolicy Shared.proposal)
()
Proposal.proposalCreation
]
, testGroup
"validator"
[ validatorSucceedsWith
"stakeCreation"
(proposalValidator Proposal.proposal)
( ProposalDatum
{ proposalId = ProposalId 0
, effects =
AssocMap.fromList
[ (ResultTag 0, [])
, (ResultTag 1, [])
]
, status = Draft
, cosigners = [signer]
, thresholds = propThresholds
, votes = ProposalVotes AssocMap.empty
}
)
(Cosign [signer2])
(Proposal.cosignProposal [signer2])
[ testGroup
"cosignature"
[ validatorSucceedsWith
"proposal"
(proposalValidator Shared.proposal)
( ProposalDatum
{ proposalId = ProposalId 0
, effects =
AssocMap.fromList
[ (ResultTag 0, [])
, (ResultTag 1, [])
]
, status = Draft
, cosigners = [signer]
, thresholds = Shared.defaultProposalThresholds
, votes = ProposalVotes AssocMap.empty
}
)
(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
-}
module Spec.Sample.Proposal (
proposal,
propPolicy,
propPolicySymbol,
propThresholds,
signer,
signer2,
-- * Script contexts
proposalCreation,
cosignProposal,
proposalRef,
stakeRef,
) where
--------------------------------------------------------------------------------
import Plutarch.Api.V1 (
mintingPolicySymbol,
mkMintingPolicy,
mkValidator,
validatorHash,
)
import Plutus.V1.Ledger.Api (
Address (Address),
Credential (ScriptCredential),
CurrencySymbol,
Datum (Datum),
MintingPolicy (..),
PubKeyHash,
ScriptContext (..),
ScriptPurpose (..),
@ -41,105 +31,33 @@ import Plutus.V1.Ledger.Api (
TxOutRef (TxOutRef),
)
import Plutus.V1.Ledger.Interval qualified as Interval
import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash)
import Plutus.V1.Ledger.Value qualified as Value
--------------------------------------------------------------------------------
import Agora.Governor (
Governor (Governor),
GovernorDatum (GovernorDatum, nextProposalId, proposalThresholds),
governorPolicy,
governorValidator,
)
import Agora.Proposal (
Proposal (..),
ProposalDatum (..),
ProposalId (..),
ProposalStatus (..),
ProposalThresholds (..),
ProposalVotes (..),
ResultTag (..),
proposalPolicy,
proposalValidator,
)
import Agora.Stake (Stake (..), stakePolicy)
import Plutarch.SafeMoney
import Plutus.V1.Ledger.Address (scriptHashAddress)
import Agora.Stake (Stake (..), StakeDatum (StakeDatum))
import Plutarch.SafeMoney (Tagged (Tagged), untag)
import PlutusTx.AssocMap qualified as AssocMap
import Spec.Sample.Shared
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.
proposalCreation :: ScriptContext
proposalCreation =
let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST
let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
proposalDatum :: Datum
proposalDatum =
Datum
@ -153,7 +71,7 @@ proposalCreation =
]
, status = Draft
, cosigners = [signer]
, thresholds = propThresholds
, thresholds = defaultProposalThresholds
, votes = ProposalVotes AssocMap.empty
}
)
@ -163,7 +81,7 @@ proposalCreation =
Datum
( toBuiltinData $
GovernorDatum
{ proposalThresholds = propThresholds
{ proposalThresholds = defaultProposalThresholds
, nextProposalId = ProposalId 0
}
)
@ -172,7 +90,7 @@ proposalCreation =
Datum
( toBuiltinData $
GovernorDatum
{ proposalThresholds = propThresholds
{ proposalThresholds = defaultProposalThresholds
, nextProposalId = ProposalId 1
}
)
@ -190,7 +108,7 @@ proposalCreation =
]
, txInfoOutputs =
[ TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing
{ txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing
, txOutValue =
mconcat
[ st
@ -221,13 +139,19 @@ proposalCreation =
]
, 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.
cosignProposal :: [PubKeyHash] -> ScriptContext
cosignProposal :: [PubKeyHash] -> TxInfo
cosignProposal newSigners =
let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST
let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
proposalBefore :: ProposalDatum
proposalBefore =
ProposalDatum
@ -239,50 +163,70 @@ cosignProposal newSigners =
]
, status = Draft
, cosigners = [signer]
, thresholds = propThresholds
, thresholds = defaultProposalThresholds
, votes = ProposalVotes AssocMap.empty
}
stakeDatum :: StakeDatum
stakeDatum = StakeDatum (Tagged 50_000_000) signer2 []
proposalAfter :: ProposalDatum
proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners}
proposalRef = (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
in ScriptContext
{ scriptContextTxInfo =
TxInfo
{ txInfoInputs =
[ TxInInfo
proposalRef
TxOut
{ txOutAddress = propValidatorAddress
, txOutValue =
mconcat
[ st
, Value.singleton "" "" 10_000_000
]
, txOutDatumHash = Just (toDatumHash proposalBefore)
}
]
, txInfoOutputs =
[ TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing
, txOutValue =
mconcat
[ st
, Value.singleton "" "" 10_000_000
]
, txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter)
}
]
, txInfoFee = Value.singleton "" "" 2
, txInfoMint = st
, txInfoDCert = []
, txInfoWdrl = []
, txInfoValidRange = Interval.always
, txInfoSignatories = newSigners
, txInfoData =
[ datumPair . Datum $ toBuiltinData proposalBefore
, datumPair . Datum $ toBuiltinData proposalAfter
]
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
}
, scriptContextPurpose = Spending proposalRef
in TxInfo
{ txInfoInputs =
[ TxInInfo
proposalRef
TxOut
{ txOutAddress = proposalValidatorAddress
, txOutValue =
mconcat
[ st
, Value.singleton "" "" 10_000_000
]
, txOutDatumHash = Just (toDatumHash proposalBefore)
}
, TxInInfo
stakeRef
TxOut
{ txOutAddress = stakeAddress
, txOutValue =
mconcat
[ Value.singleton "" "" 10_000_000
, Value.assetClassValue (untag stake.gtClassRef) 50_000_000
, Value.singleton stakeSymbol "" 1
]
, txOutDatumHash = Just (toDatumHash stakeDatum)
}
]
, txInfoOutputs =
[ TxOut
{ txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing
, txOutValue =
mconcat
[ st
, Value.singleton "" "" 10_000_000
]
, txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter)
}
, TxOut
{ txOutAddress = stakeAddress
, txOutValue =
mconcat
[ 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 (
stake,
policy,
policySymbol,
stakeSymbol,
validatorHashTN,
signer,
@ -22,19 +21,14 @@ module Spec.Sample.Stake (
--------------------------------------------------------------------------------
import Plutarch.Api.V1 (
mintingPolicySymbol,
mkMintingPolicy,
mkValidator,
validatorHash,
)
import Plutus.V1.Ledger.Api (
Address (Address),
Credential (ScriptCredential),
CurrencySymbol,
Datum (Datum),
DatumHash (DatumHash),
MintingPolicy (..),
PubKeyHash,
ScriptContext (..),
ScriptPurpose (..),
ToData (toBuiltinData),
@ -45,8 +39,7 @@ import Plutus.V1.Ledger.Api (
)
import Plutus.V1.Ledger.Contexts (TxOut (TxOut), TxOutRef (TxOutRef))
import Plutus.V1.Ledger.Interval qualified as Interval
import Plutus.V1.Ledger.Scripts (Validator)
import Plutus.V1.Ledger.Value (AssetClass (AssetClass), TokenName (TokenName))
import Plutus.V1.Ledger.Value (TokenName (TokenName))
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.Stake
import Plutarch.SafeMoney
import Spec.Sample.Shared
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.
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.
stakeCreation :: ScriptContext
stakeCreation =
let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST
datum :: Datum
datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer [])
in ScriptContext
@ -103,7 +68,7 @@ stakeCreation =
{ txInfoInputs = []
, txInfoOutputs =
[ TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
{ txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
, txOutValue = st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242
, txOutDatumHash = Just (DatumHash "")
}
@ -117,7 +82,7 @@ stakeCreation =
, txInfoData = [("", datum)]
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
}
, scriptContextPurpose = Minting policySymbol
, scriptContextPurpose = Minting stakeSymbol
}
-- | 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
in ScriptContext
{ scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
, scriptContextPurpose = Minting policySymbol
, scriptContextPurpose = Minting stakeSymbol
}
-- | This ScriptContext should fail because the datum has too much GT.
@ -138,7 +103,7 @@ stakeCreationUnsigned =
stakeCreation.scriptContextTxInfo
{ 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.
stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
stakeDepositWithdraw config =
let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST
stakeBefore :: StakeDatum
stakeBefore = StakeDatum config.startAmount signer []
@ -167,7 +132,7 @@ stakeDepositWithdraw config =
[ TxInInfo
(TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
{ txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
, txOutValue =
st
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)
@ -176,7 +141,7 @@ stakeDepositWithdraw config =
]
, txInfoOutputs =
[ TxOut
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
{ txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
, txOutValue =
st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
, 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.
validatorSucceedsWith ::
( PLift datum
, Show (PLifted datum)
, PlutusTx.ToData (PLifted datum)
, PLift redeemer
, PlutusTx.ToData (PLifted redeemer)
@ -100,10 +101,10 @@ validatorSucceedsWith ::
PLifted redeemer ->
ScriptContext ->
TestTree
validatorSucceedsWith tag policy datum redeemer scriptContext =
validatorSucceedsWith tag validator datum redeemer scriptContext =
scriptSucceeds tag $
compile
( policy
( validator
# pforgetData (pconstantData datum)
# pforgetData (pconstantData redeemer)
# pconstant scriptContext
@ -122,10 +123,10 @@ validatorFailsWith ::
PLifted redeemer ->
ScriptContext ->
TestTree
validatorFailsWith tag policy datum redeemer scriptContext =
validatorFailsWith tag validator datum redeemer scriptContext =
scriptFails tag $
compile
( policy
( validator
# pforgetData (pconstantData datum)
# pforgetData (pconstantData redeemer)
# pconstant scriptContext

1
agora.cabal
View file

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

1
agora/Agora/AuthorityToken.hs
View file

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

51
agora/Agora/Proposal.hs
View file

@ -58,7 +58,7 @@ import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap
--------------------------------------------------------------------------------
import Agora.Record (mkRecordConstr, (.&), (.=))
import Agora.SafeMoney (GTTag)
import Agora.Utils (
anyOutput,
@ -354,7 +354,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum
Term
s
( PDataRecord
'[ "id" ':= PProposalId
'[ "proposalId" ':= PProposalId
, "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
, "status" ':= PProposalStatus
, "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
@ -438,7 +438,7 @@ proposalValidator proposal =
PScriptContext ctx' <- pmatch ctx'
ctx <- pletFields @'["txInfo", "purpose"] ctx'
txInfo <- plet $ pfromData ctx.txInfo
PTxInfo txInfo' <- pmatch $ txInfo
PTxInfo txInfo' <- pmatch txInfo
txInfoF <- pletFields @'["inputs", "mint"] txInfo'
PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
@ -452,7 +452,7 @@ proposalValidator proposal =
proposalF <-
pletFields
@'[ "id"
@'[ "proposalId"
, "effects"
, "status"
, "cosigners"
@ -464,7 +464,10 @@ proposalValidator proposal =
ownAddress <- plet $ txOutF.address
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
PVote _r -> P.do
@ -482,37 +485,33 @@ proposalValidator proposal =
passert "Signed by all new cosigners" $
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" $
anyOutput @PProposalDatum # ctx.txInfo
#$ plam
$ \newValue address newProposalDatum -> P.do
newProposalF <-
pletFields
@'[ "id"
, "effects"
, "status"
, "cosigners"
, "thresholds"
, "votes"
]
newProposalDatum
-- This is a little sad. Can we do better by
-- building a new ProposalDatum and then comparing?
let correctDatum =
foldr1
(#&&)
[ newProposalF.cosigners #== pconcat # newSigs # proposalF.cosigners
, newProposalF.id #== proposalF.id
, newProposalF.effects #== proposalF.effects
, newProposalF.status #== proposalF.status
, newProposalF.thresholds #== proposalF.thresholds
, newProposalF.votes #== proposalF.votes
]
pdata newProposalDatum
#== pdata
( mkRecordConstr
PProposalDatum
( #proposalId .= proposalF.proposalId
.& #effects .= proposalF.effects
.& #status .= proposalF.status
.& #cosigners .= pdata (pconcat # newSigs # proposalF.cosigners)
.& #thresholds .= proposalF.thresholds
.& #votes .= proposalF.votes
)
)
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 "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,
) where
import Agora.Record (build, (.&), (.=))
import Agora.Record (mkRecordConstr, (.&), (.=))
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
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
lbf <- pletFields @'["_0", "_1"] lb
ubf <- pletFields @'["_0", "_1"] ub
pcon
( PProposalTime $
build $
#lowerBound
.= pdata
( pmatch lbf._0 $
\case
PFinite d -> pcon (PDJust d)
_ -> pcon (PDNothing pdnil)
)
.& #upperBound
.= pdata
( pmatch ubf._0 $ \case
PFinite d -> pcon (PDJust d)
_ -> pcon (PDNothing pdnil)
)
)
mkRecordConstr PProposalTime $
#lowerBound
.= pdata
( pmatch lbf._0 $
\case
PFinite d -> pcon (PDJust d)
_ -> pcon (PDNothing pdnil)
)
.& #upperBound
.= pdata
( pmatch ubf._0 $ \case
PFinite d -> pcon (PDJust d)
_ -> pcon (PDNothing pdnil)
)
-- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
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
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 Data.Coerce (coerce)
@ -20,17 +27,47 @@ data FieldName (sym :: Symbol) = FieldName
{- | The use of two different 'Symbol's here allows unification to happen,
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'])@.
-}
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
-- | Turn a builder into a fully built 'PDataRecord'.
build :: forall (s :: S) (r :: [PLabeledType]). RecordMorphism s '[] r -> Term s (PDataRecord r)
build f = coerce f pdnil
-- | Turn a constant 'RecordMorphism' into a fully built 'PDataRecord'.
mkRecord :: forall (r :: [PLabeledType]) (s :: S). RecordMorphism s '[] r -> Term s (PDataRecord r)
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
{ runRecordMorphism ::
Term s (PDataRecord as) ->
@ -46,14 +83,18 @@ infix 7 .=
-- | Cons a labeled type as a 'RecordMorphism'.
(.=) ::
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 ->
-- | The value at that field. This must be 'PAsData', because the underlying
-- type is @'Constr' 'Integer' ['Data']@.
Term s (PAsData a) ->
RecordMorphism s as ((sym ':= a) ': as)
_ .= x = RecordMorphism $ pcon . PDCons x
infixr 6 .&
-- | Compose two morphisms between records.
-- | Compose two 'RecordMorphism's.
(.&) ::
forall
(s :: S)

17
agora/Agora/Stake.hs
View file

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