Skip to content

Commit 88cf2c1

Browse files
Bromel777Bromel777
committed
draft
1 parent 6d424fd commit 88cf2c1

File tree

19 files changed

+1091
-29
lines changed

19 files changed

+1091
-29
lines changed

‎cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/Deposit.hs

Lines changed: 27 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,27 @@
1+
{-# LANGUAGE TemplateHaskell #-}
2+
{-# LANGUAGE UndecidableInstances #-}
3+
4+
module ErgoDex.Contracts.Proxy.LqMining.Simple.Deposit where
5+
6+
import qualified PlutusTx
7+
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
8+
import PlutusLedgerApi.V1.Value
9+
10+
data DepositConfig = DepositConfig
11+
{ expectedNumEpochs :: Integer
12+
, bundleKeyCS :: CurrencySymbol
13+
, redeemerPkh :: PubKeyHash
14+
, vlqAC :: AssetClass
15+
, tmpAC :: AssetClass
16+
} deriving stock (Show)
17+
18+
PlutusTx.makeIsDataIndexed ''DepositConfig [('DepositConfig, 0)]
19+
20+
data DepositRedeemer = DepositRedeemer
21+
{ poolInIdx :: Integer
22+
, depositInIdx :: Integer
23+
, redeemerOutIdx :: Integer
24+
, bundleOutIdx :: Integer
25+
} deriving stock (Show)
26+
27+
PlutusTx.makeIsDataIndexed ''DepositRedeemer [('DepositRedeemer, 0)]

‎cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/LMPool.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.LqMining.Simple.LMPool where
5+
6+
import qualified PlutusTx
7+
import PlutusLedgerApi.V1.Value
8+
9+
data LMPoolConfig = LMPoolConfig
10+
{ epochLen :: Integer
11+
, epochNum :: Integer
12+
, programStart :: Integer
13+
, programBudget :: Integer
14+
, execBudget :: Integer
15+
, epoch :: Integer
16+
, poolNft :: AssetClass
17+
, poolX :: AssetClass
18+
, poolLQ :: AssetClass
19+
, poolVLQ :: AssetClass
20+
, poolTMP :: AssetClass
21+
} deriving stock (Show)
22+
23+
PlutusTx.makeIsDataIndexed ''LMPoolConfig [('LMPoolConfig, 0)]
24+
25+
data LMPoolRedeemer = LMPoolRedeemer
26+
{ poolInIdx :: Integer
27+
, poolOutIdx :: Integer
28+
} deriving stock (Show)
29+
30+
PlutusTx.makeIsDataIndexed ''LMPoolRedeemer [('LMPoolRedeemer, 0)]

‎cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/Redeem.hs

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
{-# LANGUAGE TemplateHaskell #-}
2+
{-# LANGUAGE UndecidableInstances #-}
3+
4+
module ErgoDex.Contracts.Proxy.LqMining.Simple.Redeem where
5+
6+
import PlutusLedgerApi.V1.Value
7+
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
8+
9+
import qualified PlutusTx
10+
11+
data RedeemConfig = RedeemConfig
12+
{ expectedLQAC :: AssetClass
13+
, expectedLQAmount :: Integer
14+
, rewardPkh :: PubKeyHash
15+
} deriving stock (Show)
16+
17+
PlutusTx.makeIsDataIndexed ''RedeemConfig [('RedeemConfig, 0)]
18+
19+
data RedeemRedeemerConfig = RedeemRedeemerConfig
20+
{ rewardOutIdx :: Integer
21+
} deriving stock (Show)
22+
23+
PlutusTx.makeIsDataIndexed ''RedeemRedeemerConfig [('RedeemRedeemerConfig, 0)]

‎cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/StakingBundle.hs

Lines changed: 31 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
{-# LANGUAGE TemplateHaskell #-}
2+
{-# LANGUAGE UndecidableInstances #-}
3+
4+
module ErgoDex.Contracts.Proxy.LqMining.Simple.StakingBundle where
5+
6+
import PlutusLedgerApi.V1.Value
7+
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
8+
9+
import qualified PlutusTx
10+
11+
data StakingBundleConfig = StakingBundleConfig
12+
{ bundleAC :: AssetClass
13+
, poolAC :: AssetClass
14+
, bundleLQAC :: AssetClass
15+
, bundleVLQAC :: AssetClass
16+
, bundleTMPAC :: AssetClass
17+
, redeemerPkh :: PubKeyHash
18+
} deriving stock (Show)
19+
20+
PlutusTx.makeIsDataIndexed ''StakingBundleConfig [('StakingBundleConfig, 0)]
21+
22+
data StakingBundleRedeemer = StakingBundleRedeemer
23+
{ poolInIdx :: Integer
24+
, poolOutIdx :: Integer
25+
, permitIdx :: Integer
26+
, selfInIdx :: Integer
27+
, redeemerOutIx :: Integer
28+
, successorOutIndex :: Integer
29+
} deriving stock (Show)
30+
31+
PlutusTx.makeIsDataIndexed ''StakingBundleRedeemer [('StakingBundleRedeemer, 0)]

‎cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PDeposit.hs

Lines changed: 152 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,152 @@
1+
{-# LANGUAGE UndecidableInstances #-}
2+
3+
module ErgoDex.PContracts.LqMining.Simple.PDeposit where
4+
5+
import qualified GHC.Generics as GHC
6+
7+
import Plutarch
8+
import Plutarch.Api.V2 (POutputDatum(POutputDatum), PPubKeyHash, PDatum(PDatum), PTokenName(..), PCurrencySymbol(..))
9+
import Plutarch.Api.V2.Contexts (PScriptContext, PScriptPurpose (PSpending))
10+
import Plutarch.DataRepr
11+
import Plutarch.Lift
12+
import Plutarch.Prelude
13+
import Plutarch.Extra.TermCont
14+
15+
import PExtra.API (PAssetClass, assetClassValueOf, ptryFromData, assetClass, tletUnwrap)
16+
import PExtra.Monadic (tlet, tletField, tmatch)
17+
18+
import ErgoDex.PContracts.PApi (containsSignature, getRewardValueByPkh')
19+
20+
import qualified ErgoDex.Contracts.Proxy.LqMining.Simple.Deposit as D
21+
import qualified ErgoDex.PContracts.LqMining.Simple.PStakingBundle as SB
22+
import qualified ErgoDex.PContracts.LqMining.Simple.PLMPool as LMPool
23+
24+
newtype DepositConfig (s :: S)
25+
= DepositConfig
26+
( Term
27+
s
28+
( PDataRecord
29+
'[ "expectedNumEpochs" ':= PInteger
30+
, "bundleKeyCS" ':= PCurrencySymbol
31+
, "redeemerPkh" ':= PPubKeyHash
32+
, "vlqAC" ':= PAssetClass
33+
, "tmpAC" ':= PAssetClass
34+
]
35+
)
36+
)
37+
deriving stock (GHC.Generic)
38+
deriving
39+
(PIsData, PDataFields, PlutusType)
40+
41+
instance DerivePlutusType DepositConfig where type DPTStrat _ = PlutusTypeData
42+
43+
instance PUnsafeLiftDecl DepositConfig where type PLifted DepositConfig = D.DepositConfig
44+
deriving via (DerivePConstantViaData D.DepositConfig DepositConfig) instance (PConstantDecl D.DepositConfig)
45+
46+
newtype DepositRedeemer (s :: S)
47+
= DepositRedeemer
48+
( Term
49+
s
50+
( PDataRecord
51+
'[ "poolInIdx" ':= PInteger
52+
, "depositInIdx" ':= PInteger
53+
, "redeemerOutIdx" ':= PInteger
54+
, "bundleOutIdx" ':= PInteger
55+
]
56+
)
57+
)
58+
deriving stock (GHC.Generic)
59+
deriving
60+
(PIsData, PDataFields, PlutusType)
61+
62+
instance DerivePlutusType DepositRedeemer where type DPTStrat _ = PlutusTypeData
63+
64+
instance PUnsafeLiftDecl DepositRedeemer where type PLifted DepositRedeemer = D.DepositRedeemer
65+
deriving via (DerivePConstantViaData D.DepositRedeemer DepositRedeemer) instance (PConstantDecl D.DepositRedeemer)
66+
67+
depositValidatorT :: ClosedTerm (DepositConfig :--> DepositRedeemer :--> PScriptContext :--> PBool)
68+
depositValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do
69+
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
70+
conf <- pletFieldsC @'["expectedNumEpochs", "bundleKeyCS", "redeemerPkh", "vlqAC", "tmpAC"] conf'
71+
redeemer <- pletFieldsC @'["poolInIdx", "depositInIdx", "redeemerOutIdx", "bundleOutIdx"] redeemer'
72+
73+
txInfo <- pletFieldsC @'["inputs", "outputs", "signatories"] $ getField @"txInfo" ctx
74+
inputs <- tletUnwrap $ getField @"inputs" txInfo
75+
outputs <- tletUnwrap $ getField @"outputs" txInfo
76+
let
77+
poolInIx = getField @"poolInIdx" redeemer
78+
depositInIdx = getField @"depositInIdx" redeemer
79+
redeemerOutIdx = getField @"redeemerOutIdx" redeemer
80+
bundleOutIdx = getField @"bundleOutIdx" redeemer
81+
82+
expectedNumEpochs = getField @"expectedNumEpochs" conf
83+
84+
redeemerPkh = getField @"redeemerPkh" conf
85+
vlqAC = getField @"vlqAC" conf
86+
bundleKeyCS = getField @"bundleKeyCS" conf
87+
tmpAC = getField @"tmpAC" conf
88+
89+
sigs = pfromData $ getField @"signatories" txInfo
90+
91+
signedByRedeemPkh = containsSignature # sigs # redeemerPkh
92+
93+
selfIn' <- tlet $ pelemAt # depositInIdx # inputs
94+
selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn'
95+
selfValue <-
96+
let self = getField @"resolved" selfIn
97+
in tletField @"value" self
98+
99+
PSpending selfRef' <- tmatch (pfromData $ getField @"purpose" ctx)
100+
101+
let
102+
selfIdentity =
103+
let selfRef = pfromData $ pfield @"_0" # selfRef'
104+
selfInRef = pfromData $ getField @"outRef" selfIn
105+
in selfRef #== selfInRef
106+
107+
poolIn' <- tlet $ pelemAt # poolInIx # inputs
108+
poolOutRef <- tletUnwrap $ pfield @"outRef" # poolIn'
109+
let
110+
poolId = pfield @"id" # poolOutRef
111+
lqTnBytes = pcon $ PTokenName $ pfield @"_0" # poolId
112+
113+
redeemerOut' <- tlet $ pelemAt # redeemerOutIdx # outputs
114+
let
115+
redeemerValue = getRewardValueByPkh' # redeemerOut' # redeemerPkh
116+
117+
lqAc = assetClass # bundleKeyCS # lqTnBytes
118+
119+
redeemerLqValue = assetClassValueOf # redeemerValue # lqAc
120+
correctLqValue = redeemerLqValue #== LMPool.lqQty
121+
122+
bundleOut' <- tlet $ pelemAt # bundleOutIdx # outputs
123+
bundleOut <- pletFieldsC @'["value", "datum"] bundleOut'
124+
let
125+
bundleValue = getField @"value" bundleOut
126+
datumOD' = getField @"datum" bundleOut
127+
128+
POutputDatum bundleOD' <- pmatchC datumOD'
129+
130+
bundleOD <- tletField @"outputDatum" bundleOD'
131+
132+
PDatum bundleDatum'' <- pmatchC bundleOD
133+
134+
bundleDatum' <- tlet $ ptryFromData @(SB.StakingBundleConfig) $ bundleDatum''
135+
bundleDatum <- pletFieldsC @'["bundleLQAC", "redeemerPkh"] bundleDatum'
136+
let
137+
bundleLQAC = getField @"bundleLQAC" bundleDatum
138+
139+
redeemerPkhBundle = getField @"redeemerPkh" bundleDatum
140+
141+
vlqIn = assetClassValueOf # selfValue # vlqAC
142+
vlqOut = assetClassValueOf # bundleValue # vlqAC
143+
tmpOut = assetClassValueOf # bundleValue # tmpAC
144+
145+
validVLQQty = vlqIn #== vlqOut
146+
validTMPQty = (vlqIn * expectedNumEpochs) #== tmpOut
147+
148+
validBundleRedeemer = redeemerPkh #== redeemerPkhBundle
149+
150+
validBundleAC = bundleLQAC #== lqAc
151+
152+
pure $ signedByRedeemPkh #|| (selfIdentity #&& validVLQQty #&& validTMPQty #&& validBundleRedeemer #&& correctLqValue #&& validBundleAC)

0 commit comments

Comments
 (0)