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

use plutarch-safemoney instead of local Agora.SafeMoney

Browse source
This commit is contained in:
Emily Martins 2022-03-30 15:32:50 +02:00
parent dd30fc51b1
commit 097e055f19
7 changed files with 75 additions and 179 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -51,8 +51,9 @@ import Plutus.V1.Ledger.Value qualified as Value
--------------------------------------------------------------------------------
import Agora.SafeMoney
import Agora.SafeMoney (GTTag)
import Agora.Stake
import Plutarch.SafeMoney
import Spec.Util (datumPair, toDatumHash)
--------------------------------------------------------------------------------
@ -62,7 +63,7 @@ stake :: Stake
stake =
Stake
{ gtClassRef =
AssetClassRef
Tagged
( AssetClass
( "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
, "LQ"
@ -143,9 +144,9 @@ stakeCreationUnsigned =
-- | Config for creating a ScriptContext that deposits or withdraws.
data DepositWithdrawExample = DepositWithdrawExample
{ startAmount :: Discrete GTTag
{ startAmount :: Tagged GTTag Integer
-- ^ The amount of GT stored before the transaction.
, delta :: Discrete GTTag
, delta :: Tagged GTTag Integer
-- ^ The amount of GT deposited or withdrawn from the Stake.
}
@ -168,7 +169,7 @@ stakeDepositWithdraw config =
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
, txOutValue =
st
<> discreteValue stake.gtClassRef stakeBefore.stakedAmount
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)
, txOutDatumHash = Just (toDatumHash stakeAfter)
}
]
@ -177,7 +178,7 @@ stakeDepositWithdraw config =
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
, txOutValue =
st
<> discreteValue stake.gtClassRef stakeAfter.stakedAmount
<> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
, txOutDatumHash = Just (toDatumHash stakeAfter)
}
]

1
agora.cabal
View file

@ -97,6 +97,7 @@ common deps
, plutarch
, plutarch-extra
, plutarch-numeric
, plutarch-safemoney
, plutus-core
, plutus-ledger-api
, plutus-tx

9
agora/Agora/Proposal.hs
View file

@ -38,7 +38,8 @@ import PlutusTx qualified
--------------------------------------------------------------------------------
import Agora.SafeMoney (Discrete, GTTag, PDiscrete)
import Agora.SafeMoney (GTTag)
import Plutarch.SafeMoney (PDiscrete, Tagged)
--------------------------------------------------------------------------------
-- Haskell-land
@ -92,11 +93,11 @@ PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('F
to 'Proposal's when they are created.
-}
data ProposalThresholds = ProposalThresholds
{ execute :: Discrete GTTag
{ execute :: Tagged GTTag Integer
-- ^ How much GT minimum must a particular 'ResultTag' accumulate for it to pass.
, draft :: Discrete GTTag
, draft :: Tagged GTTag Integer
-- ^ How much GT required to "create" a proposal.
, vote :: Discrete GTTag
, vote :: Tagged GTTag Integer
-- ^ How much GT required to allow voting to happen.
-- (i.e. to move into 'VotingReady')
}

125
agora/Agora/SafeMoney.hs
View file

@ -1,51 +1,21 @@
{- |
Module : Agora.SafeMoney
Maintainer : emi@haskell.fyi
Description: Phantom-type protected types for handling money in Plutus.
Description: Tags and bonuses for Plutarch.SafeMoney.
Phantom-type protected types for handling money in Plutus.
Tags and bonuses for "Plutarch.SafeMoney".
-}
module Agora.SafeMoney (
-- * Types
PDiscrete (..),
Discrete (..),
-- * Tags and refs
AssetClassRef (..),
ADATag,
GTTag,
adaRef,
-- * Utility functions
paddDiscrete,
pgeqDiscrete,
pzeroDiscrete,
-- * Conversions
pdiscreteValue,
pvalueDiscrete,
discreteValue,
) where
import Prelude
--------------------------------------------------------------------------------
import Plutus.V1.Ledger.Value (AssetClass (AssetClass), Value)
import Plutus.V1.Ledger.Value qualified as Value
import PlutusTx qualified
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
import Plutarch.Api.V1 (PValue)
import Plutarch.Builtin ()
import Plutarch.Internal ()
import Plutarch.Monadic qualified as P
--------------------------------------------------------------------------------
import Agora.Utils (
passetClassValueOf',
psingletonValue,
)
import Plutarch.SafeMoney
--------------------------------------------------------------------------------
-- Example tags
@ -58,89 +28,6 @@ data ADATag
--------------------------------------------------------------------------------
-- | A tagged AssetClass. Use to resolve a reference inside of a PDiscrete
newtype AssetClassRef (tag :: Type) = AssetClassRef {getAssetClass :: AssetClass}
-- | Resolves ada tags.
adaRef :: AssetClassRef ADATag
adaRef = AssetClassRef (AssetClass ("", ""))
-- TODO: Currently it's possible to transmute from one discrete to another.
-- How do we prevent this?
--
-- @
-- transmute :: forall (a :: Type) (b :: Type). Discrete a -> Discrete b
-- transmute = Discrete . getDiscrete
-- @
{- | Represents a single asset in a 'Plutus.V1.Ledger.Value.Value' related to a particular 'AssetClass'
through 'AssetClassRef'.
-}
newtype Discrete (tag :: Type) = Discrete {getDiscrete :: Integer}
deriving stock (Show, Eq)
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
deriving newtype (Num) -- TODO: Use plutarch-numeric
{- | Represents a single asset in a 'PValue' related to a particular 'AssetClass'
through 'AssetClassRef'.
-}
newtype PDiscrete (tag :: Type) (s :: S)
= PDiscrete (Term s PInteger)
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (PDiscrete tag) PInteger)
-- | Check if one 'PDiscrete' is greater than another.
pgeqDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag :--> PDiscrete tag :--> PBool)
pgeqDiscrete = phoistAcyclic $
plam $ \x y -> P.do
PDiscrete x' <- pmatch x
PDiscrete y' <- pmatch y
y' #<= x'
-- | Returns a zero-value 'PDiscrete' unit for any tag.
pzeroDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag)
pzeroDiscrete = phoistAcyclic $ pcon (PDiscrete 0)
-- | Add two 'PDiscrete' values of the same tag.
paddDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag :--> PDiscrete tag :--> PDiscrete tag)
paddDiscrete = phoistAcyclic $
-- In the future, this should use plutarch-numeric
plam $ \x y -> P.do
PDiscrete x' <- pmatch x
PDiscrete y' <- pmatch y
pcon (PDiscrete $ x' + y')
--------------------------------------------------------------------------------
-- | Downcast a `PValue` to a `PDiscrete` unit.
pvalueDiscrete ::
forall (tag :: Type) (s :: S).
AssetClassRef tag ->
Term s (PValue :--> PDiscrete tag)
pvalueDiscrete (AssetClassRef ac) = phoistAcyclic $
plam $ \f ->
pcon . PDiscrete $ passetClassValueOf' ac # f
{- | Get a `PValue` from a `PDiscrete`.
__NOTE__: `pdiscreteValue` after `pvalueDiscrete` is not a round-trip.
It filters for a particular tag.
-}
pdiscreteValue ::
forall (tag :: Type) (s :: S).
AssetClassRef tag ->
Term s (PDiscrete tag :--> PValue)
pdiscreteValue (AssetClassRef (AssetClass (cs, tn))) = phoistAcyclic $
plam $ \f -> pmatch f $ \case
PDiscrete p ->
psingletonValue
# pconstant cs
# pconstant tn
# p
-- | Get a `Value` from a `Discrete`.
discreteValue ::
forall (tag :: Type).
AssetClassRef tag ->
Discrete tag ->
Value
discreteValue (AssetClassRef (AssetClass (cs, tn))) (Discrete v) =
Value.singleton cs tn v
adaRef :: Tagged ADATag AssetClass
adaRef = Tagged (AssetClass ("", ""))

78
agora/Agora/Stake.hs
View file

@ -22,7 +22,7 @@ module Agora.Stake (
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Prelude
import Prelude hiding (Num (..))
--------------------------------------------------------------------------------
@ -52,16 +52,7 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
--------------------------------------------------------------------------------
import Agora.SafeMoney (
AssetClassRef (..),
Discrete,
GTTag,
PDiscrete,
paddDiscrete,
pdiscreteValue,
pgeqDiscrete,
pzeroDiscrete,
)
import Agora.SafeMoney (GTTag)
import Agora.Utils (
anyInput,
anyOutput,
@ -77,38 +68,41 @@ import Agora.Utils (
ptxSignedBy,
pvalueSpent,
)
import Plutarch.Numeric
import Plutarch.SafeMoney (
PDiscrete,
Tagged (..),
pdiscreteValue,
untag,
)
--------------------------------------------------------------------------------
-- | Parameters for creating Stake scripts.
newtype Stake = Stake
{ gtClassRef :: AssetClassRef GTTag
{ gtClassRef :: Tagged GTTag AssetClass
-- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code.
}
-- | Plutarch-level redeemer for Stake scripts.
data PStakeRedeemer (s :: S)
= -- | Deposit or withdraw a discrete amount of the staked governance token.
PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag]))
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
PDestroy (Term s (PDataRecord '[]))
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving
(PlutusType, PIsData)
via PIsDataReprInstances PStakeRedeemer
-- | Haskell-level redeemer for Stake scripts.
data StakeRedeemer
= -- | Deposit or withdraw a discrete amount of the staked governance token.
DepositWithdraw (Discrete GTTag)
DepositWithdraw (Tagged GTTag Integer)
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
Destroy
deriving stock (Show, GHC.Generic)
PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)]
-- | Haskell-level datum for Stake scripts.
data StakeDatum = StakeDatum
{ stakedAmount :: Tagged GTTag Integer
, owner :: PubKeyHash
}
deriving stock (Show, GHC.Generic)
PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
-- | Plutarch-level datum for Stake scripts.
newtype PStakeDatum (s :: S) = PStakeDatum
{ getStakeDatum ::
@ -121,14 +115,18 @@ newtype PStakeDatum (s :: S) = PStakeDatum
(PlutusType, PIsData, PDataFields)
via (PIsDataReprInstances PStakeDatum)
-- | Haskell-level datum for Stake scripts.
data StakeDatum = StakeDatum
{ stakedAmount :: Discrete GTTag
, owner :: PubKeyHash
}
deriving stock (Show, GHC.Generic)
PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
-- | Plutarch-level redeemer for Stake scripts.
data PStakeRedeemer (s :: S)
= -- | Deposit or withdraw a discrete amount of the staked governance token.
PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag]))
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
PDestroy (Term s (PDataRecord '[]))
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving
(PlutusType, PIsData)
via PIsDataReprInstances PStakeRedeemer
--------------------------------------------------------------------------------
{- What this Policy does
@ -223,7 +221,7 @@ stakePolicy stake =
foldr1
(#&&)
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
, pgeqByClass' stake.gtClassRef.getAssetClass
, pgeqByClass' (untag stake.gtClassRef)
# value
# expectedValue
, pgeqByClass
@ -300,15 +298,15 @@ stakeValidator stake =
foldr1
(#&&)
[ stakeDatum.owner #== newStakeDatum.owner
, (paddDiscrete # stakeDatum.stakedAmount # delta) #== newStakeDatum.stakedAmount
, (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount
, -- We can't magically conjure GT anyway (no input to spend!)
-- do we need to check this, really?
pgeqDiscrete # (pfromData newStakeDatum.stakedAmount) # pzeroDiscrete
zero #<= pfromData newStakeDatum.stakedAmount
]
let expectedValue = paddValue # continuingValue # (pdiscreteValue stake.gtClassRef # delta)
ptrace (pshow $ passetClassValueOf' stake.gtClassRef.getAssetClass # value)
ptrace (pshow $ passetClassValueOf' stake.gtClassRef.getAssetClass # expectedValue)
ptrace (pshow $ passetClassValueOf' (untag stake.gtClassRef) # value)
ptrace (pshow $ passetClassValueOf' (untag stake.gtClassRef) # expectedValue)
-- TODO: Same as above. This is quite inefficient now, as it does two lookups
-- instead of a more efficient single pass,
@ -317,7 +315,7 @@ stakeValidator stake =
foldr1
(#&&)
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
, pgeqByClass' stake.gtClassRef.getAssetClass
, pgeqByClass' (untag stake.gtClassRef)
# value
# expectedValue
, pgeqBySymbol

14
flake.lock generated
View file

@ -1381,11 +1381,11 @@
},
"nixpkgs-2111_3": {
"locked": {
"lastModified": 1648420413,
"narHash": "sha256-AHejj7EsbTt+CMOoy15wwkFsFNmx8oinGgDZR22lS6g=",
"lastModified": 1648608655,
"narHash": "sha256-pTjZg9DwU89ZZ1fdtt6/i1X4vSNXoRJYUArgVZPh9F8=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "d6778e0b5d608eb6738af2a64e26d99cdc5b9e86",
"rev": "ba93b1d8253ed4b359b9e81d10e02c106d3f8b11",
"type": "github"
},
"original": {
@ -1621,17 +1621,17 @@
"validity": "validity"
},
"locked": {
"lastModified": 1648163186,
"narHash": "sha256-UfaSb4nk9HWzsj1Kb8RJuPV+iw1Nl4E2+97KOwIwcao=",
"lastModified": 1648639396,
"narHash": "sha256-pAkEsIDXJckVYufVPUzD/4sq4/uE7iyV0IR2BuLhZjY=",
"owner": "peter-mlabs",
"repo": "plutarch",
"rev": "0638dbd706bc2c5f48f9f40be7bbe1986a778698",
"rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6",
"type": "github"
},
"original": {
"owner": "peter-mlabs",
"ref": "liqwid/extra",
"repo": "plutarch",
"rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6",
"type": "github"
}
},

14
flake.nix
View file

@ -7,7 +7,9 @@
# see https://github.com/NixOS/nix/issues/6013
inputs.nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; };
inputs.plutarch.url = "github:peter-mlabs/plutarch/liqwid/extra";
# Rev is this PR https://github.com/peter-mlabs/plutarch/pull/5.
inputs.plutarch.url =
"github:peter-mlabs/plutarch?rev=a7a410da209b9c14c834a41e07b1c197c2a4dcd6";
inputs.plutarch.inputs.nixpkgs.follows =
"plutarch/haskell-nix/nixpkgs-unstable";
@ -56,8 +58,13 @@
extraSources = plutarch.extraSources ++ [
{
src = inputs.plutarch;
subdirs =
[ "." "plutarch-test" "plutarch-extra" "plutarch-numeric" ];
subdirs = [
"."
"plutarch-test"
"plutarch-extra"
"plutarch-numeric"
"plutarch-safemoney"
];
}
{
src = inputs.apropos-tx;
@ -96,6 +103,7 @@
ps.apropos-tx
ps.plutarch-extra
ps.plutarch-numeric
ps.plutarch-safemoney
ps.plutarch-test
ps.apropos
];