remove Agora.MultiSig
This commit is contained in:
parent
01f055d923
commit
3af4a7438a
7 changed files with 1639 additions and 753 deletions
|
|
@ -15,7 +15,6 @@ import Agora.AuthorityToken qualified as AuthorityToken
|
|||
import Agora.Effect.GovernorMutation qualified as GovernorMutation
|
||||
import Agora.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawalEffect
|
||||
import Agora.Governor qualified as Governor
|
||||
import Agora.MultiSig qualified as MultiSig
|
||||
import Agora.Proposal qualified as Proposal
|
||||
import Agora.Stake qualified as Stake
|
||||
import Agora.Treasury qualified as Treasury
|
||||
|
|
@ -37,8 +36,6 @@ agoraTypes =
|
|||
mkSumType (Proxy @Governor.GovernorDatum)
|
||||
, mkSumType (Proxy @Governor.GovernorRedeemer)
|
||||
, mkSumType (Proxy @Governor.Governor)
|
||||
, -- MultiSig
|
||||
mkSumType (Proxy @MultiSig.MultiSig)
|
||||
, -- Stake
|
||||
mkSumType (Proxy @Stake.Stake)
|
||||
, mkSumType (Proxy @Stake.ProposalLock)
|
||||
|
|
|
|||
|
|
@ -1,107 +0,0 @@
|
|||
{- |
|
||||
Module : Property.MultiSig
|
||||
Maintainer : seungheon.ooh@gmail.com
|
||||
Description: Property tests for 'MultiSig' functions
|
||||
|
||||
Property model and tests for 'MultiSig' functions
|
||||
-}
|
||||
module Property.MultiSig (props) where
|
||||
|
||||
import Agora.MultiSig (
|
||||
MultiSig (MultiSig),
|
||||
PMultiSig,
|
||||
pvalidatedByMultisig,
|
||||
)
|
||||
import Data.Tagged (Tagged (Tagged))
|
||||
import Data.Universe (Finite (..), Universe (..))
|
||||
import Plutarch.Api.V1 (PScriptContext)
|
||||
import Plutarch.Context
|
||||
import Plutarch.Extra.TermCont (pletC)
|
||||
import PlutusLedgerApi.V1 (
|
||||
ScriptContext (..),
|
||||
ScriptPurpose (..),
|
||||
TxInfo (txInfoSignatories),
|
||||
TxOutRef (..),
|
||||
)
|
||||
import Property.Generator (genPubKeyHash)
|
||||
import Test.Tasty (TestTree)
|
||||
import Test.Tasty.Plutarch.Property (classifiedPropertyNative)
|
||||
import Test.Tasty.QuickCheck (
|
||||
Gen,
|
||||
Property,
|
||||
chooseInt,
|
||||
listOf,
|
||||
testProperty,
|
||||
vectorOf,
|
||||
)
|
||||
|
||||
-- | Model for testing multisigs.
|
||||
type MultiSigModel = (MultiSig, ScriptContext)
|
||||
|
||||
-- | Propositions that may hold true of a `MultiSigModel`.
|
||||
data MultiSigProp
|
||||
= -- | Sufficient number of signatories in the script context.
|
||||
MeetsMinSigs
|
||||
| -- | Insufficient number of signatories in the script context.
|
||||
DoesNotMeetMinSigs
|
||||
deriving stock (Eq, Show, Ord)
|
||||
|
||||
instance Universe MultiSigProp where
|
||||
universe = [MeetsMinSigs, DoesNotMeetMinSigs]
|
||||
|
||||
instance Finite MultiSigProp where
|
||||
universeF = universe
|
||||
cardinality = Tagged 2
|
||||
|
||||
-- | Generate model with given proposition.
|
||||
genMultiSigProp :: MultiSigProp -> Gen MultiSigModel
|
||||
genMultiSigProp prop = do
|
||||
size <- chooseInt (4, 20)
|
||||
pkhs <- vectorOf size genPubKeyHash
|
||||
minSig <- chooseInt (1, length pkhs)
|
||||
othersigners <- take 20 <$> listOf genPubKeyHash
|
||||
|
||||
let ms = MultiSig pkhs (toInteger minSig)
|
||||
|
||||
n <- case prop of
|
||||
MeetsMinSigs -> chooseInt (minSig, length pkhs)
|
||||
DoesNotMeetMinSigs -> chooseInt (0, minSig - 1)
|
||||
|
||||
let builder :: BaseBuilder
|
||||
builder = mconcat $ signedWith <$> take n pkhs <> othersigners
|
||||
txinfo = buildTxInfoUnsafe builder
|
||||
pure (ms, ScriptContext txinfo (Spending (TxOutRef "" 0)))
|
||||
|
||||
-- | Classify model into propositions.
|
||||
classifyMultiSigProp :: MultiSigModel -> MultiSigProp
|
||||
classifyMultiSigProp (MultiSig keys (fromIntegral -> minsig), ctx)
|
||||
| minsig <= length signer = MeetsMinSigs
|
||||
| otherwise = DoesNotMeetMinSigs
|
||||
where
|
||||
signer = filter (`elem` keys) $ txInfoSignatories . scriptContextTxInfo $ ctx
|
||||
|
||||
-- | Shrinker. Not used.
|
||||
shrinkMultiSigProp :: MultiSigModel -> [MultiSigModel]
|
||||
shrinkMultiSigProp = const []
|
||||
|
||||
-- | Expected behavior of @pvalidatedByMultisig@.
|
||||
expectedHs :: MultiSigModel -> Maybe Bool
|
||||
expectedHs model = case classifyMultiSigProp model of
|
||||
MeetsMinSigs -> Just True
|
||||
_ -> Just False
|
||||
|
||||
-- | Actual implementation of @pvalidatedByMultisig@.
|
||||
actual :: Term s (PBuiltinPair PMultiSig PScriptContext :--> PBool)
|
||||
actual = plam $ \x -> unTermCont $ do
|
||||
ms <- pletC $ pfstBuiltin # x
|
||||
sc <- pletC $ psndBuiltin # x
|
||||
pure $ pvalidatedByMultisig # ms # (pfield @"txInfo" # sc)
|
||||
|
||||
-- | Proposed property.
|
||||
prop :: Property
|
||||
prop = classifiedPropertyNative genMultiSigProp shrinkMultiSigProp expectedHs classifyMultiSigProp actual
|
||||
|
||||
props :: [TestTree]
|
||||
props =
|
||||
[ testProperty "MultiSig property" prop
|
||||
]
|
||||
|
|
@ -8,7 +8,6 @@ import Test.Tasty (defaultMain, testGroup)
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
import Property.Governor qualified as Governer
|
||||
import Property.MultiSig qualified as MultiSig
|
||||
import Spec.AuthorityToken qualified as AuthorityToken
|
||||
import Spec.Effect.GovernorMutation qualified as GovernorMutation
|
||||
import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
|
||||
|
|
@ -42,7 +41,4 @@ main = do
|
|||
, testGroup
|
||||
"Utility tests"
|
||||
Utils.tests
|
||||
, testGroup
|
||||
"Multisig tests"
|
||||
MultiSig.props
|
||||
]
|
||||
|
|
|
|||
|
|
@ -149,7 +149,6 @@ library
|
|||
Agora.Effect.TreasuryWithdrawal
|
||||
Agora.Governor
|
||||
Agora.Governor.Scripts
|
||||
Agora.MultiSig
|
||||
Agora.Plutarch.Orphans
|
||||
Agora.Proposal
|
||||
Agora.Proposal.Scripts
|
||||
|
|
@ -184,7 +183,6 @@ library agora-specs
|
|||
exposed-modules:
|
||||
Property.Generator
|
||||
Property.Governor
|
||||
Property.MultiSig
|
||||
Sample.Effect.GovernorMutation
|
||||
Sample.Effect.TreasuryWithdrawal
|
||||
Sample.Governor.Initialize
|
||||
|
|
|
|||
|
|
@ -1,137 +0,0 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- |
|
||||
Module : Agora.MultiSig
|
||||
Maintainer : riley_kilgore@outlook.com
|
||||
Description: A basic N of M multisignature validation function.
|
||||
|
||||
A basic N of M multisignature validation function.
|
||||
-}
|
||||
module Agora.MultiSig (
|
||||
validatedByMultisig,
|
||||
pvalidatedByMultisig,
|
||||
PMultiSig (..),
|
||||
MultiSig (..),
|
||||
) where
|
||||
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, I (I))
|
||||
import Plutarch.Api.V1 (
|
||||
PPubKeyHash,
|
||||
PTxInfo (..),
|
||||
)
|
||||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (DerivePConstantViaData),
|
||||
PDataFields,
|
||||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutarch.Extra.TermCont (pletFieldsC)
|
||||
import Plutarch.Lift (
|
||||
PConstantDecl,
|
||||
PLifted,
|
||||
PUnsafeLiftDecl,
|
||||
)
|
||||
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
|
||||
import PlutusTx qualified
|
||||
import Prelude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | A MultiSig represents a proof that a particular set of signatures
|
||||
are present on a transaction.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
data MultiSig = MultiSig
|
||||
{ keys :: [PubKeyHash]
|
||||
-- ^ List of PubKeyHashes that must be present in the list of signatories.
|
||||
, minSigs :: Integer
|
||||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
, -- | @since 0.1.0
|
||||
Eq
|
||||
, -- | @since 0.1.0
|
||||
Show
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
|
||||
PlutusTx.makeLift ''MultiSig
|
||||
PlutusTx.unstableMakeIsData ''MultiSig
|
||||
|
||||
{- | Plutarch-level MultiSig
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
newtype PMultiSig (s :: S) = PMultiSig
|
||||
{ getMultiSig ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "keys" ':= PBuiltinList (PAsData PPubKeyHash)
|
||||
, "minSigs" ':= PInteger
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
PIsDataRepr
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PDataFields
|
||||
)
|
||||
via (PIsDataReprInstances PMultiSig)
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PMultiSig where type PLifted PMultiSig = MultiSig
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstantDecl MultiSig)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Check if a Haskell-level MultiSig signs this transaction.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
validatedByMultisig :: MultiSig -> Term s (PTxInfo :--> PBool)
|
||||
validatedByMultisig params =
|
||||
phoistAcyclic $
|
||||
pvalidatedByMultisig # pconstant params
|
||||
|
||||
{- | Check if a Plutarch-level MultiSig signs this transaction.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
pvalidatedByMultisig :: Term s (PMultiSig :--> PTxInfo :--> PBool)
|
||||
pvalidatedByMultisig =
|
||||
phoistAcyclic $
|
||||
plam $ \multi' txInfo -> unTermCont $ do
|
||||
multi <- pletFieldsC @'["keys", "minSigs"] multi'
|
||||
let signatories = pfield @"signatories" # txInfo
|
||||
pure $
|
||||
pfromData multi.minSigs
|
||||
#<= ( plength #$ pfilter
|
||||
# plam
|
||||
( \a ->
|
||||
pelem # a # pfromData signatories
|
||||
)
|
||||
# multi.keys
|
||||
)
|
||||
2133
flake.lock
generated
2133
flake.lock
generated
File diff suppressed because it is too large
Load diff
|
|
@ -17,7 +17,7 @@
|
|||
"plutarch/haskell-nix/nixpkgs-unstable";
|
||||
|
||||
inputs.liqwid-plutarch-extra.url =
|
||||
"github:Liqwid-Labs/liqwid-plutarch-extra?rev=a951b85d15e7cca1a03dd2a8e36b60fae561d74a";
|
||||
"github:Liqwid-Labs/liqwid-plutarch-extra?ref=seungheonoh/agoraUtils";
|
||||
inputs.plutarch-numeric.url =
|
||||
"github:Liqwid-Labs/plutarch-numeric?ref=main";
|
||||
inputs.plutarch-safe-money.url =
|
||||
|
|
@ -29,8 +29,10 @@
|
|||
# Testing
|
||||
inputs.plutarch-quickcheck.url =
|
||||
"github:liqwid-labs/plutarch-quickcheck?ref=staging";
|
||||
|
||||
# PCB Rev is locked until Agora test have explicit Minting CS. Check PCB PR #12
|
||||
inputs.plutarch-context-builder.url =
|
||||
"github:Liqwid-Labs/plutarch-context-builder?ref=staging";
|
||||
"github:Liqwid-Labs/plutarch-context-builder?ref=62ab154fdcd8dd07a741e7955e078813aff4ed6a";
|
||||
|
||||
outputs = inputs@{ self, nixpkgs, nixpkgs-latest, haskell-nix, plutarch, ... }:
|
||||
let
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue