fix compilation errors
This commit is contained in:
Hongrui Fang
parent
d921927a2f
commit
6da4e7286d
21 changed files with 279 additions and 677 deletions
|
|
@ -7,232 +7,236 @@ Property model and tests for 'Governor' related functions
|
|||
-}
|
||||
module Property.Governor (props) where
|
||||
|
||||
import Agora.Governor (Governor (gstOutRef), GovernorDatum (..), pisGovernorDatumValid)
|
||||
import Agora.Governor.Scripts (governorPolicy)
|
||||
import Agora.Proposal (
|
||||
ProposalId (ProposalId),
|
||||
ProposalThresholds (ProposalThresholds),
|
||||
)
|
||||
import Agora.Proposal.Time (
|
||||
MaxTimeRangeWidth (MaxTimeRangeWidth),
|
||||
ProposalTimingConfig (ProposalTimingConfig),
|
||||
)
|
||||
import Data.Default.Class (Default (def))
|
||||
import Data.Tagged (Tagged (Tagged))
|
||||
import Data.Universe (Finite (..), Universe (..))
|
||||
import Plutarch.Api.V2 (PScriptContext)
|
||||
import Plutarch.Builtin (pforgetData)
|
||||
import Plutarch.Context (
|
||||
MintingBuilder,
|
||||
buildMinting',
|
||||
input,
|
||||
mint,
|
||||
output,
|
||||
script,
|
||||
withDatum,
|
||||
withMinting,
|
||||
withRef,
|
||||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
import PlutusLedgerApi.V2 (
|
||||
ScriptContext (scriptContextTxInfo),
|
||||
TxInInfo (txInInfoOutRef),
|
||||
TxInfo (txInfoInputs, txInfoMint, txInfoOutputs),
|
||||
TxOut (txOutValue),
|
||||
)
|
||||
import Property.Generator (genInput, genOutput)
|
||||
import Sample.Shared (
|
||||
governor,
|
||||
governorAssetClass,
|
||||
governorSymbol,
|
||||
governorValidatorHash,
|
||||
gstUTXORef,
|
||||
)
|
||||
-- import Agora.Governor (Governor (gstOutRef), GovernorDatum (..), pisGovernorDatumValid)
|
||||
-- import Agora.Governor.Scripts (governorPolicy)
|
||||
-- import Agora.Proposal (
|
||||
-- ProposalId (ProposalId),
|
||||
-- ProposalThresholds (ProposalThresholds),
|
||||
-- )
|
||||
-- import Agora.Proposal.Time (
|
||||
-- MaxTimeRangeWidth (MaxTimeRangeWidth),
|
||||
-- ProposalTimingConfig (ProposalTimingConfig),
|
||||
-- )
|
||||
-- import Data.Default.Class (Default (def))
|
||||
-- import Data.Tagged (Tagged (Tagged))
|
||||
-- import Data.Universe (Finite (..), Universe (..))
|
||||
-- import Plutarch.Api.V2 (PScriptContext)
|
||||
-- import Plutarch.Builtin (pforgetData)
|
||||
-- import Plutarch.Context (
|
||||
-- MintingBuilder,
|
||||
-- buildMinting',
|
||||
-- input,
|
||||
-- mint,
|
||||
-- output,
|
||||
-- script,
|
||||
-- withDatum,
|
||||
-- withMinting,
|
||||
-- withRef,
|
||||
-- withValue,
|
||||
-- )
|
||||
-- import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
-- import PlutusLedgerApi.V2 (
|
||||
-- ScriptContext (scriptContextTxInfo),
|
||||
-- TxInInfo (txInInfoOutRef),
|
||||
-- TxInfo (txInfoInputs, txInfoMint, txInfoOutputs),
|
||||
-- TxOut (txOutValue),
|
||||
-- )
|
||||
-- import Property.Generator (genInput, genOutput)
|
||||
-- import Sample.Shared (
|
||||
-- governor,
|
||||
-- governorAssetClass,
|
||||
-- governorSymbol,
|
||||
-- governorValidatorHash,
|
||||
-- gstUTXORef,
|
||||
-- )
|
||||
import Test.Tasty (TestTree)
|
||||
import Test.Tasty.Plutarch.Property (classifiedPropertyNative)
|
||||
import Test.Tasty.QuickCheck (
|
||||
Gen,
|
||||
Property,
|
||||
choose,
|
||||
chooseInteger,
|
||||
listOf1,
|
||||
testProperty,
|
||||
)
|
||||
|
||||
data GovernorDatumCases
|
||||
= ExecuteLE0
|
||||
| CreateLE0
|
||||
| ToVotingLE0
|
||||
| VoteLE0
|
||||
| CosignLE0
|
||||
| Correct
|
||||
deriving stock (Eq, Show)
|
||||
-- import Test.Tasty.Plutarch.Property (classifiedPropertyNative)
|
||||
-- import Test.Tasty.QuickCheck (
|
||||
-- Gen,
|
||||
-- Property,
|
||||
-- choose,
|
||||
-- chooseInteger,
|
||||
-- listOf1,
|
||||
-- testProperty,
|
||||
-- )
|
||||
|
||||
instance Universe GovernorDatumCases where
|
||||
universe =
|
||||
[ ExecuteLE0
|
||||
, CreateLE0
|
||||
, VoteLE0
|
||||
, CosignLE0
|
||||
, Correct
|
||||
]
|
||||
-- data GovernorDatumCases
|
||||
-- = ExecuteLE0
|
||||
-- | CreateLE0
|
||||
-- | ToVotingLE0
|
||||
-- | VoteLE0
|
||||
-- | CosignLE0
|
||||
-- | Correct
|
||||
-- deriving stock (Eq, Show)
|
||||
|
||||
instance Finite GovernorDatumCases where
|
||||
universeF = universe
|
||||
cardinality = Tagged 6
|
||||
-- instance Universe GovernorDatumCases where
|
||||
-- universe =
|
||||
-- [ ExecuteLE0
|
||||
-- , CreateLE0
|
||||
-- , VoteLE0
|
||||
-- , CosignLE0
|
||||
-- , Correct
|
||||
-- ]
|
||||
|
||||
{- | Property that checks `governorDatumValid`.
|
||||
`governorDatumValid` determines if given governor datum is valid or not. This property
|
||||
ensures `governorDatumValid` is checking the datum correctly and ruling out improper datum.
|
||||
-}
|
||||
governorDatumValidProperty :: Property
|
||||
governorDatumValidProperty =
|
||||
classifiedPropertyNative gen (const []) expected classifier pisGovernorDatumValid
|
||||
where
|
||||
classifier :: GovernorDatum -> GovernorDatumCases
|
||||
classifier
|
||||
( (.proposalThresholds) ->
|
||||
ProposalThresholds
|
||||
execute
|
||||
create
|
||||
toVoting
|
||||
vote
|
||||
cosign
|
||||
)
|
||||
| execute < 0 = ExecuteLE0
|
||||
| create < 0 = CreateLE0
|
||||
| toVoting < 0 = ToVotingLE0
|
||||
| vote < 0 = VoteLE0
|
||||
| cosign < 0 = CosignLE0
|
||||
| otherwise = Correct
|
||||
-- instance Finite GovernorDatumCases where
|
||||
-- universeF = universe
|
||||
-- cardinality = Tagged 6
|
||||
|
||||
expected :: GovernorDatum -> Maybe Bool
|
||||
expected c = Just $ classifier c == Correct
|
||||
-- {- | Property that checks `governorDatumValid`.
|
||||
-- `governorDatumValid` determines if given governor datum is valid or not. This property
|
||||
-- ensures `governorDatumValid` is checking the datum correctly and ruling out improper datum.
|
||||
-- -}
|
||||
-- governorDatumValidProperty :: Property
|
||||
-- governorDatumValidProperty =
|
||||
-- classifiedPropertyNative gen (const []) expected classifier pisGovernorDatumValid
|
||||
-- where
|
||||
-- classifier :: GovernorDatum -> GovernorDatumCases
|
||||
-- classifier
|
||||
-- ( (.proposalThresholds) ->
|
||||
-- ProposalThresholds
|
||||
-- execute
|
||||
-- create
|
||||
-- toVoting
|
||||
-- vote
|
||||
-- cosign
|
||||
-- )
|
||||
-- | execute < 0 = ExecuteLE0
|
||||
-- | create < 0 = CreateLE0
|
||||
-- | toVoting < 0 = ToVotingLE0
|
||||
-- | vote < 0 = VoteLE0
|
||||
-- | cosign < 0 = CosignLE0
|
||||
-- | otherwise = Correct
|
||||
|
||||
gen :: GovernorDatumCases -> Gen GovernorDatum
|
||||
gen c = do
|
||||
thres <- genProposalThresholds c
|
||||
-- expected :: GovernorDatum -> Maybe Bool
|
||||
-- expected c = Just $ classifier c == Correct
|
||||
|
||||
let timing = ProposalTimingConfig 0 0 0 0
|
||||
return $ GovernorDatum thres (ProposalId 0) timing (MaxTimeRangeWidth 1) 3
|
||||
where
|
||||
taggedInteger p = Tagged <$> chooseInteger p
|
||||
genProposalThresholds :: GovernorDatumCases -> Gen ProposalThresholds
|
||||
genProposalThresholds c = do
|
||||
let validGT = taggedInteger (0, 1000000000)
|
||||
execute <- validGT
|
||||
create <- validGT
|
||||
toVoting <- validGT
|
||||
vote <- validGT
|
||||
cosign <- validGT
|
||||
le0 <- taggedInteger (-1000, -1)
|
||||
-- gen :: GovernorDatumCases -> Gen GovernorDatum
|
||||
-- gen c = do
|
||||
-- thres <- genProposalThresholds c
|
||||
|
||||
case c of
|
||||
ExecuteLE0 ->
|
||||
-- execute < 0
|
||||
return $ ProposalThresholds le0 create toVoting vote cosign
|
||||
CreateLE0 ->
|
||||
-- c < 0
|
||||
return $ ProposalThresholds execute le0 toVoting vote cosign
|
||||
ToVotingLE0 ->
|
||||
return $ ProposalThresholds execute create le0 vote cosign
|
||||
VoteLE0 ->
|
||||
-- vote < 0
|
||||
return $ ProposalThresholds execute create toVoting le0 cosign
|
||||
CosignLE0 ->
|
||||
return $ ProposalThresholds execute create toVoting vote le0
|
||||
Correct ->
|
||||
return $ ProposalThresholds execute create toVoting vote cosign
|
||||
-- let timing = ProposalTimingConfig 0 0 0 0
|
||||
-- return $ GovernorDatum thres (ProposalId 0) timing (MaxTimeRangeWidth 1) 3
|
||||
-- where
|
||||
-- taggedInteger p = Tagged <$> chooseInteger p
|
||||
-- genProposalThresholds :: GovernorDatumCases -> Gen ProposalThresholds
|
||||
-- genProposalThresholds c = do
|
||||
-- let validGT = taggedInteger (0, 1000000000)
|
||||
-- execute <- validGT
|
||||
-- create <- validGT
|
||||
-- toVoting <- validGT
|
||||
-- vote <- validGT
|
||||
-- cosign <- validGT
|
||||
-- le0 <- taggedInteger (-1000, -1)
|
||||
|
||||
data GovernorPolicyCases
|
||||
= ReferenceUTXONotSpent
|
||||
| IncorrectAmountOfTokenMinted
|
||||
| GovernorOutputNotFound
|
||||
| GovernorPolicyCorrect
|
||||
deriving stock (Eq, Show)
|
||||
-- case c of
|
||||
-- ExecuteLE0 ->
|
||||
-- -- execute < 0
|
||||
-- return $ ProposalThresholds le0 create toVoting vote cosign
|
||||
-- CreateLE0 ->
|
||||
-- -- c < 0
|
||||
-- return $ ProposalThresholds execute le0 toVoting vote cosign
|
||||
-- ToVotingLE0 ->
|
||||
-- return $ ProposalThresholds execute create le0 vote cosign
|
||||
-- VoteLE0 ->
|
||||
-- -- vote < 0
|
||||
-- return $ ProposalThresholds execute create toVoting le0 cosign
|
||||
-- CosignLE0 ->
|
||||
-- return $ ProposalThresholds execute create toVoting vote le0
|
||||
-- Correct ->
|
||||
-- return $ ProposalThresholds execute create toVoting vote cosign
|
||||
|
||||
instance Universe GovernorPolicyCases where
|
||||
universe =
|
||||
[ ReferenceUTXONotSpent
|
||||
, IncorrectAmountOfTokenMinted
|
||||
, GovernorOutputNotFound
|
||||
, GovernorPolicyCorrect
|
||||
]
|
||||
-- data GovernorPolicyCases
|
||||
-- = ReferenceUTXONotSpent
|
||||
-- | IncorrectAmountOfTokenMinted
|
||||
-- | GovernorOutputNotFound
|
||||
-- | GovernorPolicyCorrect
|
||||
-- deriving stock (Eq, Show)
|
||||
|
||||
instance Finite GovernorPolicyCases where
|
||||
universeF = universe
|
||||
cardinality = Tagged 4
|
||||
-- instance Universe GovernorPolicyCases where
|
||||
-- universe =
|
||||
-- [ ReferenceUTXONotSpent
|
||||
-- , IncorrectAmountOfTokenMinted
|
||||
-- , GovernorOutputNotFound
|
||||
-- , GovernorPolicyCorrect
|
||||
-- ]
|
||||
|
||||
governorMintingProperty :: Property
|
||||
governorMintingProperty =
|
||||
classifiedPropertyNative gen (const []) expected classifier actual
|
||||
where
|
||||
{- Note:
|
||||
I don't think it's easily possible to randomize orefs. We can't really pass pass `Governor` type to `actual` function.
|
||||
-}
|
||||
gst = assetClassValue governorAssetClass 1
|
||||
mintAmount x = mint . mconcat $ replicate x gst
|
||||
outputToGov =
|
||||
output $
|
||||
mconcat
|
||||
[ script governorValidatorHash
|
||||
, withValue gst
|
||||
, withDatum govDatum
|
||||
]
|
||||
referencedInput = input $ withRef gstUTXORef
|
||||
-- instance Finite GovernorPolicyCases where
|
||||
-- universeF = universe
|
||||
-- cardinality = Tagged 4
|
||||
|
||||
govDatum :: GovernorDatum
|
||||
govDatum =
|
||||
GovernorDatum
|
||||
{ proposalThresholds = def
|
||||
, nextProposalId = ProposalId 0
|
||||
, proposalTimings = def
|
||||
, createProposalTimeRangeMaxWidth = def
|
||||
, maximumProposalsPerStake = 3
|
||||
}
|
||||
-- governorMintingProperty :: Property
|
||||
-- governorMintingProperty =
|
||||
-- classifiedPropertyNative gen (const []) expected classifier actual
|
||||
-- where
|
||||
-- {- Note:
|
||||
-- I don't think it's easily possible to randomize orefs. We can't really pass pass `Governor` type to `actual` function.
|
||||
-- -}
|
||||
-- gst = assetClassValue governorAssetClass 1
|
||||
-- mintAmount x = mint . mconcat $ replicate x gst
|
||||
-- outputToGov =
|
||||
-- output $
|
||||
-- mconcat
|
||||
-- [ script governorValidatorHash
|
||||
-- , withValue gst
|
||||
-- , withDatum govDatum
|
||||
-- ]
|
||||
-- referencedInput = input $ withRef gstUTXORef
|
||||
|
||||
gen :: GovernorPolicyCases -> Gen ScriptContext
|
||||
gen c = do
|
||||
inputs <- fmap mconcat . listOf1 $ genInput @MintingBuilder
|
||||
outputs <- fmap mconcat . listOf1 $ genOutput @MintingBuilder
|
||||
toks <- choose (2, 100)
|
||||
-- govDatum :: GovernorDatum
|
||||
-- govDatum =
|
||||
-- GovernorDatum
|
||||
-- { proposalThresholds = def
|
||||
-- , nextProposalId = ProposalId 0
|
||||
-- , proposalTimings = def
|
||||
-- , createProposalTimeRangeMaxWidth = def
|
||||
-- , maximumProposalsPerStake = 3
|
||||
-- }
|
||||
|
||||
let comp =
|
||||
case c of
|
||||
ReferenceUTXONotSpent -> outputToGov <> mintAmount 1
|
||||
IncorrectAmountOfTokenMinted -> referencedInput <> outputToGov <> mintAmount toks
|
||||
GovernorOutputNotFound -> referencedInput <> mintAmount 1
|
||||
GovernorPolicyCorrect -> referencedInput <> outputToGov <> mintAmount 1
|
||||
-- gen :: GovernorPolicyCases -> Gen ScriptContext
|
||||
-- gen c = do
|
||||
-- inputs <- fmap mconcat . listOf1 $ genInput @MintingBuilder
|
||||
-- outputs <- fmap mconcat . listOf1 $ genOutput @MintingBuilder
|
||||
-- toks <- choose (2, 100)
|
||||
|
||||
return . buildMinting' $ inputs <> outputs <> comp <> withMinting governorSymbol
|
||||
-- let comp =
|
||||
-- case c of
|
||||
-- ReferenceUTXONotSpent -> outputToGov <> mintAmount 1
|
||||
-- IncorrectAmountOfTokenMinted -> referencedInput <> outputToGov <> mintAmount toks
|
||||
-- GovernorOutputNotFound -> referencedInput <> mintAmount 1
|
||||
-- GovernorPolicyCorrect -> referencedInput <> outputToGov <> mintAmount 1
|
||||
|
||||
expected :: ScriptContext -> Maybe ()
|
||||
expected sc =
|
||||
case classifier sc of
|
||||
GovernorPolicyCorrect -> Just ()
|
||||
_ -> Nothing
|
||||
-- return . buildMinting' $ inputs <> outputs <> comp <> withMinting governorSymbol
|
||||
|
||||
opaqueToUnit :: Term s (POpaque :--> PUnit)
|
||||
opaqueToUnit = plam $ \_ -> pconstant ()
|
||||
-- expected :: ScriptContext -> Maybe ()
|
||||
-- expected sc =
|
||||
-- case classifier sc of
|
||||
-- GovernorPolicyCorrect -> Just ()
|
||||
-- _ -> Nothing
|
||||
|
||||
actual :: Term s (PScriptContext :--> PUnit)
|
||||
actual = plam $ \sc -> opaqueToUnit #$ governorPolicy # pconstant governor.gstOutRef # pforgetData (pconstantData ()) # sc
|
||||
-- opaqueToUnit :: Term s (POpaque :--> PUnit)
|
||||
-- opaqueToUnit = plam $ \_ -> pconstant ()
|
||||
|
||||
classifier :: ScriptContext -> GovernorPolicyCases
|
||||
classifier sc
|
||||
| minted /= gst = IncorrectAmountOfTokenMinted
|
||||
| refInputNotExists = ReferenceUTXONotSpent
|
||||
| govOutputNotExists = GovernorOutputNotFound
|
||||
| otherwise = GovernorPolicyCorrect
|
||||
where
|
||||
txinfo = scriptContextTxInfo sc
|
||||
minted = txInfoMint txinfo
|
||||
refInputNotExists = gstUTXORef `notElem` (txInInfoOutRef <$> txInfoInputs txinfo)
|
||||
govOutputNotExists = gst `notElem` (txOutValue <$> txInfoOutputs txinfo)
|
||||
-- actual :: Term s (PScriptContext :--> PUnit)
|
||||
-- actual = plam $ \sc -> opaqueToUnit #$ governorPolicy # pconstant governor.gstOutRef # pforgetData (pconstantData ()) # sc
|
||||
|
||||
-- classifier :: ScriptContext -> GovernorPolicyCases
|
||||
-- classifier sc
|
||||
-- | minted /= gst = IncorrectAmountOfTokenMinted
|
||||
-- | refInputNotExists = ReferenceUTXONotSpent
|
||||
-- | govOutputNotExists = GovernorOutputNotFound
|
||||
-- | otherwise = GovernorPolicyCorrect
|
||||
-- where
|
||||
-- txinfo = scriptContextTxInfo sc
|
||||
-- minted = txInfoMint txinfo
|
||||
-- refInputNotExists = gstUTXORef `notElem` (txInInfoOutRef <$> txInfoInputs txinfo)
|
||||
-- govOutputNotExists = gst `notElem` (txOutValue <$> txInfoOutputs txinfo)
|
||||
|
||||
-- props :: [TestTree]
|
||||
-- props =
|
||||
-- [ testProperty "governorDatumValid" governorDatumValidProperty
|
||||
-- , testProperty "governorPolicy" governorMintingProperty
|
||||
-- ]
|
||||
|
||||
props :: [TestTree]
|
||||
props =
|
||||
[ testProperty "governorDatumValid" governorDatumValidProperty
|
||||
, testProperty "governorPolicy" governorMintingProperty
|
||||
]
|
||||
props = []
|
||||
|
|
|
|||
|
|
@ -4,9 +4,9 @@ module Sample.AuthorityToken.UnauthorizedMintingExploit (
|
|||
mkTestCase,
|
||||
) where
|
||||
|
||||
import Agora.Utils (validatorHashToTokenName)
|
||||
import Control.Exception (assert)
|
||||
import Plutarch.Context (input, mint, normalizeValue, output, script, withValue)
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import Sample.Shared (authorityTokenPolicy, authorityTokenSymbol, minAda)
|
||||
import Test.Specification (SpecificationTree, testPolicy)
|
||||
|
|
|
|||
|
|
@ -17,12 +17,12 @@ import Agora.Effect.GovernorMutation (
|
|||
import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
|
||||
import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
|
||||
import Agora.SafeMoney (AuthorityTokenTag)
|
||||
import Agora.Utils (validatorHashToTokenName)
|
||||
import Data.Default.Class (Default (def))
|
||||
import Data.Map ((!))
|
||||
import Data.Tagged (Tagged (..))
|
||||
import Plutarch.Api.V2 (validatorHash)
|
||||
import Plutarch.Extra.AssetClass (AssetClass (AssetClass), assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1 qualified as Interval (always)
|
||||
import PlutusLedgerApi.V1.Address (scriptHashAddress)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value (
|
||||
|
|
|
|||
|
|
@ -18,7 +18,6 @@ module Sample.Governor.Mutate (
|
|||
|
||||
import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
|
||||
import Agora.Proposal (ProposalId (ProposalId), ProposalThresholds (..))
|
||||
import Agora.Utils (scriptHashToTokenName)
|
||||
import Data.Default (def)
|
||||
import Data.Map ((!))
|
||||
import Plutarch.Api.V2 (PMintingPolicy, mintingPolicySymbol, mkMintingPolicy, validatorHash)
|
||||
|
|
@ -33,6 +32,7 @@ import Plutarch.Context (
|
|||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import PlutusLedgerApi.V2 (
|
||||
CurrencySymbol (CurrencySymbol),
|
||||
|
|
|
|||
|
|
@ -68,7 +68,6 @@ import Agora.SafeMoney (AuthorityTokenTag, GTTag)
|
|||
import Agora.Stake (
|
||||
StakeDatum (..),
|
||||
)
|
||||
import Agora.Utils (scriptHashToTokenName)
|
||||
import Control.Applicative (liftA2)
|
||||
import Control.Monad.State (execState, modify, when)
|
||||
import Data.Default (def)
|
||||
|
|
@ -90,6 +89,7 @@ import Plutarch.Context (
|
|||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (AssetClass (AssetClass), assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
|
||||
import Plutarch.Lift (PLifted, PUnsafeLiftDecl)
|
||||
import PlutusLedgerApi.V2 (
|
||||
Credential (PubKeyCredential),
|
||||
|
|
|
|||
|
|
@ -46,7 +46,6 @@ import Agora.Stake (
|
|||
StakeDatum (..),
|
||||
StakeRedeemer (PermitVote),
|
||||
)
|
||||
import Agora.Utils (validatorHashToTokenName)
|
||||
import Data.Coerce (coerce)
|
||||
import Data.Default (Default (def))
|
||||
import Data.Map.Strict qualified as StrictMap
|
||||
|
|
@ -66,6 +65,7 @@ import Plutarch.Context (
|
|||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import PlutusLedgerApi.V2 (
|
||||
Credential (PubKeyCredential),
|
||||
|
|
|
|||
|
|
@ -49,7 +49,6 @@ import Agora.Stake (
|
|||
StakeDatum (..),
|
||||
StakeRedeemer (RetractVotes),
|
||||
)
|
||||
import Agora.Utils (validatorHashToTokenName)
|
||||
import Data.Default.Class (Default (def))
|
||||
import Data.Map.Strict qualified as StrictMap
|
||||
import Data.Tagged (Tagged, untag)
|
||||
|
|
@ -67,6 +66,7 @@ import Plutarch.Context (
|
|||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import PlutusLedgerApi.V2 (
|
||||
Credential (PubKeyCredential),
|
||||
|
|
|
|||
|
|
@ -72,9 +72,6 @@ import Agora.Proposal.Time (
|
|||
ProposalTimingConfig (..),
|
||||
)
|
||||
import Agora.SafeMoney (GovernorSTTag, ProposalSTTag, StakeSTTag)
|
||||
import Agora.Utils (
|
||||
validatorHashToTokenName,
|
||||
)
|
||||
import Data.Default.Class (Default (..))
|
||||
import Data.Map (Map, (!))
|
||||
import Data.Tagged (Tagged (..))
|
||||
|
|
@ -86,6 +83,7 @@ import Plutarch.Api.V2 (
|
|||
validatorHash,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (AssetClass (AssetClass))
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1.Address (scriptHashAddress)
|
||||
import PlutusLedgerApi.V1.Value (TokenName, Value)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value (
|
||||
|
|
|
|||
|
|
@ -21,7 +21,6 @@ import Agora.Governor (Governor (gtClassRef))
|
|||
import Agora.Proposal (ProposalId (ProposalId))
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake (ProposalLock (Created), StakeDatum (..))
|
||||
import Agora.Utils (validatorHashToTokenName)
|
||||
import Data.Semigroup (stimesMonoid)
|
||||
import Data.Tagged (Tagged)
|
||||
import Plutarch.Context (
|
||||
|
|
@ -36,6 +35,7 @@ import Plutarch.Context (
|
|||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import PlutusLedgerApi.V2 (
|
||||
|
|
|
|||
|
|
@ -4,7 +4,6 @@ module Sample.Stake.UnauthorizedMintingExploit (
|
|||
mkTestCase,
|
||||
) where
|
||||
|
||||
import Agora.Utils (validatorHashToTokenName)
|
||||
import Plutarch.Context (
|
||||
input,
|
||||
mint,
|
||||
|
|
@ -14,6 +13,7 @@ import Plutarch.Context (
|
|||
withValue,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (assetClassValue)
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import Sample.Shared (
|
||||
minAda,
|
||||
|
|
|
|||
|
|
@ -11,10 +11,6 @@ module Agora.AuthorityToken (
|
|||
singleAuthorityTokenBurned,
|
||||
) where
|
||||
|
||||
import Agora.Utils (
|
||||
passert,
|
||||
psymbolValueOf',
|
||||
)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (..),
|
||||
PCurrencySymbol (..),
|
||||
|
|
@ -33,6 +29,7 @@ import Plutarch.Api.V2 (
|
|||
PTxOut (PTxOut),
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (PAssetClassData, ptoScottEncoding)
|
||||
import Plutarch.Extra.Bool (passert)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (plookupAssoc)
|
||||
import Plutarch.Extra.Maybe (pfromJust)
|
||||
import Plutarch.Extra.ScriptContext (pisTokenSpent)
|
||||
|
|
@ -44,7 +41,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
|||
pmatchC,
|
||||
)
|
||||
import Plutarch.Extra.Traversable (pfoldMap)
|
||||
import Plutarch.Extra.Value (psymbolValueOf)
|
||||
import Plutarch.Extra.Value (psymbolValueOf, psymbolValueOf')
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -26,7 +26,6 @@ import Agora.Governor (
|
|||
PGovernorRedeemer,
|
||||
)
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import Agora.Utils (pfromSingleton, ptryFromRedeemer)
|
||||
import Plutarch.Api.V1 (PCurrencySymbol, PValidatorHash)
|
||||
import Plutarch.Api.V2 (
|
||||
PScriptPurpose (PSpending),
|
||||
|
|
@ -38,9 +37,15 @@ import Plutarch.DataRepr (
|
|||
PDataFields,
|
||||
)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (ptryFromSingleton)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pdnothing)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.=))
|
||||
import Plutarch.Extra.ScriptContext (paddressFromValidatorHash, pfromOutputDatum, pisScriptAddress)
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
paddressFromValidatorHash,
|
||||
pisScriptAddress,
|
||||
ptryFromOutputDatum,
|
||||
ptryFromRedeemer,
|
||||
)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC)
|
||||
import Plutarch.Extra.Value (psymbolValueOf)
|
||||
import Plutarch.Lift (PConstantDecl, PLifted, PUnsafeLiftDecl)
|
||||
|
|
@ -216,11 +221,11 @@ mutateGovernorValidator =
|
|||
|
||||
let governorOutput =
|
||||
ptrace "Only governor output is allowed" $
|
||||
pfromSingleton # pfromData txInfoF.outputs
|
||||
ptryFromSingleton # pfromData txInfoF.outputs
|
||||
|
||||
governorOutputDatum =
|
||||
ptrace "Resolve governor outoput datum" $
|
||||
pfromOutputDatum @PGovernorDatum
|
||||
ptryFromOutputDatum @PGovernorDatum
|
||||
# (pfield @"datum" # governorOutput)
|
||||
# txInfoF.datums
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,6 @@ module Agora.Effect.TreasuryWithdrawal (
|
|||
|
||||
import Agora.Effect (makeEffect)
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import Agora.Utils (pdelete)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential,
|
||||
PCurrencySymbol,
|
||||
|
|
@ -35,6 +34,7 @@ import Plutarch.DataRepr (
|
|||
PDataFields,
|
||||
)
|
||||
import Plutarch.Extra.Field (pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pdeleteFirst)
|
||||
import Plutarch.Extra.ScriptContext (pisPubKey)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC)
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
|
||||
|
|
@ -178,7 +178,7 @@ treasuryWithdrawalValidator = plam $
|
|||
(ptraceError "Invalid receiver")
|
||||
|
||||
pure $
|
||||
pmatch (pdelete # credValue # receivers) $ \case
|
||||
pmatch (pdeleteFirst # credValue # receivers) $ \case
|
||||
PJust updatedReceivers ->
|
||||
ptrace "Receiver output" updatedReceivers
|
||||
PNothing ->
|
||||
|
|
|
|||
|
|
@ -40,10 +40,6 @@ import Agora.Stake (
|
|||
pnumCreatedProposals,
|
||||
presolveStakeInputDatum,
|
||||
)
|
||||
import Agora.Utils (
|
||||
plistEqualsBy,
|
||||
pscriptHashToTokenName,
|
||||
)
|
||||
import Plutarch.Api.V1 (PCurrencySymbol)
|
||||
import Plutarch.Api.V1.AssocMap (plookup)
|
||||
import Plutarch.Api.V1.AssocMap qualified as AssocMap
|
||||
|
|
@ -57,17 +53,18 @@ import Plutarch.Api.V2 (
|
|||
)
|
||||
import Plutarch.Extra.AssetClass (PAssetClassData, passetClass, ptoScottEncoding)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, plistEqualsBy, pmapMaybe)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.Map (pkeys, ptryLookup)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pjust, pmaybe, pmaybeData, pnothing)
|
||||
import Plutarch.Extra.Ord (psort)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
pfindTxInByTxOutRef,
|
||||
pfromDatumHash,
|
||||
pfromOutputDatum,
|
||||
pisUTXOSpent,
|
||||
pscriptHashFromAddress,
|
||||
pscriptHashToTokenName,
|
||||
ptryFromDatumHash,
|
||||
ptryFromOutputDatum,
|
||||
pvalueSpent,
|
||||
)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
||||
|
|
@ -153,7 +150,7 @@ governorPolicy =
|
|||
|
||||
governorDatum =
|
||||
ptrace "Resolve governor datum" $
|
||||
pfromOutputDatum @PGovernorDatum
|
||||
ptryFromOutputDatum @PGovernorDatum
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
in pif isGovernorUTxO (pjust # governorDatum) pnothing
|
||||
|
|
@ -323,7 +320,7 @@ governorValidator =
|
|||
|
||||
datum =
|
||||
ptrace "Resolve governor datum" $
|
||||
pfromOutputDatum @PGovernorDatum
|
||||
ptryFromOutputDatum @PGovernorDatum
|
||||
# outputF.datum
|
||||
# txInfoF.datums
|
||||
in pif
|
||||
|
|
@ -350,7 +347,7 @@ governorValidator =
|
|||
proposalDatum =
|
||||
ptrace "Resolve proposal output datum" $
|
||||
pfromData $
|
||||
pfromOutputDatum
|
||||
ptryFromOutputDatum
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
in pif isProposalUTxO (pjust # proposalDatum) pnothing
|
||||
|
|
@ -546,7 +543,7 @@ governorValidator =
|
|||
#== 1
|
||||
|
||||
let hasCorrectDatum =
|
||||
effect.datumHash #== pfromDatumHash # outputF.datum
|
||||
effect.datumHash #== ptryFromDatumHash # outputF.datum
|
||||
|
||||
pguardC "Authority output valid" $
|
||||
foldr1
|
||||
|
|
@ -568,7 +565,7 @@ governorValidator =
|
|||
-- The sorted hashes of all the GAT receivers.
|
||||
actualReceivers =
|
||||
psort
|
||||
#$ pmapMaybe
|
||||
#$ pmapMaybe @PList
|
||||
# getReceiverScriptHash
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
|
|
|
|||
|
|
@ -3,12 +3,13 @@
|
|||
module Agora.Linker (linker, AgoraScriptInfo (..)) where
|
||||
|
||||
import Agora.Governor (Governor (gstOutRef, gtClassRef, maximumCosigners))
|
||||
import Agora.Utils (validatorHashToAddress, validatorHashToTokenName)
|
||||
import Agora.Utils (validatorHashToAddress)
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Map (fromList)
|
||||
import Data.Tagged (untag)
|
||||
import Plutarch.Api.V2 (mintingPolicySymbol, validatorHash)
|
||||
import Plutarch.Extra.AssetClass (AssetClass (AssetClass))
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1 (Address, CurrencySymbol, TxOutRef, ValidatorHash)
|
||||
import Ply (
|
||||
ScriptRole (MintingPolicyRole, ValidatorRole),
|
||||
|
|
|
|||
|
|
@ -35,13 +35,6 @@ import Agora.Stake (
|
|||
pisVoter,
|
||||
presolveStakeInputDatum,
|
||||
)
|
||||
import Agora.Utils (
|
||||
pfromSingleton,
|
||||
pinsertUniqueBy,
|
||||
plistEqualsBy,
|
||||
pmapMaybe,
|
||||
ptryFromRedeemer,
|
||||
)
|
||||
import Plutarch.Api.V1 (PCredential, PCurrencySymbol)
|
||||
import Plutarch.Api.V1.AssocMap (plookup)
|
||||
import Plutarch.Api.V2 (
|
||||
|
|
@ -56,7 +49,12 @@ import Plutarch.Extra.AssetClass (
|
|||
)
|
||||
import Plutarch.Extra.Category (PCategory (pidentity))
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (
|
||||
pfindJust,
|
||||
plistEqualsBy,
|
||||
pmapMaybe,
|
||||
ptryFromSingleton,
|
||||
)
|
||||
import "plutarch-extra" Plutarch.Extra.Map (pupdate)
|
||||
import Plutarch.Extra.Maybe (
|
||||
passertPJust,
|
||||
|
|
@ -66,11 +64,12 @@ import Plutarch.Extra.Maybe (
|
|||
pmaybe,
|
||||
pnothing,
|
||||
)
|
||||
import Plutarch.Extra.Ord (pfromOrdBy, psort)
|
||||
import Plutarch.Extra.Ord (pfromOrdBy, pinsertUniqueBy, psort)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
pfindTxInByTxOutRef,
|
||||
pfromOutputDatum,
|
||||
ptryFromOutputDatum,
|
||||
ptryFromRedeemer,
|
||||
)
|
||||
import Plutarch.Extra.Sum (PSum (PSum))
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
||||
|
|
@ -309,7 +308,7 @@ proposalValidator =
|
|||
-- Using inline datum to avoid O(n^2) lookup.
|
||||
pfromData $
|
||||
ptrace "Resolve proposal datum" $
|
||||
pfromOutputDatum @(PAsData PProposalDatum)
|
||||
ptryFromOutputDatum @(PAsData PProposalDatum)
|
||||
# outputF.datum
|
||||
# txInfoF.datums
|
||||
in pif
|
||||
|
|
@ -348,7 +347,7 @@ proposalValidator =
|
|||
pletC $
|
||||
plam $
|
||||
let stakeInputs =
|
||||
pmapMaybe
|
||||
pmapMaybe @PList
|
||||
# resolveStakeInputDatum
|
||||
# pfromData txInfoF.inputs
|
||||
|
||||
|
|
@ -439,7 +438,7 @@ proposalValidator =
|
|||
stakeF <-
|
||||
pletFieldsC @'["owner", "stakedAmount"] $
|
||||
ptrace "Exactly one stake input" $
|
||||
pfromSingleton # sctxF.inputStakes
|
||||
ptryFromSingleton # sctxF.inputStakes
|
||||
|
||||
let newCosigner = stakeF.owner
|
||||
|
||||
|
|
|
|||
|
|
@ -30,7 +30,6 @@ module Agora.Proposal.Time (
|
|||
pisWithin,
|
||||
) where
|
||||
|
||||
import Agora.Utils (pcurrentTimeDuration)
|
||||
import Control.Composition ((.*))
|
||||
import Data.Functor ((<&>))
|
||||
import Plutarch.Api.V1 (
|
||||
|
|
@ -52,6 +51,7 @@ import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
|
|||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pmatchC)
|
||||
import Plutarch.Extra.Time (
|
||||
PCurrentTime (PCurrentTime),
|
||||
pcurrentTimeDuration,
|
||||
pisWithinCurrentTime,
|
||||
)
|
||||
import Plutarch.Lift (
|
||||
|
|
|
|||
|
|
@ -50,7 +50,6 @@ import Agora.Proposal (
|
|||
ResultTag,
|
||||
)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Utils (pmapMaybe, ppureIf)
|
||||
import Data.Tagged (Tagged)
|
||||
import Generics.SOP qualified as SOP
|
||||
import Plutarch.Api.V1 (PCredential)
|
||||
|
|
@ -67,15 +66,16 @@ import Plutarch.DataRepr (
|
|||
DerivePConstantViaData (DerivePConstantViaData),
|
||||
PDataFields,
|
||||
)
|
||||
import Plutarch.Extra.Applicative (ppureIf)
|
||||
import Plutarch.Extra.AssetClass (PAssetClass)
|
||||
import Plutarch.Extra.Field (pletAll)
|
||||
import Plutarch.Extra.IsData (
|
||||
DerivePConstantViaDataList (DerivePConstantViaDataList),
|
||||
ProductIsData (ProductIsData),
|
||||
)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing)
|
||||
import Plutarch.Extra.ScriptContext (pfromOutputDatum)
|
||||
import Plutarch.Extra.ScriptContext (ptryFromOutputDatum)
|
||||
import Plutarch.Extra.Sum (PSum (PSum))
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import Plutarch.Extra.Traversable (pfoldMap)
|
||||
|
|
@ -734,7 +734,7 @@ presolveStakeInputDatum = phoistAcyclic $
|
|||
datum =
|
||||
ptrace "Resolve stake datum" $
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PStakeDatum)
|
||||
ptryFromOutputDatum @(PAsData PStakeDatum)
|
||||
# txOutF.datum
|
||||
# datums
|
||||
in pif
|
||||
|
|
|
|||
|
|
@ -48,10 +48,10 @@ import Agora.Stake (
|
|||
),
|
||||
pstakeLocked,
|
||||
)
|
||||
import Agora.Utils (pfromSingleton, pisSingleton, pmustDeleteBy)
|
||||
import Plutarch.Api.V1.Address (PCredential)
|
||||
import Plutarch.Api.V2 (PMaybeData)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pisSingleton, ptryDeleteFirstBy, ptryFromSingleton)
|
||||
import Plutarch.Extra.Maybe (pdjust, pdnothing, pmaybeData)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pmatchC)
|
||||
|
|
@ -87,7 +87,7 @@ pbatchUpdateInputs = phoistAcyclic $
|
|||
plam $ \f -> flip pmatch $ \ctxF ->
|
||||
pnull
|
||||
#$ pfoldr
|
||||
# (pmustDeleteBy # f)
|
||||
# plam (\x -> ptryDeleteFirstBy # (f # x))
|
||||
# ctxF.stakeOutputDatums
|
||||
# ctxF.stakeInputDatums
|
||||
|
||||
|
|
@ -387,12 +387,12 @@ pdepositWithdraw = phoistAcyclic $
|
|||
stakeInputDatum <-
|
||||
pletC $
|
||||
ptrace "Single stake input" $
|
||||
pfromSingleton # ctxF.stakeInputDatums
|
||||
ptryFromSingleton # ctxF.stakeInputDatums
|
||||
stakeInputDatumF <- pletAllC stakeInputDatum
|
||||
|
||||
let stakeOutputDatum =
|
||||
ptrace "Single stake output" $
|
||||
pfromSingleton # ctxF.stakeOutputDatums
|
||||
ptryFromSingleton # ctxF.stakeOutputDatums
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -52,13 +52,7 @@ import Agora.Stake.Redeemers (
|
|||
ppermitVote,
|
||||
pretractVote,
|
||||
)
|
||||
import Agora.Utils (
|
||||
passert,
|
||||
pisDNothing,
|
||||
pmapMaybe,
|
||||
psymbolValueOf',
|
||||
pvalidatorHashToTokenName,
|
||||
)
|
||||
import Agora.Utils (pisDNothing)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (PPubKeyCredential, PScriptCredential),
|
||||
PCurrencySymbol,
|
||||
|
|
@ -79,9 +73,10 @@ import Plutarch.Extra.AssetClass (
|
|||
passetClass,
|
||||
ptoScottEncoding,
|
||||
)
|
||||
import Plutarch.Extra.Bool (passert)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import Plutarch.Extra.Functor (PFunctor (pfmap))
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
|
||||
import Plutarch.Extra.Maybe (
|
||||
passertPJust,
|
||||
pfromJust,
|
||||
|
|
@ -93,7 +88,8 @@ import Plutarch.Extra.Maybe (
|
|||
import Plutarch.Extra.Ord (POrdering (PEQ, PGT, PLT), pcompareBy, pfromOrd)
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
pfindTxInByTxOutRef,
|
||||
pfromOutputDatum,
|
||||
ptryFromOutputDatum,
|
||||
pvalidatorHashToTokenName,
|
||||
pvalueSpent,
|
||||
)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
||||
|
|
@ -106,6 +102,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
|||
import Plutarch.Extra.Value (
|
||||
passetClassValueOf,
|
||||
psymbolValueOf,
|
||||
psymbolValueOf',
|
||||
)
|
||||
import Plutarch.Num (PNum (pnegate))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
|
|
@ -197,7 +194,7 @@ stakePolicy =
|
|||
datumF <-
|
||||
pletAllC $
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PStakeDatum)
|
||||
ptryFromOutputDatum @(PAsData PStakeDatum)
|
||||
# outputF.datum
|
||||
# txInfoF.datums
|
||||
|
||||
|
|
@ -277,10 +274,11 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
#$ pfield @"address"
|
||||
# validatedInput
|
||||
|
||||
let sstName = pvalidatorHashToTokenName #$ pmatch stakeValidatorCredential $
|
||||
\case
|
||||
PScriptCredential r -> pfield @"_0" # r
|
||||
_ -> perror
|
||||
let sstName = pvalidatorHashToTokenName $
|
||||
pmatch stakeValidatorCredential $
|
||||
\case
|
||||
PScriptCredential r -> pfield @"_0" # r
|
||||
_ -> perror
|
||||
|
||||
sstClass <- pletC $ passetClass # sstSymbol # sstName
|
||||
|
||||
|
|
@ -310,7 +308,7 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
datum =
|
||||
ptrace "Resolve stake datum" $
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PStakeDatum)
|
||||
ptryFromOutputDatum @(PAsData PStakeDatum)
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
in passert
|
||||
|
|
@ -439,7 +437,7 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
#== 1
|
||||
proposalDatum =
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PProposalDatum)
|
||||
ptryFromOutputDatum @(PAsData PProposalDatum)
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
in pif isProposalUTxO (pjust # proposalDatum) pnothing
|
||||
|
|
|
|||
|
|
@ -8,101 +8,22 @@ Description: Plutarch utility functions that should be upstreamed or don't belon
|
|||
Plutarch utility functions that should be upstreamed or don't belong anywhere else.
|
||||
-}
|
||||
module Agora.Utils (
|
||||
validatorHashToTokenName,
|
||||
validatorHashToAddress,
|
||||
pltAsData,
|
||||
withBuiltinPairAsData,
|
||||
pvalidatorHashToTokenName,
|
||||
pscriptHashToTokenName,
|
||||
scriptHashToTokenName,
|
||||
plistEqualsBy,
|
||||
pstringIntercalate,
|
||||
punwords,
|
||||
pcurrentTimeDuration,
|
||||
pdelete,
|
||||
pdeleteBy,
|
||||
pmustDeleteBy,
|
||||
pisSingleton,
|
||||
pfromSingleton,
|
||||
pmapMaybe,
|
||||
PAlternative (..),
|
||||
ppureIf,
|
||||
pltBy,
|
||||
pinsertUniqueBy,
|
||||
ptryFromRedeemer,
|
||||
passert,
|
||||
pisNothing,
|
||||
pisDNothing,
|
||||
psymbolValueOf',
|
||||
) where
|
||||
|
||||
import Plutarch.Api.V1 (
|
||||
KeyGuarantees (Unsorted),
|
||||
PPOSIXTime,
|
||||
PRedeemer,
|
||||
PValidatorHash,
|
||||
)
|
||||
import Plutarch.Api.V1.AssocMap (PMap, plookup)
|
||||
import Plutarch.Api.V2 (
|
||||
AmountGuarantees,
|
||||
PCurrencySymbol,
|
||||
PMaybeData (PDNothing),
|
||||
PScriptHash,
|
||||
PScriptPurpose,
|
||||
PTokenName,
|
||||
PValue,
|
||||
)
|
||||
import Plutarch.Extra.Applicative (PApplicative (ppure))
|
||||
import Plutarch.Extra.Category (PCategory (pidentity))
|
||||
import Plutarch.Extra.Functor (PFunctor (PSubcategory, pfmap))
|
||||
import Plutarch.Extra.Maybe (pjust, pnothing)
|
||||
import Plutarch.Extra.Ord (PComparator, POrdering (PLT), pcompareBy, pequateBy)
|
||||
import Plutarch.Extra.Time (PCurrentTime (PCurrentTime))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import PlutusLedgerApi.V2 (
|
||||
Address (Address),
|
||||
Credential (ScriptCredential),
|
||||
ScriptHash (ScriptHash),
|
||||
TokenName (TokenName),
|
||||
ValidatorHash (ValidatorHash),
|
||||
ValidatorHash,
|
||||
)
|
||||
|
||||
{- Functions which should (probably) not be upstreamed
|
||||
All of these functions are quite inefficient.
|
||||
-}
|
||||
|
||||
{- | Safely convert a 'ValidatorHash' into a 'TokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
validatorHashToTokenName :: ValidatorHash -> TokenName
|
||||
validatorHashToTokenName (ValidatorHash hash) = TokenName hash
|
||||
|
||||
{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pvalidatorHashToTokenName :: forall (s :: S). Term s (PValidatorHash :--> PTokenName)
|
||||
pvalidatorHashToTokenName = phoistAcyclic $ plam punsafeCoerce
|
||||
|
||||
{- | Safely convert a 'PScriptHash' into a 'PTokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
scriptHashToTokenName :: ScriptHash -> TokenName
|
||||
scriptHashToTokenName (ScriptHash hash) = TokenName hash
|
||||
|
||||
{- | Safely convert a 'PScriptHash' into a 'PTokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pscriptHashToTokenName :: forall (s :: S). Term s PScriptHash -> Term s PTokenName
|
||||
pscriptHashToTokenName = punsafeCoerce
|
||||
|
||||
{- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
|
||||
|
||||
@since 0.1.0
|
||||
|
|
@ -110,62 +31,6 @@ pscriptHashToTokenName = punsafeCoerce
|
|||
validatorHashToAddress :: ValidatorHash -> Address
|
||||
validatorHashToAddress vh = Address (ScriptCredential vh) Nothing
|
||||
|
||||
{- | Compare two 'PAsData' value, return true if the first one is less than the second one.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
pltAsData ::
|
||||
forall (a :: PType) (s :: S).
|
||||
(POrd a, PIsData a) =>
|
||||
Term s (PAsData a :--> PAsData a :--> PBool)
|
||||
pltAsData = phoistAcyclic $
|
||||
plam $
|
||||
\(pfromData -> l) (pfromData -> r) -> l #< r
|
||||
|
||||
{- | Extract data stored in a 'PBuiltinPair' and call a function to process it.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
withBuiltinPairAsData ::
|
||||
forall (a :: PType) (b :: PType) (c :: PType) (s :: S).
|
||||
(PIsData a, PIsData b) =>
|
||||
(Term s a -> Term s b -> Term s c) ->
|
||||
Term
|
||||
s
|
||||
(PBuiltinPair (PAsData a) (PAsData b)) ->
|
||||
Term s c
|
||||
withBuiltinPairAsData f p =
|
||||
let a = pfromData $ pfstBuiltin # p
|
||||
b = pfromData $ psndBuiltin # p
|
||||
in f a b
|
||||
|
||||
-- | @since 1.0.0
|
||||
plistEqualsBy ::
|
||||
forall
|
||||
(list1 :: PType -> PType)
|
||||
(list2 :: PType -> PType)
|
||||
(a :: PType)
|
||||
(b :: PType)
|
||||
(s :: S).
|
||||
(PIsListLike list1 a, PIsListLike list2 b) =>
|
||||
Term s ((a :--> b :--> PBool) :--> list1 a :--> list2 b :--> PBool)
|
||||
plistEqualsBy = phoistAcyclic $
|
||||
plam $ \eq -> pfix #$ plam $ \self l1 l2 ->
|
||||
pelimList
|
||||
( \x xs ->
|
||||
pelimList
|
||||
( \y ys ->
|
||||
-- Avoid comparison if two lists have different length.
|
||||
self # xs # ys #&& eq # x # y
|
||||
)
|
||||
-- l2 is empty, but l1 is not.
|
||||
(pconstant False)
|
||||
l2
|
||||
)
|
||||
-- l1 is empty, so l2 should be empty as well.
|
||||
(pnull # l2)
|
||||
l1
|
||||
|
||||
-- | @since 1.0.0
|
||||
pstringIntercalate ::
|
||||
forall (s :: S).
|
||||
|
|
@ -183,225 +48,6 @@ punwords ::
|
|||
Term s PString
|
||||
punwords = pstringIntercalate " "
|
||||
|
||||
-- | @since 1.0.0
|
||||
pcurrentTimeDuration ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PCurrentTime
|
||||
:--> PPOSIXTime
|
||||
)
|
||||
pcurrentTimeDuration = phoistAcyclic $
|
||||
plam $
|
||||
flip pmatch $
|
||||
\(PCurrentTime lb ub) -> ub - lb
|
||||
|
||||
{- | / O(n) /. Remove the first occurance of a value from the given list.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pdelete ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PEq a, PIsListLike list a) =>
|
||||
Term s (a :--> list a :--> PMaybe (list a))
|
||||
pdelete = phoistAcyclic $ pdeleteBy # plam (#==)
|
||||
|
||||
-- | @since 1.0.0
|
||||
pdeleteBy ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s ((a :--> a :--> PBool) :--> a :--> list a :--> PMaybe (list a))
|
||||
pdeleteBy = phoistAcyclic $
|
||||
plam $ \f' x -> plet (f' # x) $ \f ->
|
||||
precList
|
||||
( \self h t ->
|
||||
pif
|
||||
(f # h)
|
||||
(pjust # t)
|
||||
(pfmap # (pcons # h) # (self # t))
|
||||
)
|
||||
(const pnothing)
|
||||
|
||||
-- | @since 1.0.0
|
||||
pmustDeleteBy ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s ((a :--> a :--> PBool) :--> a :--> list a :--> list a)
|
||||
pmustDeleteBy = phoistAcyclic $
|
||||
plam $ \f' x -> plet (f' # x) $ \f ->
|
||||
precList
|
||||
( \self h t ->
|
||||
pif
|
||||
(f # h)
|
||||
t
|
||||
(pcons # h #$ self # t)
|
||||
)
|
||||
(const $ ptraceError "Cannot delete element")
|
||||
|
||||
{- | / O(1) /.Return true if the given list has only one element.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pisSingleton ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s (list a :--> PBool)
|
||||
pisSingleton =
|
||||
phoistAcyclic $
|
||||
precList
|
||||
(\_ _ t -> pnull # t)
|
||||
(const $ pconstant False)
|
||||
|
||||
{- Throws an error if the given list contains zero or more than one elements.
|
||||
Otherwise returns the only element.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pfromSingleton ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s (list a :--> a)
|
||||
pfromSingleton =
|
||||
phoistAcyclic $
|
||||
precList
|
||||
( \_ h t ->
|
||||
pif
|
||||
(pnull # t)
|
||||
h
|
||||
(ptraceError "More than one element")
|
||||
)
|
||||
(const $ ptraceError "Empty list")
|
||||
|
||||
{- | A version of 'pmap' which can throw out elements and change the list type
|
||||
along the way.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pmapMaybe ::
|
||||
forall
|
||||
(listO :: PType -> PType)
|
||||
(b :: PType)
|
||||
(listI :: PType -> PType)
|
||||
(a :: PType)
|
||||
(s :: S).
|
||||
(PIsListLike listI a, PIsListLike listO b) =>
|
||||
Term s ((a :--> PMaybe b) :--> listI a :--> listO b)
|
||||
pmapMaybe = phoistAcyclic $
|
||||
plam $ \f ->
|
||||
precList
|
||||
( \self h t ->
|
||||
pmatch
|
||||
(f # h)
|
||||
( \case
|
||||
PJust x -> pcons # x
|
||||
PNothing -> pidentity
|
||||
)
|
||||
# (self # t)
|
||||
)
|
||||
(const pnil)
|
||||
|
||||
infixl 3 #<|>
|
||||
|
||||
-- | @since 1.0.0
|
||||
class (PApplicative f) => PAlternative (f :: PType -> PType) where
|
||||
(#<|>) ::
|
||||
forall (a :: PType) (s :: S).
|
||||
(PSubcategory f a) =>
|
||||
Term s (f a :--> f a :--> f a)
|
||||
pempty ::
|
||||
forall (a :: PType) (s :: S).
|
||||
(PSubcategory f a) =>
|
||||
Term s (f a)
|
||||
|
||||
-- | @since 1.0.0
|
||||
instance PAlternative PMaybe where
|
||||
(#<|>) = phoistAcyclic $
|
||||
plam $ \a b -> pmatch a $ \case
|
||||
PNothing -> b
|
||||
PJust _ -> a
|
||||
pempty = pnothing
|
||||
|
||||
-- | @since 1.0.0
|
||||
ppureIf ::
|
||||
forall
|
||||
(f :: PType -> PType)
|
||||
(a :: PType)
|
||||
(s :: S).
|
||||
(PAlternative f, PSubcategory f a) =>
|
||||
Term s (PBool :--> a :--> f a)
|
||||
ppureIf = phoistAcyclic $
|
||||
plam $ \cond x ->
|
||||
pif
|
||||
cond
|
||||
(ppure # x)
|
||||
pempty
|
||||
|
||||
{- | Less then check using a `PComparator`.
|
||||
|
||||
@ since 1.0.0
|
||||
-}
|
||||
pltBy ::
|
||||
forall (a :: PType) (s :: S).
|
||||
Term
|
||||
s
|
||||
( PComparator a
|
||||
:--> a
|
||||
:--> a
|
||||
:--> PBool
|
||||
)
|
||||
pltBy = phoistAcyclic $
|
||||
plam $ \c x y ->
|
||||
pcompareBy # c # x # y #== pcon PLT
|
||||
|
||||
-- | @since 1.0.0
|
||||
pinsertUniqueBy ::
|
||||
forall (list :: PType -> PType) (a :: PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s (PComparator a :--> a :--> list a :--> list a)
|
||||
pinsertUniqueBy = phoistAcyclic $
|
||||
plam $ \c x ->
|
||||
let lt = pltBy # c
|
||||
eq = pequateBy # c
|
||||
in precList
|
||||
( \self h t ->
|
||||
let ensureUniqueness =
|
||||
pif
|
||||
(eq # x # h)
|
||||
(ptraceError "inserted value already exists")
|
||||
next =
|
||||
pif
|
||||
(lt # x # h)
|
||||
(pcons # x #$ pcons # h # t)
|
||||
(pcons # h #$ self # t)
|
||||
in ensureUniqueness next
|
||||
)
|
||||
(const $ psingleton # x)
|
||||
|
||||
-- | @since 1.0.0
|
||||
ptryFromRedeemer ::
|
||||
forall (r :: PType) (s :: S).
|
||||
(PTryFrom PData r) =>
|
||||
Term
|
||||
s
|
||||
( PScriptPurpose
|
||||
:--> PMap 'Unsorted PScriptPurpose PRedeemer
|
||||
:--> PMaybe r
|
||||
)
|
||||
ptryFromRedeemer = phoistAcyclic $
|
||||
plam $ \p m ->
|
||||
pfmap
|
||||
# plam (flip ptryFrom fst . pto)
|
||||
# (plookup # p # m)
|
||||
|
||||
-- | @since 1.0.0
|
||||
passert ::
|
||||
forall (a :: PType) (s :: S).
|
||||
Term s PString ->
|
||||
Term s PBool ->
|
||||
Term s a ->
|
||||
Term s a
|
||||
passert msg cond x = pif cond x $ ptraceError msg
|
||||
|
||||
-- | @since 1.0.0
|
||||
pisNothing ::
|
||||
forall (a :: PType) (s :: S).
|
||||
|
|
@ -421,46 +67,3 @@ pisDNothing = phoistAcyclic $
|
|||
flip pmatch $ \case
|
||||
PDNothing _ -> pconstant True
|
||||
_ -> pconstant False
|
||||
|
||||
{- | Get the negative and positive amount of a particular 'CurrencySymbol', and
|
||||
return nothing if it doesn't exist in the value.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
psymbolValueOf' ::
|
||||
forall
|
||||
(keys :: KeyGuarantees)
|
||||
(amounts :: AmountGuarantees)
|
||||
(s :: S).
|
||||
Term
|
||||
s
|
||||
( PCurrencySymbol
|
||||
:--> PValue keys amounts
|
||||
:--> PMaybe
|
||||
( PPair
|
||||
-- Positive amount
|
||||
PInteger
|
||||
-- Negative amount
|
||||
PInteger
|
||||
)
|
||||
)
|
||||
psymbolValueOf' = phoistAcyclic $
|
||||
plam $ \sym value ->
|
||||
let tnMap = plookup # sym # pto value
|
||||
f =
|
||||
plam $
|
||||
( pfoldr
|
||||
# plam
|
||||
( \x r ->
|
||||
let q = pfromData $ psndBuiltin # x
|
||||
in pmatch r $ \(PPair p n) ->
|
||||
pif
|
||||
(0 #< q)
|
||||
(pcon $ PPair (p + q) n)
|
||||
(pcon $ PPair p (n + q))
|
||||
)
|
||||
# pcon (PPair 0 0)
|
||||
#
|
||||
)
|
||||
. pto
|
||||
in pfmap # f # tnMap
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue