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

Merge branch 'master' of github.com:Liqwid-Labs/agora into jhodgdev/treasury-tests

Browse source
This commit is contained in:
Jack Hodgkinson 2022-03-25 11:13:30 +00:00
commit 5c9dfb4e0f
12 changed files with 88 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

5
Makefile
View file

@ -23,7 +23,10 @@ format:
git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.cabal' | xargs cabal-fmt -i
format_check:
find -name '*.hs' -not -path './dist-*/*' | xargs fourmolu $(FORMAT_EXTENSIONS) -m check
find -name '*.hs' \
-not -path './dist*/*' \
-not -path './haddock/*' \
| xargs fourmolu $(FORMAT_EXTENSIONS) -m check
haddock:
cabal haddock --haddock-html --haddock-hoogle --builddir=haddock

1
agora-test/Spec.hs
View file

@ -11,6 +11,7 @@ import Test.Tasty (defaultMain, testGroup)
import Spec.Model.MultiSig qualified as MultiSig
import Spec.Stake qualified as Stake
-- | The Agora test suite
main :: IO ()
main =
defaultMain $

10
agora-test/Spec/Model/MultiSig.hs
View file

@ -1,3 +1,10 @@
{- |
Module : Spec.Model.MultiSig
Maintainer : emi@haskell.fyi
Description: apropos-tx model and tests for 'MultiSig' functions
apropos-tx model and tests for 'MultiSig' functions
-}
module Spec.Model.MultiSig (
plutarchTests,
genTests,
@ -7,7 +14,6 @@ import Data.List (intersect)
--------------------------------------------------------------------------------
import Plutarch (compile)
import Plutus.V1.Ledger.Api (
Script,
ScriptContext (scriptContextPurpose),
@ -165,6 +171,7 @@ instance HasScriptRunner MultiSigProp MultiSigModel where
(pcon PUnit)
perror
-- | Consistency tests for the 'HasParameterisedGenerator' instance of 'MultiSigModel'
genTests :: TestTree
genTests =
testGroup "genTests" $
@ -175,6 +182,7 @@ genTests =
Yes
]
-- | Tests for the 'HasScriptRunner' instance of 'MultiSigModel'
plutarchTests :: TestTree
plutarchTests =
testGroup "plutarchTests" $

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

@ -58,25 +58,30 @@ import Spec.Util (datumPair, toDatumHash)
--------------------------------------------------------------------------------
-- | 'Stake' parameters for 'LQ'.
stake :: Stake LQ
stake = Stake
-- | 'Stake' policy instance.
policy :: MintingPolicy
policy = mkMintingPolicy (stakePolicy stake)
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
-- | This script context should be a valid transaction
-- | This script context should be a valid transaction.
stakeCreation :: ScriptContext
stakeCreation =
let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
@ -105,7 +110,7 @@ stakeCreation =
, scriptContextPurpose = Minting policySymbol
}
-- | This ScriptContext should fail because the datum has too much GT
-- | This ScriptContext should fail because the datum has too much GT.
stakeCreationWrongDatum :: ScriptContext
stakeCreationWrongDatum =
let datum :: Datum
@ -115,7 +120,7 @@ stakeCreationWrongDatum =
, scriptContextPurpose = Minting policySymbol
}
-- | This ScriptContext should fail because the datum has too much GT
-- | This ScriptContext should fail because the datum has too much GT.
stakeCreationUnsigned :: ScriptContext
stakeCreationUnsigned =
ScriptContext
@ -128,11 +133,15 @@ stakeCreationUnsigned =
--------------------------------------------------------------------------------
-- | Config for creating a ScriptContext that deposits or withdraws.
data DepositWithdrawExample = DepositWithdrawExample
{ startAmount :: Integer
-- ^ The amount of GT stored before the transaction.
, delta :: Integer
-- ^ The amount of GT deposited or withdrawn from the Stake.
}
-- | 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

8
agora-test/Spec/Stake.hs
View file

@ -1,3 +1,10 @@
{- |
Module : Spec.Stake
Maintainer : emi@haskell.fyi
Description: Tests for Stake policy and validator
Tests for Stake policy and validator
-}
module Spec.Stake (tests) where
--------------------------------------------------------------------------------
@ -20,6 +27,7 @@ import Spec.Util (policyFailsWith, policySucceedsWith, toDatum, validatorFailsWi
--------------------------------------------------------------------------------
-- | Stake tests
tests :: [TestTree]
tests =
[ testGroup

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

@ -1,3 +1,10 @@
{- |
Module : Spec.Util
Maintainer : emi@haskell.fyi
Description: Utility functions for testing Plutarch scripts with ScriptContext
Utility functions for testing Plutarch scripts with ScriptContext
-}
module Spec.Util (
-- * Testing utils
scriptSucceeds,
@ -7,7 +14,7 @@ module Spec.Util (
validatorSucceedsWith,
validatorFailsWith,
-- * Plutus land utils
-- * Plutus-land utils
datumHash,
toDatum,
toDatumHash,
@ -21,7 +28,7 @@ import Prelude
--------------------------------------------------------------------------------
import Codec.Serialise (serialise)
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Lazy qualified as ByteString.Lazy
--------------------------------------------------------------------------------
@ -30,13 +37,11 @@ import Test.Tasty.HUnit (assertFailure, testCase)
--------------------------------------------------------------------------------
import Plutarch
import Plutarch.Api.V1 (PMintingPolicy, PValidator)
import Plutarch.Builtin (pforgetData)
import Plutarch.Crypto (pblake2b_256)
import Plutarch.Evaluate (evalScript)
import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
import Plutarch.Prelude ()
import Plutus.V1.Ledger.Contexts (ScriptContext)
import Plutus.V1.Ledger.Scripts (Datum (Datum), DatumHash (DatumHash), Script)
import PlutusTx.Builtins qualified as PlutusTx
@ -44,6 +49,7 @@ import PlutusTx.IsData qualified as PlutusTx
--------------------------------------------------------------------------------
-- | Check that a policy script succeeds, given a name and arguments.
policySucceedsWith ::
( PLift redeemer
, PlutusTx.ToData (PLifted redeemer)
@ -61,6 +67,7 @@ policySucceedsWith tag policy redeemer scriptContext =
# pconstant scriptContext
)
-- | Check that a policy script fails, given a name and arguments.
policyFailsWith ::
( PLift redeemer
, PlutusTx.ToData (PLifted redeemer)
@ -78,6 +85,7 @@ policyFailsWith tag policy redeemer scriptContext =
# pconstant scriptContext
)
-- | Check that a validator script succeeds, given a name and arguments.
validatorSucceedsWith ::
( PLift datum
, PlutusTx.ToData (PLifted datum)
@ -99,6 +107,7 @@ validatorSucceedsWith tag policy datum redeemer scriptContext =
# pconstant scriptContext
)
-- | Check that a validator script fails, given a name and arguments.
validatorFailsWith ::
( PLift datum
, PlutusTx.ToData (PLifted datum)
@ -120,6 +129,7 @@ validatorFailsWith tag policy datum redeemer scriptContext =
# pconstant scriptContext
)
-- | Check that an arbitrary script doesn't error when evaluated, given a name.
scriptSucceeds :: String -> Script -> TestTree
scriptSucceeds name script = testCase name $ do
let (res, _budget, traces) = evalScript script
@ -130,6 +140,7 @@ scriptSucceeds name script = testCase name $ do
Right _v ->
pure ()
-- | Check that an arbitrary script **does** error when evaluated, given a name.
scriptFails :: String -> Script -> TestTree
scriptFails name script = testCase name $ do
let (res, _budget, traces) = evalScript script
@ -142,7 +153,7 @@ scriptFails name script = testCase name $ do
--------------------------------------------------------------------------------
{- | Create a pair from data for use in 'txInfoData'
{- | Create a pair from data for use in 'txInfoData'.
Example:
@
@ -152,17 +163,22 @@ scriptFails name script = testCase name $ do
datumPair :: PlutusTx.ToData a => a -> (DatumHash, Datum)
datumPair = (,) <$> toDatumHash <*> toDatum
-- | Calculate the blake2b-256 hash of a Datum.
datumHash :: Datum -> DatumHash
datumHash (Datum data') = toDatumHash data'
-- | Convenience function to create a Datum from any type that implements ToData.
toDatum :: PlutusTx.ToData a => a -> Datum
toDatum = Datum . PlutusTx.toBuiltinData
-- Shamelessly go through plutus.
{- | Calculate the blake2b-256 hash of any type that implements ToData
Shamelessly go through plutus.
-}
toDatumHash :: PlutusTx.ToData a => a -> DatumHash
toDatumHash datum =
DatumHash $
PlutusTx.toBuiltin $
plift $
pblake2b_256
# pconstant (LBS.toStrict $ serialise $ PlutusTx.toData datum)
# pconstant (ByteString.Lazy.toStrict $ serialise $ PlutusTx.toData datum)

1
agora/Agora/MultiSig.hs
View file

@ -10,6 +10,7 @@ A basic N of M multisignature validation function.
module Agora.MultiSig (
validatedByMultisig,
pvalidatedByMultisig,
PMultiSig (..),
MultiSig (..),
) where

14
agora/Agora/SafeMoney.hs
View file

@ -9,7 +9,6 @@ module Agora.SafeMoney (
-- * Types
MoneyClass,
PDiscrete,
Discrete,
-- * Utility functions
paddDiscrete,
@ -44,11 +43,11 @@ import Plutarch.Monadic qualified as P
--------------------------------------------------------------------------------
import Agora.Utils
import Agora.Utils (passetClassValueOf, psingletonValue)
--------------------------------------------------------------------------------
-- | Type-level unique identifier for an `AssetClass`
-- | Type-level unique identifier for an 'Plutus.V1.Ledger.Value.AssetClass'
type MoneyClass =
( -- AssetClass
Symbol
@ -63,10 +62,6 @@ newtype PDiscrete (mc :: MoneyClass) (s :: S)
= PDiscrete (Term s PInteger)
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (PDiscrete mc) PInteger)
newtype Discrete (mc :: MoneyClass)
= Discrete Integer
deriving stock (Show)
-- | Check if one 'PDiscrete' is greater than another.
pgeqDiscrete :: forall (mc :: MoneyClass) (s :: S). Term s (PDiscrete mc :--> PDiscrete mc :--> PBool)
pgeqDiscrete = phoistAcyclic $
@ -75,7 +70,7 @@ pgeqDiscrete = phoistAcyclic $
PDiscrete y' <- pmatch y
y' #<= x'
-- | Conjure zero discrete unit for any moneyclass
-- | Returns a zero-value 'PDiscrete' unit for any 'MoneyClass'.
pzeroDiscrete :: forall (mc :: MoneyClass) (s :: S). Term s (PDiscrete mc)
pzeroDiscrete = phoistAcyclic $ pcon (PDiscrete 0)
@ -114,7 +109,8 @@ pvalueDiscrete = phoistAcyclic $
# f
{- | Get a `PValue` from a `PDiscrete`.
__NOTE__: `pdiscreteValue` after `pvalueDiscrete` loses information
__NOTE__: `pdiscreteValue` after `pvalueDiscrete` is not a round-trip.
It filters for a particular 'MoneyClass'.
-}
pdiscreteValue ::
forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s.

2
agora/Agora/SafeMoney/QQ.hs
View file

@ -40,7 +40,7 @@ import Agora.SafeMoney (MoneyClass, PDiscrete)
{- | Generate 'PDiscrete' values tagged by a particular MoneyClass
@
[discrete| 123.456 ADA |] :: 'Term' s ('PDiscrete' 'ADA')
[discrete| 123.456 'Agora.SafeMoney.ADA' |] :: 'Term' s ('PDiscrete' 'Agora.SafeMoney.ADA')
@
-}
discrete :: QuasiQuoter

14
agora/Agora/Stake.hs
View file

@ -72,8 +72,8 @@ import Agora.Utils (
paddValue,
passert,
pfindTxInByTxOutRef,
pgeqBy,
pgeqBy',
pgeqByClass,
pgeqByClass',
pgeqBySymbol,
psingletonValue,
psymbolValueOf,
@ -233,8 +233,8 @@ stakePolicy _stake =
let valueCorrect =
foldr1
(#&&)
[ pgeqBy' (AssetClass ("", "")) # value # expectedValue
, pgeqBy'
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
, pgeqByClass'
( AssetClass
( fromString . symbolVal $ Proxy @ac
, fromString . symbolVal $ Proxy @n
@ -242,7 +242,7 @@ stakePolicy _stake =
)
# value
# expectedValue
, pgeqBy
, pgeqByClass
# ownSymbol
# tn
# value
@ -333,8 +333,8 @@ stakeValidator stake =
let valueCorrect =
foldr1
(#&&)
[ pgeqBy' (AssetClass ("", "")) # value # expectedValue
, pgeqBy'
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
, pgeqByClass'
( AssetClass
( fromString . symbolVal $ Proxy @ac
, fromString . symbolVal $ Proxy @n

14
agora/Agora/Utils.hs
View file

@ -19,9 +19,9 @@ module Agora.Utils (
psymbolValueOf,
passetClassValueOf,
passetClassValueOf',
pgeqBy,
pgeqByClass,
pgeqBySymbol,
pgeqBy',
pgeqByClass',
pfindTxInByTxOutRef,
psingletonValue,
pfindMap,
@ -184,13 +184,13 @@ passetClassValueOf' (AssetClass (sym, token)) =
passetClassValueOf # pconstant sym # pconstant token
-- | Return '>=' on two values comparing by only a particular AssetClass
pgeqBy :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PValue :--> PBool)
pgeqBy =
pgeqByClass :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PValue :--> PBool)
pgeqByClass =
phoistAcyclic $
plam $ \cs tn a b ->
passetClassValueOf # cs # tn # b #<= passetClassValueOf # cs # tn # a
-- | Return '>=' on two values comparing by only a particular AssetClass
-- | Return '>=' on two values comparing by only a particular CurrencySymbol
pgeqBySymbol :: Term s (PCurrencySymbol :--> PValue :--> PValue :--> PBool)
pgeqBySymbol =
phoistAcyclic $
@ -198,8 +198,8 @@ pgeqBySymbol =
psymbolValueOf # cs # b #<= psymbolValueOf # cs # a
-- | Return '>=' on two values comparing by only a particular Haskell-level AssetClass
pgeqBy' :: AssetClass -> Term s (PValue :--> PValue :--> PBool)
pgeqBy' ac =
pgeqByClass' :: AssetClass -> Term s (PValue :--> PValue :--> PBool)
pgeqByClass' ac =
phoistAcyclic $
plam $ \a b ->
passetClassValueOf' ac # b #<= passetClassValueOf' ac # a

10
agora/PPrelude.hs
View file

@ -1,7 +1,17 @@
{- |
Module : PPrelude
Maintainer : emi@haskell.fyi
Description: Prelude imported throughout this project
Prelude imported throughout this project
-}
module PPrelude (
module Prelude,
module Plutarch.Prelude,
module Plutarch,
) where
-- These are not exported by Plutarch.Prelude, for some reason. Maybe we can 'fix' this upstream?
import Plutarch (ClosedTerm, compile)
import Plutarch.Prelude
import Prelude