Skip to content

Commit eef8640

Browse files
Bromel777Bromel777
committed
vesting contracts
1 parent 2fb44f4 commit eef8640

File tree

15 files changed

+948
-0
lines changed

15 files changed

+948
-0
lines changed

‎cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/Vesting.hs

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
{-# LANGUAGE TemplateHaskell #-}
2+
{-# LANGUAGE UndecidableInstances #-}
3+
4+
module ErgoDex.Contracts.Proxy.Vesting (
5+
VestingConfig (..),
6+
VestingRedeemer (..)
7+
) where
8+
9+
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
10+
import PlutusLedgerApi.V1.Value
11+
import PlutusLedgerApi.V1.Time
12+
import qualified PlutusTx
13+
14+
data VestingRedeemer = VestingRedeemer
15+
{ vestingInIx :: Integer
16+
, rewardOutIx :: Integer
17+
}
18+
deriving stock (Show)
19+
20+
PlutusTx.makeIsDataIndexed ''VestingRedeemer [('VestingRedeemer, 0)]
21+
22+
data VestingConfig = VestingConfig
23+
{ deadline :: POSIXTime
24+
, pkh :: PubKeyHash
25+
, vestingAC :: AssetClass
26+
}
27+
deriving stock (Show)
28+
29+
PlutusTx.makeIsDataIndexed ''VestingConfig [('VestingConfig, 0)]
30+

‎cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/VestingWithPeriod.hs

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,33 @@
1+
{-# LANGUAGE TemplateHaskell #-}
2+
{-# LANGUAGE UndecidableInstances #-}
3+
4+
module ErgoDex.Contracts.Proxy.VestingWithPeriod (
5+
VestingWithPeriodConfig (..),
6+
VestingWithPeriodRedeemer (..)
7+
) where
8+
9+
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
10+
import PlutusLedgerApi.V1.Value
11+
import PlutusLedgerApi.V1.Time
12+
import qualified PlutusTx
13+
14+
data VestingWithPeriodRedeemer = VestingWithPeriodRedeemer
15+
{ vestingInIx :: Integer
16+
, vestingPeriodIdx :: Integer
17+
}
18+
deriving stock (Show)
19+
20+
PlutusTx.makeIsDataIndexed ''VestingWithPeriodRedeemer [('VestingWithPeriodRedeemer, 0)]
21+
22+
data VestingWithPeriodConfig = VestingWithPeriodConfig
23+
{ vestingStart :: POSIXTime
24+
, vestingPeriodDuration :: POSIXTime
25+
, totalVested :: Integer
26+
, periodVested :: Integer
27+
, pkhs :: [PubKeyHash]
28+
, vestingAC :: AssetClass
29+
}
30+
deriving stock (Show)
31+
32+
PlutusTx.makeIsDataIndexed ''VestingWithPeriodConfig [('VestingWithPeriodConfig, 0)]
33+

‎cardano-dex-contracts-onchain/ErgoDex/PContracts/PApi.hs

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,9 @@
11
module ErgoDex.PContracts.PApi (
22
containsSignature,
3+
containsSignature',
34
ownCurrencySymbol,
45
getRewardValue',
6+
getRewardValueByPKH',
57
tletUnwrap,
68
pmin,
79
getInputValue,
@@ -53,6 +55,9 @@ pmin = phoistAcyclic $ plam $ \a b -> pif (a #<= b) a b
5355
containsSignature :: Term s (PBuiltinList (PAsData PPubKeyHash) :--> PPubKeyHash :--> PBool)
5456
containsSignature = phoistAcyclic $ plam $ \signatories userPubKeyHash -> pelem # pdata userPubKeyHash # signatories
5557

58+
containsSignature' :: Term s (PBuiltinList (PAsData PPubKeyHash) :--> (PAsData PPubKeyHash) :--> PBool)
59+
containsSignature' = phoistAcyclic $ plam $ \signatories userPubKeyHash -> pelem # userPubKeyHash # signatories
60+
5661
-- Guarantees reward proposition correctness
5762
getRewardValue' :: Term s (PTxOut :--> PPubKeyHash :--> PMaybeData PPubKeyHash :--> V1.PValue 'V1.Sorted 'V1.Positive)
5863
getRewardValue' = phoistAcyclic $
@@ -69,6 +74,19 @@ getRewardValue' = phoistAcyclic $
6974
sPkh <- tlet $ getStakeHash # addr
7075
pure $ pif (sPkh #== stakePkhM) outValue (ptraceError "Invalid reward proposition")
7176

77+
-- Guarantees reward proposition correctness
78+
getRewardValueByPKH' :: Term s (PTxOut :--> PPubKeyHash :--> V1.PValue 'V1.Sorted 'V1.Positive)
79+
getRewardValueByPKH' = phoistAcyclic $
80+
plam $ \out pubkeyHash -> unTermCont $ do
81+
let addr = pfield @"address" # out
82+
cred <- tletField @"credential" addr
83+
tletUnwrap $ pmatch cred $ \case
84+
PPubKeyCredential pcred ->
85+
let pkh = pfield @"_0" # pcred
86+
value = pfield @"value" # out
87+
in pif (pkh #== pubkeyHash) value (ptraceError "Invalid reward proposition")
88+
_ -> ptraceError "Invalid reward proposition"
89+
7290
getStakeHash :: forall (s :: S). Term s (PAddress :--> PMaybeData PPubKeyHash)
7391
getStakeHash = phoistAcyclic $
7492
plam $ \address -> unTermCont $ do

‎cardano-dex-contracts-onchain/ErgoDex/PContracts/PValidators.hs

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,8 @@ import qualified ErgoDex.PContracts.PDeposit as PD
1414
import qualified ErgoDex.PContracts.PPool as PP
1515
import qualified ErgoDex.PContracts.PRedeem as PR
1616
import qualified ErgoDex.PContracts.PSwap as PS
17+
import qualified ErgoDex.PContracts.PVesting as PV
18+
import qualified ErgoDex.PContracts.PVestingWithPeriod as PVWP
1719

1820
import Plutarch
1921
import Plutarch.Api.V2 (mkValidator, validatorHash)
@@ -43,5 +45,11 @@ depositValidator = mkValidator $ wrapValidator PD.depositValidatorT
4345
redeemValidator :: Validator
4446
redeemValidator = mkValidator $ wrapValidator PR.redeemValidatorT
4547

48+
vestingValidator :: Validator
49+
vestingValidator = mkValidator $ wrapValidator PV.vestingValidator
50+
51+
vestingWithPeriodValidator :: Validator
52+
vestingWithPeriodValidator = mkValidator $ wrapValidator PVWP.vestingWithPeriodValidator
53+
4654
validatorAddress :: Validator -> Address
4755
validatorAddress = scriptHashAddress . validatorHash

‎cardano-dex-contracts-onchain/ErgoDex/PContracts/PVesting.hs

Lines changed: 111 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,111 @@
1+
{-# LANGUAGE UndecidableInstances #-}
2+
3+
module ErgoDex.PContracts.PVesting (
4+
VestingConfig (..),
5+
vestingValidatorT
6+
) where
7+
8+
import qualified GHC.Generics as GHC
9+
10+
import Plutarch
11+
import Plutarch.Api.V2
12+
import Plutarch.Extra.Interval
13+
import Plutarch.Api.V1.Time
14+
import Plutarch.DataRepr
15+
import Plutarch.Lift
16+
import Plutarch.Prelude
17+
import Plutarch.Extra.TermCont
18+
import Plutarch.Api.V1.Interval (PInterval)
19+
import qualified Plutarch.Monadic as P
20+
21+
import PExtra.API
22+
import PExtra.Monadic (tlet, tletField)
23+
24+
import ErgoDex.PContracts.PApi
25+
26+
import qualified ErgoDex.Contracts.Proxy.Vesting as V
27+
28+
newtype VestingRedeemer (s :: S)
29+
= VestingRedeemer
30+
( Term
31+
s
32+
( PDataRecord
33+
'[ "vestingInIx" ':= PInteger
34+
, "rewardOutIx" ':= PInteger
35+
]
36+
)
37+
)
38+
deriving stock (GHC.Generic)
39+
deriving
40+
(PIsData, PDataFields, PlutusType)
41+
42+
instance DerivePlutusType VestingRedeemer where type DPTStrat _ = PlutusTypeData
43+
44+
instance PUnsafeLiftDecl VestingRedeemer where type PLifted VestingRedeemer = V.VestingRedeemer
45+
deriving via (DerivePConstantViaData V.VestingRedeemer VestingRedeemer) instance (PConstantDecl V.VestingRedeemer)
46+
47+
newtype VestingConfig (s :: S)
48+
= VestingConfig
49+
( Term
50+
s
51+
( PDataRecord
52+
'[ "deadline" ':= PPOSIXTime
53+
, "pkh" ':= PPubKeyHash
54+
, "vestingAC" ':= PAssetClass
55+
]
56+
)
57+
)
58+
deriving stock (GHC.Generic)
59+
deriving
60+
(PIsData, PDataFields, PlutusType)
61+
62+
instance DerivePlutusType VestingConfig where type DPTStrat _ = PlutusTypeData
63+
64+
instance PUnsafeLiftDecl VestingConfig where type PLifted VestingConfig = V.VestingConfig
65+
deriving via (DerivePConstantViaData V.VestingConfig VestingConfig) instance (PConstantDecl V.VestingConfig)
66+
67+
vestingValidatorT :: ClosedTerm (VestingConfig :--> VestingRedeemer :--> PScriptContext :--> PBool)
68+
vestingValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do
69+
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
70+
conf <- pletFieldsC @'["deadline", "pkh", "vestingAC"] conf'
71+
let
72+
deadline = pfromData $ getField @"deadline" conf
73+
pkh = pfromData $ getField @"pkh" conf
74+
vestingAC = pfromData $ getField @"vestingAC" conf
75+
txInfo <- pletFieldsC @'["inputs", "outputs", "validRange", "signatories"] $ getField @"txInfo" ctx
76+
redeemer <- pletFieldsC @'["vestingInIx", "rewardOutIx"] redeemer'
77+
let
78+
vestingInIx = getField @"vestingInIx" redeemer
79+
rewardOutIx = getField @"rewardOutIx" redeemer
80+
81+
validRange <- tletUnwrap $ getField @"validRange" txInfo
82+
inputs <- tletUnwrap $ getField @"inputs" txInfo
83+
outputs <- tletUnwrap $ getField @"outputs" txInfo
84+
85+
selfIn' <- tlet $ pelemAt # vestingInIx # inputs
86+
selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn'
87+
selfValue <-
88+
let self = getField @"resolved" selfIn
89+
in tletField @"value" self
90+
91+
PSpending selfRef' <- pmatchC $ getField @"purpose" ctx
92+
93+
selfRef <- tletField @"_0" selfRef'
94+
95+
let
96+
selfInRef = getField @"outRef" selfIn
97+
selfIdentity = selfRef #== selfInRef
98+
99+
sigs = pfromData $ getField @"signatories" txInfo
100+
validSignature = containsSignature # sigs # pkh
101+
102+
validTime = pbefore # deadline # validRange
103+
104+
rewardOut <- tlet $ pelemAt # rewardOutIx # outputs
105+
rewardValue <- tlet $ getRewardValueByPKH' # rewardOut # pkh
106+
let
107+
vestingIn = assetClassValueOf # selfValue # vestingAC
108+
vestingOut = assetClassValueOf # rewardValue # vestingAC
109+
correctReward = vestingIn #== vestingOut
110+
111+
pure $ validSignature #&& correctReward #&& validTime #&& selfIdentity

‎cardano-dex-contracts-onchain/ErgoDex/PContracts/PVestingWithPeriod.hs

Lines changed: 116 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,116 @@
1+
{-# LANGUAGE UndecidableInstances #-}
2+
3+
module ErgoDex.PContracts.PVestingWithPeriod (
4+
VestingWithPeriodConfig (..),
5+
vestingWithPeriodValidatorT
6+
) where
7+
8+
import qualified GHC.Generics as GHC
9+
10+
import Plutarch
11+
import Plutarch.List
12+
import Plutarch.Api.V2
13+
import Plutarch.Extra.Interval
14+
import Plutarch.DataRepr
15+
import Plutarch.Lift
16+
import Plutarch.Prelude
17+
import Plutarch.Extra.TermCont
18+
19+
import PExtra.API
20+
import PExtra.Monadic (tlet, tletField)
21+
import PExtra.Time
22+
23+
import ErgoDex.PContracts.PApi
24+
25+
import qualified ErgoDex.Contracts.Proxy.VestingWithPeriod as VWP
26+
27+
newtype VestingWithPeriodRedeemer (s :: S)
28+
= VestingWithPeriodRedeemer
29+
( Term
30+
s
31+
( PDataRecord
32+
'[ "vestingInIx" ':= PInteger
33+
, "vestingPeriodIdx" ':= PInteger
34+
]
35+
)
36+
)
37+
deriving stock (GHC.Generic)
38+
deriving
39+
(PIsData, PDataFields, PlutusType)
40+
41+
instance DerivePlutusType VestingWithPeriodRedeemer where type DPTStrat _ = PlutusTypeData
42+
43+
instance PUnsafeLiftDecl VestingWithPeriodRedeemer where type PLifted VestingWithPeriodRedeemer = VWP.VestingWithPeriodRedeemer
44+
deriving via (DerivePConstantViaData VWP.VestingWithPeriodRedeemer VestingWithPeriodRedeemer) instance (PConstantDecl VWP.VestingWithPeriodRedeemer)
45+
46+
newtype VestingWithPeriodConfig (s :: S)
47+
= VestingConfig
48+
( Term
49+
s
50+
( PDataRecord
51+
'[ "vestingStart" ':= PPOSIXTime
52+
, "vestingPeriodDuration" ':= PPOSIXTime
53+
, "totalVested" ':= PInteger
54+
, "periodVested" ':= PInteger
55+
, "pkhs" ':= PBuiltinList (PAsData PPubKeyHash)
56+
, "vestingAC" ':= PAssetClass
57+
]
58+
)
59+
)
60+
deriving stock (GHC.Generic)
61+
deriving
62+
(PIsData, PDataFields, PlutusType)
63+
64+
instance DerivePlutusType VestingWithPeriodConfig where type DPTStrat _ = PlutusTypeData
65+
66+
instance PUnsafeLiftDecl VestingWithPeriodConfig where type PLifted VestingWithPeriodConfig = VWP.VestingWithPeriodConfig
67+
deriving via (DerivePConstantViaData VWP.VestingWithPeriodConfig VestingWithPeriodConfig) instance (PConstantDecl VWP.VestingWithPeriodConfig)
68+
69+
vestingWithPeriodValidatorT :: ClosedTerm (VestingWithPeriodConfig :--> VestingWithPeriodRedeemer :--> PScriptContext :--> PBool)
70+
vestingWithPeriodValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do
71+
let ctx = pfield @"txInfo" # ctx'
72+
73+
conf <- pletFieldsC @'["vestingStart", "vestingPeriodDuration", "totalVested", "periodVested", "pkhs", "vestingAC"] conf'
74+
redeemer <- pletFieldsC @'["vestingPeriodIdx"] redeemer'
75+
txInfo <- pletFieldsC @'["validRange", "signatories"] ctx
76+
let
77+
vestingStart = pfromData $ getField @"vestingStart" conf
78+
vestingPeriodDuration = pfromData $ getField @"vestingPeriodDuration" conf
79+
80+
totalVested = pfromData $ getField @"totalVested" conf
81+
periodVested = pfromData $ getField @"periodVested" conf
82+
pkhs = pfromData $ getField @"pkhs" conf
83+
vestingAC = pfromData $ getField @"vestingAC" conf
84+
85+
vestingPeriodIdx = pfromData $ getField @"vestingPeriodIdx" redeemer
86+
87+
sigs = pfromData $ getField @"signatories" txInfo
88+
89+
validRange <- tletUnwrap $ getField @"validRange" txInfo
90+
let
91+
periodAdditionalTime = pmultiply # vestingPeriodIdx # vestingPeriodDuration
92+
93+
periodStartTime = periodAdditionalTime + vestingStart
94+
validTime = pbefore # periodStartTime # validRange
95+
validSignature = pall # (containsSignature' # sigs) # pkhs
96+
97+
maxPeriodsQty = pdiv # totalVested # periodVested
98+
isLastPeriod = maxPeriodsQty #<= vestingPeriodIdx
99+
100+
correctReward <-
101+
tlet $
102+
isLastPeriod #|| (checkRewardCorrectness # ctx' # totalVested # periodVested # vestingPeriodIdx # vestingAC)
103+
104+
pure $ validTime #&& validSignature #&& correctReward
105+
106+
107+
checkRewardCorrectness :: Term s (PScriptContext :--> PInteger :--> PInteger :--> PInteger :--> PAssetClass :--> PBool)
108+
checkRewardCorrectness =
109+
plam $ \ctx totalVested periodVested periodId vestingAC ->
110+
let
111+
selfOutputsList = getContinuingOutputs # ctx
112+
selfOutput = phead # selfOutputsList
113+
selfValue = pfield @"value" # selfOutput
114+
correctOutQty = totalVested - (periodId * periodVested)
115+
realOutQty = assetClassValueOf # selfValue # vestingAC
116+
in realOutQty #== correctOutQty

‎cardano-dex-contracts-onchain/ErgoDex/PValidators.hs

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,9 @@ module ErgoDex.PValidators (
33
swapValidator,
44
depositValidator,
55
redeemValidator,
6+
vestingValidator,
67
validatorAddress,
8+
vestingWithPeriodValidator,
79
wrapValidator,
810
) where
911

@@ -14,6 +16,7 @@ import qualified ErgoDex.PContracts.PDeposit as PD
1416
import qualified ErgoDex.PContracts.PPool as PP
1517
import qualified ErgoDex.PContracts.PRedeem as PR
1618
import qualified ErgoDex.PContracts.PSwap as PS
19+
import qualified ErgoDex.PContracts.PVesting as PV
1720

1821
import Plutarch
1922
import Plutarch.Api.V2 (mkValidator, validatorHash)
@@ -47,5 +50,11 @@ depositValidator = mkValidator cfgForValidator $ wrapValidator PD.depositValidat
4750
redeemValidator :: Validator
4851
redeemValidator = mkValidator cfgForValidator $ wrapValidator PR.redeemValidatorT
4952

53+
vestingValidator :: Validator
54+
vestingValidator = mkValidator cfgForValidator $ wrapValidator PV.vestingValidatorT
55+
56+
vestingWithPeriodValidator :: Validator
57+
vestingWithPeriodValidator = mkValidator cfgForValidator $ wrapValidator PV.vestingValidatorT
58+
5059
validatorAddress :: Validator -> Address
5160
validatorAddress = scriptHashAddress . validatorHash

0 commit comments

Comments
 (0)