diff --git a/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/Deposit.hs b/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/Deposit.hs new file mode 100644 index 0000000..bcb27a1 --- /dev/null +++ b/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/Deposit.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module ErgoDex.Contracts.Proxy.LqMining.Simple.Deposit where + +import qualified PlutusTx +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V1.Value + +data DepositConfig = DepositConfig + { expectedNumEpochs :: Integer + , bundleKeyCS :: CurrencySymbol + , redeemerPkh :: PubKeyHash + , vlqAC :: AssetClass + , tmpAC :: AssetClass + } deriving stock (Show) + +PlutusTx.makeIsDataIndexed ''DepositConfig [('DepositConfig, 0)] + +data DepositRedeemer = DepositRedeemer + { poolInIdx :: Integer + , depositInIdx :: Integer + , redeemerOutIdx :: Integer + , bundleOutIdx :: Integer + } deriving stock (Show) + +PlutusTx.makeIsDataIndexed ''DepositRedeemer [('DepositRedeemer, 0)] \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/LMPool.hs b/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/LMPool.hs new file mode 100644 index 0000000..033e692 --- /dev/null +++ b/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/LMPool.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module ErgoDex.Contracts.Proxy.LqMining.Simple.LMPool where + +import qualified PlutusTx +import PlutusLedgerApi.V1.Value + +data LMPoolConfig = LMPoolConfig + { epochLen :: Integer + , epochNum :: Integer + , programStart :: Integer + , programBudget :: Integer + , execBudget :: Integer + , epoch :: Integer + , maxRoundingError :: Integer + , poolNft :: AssetClass + , poolX :: AssetClass + , poolLQ :: AssetClass + , poolVLQ :: AssetClass + , poolTMP :: AssetClass + } deriving stock (Show) + +PlutusTx.makeIsDataIndexed ''LMPoolConfig [('LMPoolConfig, 0)] + +data LMPoolRedeemer = LMPoolRedeemer + { poolInIdx :: Integer + , poolOutIdx :: Integer + } deriving stock (Show) + +PlutusTx.makeIsDataIndexed ''LMPoolRedeemer [('LMPoolRedeemer, 0)] \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/Redeem.hs b/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/Redeem.hs new file mode 100644 index 0000000..7547c5a --- /dev/null +++ b/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/Redeem.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module ErgoDex.Contracts.Proxy.LqMining.Simple.Redeem where + +import PlutusLedgerApi.V1.Value +import PlutusLedgerApi.V1.Crypto (PubKeyHash) + +import qualified PlutusTx + +data RedeemConfig = RedeemConfig + { expectedLQAC :: AssetClass + , expectedLQAmount :: Integer + , rewardPkh :: PubKeyHash + } deriving stock (Show) + +PlutusTx.makeIsDataIndexed ''RedeemConfig [('RedeemConfig, 0)] + +data RedeemRedeemerConfig = RedeemRedeemerConfig + { rewardOutIdx :: Integer + } deriving stock (Show) + +PlutusTx.makeIsDataIndexed ''RedeemRedeemerConfig [('RedeemRedeemerConfig, 0)] \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/StakingBundle.hs b/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/StakingBundle.hs new file mode 100644 index 0000000..4679934 --- /dev/null +++ b/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/LqMining/Simple/StakingBundle.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module ErgoDex.Contracts.Proxy.LqMining.Simple.StakingBundle where + +import PlutusLedgerApi.V1.Value +import PlutusLedgerApi.V1.Crypto (PubKeyHash) + +import qualified PlutusTx + +data StakingBundleConfig = StakingBundleConfig + { bundleAC :: AssetClass + , poolAC :: AssetClass + , bundleLQAC :: AssetClass + , bundleVLQAC :: AssetClass + , bundleTMPAC :: AssetClass + , redeemerPkh :: PubKeyHash + } deriving stock (Show) + +PlutusTx.makeIsDataIndexed ''StakingBundleConfig [('StakingBundleConfig, 0)] + +data StakingBundleRedeemer = StakingBundleRedeemer + { poolInIdx :: Integer + , permitIdx :: Integer + , selfInIdx :: Integer + , redeemerOutIx :: Integer + , successorOutIndex :: Integer + } deriving stock (Show) + +PlutusTx.makeIsDataIndexed ''StakingBundleRedeemer [('StakingBundleRedeemer, 0)] \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PDeposit.hs b/cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PDeposit.hs new file mode 100644 index 0000000..024dbaa --- /dev/null +++ b/cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PDeposit.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE UndecidableInstances #-} + +module ErgoDex.PContracts.LqMining.Simple.PDeposit where + +import qualified GHC.Generics as GHC + +import Plutarch +import Plutarch.Api.V2 (POutputDatum(POutputDatum), PPubKeyHash, PDatum(PDatum), PTokenName(..), PCurrencySymbol(..)) +import Plutarch.Api.V2.Contexts (PScriptContext, PScriptPurpose (PSpending)) +import Plutarch.DataRepr +import Plutarch.Lift +import Plutarch.Prelude +import Plutarch.Extra.TermCont + +import PExtra.API (PAssetClass, assetClassValueOf, ptryFromData, assetClass, tletUnwrap) +import PExtra.Monadic (tlet, tletField, tmatch) + +import ErgoDex.PContracts.PApi (containsSignature, getRewardValueByPkh', maxLqCap) + +import qualified ErgoDex.Contracts.Proxy.LqMining.Simple.Deposit as D +import qualified ErgoDex.PContracts.LqMining.Simple.PStakingBundle as SB +import qualified ErgoDex.PContracts.LqMining.Simple.PLMPool as LMPool + +newtype DepositConfig (s :: S) + = DepositConfig + ( Term + s + ( PDataRecord + '[ "expectedNumEpochs" ':= PInteger + , "bundleKeyCS" ':= PCurrencySymbol + , "redeemerPkh" ':= PPubKeyHash + , "vlqAC" ':= PAssetClass + , "tmpAC" ':= PAssetClass + ] + ) + ) + deriving stock (GHC.Generic) + deriving + (PIsData, PDataFields, PlutusType) + +instance DerivePlutusType DepositConfig where type DPTStrat _ = PlutusTypeData + +instance PUnsafeLiftDecl DepositConfig where type PLifted DepositConfig = D.DepositConfig +deriving via (DerivePConstantViaData D.DepositConfig DepositConfig) instance (PConstantDecl D.DepositConfig) + +newtype DepositRedeemer (s :: S) + = DepositRedeemer + ( Term + s + ( PDataRecord + '[ "poolInIdx" ':= PInteger + , "depositInIdx" ':= PInteger + , "redeemerOutIdx" ':= PInteger + , "bundleOutIdx" ':= PInteger + ] + ) + ) + deriving stock (GHC.Generic) + deriving + (PIsData, PDataFields, PlutusType) + +instance DerivePlutusType DepositRedeemer where type DPTStrat _ = PlutusTypeData + +instance PUnsafeLiftDecl DepositRedeemer where type PLifted DepositRedeemer = D.DepositRedeemer +deriving via (DerivePConstantViaData D.DepositRedeemer DepositRedeemer) instance (PConstantDecl D.DepositRedeemer) + +depositValidatorT :: ClosedTerm (DepositConfig :--> DepositRedeemer :--> PScriptContext :--> PBool) +depositValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do + ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' + conf <- pletFieldsC @'["expectedNumEpochs", "bundleKeyCS", "redeemerPkh", "vlqAC", "tmpAC"] conf' + redeemer <- pletFieldsC @'["poolInIdx", "depositInIdx", "redeemerOutIdx", "bundleOutIdx"] redeemer' + + txInfo <- pletFieldsC @'["inputs", "outputs", "signatories"] $ getField @"txInfo" ctx + inputs <- tletUnwrap $ getField @"inputs" txInfo + outputs <- tletUnwrap $ getField @"outputs" txInfo + let + poolInIx = getField @"poolInIdx" redeemer + depositInIdx = getField @"depositInIdx" redeemer + redeemerOutIdx = getField @"redeemerOutIdx" redeemer + bundleOutIdx = getField @"bundleOutIdx" redeemer + + expectedNumEpochs = getField @"expectedNumEpochs" conf + + redeemerPkh = getField @"redeemerPkh" conf + vlqAC = getField @"vlqAC" conf + bundleKeyCS = getField @"bundleKeyCS" conf + tmpAC = getField @"tmpAC" conf + + sigs = pfromData $ getField @"signatories" txInfo + + signedByRedeemPkh = containsSignature # sigs # redeemerPkh + + selfIn' <- tlet $ pelemAt # depositInIdx # inputs + selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' + selfValue <- + let self = getField @"resolved" selfIn + in tletField @"value" self + + PSpending selfRef' <- tmatch (pfromData $ getField @"purpose" ctx) + + let + selfIdentity = + let selfRef = pfromData $ pfield @"_0" # selfRef' + selfInRef = pfromData $ getField @"outRef" selfIn + in selfRef #== selfInRef + + poolIn' <- tlet $ pelemAt # poolInIx # inputs + poolOutRef <- tletUnwrap $ pfield @"outRef" # poolIn' + let + poolId = pfield @"id" # poolOutRef + lqTnBytes = pcon $ PTokenName $ pfield @"_0" # poolId + + redeemerOut' <- tlet $ pelemAt # redeemerOutIdx # outputs + let + redeemerValue = getRewardValueByPkh' # redeemerOut' # redeemerPkh + + lqAc = assetClass # bundleKeyCS # lqTnBytes + + redeemerLqValue = assetClassValueOf # redeemerValue # lqAc + correctLqValue = redeemerLqValue #== maxLqCap + + bundleOut' <- tlet $ pelemAt # bundleOutIdx # outputs + bundleOut <- pletFieldsC @'["value", "datum"] bundleOut' + let + bundleValue = getField @"value" bundleOut + datumOD' = getField @"datum" bundleOut + + POutputDatum bundleOD' <- pmatchC datumOD' + + bundleOD <- tletField @"outputDatum" bundleOD' + + PDatum bundleDatum'' <- pmatchC bundleOD + + bundleDatum' <- tlet $ ptryFromData @(SB.StakingBundleConfig) $ bundleDatum'' + bundleDatum <- pletFieldsC @'["bundleLQAC", "redeemerPkh"] bundleDatum' + let + bundleLQAC = getField @"bundleLQAC" bundleDatum + + redeemerPkhBundle = getField @"redeemerPkh" bundleDatum + + vlqIn = assetClassValueOf # selfValue # vlqAC + vlqOut = assetClassValueOf # bundleValue # vlqAC + tmpOut = assetClassValueOf # bundleValue # tmpAC + + validVLQQty = vlqIn #== vlqOut + validTMPQty = (vlqIn * expectedNumEpochs) #== tmpOut + + validBundleRedeemer = redeemerPkh #== redeemerPkhBundle + + validBundleAC = bundleLQAC #== lqAc + + pure $ signedByRedeemPkh #|| (selfIdentity #&& validVLQQty #&& validTMPQty #&& validBundleRedeemer #&& correctLqValue #&& validBundleAC) \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PLMPool.hs b/cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PLMPool.hs new file mode 100644 index 0000000..7ebade2 --- /dev/null +++ b/cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PLMPool.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE UndecidableInstances #-} + +module ErgoDex.PContracts.LqMining.Simple.PLMPool where + +import qualified GHC.Generics as GHC + +import Plutarch +import Plutarch.Api.V2 (PMaybeData (PDJust), PTxOut, POutputDatum(POutputDatum, PNoOutputDatum, POutputDatumHash), PPubKeyHash, PDatum(PDatum), PExtended(PFinite)) +import Plutarch.Api.V2.Contexts (PScriptContext, PScriptPurpose (PSpending)) +import Plutarch.Api.V1.Time (PPOSIXTime(PPOSIXTime)) +import Plutarch.DataRepr +import Plutarch.Lift +import Plutarch.Prelude +import Plutarch.Extra.TermCont +import Plutarch.Builtin (pasInt, pforgetData, pfromData, pdata, PIsData(..)) +import Plutarch.Unsafe (punsafeCoerce) +import Plutarch.Internal.PlutusType (PInner, PlutusType, pcon', pmatch') + +import PExtra.Ada +import PExtra.API (PAssetClass, assetClassValueOf, ptryFromData) +import PExtra.List (pelemAt) +import PExtra.Monadic (tcon, tlet, tletField, tmatch, tmatchField) + +import qualified ErgoDex.Contracts.Pool as P +import ErgoDex.PContracts.PApi (burnLqInitial, feeDen, maxLqCap, tletUnwrap, zero, containsSignature, pmax) + +import qualified ErgoDex.Contracts.Proxy.LqMining.Simple.LMPool as Pool + +newtype LMPoolConfig (s :: S) + = LMPoolConfig + ( Term + s + ( PDataRecord + '[ "epochLen" ':= PInteger + , "epochNum" ':= PInteger + , "programStart" ':= PInteger + , "programBudget" ':= PInteger + , "execBudget" ':= PInteger + , "epoch" ':= PInteger + , "maxRoundingError" ':= PInteger + , "poolNft" ':= PAssetClass + , "poolX" ':= PAssetClass + , "poolLQ" ':= PAssetClass + , "poolVLQ" ':= PAssetClass + , "poolTMP" ':= PAssetClass + ] + ) + ) + deriving stock (GHC.Generic) + deriving + (PIsData, PDataFields, PlutusType) + +instance DerivePlutusType LMPoolConfig where type DPTStrat _ = PlutusTypeData + +instance PUnsafeLiftDecl LMPoolConfig where type PLifted LMPoolConfig = Pool.LMPoolConfig +deriving via (DerivePConstantViaData Pool.LMPoolConfig LMPoolConfig) instance (PConstantDecl Pool.LMPoolConfig) + +instance PTryFrom PData (PAsData LMPoolConfig) + +newtype LMPoolRedeemer (s :: S) + = LMPoolRedeemer + ( Term + s + ( PDataRecord + '[ "poolInIdx" ':= PInteger + , "poolOutIdx" ':= PInteger + ] + ) + ) + deriving stock (GHC.Generic) + deriving + (PIsData, PDataFields, PlutusType) + +instance DerivePlutusType LMPoolRedeemer where type DPTStrat _ = PlutusTypeData + +instance PUnsafeLiftDecl LMPoolRedeemer where type PLifted LMPoolRedeemer = Pool.LMPoolRedeemer +deriving via (DerivePConstantViaData Pool.LMPoolRedeemer LMPoolRedeemer) instance (PConstantDecl Pool.LMPoolRedeemer) + +lmPoolValidatorT :: ClosedTerm (LMPoolConfig :--> LMPoolRedeemer :--> PScriptContext :--> PBool) +lmPoolValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do + ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' + conf <- pletFieldsC @'["epochLen", "epochNum", "programStart", "programBudget", "maxRoundingError", "execBudget", "poolNft", "poolX", "poolLQ", "poolVLQ", "poolTMP"] conf' + redeemer <- pletFieldsC @'["poolInIdx", "poolOutIdx"] redeemer' + txInfo <- pletFieldsC @'["inputs", "outputs", "validRange"] $ getField @"txInfo" ctx + + validRange <- tletUnwrap $ getField @"validRange" txInfo + inputs <- tletUnwrap $ getField @"inputs" txInfo + outputs <- tletUnwrap $ getField @"outputs" txInfo + let + epochLen = getField @"epochLen" conf + epochNum = getField @"epochNum" conf + programStart = pfromData $ getField @"programStart" conf + programBudget = getField @"programBudget" conf + execBudget = getField @"execBudget" conf + + poolNft = getField @"poolNft" conf + poolX = getField @"poolX" conf + poolLQ = getField @"poolLQ" conf + poolVLQ = getField @"poolVLQ" conf + poolTMP = getField @"poolTMP" conf + maxRoundingError = getField @"maxRoundingError" conf + + poolInIx = getField @"poolInIdx" redeemer + poolOutIdx = getField @"poolOutIdx" redeemer + + selfIn' <- tlet $ pelemAt # poolInIx # inputs + selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' + let self = getField @"resolved" selfIn + + PSpending selfRef' <- tmatch (pfromData $ getField @"purpose" ctx) + let + selfIdentity = + let selfRef = pfromData $ pfield @"_0" # selfRef' + selfInRef = pfromData $ getField @"outRef" selfIn + in selfRef #== selfInRef + + successor <- tlet $ findPoolOutput # poolNft # outputs -- nft is preserved + + succDatum <- tletField @"datum" successor + + selfValue <- tletField @"value" self + succValue <- tletField @"value" successor + + POutputDatum succD' <- pmatchC succDatum + + succD <- tletField @"outputDatum" succD' + + PDatum succDatum <- pmatchC succD + + succDatum' <- tlet $ ptryFromData @(LMPoolConfig) $ succDatum + let + succPoolDatumEpoch = pfield @"epoch" # succDatum' + epochAlloc = pdiv # programBudget # epochNum + + reserveAda = assetClassValueOf # selfValue # pAdaAssetClass + reserveX = assetClassValueOf # selfValue # poolX + reserveLQ = assetClassValueOf # selfValue # poolLQ + reserveVLQ = assetClassValueOf # selfValue # poolVLQ + reserveTMP = assetClassValueOf # selfValue # poolTMP + + succAda = assetClassValueOf # succValue # pAdaAssetClass + succX = assetClassValueOf # succValue # poolX + succLQ = assetClassValueOf # succValue # poolLQ + succVLQ = assetClassValueOf # succValue # poolVLQ + succTMP = assetClassValueOf # succValue # poolTMP + + deltaX = succX - reserveX + deltaLQ = succLQ - reserveLQ + deltaVLQ = succVLQ - reserveVLQ + deltaTMP = succTMP - reserveTMP + + from = pfield @"from" # validRange + pextended = pfield @"_0" # from + + PFinite req <- pmatchC pextended + (PPOSIXTime curTime) <- pmatchC $ pfield @"_0" # req + let + curTimeIdx = curTime - programStart + 1 + curEpochIxRem = pmod # curTimeIdx # epochLen + curEpochIxR = pdiv # curTimeIdx # epochLen + + curEpochIx <- + tlet $ + pif + (0 #< curEpochIxRem) + (curEpochIxR + 1) + curEpochIxR + + validAction <- + tlet $ + pif + (deltaLQ #< 0) + (checkRedeem # deltaVLQ # epochNum # curEpochIx # deltaLQ # deltaTMP) + ( + pif + (deltaLQ #== 0) + (checkCompound # succPoolDatumEpoch # epochNum # curEpochIx # reserveX # epochAlloc # deltaTMP # reserveLQ # reserveAda # succAda # deltaX # deltaLQ # deltaVLQ # execBudget # programBudget) + (checkDeposit # deltaLQ # epochNum # curEpochIx # deltaVLQ # deltaTMP # maxRoundingError # programBudget # reserveX # epochAlloc) + ) + pure $ selfIdentity #&& validAction -- #&& confPreserved + +checkDeposit :: + Term + s + ( PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PBool + ) +checkDeposit = + plam $ \releasedVLQ epochNum curEpochIx deltaVLQ deltaTMP maxRoundingError programBudget reservesX epochAlloc -> + unTermCont $ do + let + curEpochMax = pmax # 0 # curEpochIx + epochsAllocated = epochNum - curEpochMax + releasedTMP = releasedVLQ * epochsAllocated + curEpochToCalc = + pif + (curEpochIx #<= epochNum) + (curEpochIx) + (epochNum + 1) + prevEpochsCompoundedForDeposit = + (curEpochToCalc - 1) * epochAlloc #<= ((programBudget - reservesX) + maxRoundingError) + pure $ prevEpochsCompoundedForDeposit #&& (releasedVLQ #== -deltaVLQ) #&& (releasedTMP #== -deltaTMP) + +checkRedeem :: Term s (PInteger :--> PInteger :--> PInteger :--> PInteger :--> PInteger :--> PBool) +checkRedeem = + plam $ \deltaVLQ epochNum curEpochIx deltaLQ deltaTMP -> + unTermCont $ do + let + curEpochMax = pmax # 0 # curEpochIx + minReturnedTMP = + pif (epochNum #< curEpochIx) + epochsDeallocated = epochNum - curEpochMax + returnedTMP = deltaVLQ * epochsDeallocated + in pure $ (deltaVLQ #== -deltaLQ) #&& (returnedTMP #== deltaTMP) + +checkCompound :: + Term + s + ( PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PInteger + :--> PBool + ) +checkCompound = + plam $ \succPoolDatumEpoch epochNum curEpochIx reservesX epochAlloc deltaTMP reservesLQ execBudgetRem0 execBudgetRem1 deltaX deltaLQ deltaVLQ execBudget programBudget -> + unTermCont $ do + let + epochsToCompound = epochNum - succPoolDatumEpoch + legalEpoch = succPoolDatumEpoch #<= (curEpochIx - 1) + prevEpochCompounded = (reservesX - epochsToCompound * epochAlloc) #<= epochAlloc + reward = pdiv # (epochAlloc * deltaTMP) # reservesLQ -- handle round loss? + execFee = pdiv # (reward * execBudget) # programBudget + in pure (legalEpoch + #&& prevEpochCompounded + #&& (-deltaX #== reward) + #&& (deltaLQ #== 0) + #&& (deltaVLQ #== 0) + #&& ((execBudgetRem1 - execBudgetRem0) #<= execFee)) + +findPoolOutput :: Term s (PAssetClass :--> PBuiltinList PTxOut :--> PTxOut) +findPoolOutput = + phoistAcyclic $ + plam $ \nft -> + precList + ( \self x xs -> + let value = pfield @"value" # x + amt = assetClassValueOf # value # nft + in pif (amt #== 1) x (self # xs) + ) + (const $ ptraceError "Pool output not found") \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PRedeem.hs b/cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PRedeem.hs new file mode 100644 index 0000000..2f3b70f --- /dev/null +++ b/cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PRedeem.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE UndecidableInstances #-} + +module ErgoDex.PContracts.LqMining.Simple.PRedeem where + +import qualified GHC.Generics as GHC + +import Plutarch +import Plutarch.Api.V2 (PPubKeyHash) +import Plutarch.Api.V2.Contexts (PScriptContext) +import Plutarch.DataRepr +import Plutarch.Lift +import Plutarch.Prelude +import Plutarch.Extra.TermCont + +import PExtra.API (PAssetClass, assetClassValueOf) +import PExtra.Monadic (tlet, tletField) + +import ErgoDex.PContracts.PApi (getRewardValueByPkh') +import qualified ErgoDex.Contracts.Proxy.LqMining.Simple.Redeem as R + +newtype RedeemConfig (s :: S) + = RedeemConfig + ( Term + s + ( PDataRecord + '[ "expectedLQAC" ':= PAssetClass + , "expectedLQAmount" ':= PInteger + , "redeemerPkh" ':= PPubKeyHash + ] + ) + ) + deriving stock (GHC.Generic) + deriving + (PIsData, PDataFields, PlutusType) + +instance DerivePlutusType RedeemConfig where type DPTStrat _ = PlutusTypeData + +instance PUnsafeLiftDecl RedeemConfig where type PLifted RedeemConfig = R.RedeemConfig +deriving via (DerivePConstantViaData R.RedeemConfig RedeemConfig) instance (PConstantDecl R.RedeemConfig) + +newtype RedeemRedeemerConfig (s :: S) + = RedeemRedeemerConfig + ( Term + s + ( PDataRecord + '[ "rewardOutIdx" ':= PInteger ] + ) + ) + deriving stock (GHC.Generic) + deriving + (PIsData, PDataFields, PlutusType) + +instance DerivePlutusType RedeemRedeemerConfig where type DPTStrat _ = PlutusTypeData + +instance PUnsafeLiftDecl RedeemRedeemerConfig where type PLifted RedeemRedeemerConfig = R.RedeemRedeemerConfig +deriving via (DerivePConstantViaData R.RedeemRedeemerConfig RedeemRedeemerConfig) instance (PConstantDecl R.RedeemRedeemerConfig) + +redeemValidatorT :: ClosedTerm (RedeemConfig :--> RedeemRedeemerConfig :--> PScriptContext :--> PBool) +redeemValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do + txInfo <- tletField @"txInfo" ctx' + outputs <- tletField @"outputs" $ txInfo + conf <- pletFieldsC @'["expectedLQAC", "expectedLQAmount", "redeemerPkh"] conf' + + rewardOutIdx <- tletField @"rewardOutIdx" redeemer' + let + expectedLQAC = getField @"expectedLQAC" conf + expectedLQAmount = getField @"expectedLQAmount" conf + redeemerPkh = getField @"redeemerPkh" conf + + rewardOut' <- tlet $ pelemAt # rewardOutIdx # outputs + let + rewardValue = getRewardValueByPkh' # rewardOut' # redeemerPkh + + tmpOut = assetClassValueOf # rewardValue # expectedLQAC + + correctReward = tmpOut #== expectedLQAmount + + pure $ correctReward \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PStakingBundle.hs b/cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PStakingBundle.hs new file mode 100644 index 0000000..88cf319 --- /dev/null +++ b/cardano-dex-contracts-onchain/ErgoDex/PContracts/LqMining/Simple/PStakingBundle.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE UndecidableInstances #-} + +module ErgoDex.PContracts.LqMining.Simple.PStakingBundle where + +import qualified GHC.Generics as GHC + +import qualified Plutarch.Api.V1.Value as V1 + +import Plutarch +import Plutarch.Api.V2 (PTxOut, POutputDatum(POutputDatum), PPubKeyHash, PDatum(PDatum), PTxInInfo) +import Plutarch.Api.V2.Contexts (PScriptContext, PScriptPurpose (PSpending)) +import Plutarch.DataRepr +import Plutarch.Lift +import Plutarch.Prelude +import Plutarch.Extra.TermCont + +import PExtra.API (PAssetClass, assetClassValueOf, ptryFromData) +import PExtra.Monadic (tlet, tletField, tmatch) + +import ErgoDex.PContracts.PPool +import ErgoDex.PContracts.PApi (maxLqCap, tletUnwrap, getRewardValueByPkh') + +import qualified ErgoDex.Contracts.Proxy.LqMining.Simple.StakingBundle as SB +import qualified ErgoDex.PContracts.LqMining.Simple.PLMPool as Pool + +newtype StakingBundleConfig (s :: S) + = StakingBundleConfig + ( Term + s + ( PDataRecord + '[ "bundleAC" ':= PAssetClass + , "poolAC" ':= PAssetClass + , "bundleLQAC" ':= PAssetClass + , "bundleVLQAC" ':= PAssetClass + , "bundleTMPAC" ':= PAssetClass + , "redeemerPkh" ':= PPubKeyHash + ] + ) + ) + deriving stock (GHC.Generic) + deriving + (PlutusType, PIsData, PDataFields, PEq, PShow) + +instance DerivePlutusType StakingBundleConfig where type DPTStrat _ = PlutusTypeData + +instance PUnsafeLiftDecl StakingBundleConfig where type PLifted StakingBundleConfig = SB.StakingBundleConfig +deriving via (DerivePConstantViaData SB.StakingBundleConfig StakingBundleConfig) instance (PConstantDecl SB.StakingBundleConfig) + +instance PTryFrom PData (PAsData StakingBundleConfig) + +newtype StakingBundleRedeemer (s :: S) + = StakingBundleRedeemer + ( Term + s + ( PDataRecord + '[ "poolInIdx" ':= PInteger + , "permitIdx" ':= PInteger + , "selfInIdx" ':= PInteger + , "redeemerOutIx" ':= PInteger + , "successorOutIndex" ':= PInteger + ] + ) + ) + deriving stock (GHC.Generic) + deriving + (PIsData, PDataFields, PlutusType) + +instance DerivePlutusType StakingBundleRedeemer where type DPTStrat _ = PlutusTypeData + +instance PUnsafeLiftDecl StakingBundleRedeemer where type PLifted StakingBundleRedeemer = SB.StakingBundleRedeemer +deriving via (DerivePConstantViaData SB.StakingBundleRedeemer StakingBundleRedeemer) instance (PConstantDecl SB.StakingBundleRedeemer) + +stakingBundleValidatorT :: ClosedTerm (StakingBundleConfig :--> StakingBundleRedeemer :--> PScriptContext :--> PBool) +stakingBundleValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do + ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' + conf <- pletFieldsC @'["bundleAC", "poolAC", "redeemerPkh", "bundleVLQAC", "bundleTMPAC", "bundleLQAC"] conf' + redeemer <- pletFieldsC @'["poolInIdx", "permitIdx", "selfInIdx", "redeemerOutIx", "successorOutIndex"] redeemer' + txInfo <- pletFieldsC @'["inputs", "outputs"] $ getField @"txInfo" ctx + + inputs <- tletUnwrap $ getField @"inputs" txInfo + outputs <- tletUnwrap $ getField @"outputs" txInfo + let + bundleAC = getField @"bundleAC" conf + poolNFT = getField @"poolAC" conf + redeemerPkh = getField @"redeemerPkh" conf + bundleVLQAC = getField @"bundleVLQAC" conf + bundleTMPAC = getField @"bundleTMPAC" conf + bundleLQAC = getField @"bundleLQAC" conf + + poolInIdx = getField @"poolInIdx" redeemer + permitIdx = getField @"permitIdx" redeemer + selfInIdx = getField @"selfInIdx" redeemer + + purpose = pfromData $ getField @"purpose" ctx + + redeemerOutIx = getField @"redeemerOutIx" redeemer + successorOutIndex = getField @"successorOutIndex" redeemer + + poolIn' <- tlet $ pelemAt # poolInIdx # inputs + let pool = pfield @"resolved" # poolIn' + + poolInValue <- tletField @"value" pool + poolInDatum <- tletField @"datum" pool + + POutputDatum poolInD' <- pmatchC poolInDatum + + poolInD <- tletField @"outputDatum" poolInD' + + PDatum succPoolInDatum <- pmatchC poolInD + + succPoolInDatum' <- tletUnwrap $ ptryFromData @(Pool.LMPoolConfig) $ succPoolInDatum + + poolOut <- tlet $ findPoolOutput # poolNFT # outputs + let + poolOutValue = pfield @"value" # poolOut + + poolLQ = pfield @"poolLQ" # succPoolInDatum' + poolOutLQ = assetClassValueOf # poolOutValue # poolLQ + lqLockedInPoolTotal = assetClassValueOf # poolInValue # poolLQ + + deltaLQ = poolOutLQ - lqLockedInPoolTotal + + validAction <- + tlet $ + pif + (deltaLQ #== 0) -- compound + (checkCompound + # succPoolInDatum' + # poolInValue + # purpose + # poolNFT + # bundleVLQAC + # bundleTMPAC + # poolLQ + # inputs + # selfInIdx + # outputs + # successorOutIndex + # conf' + # redeemerOutIx + # redeemerPkh + ) + ( + pif + (deltaLQ #< 0) -- redeem + (checkRedeem # inputs # permitIdx # bundleLQAC) + (pcon PFalse) + ) + pure $ validAction + +checkCompound :: + Term + s + ( Pool.LMPoolConfig + :--> V1.PValue 'V1.Sorted 'V1.Positive + :--> PScriptPurpose + :--> PAssetClass + :--> PAssetClass + :--> PAssetClass + :--> PAssetClass + :--> PBuiltinList PTxInInfo + :--> PInteger + :--> PBuiltinList PTxOut + :--> PInteger + :--> StakingBundleConfig + :--> PInteger + :--> PPubKeyHash + :--> PBool + ) +checkCompound = + plam$ \inputPoolCfg inputPoolValue purpose poolNFT bundleVLQAC bundleTMPAC poolLQ inputs selfIdx outputs successorIdx selfCfg redeemerIdx rewardPkh -> unTermCont $ do + poolOut <- tlet $ findPoolOutput # poolNFT # outputs + + poolOutDatum <- tletField @"datum" poolOut + + POutputDatum poolD' <- pmatchC poolOutDatum + + poolD <- tletField @"outputDatum" poolD' + + PDatum succDatum <- pmatchC poolD + succPoolOutDatum' <- tletUnwrap $ ptryFromData @(Pool.LMPoolConfig) $ succDatum + + outputPoolCfg <- pletFieldsC @'["programBudget", "epoch", "poolX"] succPoolOutDatum' + let + programBudget = getField @"programBudget" outputPoolCfg + poolX = getField @"poolX" outputPoolCfg + + lqLockedInPoolTotal = assetClassValueOf # inputPoolValue # poolLQ + + epoch = getField @"epoch" outputPoolCfg + + epochNum = pfield @"epochNum" # inputPoolCfg + + epochRewardTotal = pdiv # programBudget # epochNum + epochsToCompound = epochNum - epoch + + selfIn' <- tlet $ pelemAt # selfIdx # inputs + selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' + let self = getField @"resolved" selfIn + + selfValue <- tletField @"value" self + selfDatum <- tletField @"datum" self + + PSpending selfRef' <- tmatch purpose + let + selfIdentity = + let selfRef = pfromData $ pfield @"_0" # selfRef' + selfInRef = pfromData $ getField @"outRef" selfIn + in selfRef #== selfInRef + + successorOut' <- tlet $ pelemAt # successorIdx # outputs + successorOut <- pletFieldsC @'["value", "datum"] successorOut' + redeemerOut <- tlet $ pelemAt # redeemerIdx # outputs + let + redeemerValue = getRewardValueByPkh' # redeemerOut # rewardPkh + + rewardX = assetClassValueOf # redeemerValue # poolX + + successorValue = getField @"value" successorOut + successorDatum = getField @"datum" successorOut + + bundleVLQQty = assetClassValueOf # selfValue # bundleVLQAC + bundleTMPQty = assetClassValueOf # selfValue # bundleTMPAC + releasedTMP = bundleTMPQty - epochsToCompound * bundleVLQQty + + successorBundleVLQ = assetClassValueOf # successorValue # bundleVLQAC + successorBundleTMP = assetClassValueOf # successorValue # bundleTMPAC + + epcohsBurned = (pdiv # bundleTMPQty # bundleVLQQty) - epochsToCompound + reward = pdiv # (epochRewardTotal * bundleVLQQty * epcohsBurned) # lqLockedInPoolTotal + + correctDatum = selfDatum #== successorDatum + correctVLQQty = successorBundleVLQ #== bundleVLQQty + correctTMPQty = (bundleTMPQty - successorBundleTMP) #== releasedTMP + correctReward = reward #== rewardX + + _ <- tlet $ ptraceShowId reward + + pure $ selfIdentity #&& correctDatum #&& correctVLQQty #&& correctTMPQty #&& correctReward + +checkRedeem :: Term s (PBuiltinList PTxInInfo :--> PInteger :--> PAssetClass :--> PBool) +checkRedeem = + plam $ \inputs permitIdx bundleAC -> unTermCont $ do + permitIn' <- tlet $ pelemAt # permitIdx # inputs + let + permitResolved = pfield @"resolved" # permitIn' + permitInValue = pfield @"value" # permitResolved + permitACValue = assetClassValueOf # permitInValue # bundleAC + + correctpermitACValue = permitACValue #== maxLqCap + + pure correctpermitACValue \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PApi.hs b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PApi.hs index 67ed8b7..45d6a68 100644 --- a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PApi.hs +++ b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PApi.hs @@ -2,6 +2,7 @@ module ErgoDex.PContracts.PApi ( containsSignature, ownCurrencySymbol, getRewardValue', + getRewardValueByPkh', tletUnwrap, pmin, getInputValue, @@ -12,6 +13,7 @@ module ErgoDex.PContracts.PApi ( maxLqCap, burnLqInitial, feeDen, + pmax ) where import Plutarch @@ -69,6 +71,19 @@ getRewardValue' = phoistAcyclic $ sPkh <- tlet $ getStakeHash # addr pure $ pif (sPkh #== stakePkhM) outValue (ptraceError "Invalid reward proposition") +getRewardValueByPkh' :: Term s (PTxOut :--> PPubKeyHash :--> V1.PValue 'V1.Sorted 'V1.Positive) +getRewardValueByPkh' = phoistAcyclic $ + plam $ \out pubkeyHash -> unTermCont $ do + let addr = pfield @"address" # out + cred <- tletField @"credential" addr + tletUnwrap $ + pmatch cred $ \case + PPubKeyCredential pcred -> + let pkh = pfield @"_0" # pcred + value = pfield @"value" # out + in pif (pkh #== pubkeyHash) value (ptraceError "Invalid reward proposition") + _ -> ptraceError "Invalid reward proposition" + getStakeHash :: forall (s :: S). Term s (PAddress :--> PMaybeData PPubKeyHash) getStakeHash = phoistAcyclic $ plam $ \address -> unTermCont $ do @@ -114,3 +129,6 @@ ownCurrencySymbol = phoistAcyclic $ PScriptContext te <- tmatch sc PMinting cs' <- tmatchField @"purpose" te pure $ pfield @"_0" # cs' + +pmax :: POrd a => Term s (a :--> a :--> a) +pmax = phoistAcyclic $ plam $ \a b -> pif (a #<= b) b a \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PAssets.hs b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PAssets.hs index 2e5a998..1e491c0 100644 --- a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PAssets.hs +++ b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PAssets.hs @@ -1,16 +1,18 @@ module ErgoDex.PContracts.PAssets ( poolNftMintValidatorT, poolLqMintValidatorT, + lmPoolLqMintValidatorT ) where import ErgoDex.PContracts.PApi (ownCurrencySymbol, tletUnwrap) -import PExtra.API (assetClass, assetClassValueOf) +import PExtra.API (assetClass, assetClassValueOf, PAssetClass(..)) import PExtra.List (pexists) import PExtra.Monadic import Plutarch import Plutarch.Api.V2 import Plutarch.Api.V1 (PTokenName) import Plutarch.Prelude +import Plutarch.Extra.TermCont poolNftMintValidatorT :: Term s PTxOutRef -> Term s PTokenName -> Term s (PData :--> PScriptContext :--> PBool) poolNftMintValidatorT oref tn = plam $ \_ ctx -> unTermCont $ do @@ -43,3 +45,32 @@ poolLqMintValidatorT oref tn emission = plam $ \_ ctx -> unTermCont $ do let ownAc = assetClass # (ownCurrencySymbol # ctx) # tn pure $ assetClassValueOf # valueMint # ownAc #== emission pure $ targetUtxoConsumed #&& tokenMintExact + + +lmPoolLqMintValidatorT :: Term s PAssetClass -> Term s PInteger -> Term s (PData :--> PScriptContext :--> PBool) +lmPoolLqMintValidatorT poolNft emission = plam $ \_ ctx -> unTermCont $ do + txinfo' <- tletField @"txInfo" ctx + txinfo <- tcont $ pletFields @'["inputs", "mint"] txinfo' + inputs <- tletUnwrap $ getField @"inputs" txinfo + let target = + let nftPreserved i = unTermCont $ do + out' <- tcont $ pletFields @'["outRef", "resolved"] i + value' <- + let out = pfromData $ getField @"resolved" out' + in tletField @"value" out + let + nftValue = assetClassValueOf # value' # poolNft + pure $ pif (nftValue #== 1) + ( + unTermCont $ do + valueMint <- tlet $ getField @"mint" txinfo + let + oref' = pfromData $ getField @"outRef" out' + oId' = pfield @"id" # oref' + tnBytes = pcon $ PTokenName $ pfield @"_0" # oId' + ownAc = assetClass # (ownCurrencySymbol # ctx) # tnBytes + pure $ assetClassValueOf # valueMint # ownAc #== emission + ) + (pcon PFalse) + in pexists # plam (nftPreserved) # inputs + pure target \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PMintingValidators.hs b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PMintingValidators.hs index a905947..032dd5d 100644 --- a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PMintingValidators.hs +++ b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PMintingValidators.hs @@ -1,6 +1,7 @@ module ErgoDex.PMintingValidators ( poolNftMiningValidator, poolLqMiningValidator, + lmPoolLqMintValidator, wrapMintingValidator, ) where @@ -34,3 +35,9 @@ poolLqMiningValidator oref tn emission = mkMintingPolicy $ wrapMintingValidator $ A.poolLqMintValidatorT (pconstant oref) (pconstant tn) (pconstant emission) + +lmPoolLqMintValidator :: AssetClass -> Integer -> MintingPolicy +lmPoolLqMintValidator ac emission = + mkMintingPolicy $ + wrapMintingValidator $ + A.lmPoolLqMintValidatorT (pconstant ac) (pconstant emission) diff --git a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PPool.hs b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PPool.hs index 3c5d5cc..6ef05a3 100644 --- a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PPool.hs +++ b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PPool.hs @@ -5,6 +5,7 @@ module ErgoDex.PContracts.PPool ( PoolAction (..), PoolRedeemer (..), poolValidatorT, + findPoolOutput ) where import qualified GHC.Generics as GHC diff --git a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PValidators.hs b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PValidators.hs index 65233b7..5b2ba66 100644 --- a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PValidators.hs +++ b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PValidators.hs @@ -3,6 +3,8 @@ module ErgoDex.PValidators ( swapValidator, depositValidator, redeemValidator, + lmRedeemValidator, + lmStakingBundleValidator, validatorAddress, wrapValidator, ) where @@ -10,6 +12,9 @@ module ErgoDex.PValidators ( import PlutusLedgerApi.V1.Scripts (Validator (getValidator)) import PlutusLedgerApi.V1.Address +import qualified ErgoDex.PContracts.LqMining.Simple.Redeem as LMR +import qualified ErgoDex.PContracts.LqMining.Simple.StakingBundle as LMSB + import qualified ErgoDex.PContracts.PDeposit as PD import qualified ErgoDex.PContracts.PPool as PP import qualified ErgoDex.PContracts.PRedeem as PR @@ -43,5 +48,11 @@ depositValidator = mkValidator $ wrapValidator PD.depositValidatorT redeemValidator :: Validator redeemValidator = mkValidator $ wrapValidator PR.redeemValidatorT +lmRedeemValidator :: Validator +lmRedeemValidator = mkValidator $ wrapValidator LMR.redeemValidatorT + +lmStakingBundleValidator :: Validator +lmStakingBundleValidator = mkValidator $ wrapValidator LMSB.stakingBundleValidatorT + validatorAddress :: Validator -> Address validatorAddress = scriptHashAddress . validatorHash diff --git a/cardano-dex-contracts-onchain/ErgoDex/PMintingValidators.hs b/cardano-dex-contracts-onchain/ErgoDex/PMintingValidators.hs index 3a8d67e..50c1856 100644 --- a/cardano-dex-contracts-onchain/ErgoDex/PMintingValidators.hs +++ b/cardano-dex-contracts-onchain/ErgoDex/PMintingValidators.hs @@ -1,6 +1,7 @@ module ErgoDex.PMintingValidators ( poolNftMiningValidator, poolLqMiningValidator, + lmPoolLqMintValidator, wrapMintingValidator, ) where @@ -13,11 +14,11 @@ import Plutarch.Unsafe (punsafeCoerce) import qualified ErgoDex.PContracts.PAssets as A import PlutusLedgerApi.V1.Scripts (MintingPolicy) -import PlutusLedgerApi.V1.Value (TokenName) +import PlutusLedgerApi.V1.Value (TokenName, AssetClass) import PlutusLedgerApi.V1.Contexts cfgForMintingValidator :: Config -cfgForMintingValidator = Config NoTracing +cfgForMintingValidator = Config DoTracingAndBinds wrapMintingValidator :: PIsData rdmr => @@ -39,3 +40,9 @@ poolLqMiningValidator oref tn emission = mkMintingPolicy cfgForMintingValidator $ wrapMintingValidator $ A.poolLqMintValidatorT (pconstant oref) (pconstant tn) (pconstant emission) + +lmPoolLqMintValidator :: AssetClass -> Integer -> MintingPolicy +lmPoolLqMintValidator ac emission = + mkMintingPolicy cfgForMintingValidator $ + wrapMintingValidator $ + A.lmPoolLqMintValidatorT (pconstant ac) (pconstant emission) \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/ErgoDex/PValidators.hs b/cardano-dex-contracts-onchain/ErgoDex/PValidators.hs index ad882c2..3102ba6 100644 --- a/cardano-dex-contracts-onchain/ErgoDex/PValidators.hs +++ b/cardano-dex-contracts-onchain/ErgoDex/PValidators.hs @@ -3,6 +3,10 @@ module ErgoDex.PValidators ( swapValidator, depositValidator, redeemValidator, + lmRedeemValidator, + lmStakingBundleValidator, + lmDepositValidator, + lmPoolValidator, validatorAddress, wrapValidator, ) where @@ -10,6 +14,11 @@ module ErgoDex.PValidators ( import PlutusLedgerApi.V1.Scripts (Validator (getValidator)) import PlutusLedgerApi.V1.Address +import qualified ErgoDex.PContracts.LqMining.Simple.PRedeem as LMR +import qualified ErgoDex.PContracts.LqMining.Simple.PStakingBundle as LMSB +import qualified ErgoDex.PContracts.LqMining.Simple.PDeposit as LMD +import qualified ErgoDex.PContracts.LqMining.Simple.PLMPool as LMP + import qualified ErgoDex.PContracts.PDeposit as PD import qualified ErgoDex.PContracts.PPool as PP import qualified ErgoDex.PContracts.PRedeem as PR @@ -23,7 +32,7 @@ import Plutarch.Unsafe (punsafeCoerce) import Plutarch.Internal cfgForValidator :: Config -cfgForValidator = Config NoTracing +cfgForValidator = Config DoTracingAndBinds wrapValidator :: (PIsData dt, PIsData rdmr) => @@ -47,5 +56,17 @@ depositValidator = mkValidator cfgForValidator $ wrapValidator PD.depositValidat redeemValidator :: Validator redeemValidator = mkValidator cfgForValidator $ wrapValidator PR.redeemValidatorT +lmRedeemValidator :: Validator +lmRedeemValidator = mkValidator cfgForValidator $ wrapValidator LMR.redeemValidatorT + +lmStakingBundleValidator :: Validator +lmStakingBundleValidator = mkValidator cfgForValidator $ wrapValidator LMSB.stakingBundleValidatorT + +lmDepositValidator :: Validator +lmDepositValidator = mkValidator cfgForValidator $ wrapValidator LMD.depositValidatorT + +lmPoolValidator :: Validator +lmPoolValidator = mkValidator cfgForValidator $ wrapValidator LMP.lmPoolValidatorT + validatorAddress :: Validator -> Address validatorAddress = scriptHashAddress . validatorHash diff --git a/cardano-dex-contracts-onchain/PExtra/API.hs b/cardano-dex-contracts-onchain/PExtra/API.hs index 303c9b8..d790236 100644 --- a/cardano-dex-contracts-onchain/PExtra/API.hs +++ b/cardano-dex-contracts-onchain/PExtra/API.hs @@ -18,11 +18,14 @@ module PExtra.API ( findOwnInput, --convertBackValue, mustPayToPubKey, + ptryFromData ) where import qualified GHC.Generics as GHC import Plutarch.Prelude +import Plutarch.Lift +import Plutarch.FFI import Plutarch.Api.V2 ( PAddress (PAddress), @@ -34,6 +37,7 @@ import Plutarch.Api.V2 ( PTxInfo (..), PTxOut (..), PTxOutRef (..), + PMintingPolicy, ) import Plutarch.Api.V1 ( @@ -44,9 +48,13 @@ import Plutarch.Api.V1 ( ) import qualified Plutarch.Api.V1.Value as PlutarchValue -import Plutarch.DataRepr (PDataFields) +import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields) import Plutarch.List (pconvertLists) import Plutarch.Extra.TermCont +import Plutarch +import qualified Data.Text as T +import qualified PlutusLedgerApi.V1.Scripts as Scripts +import qualified PlutusLedgerApi.V1.Value as Value import PExtra.Monadic (tcon, tlet, tletField, tmatchField) @@ -70,9 +78,14 @@ newtype PAssetClass (s :: S) ) ) deriving stock (GHC.Generic) - deriving anyclass (PIsData, PDataFields, PlutusType) + deriving anyclass (PIsData, PDataFields, PlutusType, PShow, PTryFrom PData) + +instance PUnsafeLiftDecl PAssetClass where type PLifted PAssetClass = Value.AssetClass instance DerivePlutusType PAssetClass where type DPTStrat _ = PlutusTypeData +deriving via (DerivePConstantViaData Value.AssetClass PAssetClass) instance (PConstantDecl Value.AssetClass) + +instance PTryFrom PData (PAsData PAssetClass) instance PEq PAssetClass where a #== b = @@ -199,3 +212,6 @@ convertAC' = phoistAcyclic $ cs <- tletField @"currencySymbol" ac tn <- tletField @"tokenName" ac tcon $ PPair cs tn + +ptryFromData :: forall a s. PTryFrom PData (PAsData a) => Term s PData -> Term s (PAsData a) +ptryFromData x = unTermCont $ fst <$> tcont (ptryFrom @(PAsData a) x) \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/cardano-dex-contracts-onchain.cabal b/cardano-dex-contracts-onchain/cardano-dex-contracts-onchain.cabal index 521b629..6ae66d5 100644 --- a/cardano-dex-contracts-onchain/cardano-dex-contracts-onchain.cabal +++ b/cardano-dex-contracts-onchain/cardano-dex-contracts-onchain.cabal @@ -91,6 +91,10 @@ library ErgoDex.Contracts.Proxy.Swap ErgoDex.Contracts.Proxy.Order ErgoDex.Contracts.Proxy.Redeem + ErgoDex.Contracts.Proxy.LqMining.Simple.Deposit + ErgoDex.Contracts.Proxy.LqMining.Simple.LMPool + ErgoDex.Contracts.Proxy.LqMining.Simple.Redeem + ErgoDex.Contracts.Proxy.LqMining.Simple.StakingBundle ErgoDex.Contracts.Pool ErgoDex.PContracts.PApi ErgoDex.PContracts.PAssets @@ -99,6 +103,10 @@ library ErgoDex.PContracts.PPool ErgoDex.PContracts.PRedeem ErgoDex.PContracts.PSwap + ErgoDex.PContracts.LqMining.Simple.PDeposit + ErgoDex.PContracts.LqMining.Simple.PLMPool + ErgoDex.PContracts.LqMining.Simple.PRedeem + ErgoDex.PContracts.LqMining.Simple.PStakingBundle ErgoDex.PMintingValidators ErgoDex.PValidators PExtra.Ada @@ -130,6 +138,10 @@ test-suite cardano-dex-contracts-test hs-source-dirs: test other-modules: Gen.Models + Gen.LqMining.Simple.RedeemGen + Gen.LqMining.Simple.DepositGen + Gen.LqMining.Simple.LMPoolGen + Gen.LqMining.Simple.StakingBundleGen Gen.DepositGen Gen.PoolGen Gen.SwapGen @@ -140,6 +152,10 @@ test-suite cardano-dex-contracts-test Tests.Pool Tests.Swap Tests.Redeem + Tests.LqMining.Simple.Deposit + Tests.LqMining.Simple.Redeem + Tests.LqMining.Simple.LMPool + Tests.LqMining.Simple.StakingBundle Eval build-depends: , base diff --git a/cardano-dex-contracts-onchain/test/Eval.hs b/cardano-dex-contracts-onchain/test/Eval.hs index 17cd2c6..6cd535e 100644 --- a/cardano-dex-contracts-onchain/test/Eval.hs +++ b/cardano-dex-contracts-onchain/test/Eval.hs @@ -4,21 +4,23 @@ module Eval where import Plutarch.Prelude import PExtra.API import Data.Text (Text, pack) -import Plutarch.Evaluate (evalScript, EvalError) +import Plutarch.Evaluate (evalScript, evalScriptHuge, EvalError) import Plutarch (ClosedTerm, compile, Config(..), TracingMode (..)) import PlutusLedgerApi.V1 (Data, ExBudget) import PlutusLedgerApi.V1.Scripts (Script (unScript), applyArguments) import Control.Arrow import UntypedPlutusCore (DeBruijn, DefaultFun, DefaultUni, Program) import PlutusTx (Data) +import Debug.Trace evalConfig :: Config -evalConfig = Config DoTracing +evalConfig = Config DoTracingAndBinds evalWithArgs :: ClosedTerm a -> [Data] -> Either Text (ExBudget, [Text], Program DeBruijn DefaultUni DefaultFun ()) evalWithArgs x args = do cmp <- compile evalConfig x let (escr, budg, trc) = evalScript $ applyArguments cmp args + traceM (show trc) scr <- left (pack . show) escr pure (budg, trc, unScript scr) diff --git a/cardano-dex-contracts-onchain/test/Gen/LqMining/Simple/DepositGen.hs b/cardano-dex-contracts-onchain/test/Gen/LqMining/Simple/DepositGen.hs new file mode 100644 index 0000000..cf64c83 --- /dev/null +++ b/cardano-dex-contracts-onchain/test/Gen/LqMining/Simple/DepositGen.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Gen.LqMining.Simple.DepositGen where + +import Hedgehog + +import Gen.Models + +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V1.Value +import PlutusTx.Builtins.Internal + +import qualified PlutusLedgerApi.V1.Interval as PInterval + +import qualified ErgoDex.Contracts.Proxy.LqMining.Simple.Deposit as D +import qualified ErgoDex.Contracts.Proxy.LqMining.Simple.StakingBundle as SB + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Hex +import qualified Data.Text.Encoding as E +import qualified Data.Text as T + +genRedeemerTxOut :: TxOutRef -> CurrencySymbol -> Integer -> PubKeyHash -> (TxOut, AssetClass) +genRedeemerTxOut TxOutRef{..} bundleCS bundleACQty userPkh = + let + bundleAC = AssetClass (bundleCS, TokenName (getTxId txOutRefId)) + bundleQty = bundleACQty + value = mkValues [mkValue bundleAC bundleQty, mkAdaValue 1000] mempty + in (mkTxOut' NoOutputDatum value userPkh, bundleAC) + +genDepositTxInInfo :: TxOutRef -> AssetClass -> Integer -> AssetClass -> Integer -> OutputDatum -> TxInInfo +genDepositTxInInfo depositRef vlqAC vlqQty tmpAC tmpQty od = + let + value = mkValues [mkValue vlqAC vlqQty, mkValue tmpAC tmpQty, mkAdaValue 1000] mempty + txOut = mkTxOut od value mkLMDepositValidator + in mkTxIn depositRef txOut + +-- in deposit contract we need only pool TxOutRef +genFakePoolTxInInfo :: TxOutRef -> TxInInfo +genFakePoolTxInInfo poolTxOutRef = + let + value = mkValues [mkAdaValue 1000] mempty + pkh = PubKeyHash . BuiltinByteString $ "test" + txOut = mkTxOut' NoOutputDatum value pkh + in mkTxIn poolTxOutRef txOut + +genDepositConfig :: Integer -> CurrencySymbol -> PubKeyHash -> AssetClass -> AssetClass -> D.DepositConfig +genDepositConfig expectedNumEpochs bundleKeyCS redeemerPkh vlqAC tmpAC = + D.DepositConfig expectedNumEpochs bundleKeyCS redeemerPkh vlqAC tmpAC + +mkLMDepositTxInfo :: [TxInInfo] -> [TxOut] -> TxInfo +mkLMDepositTxInfo txIns txOuts = + TxInfo + { txInfoInputs = txIns + , txInfoOutputs = txOuts + , txInfoReferenceInputs = mempty + , txInfoRedeemers = fromList [] + , txInfoFee = mempty + , txInfoMint = mempty + , txInfoDCert = [] + , txInfoWdrl = fromList [] + , txInfoValidRange = PInterval.always + , txInfoSignatories = [] + , txInfoData = fromList [] + , txInfoId = "b0" + } \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/test/Gen/LqMining/Simple/LMPoolGen.hs b/cardano-dex-contracts-onchain/test/Gen/LqMining/Simple/LMPoolGen.hs new file mode 100644 index 0000000..89a257c --- /dev/null +++ b/cardano-dex-contracts-onchain/test/Gen/LqMining/Simple/LMPoolGen.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Gen.LqMining.Simple.LMPoolGen where + +import Hedgehog + +import Gen.Models + +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V1.Value +import PlutusTx.Builtins.Internal + +import qualified PlutusLedgerApi.V1.Interval as PInterval + +import qualified ErgoDex.Contracts.Proxy.LqMining.Simple.LMPool as SLMP + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Hex +import qualified Data.Text.Encoding as E +import qualified Data.Text as T + +genLMPoolConfig + :: Integer + -> Integer + -> Integer + -> Integer + -> Integer + -> Integer + -> AssetClass + -> AssetClass + -> AssetClass + -> AssetClass + -> AssetClass + -> SLMP.LMPoolConfig +genLMPoolConfig epochLen epochNum programStart programBudget execBudget epoch poolNft poolX poolLQ poolVLQ poolTMP = + SLMP.LMPoolConfig epochLen epochNum programStart programBudget execBudget epoch 10 poolNft poolX poolLQ poolVLQ poolTMP + +genPoolTxInInfo :: TxOutRef -> Integer -> Integer -> Integer -> Integer -> Integer -> SLMP.LMPoolConfig -> TxInInfo +genPoolTxInInfo poolRef poolNftQty poolXQty poolLQQty poolVLQQty poolTMPQty cfg = + let txOut = genPoolTxOut poolNftQty poolXQty poolLQQty poolVLQQty poolTMPQty cfg + in mkTxIn poolRef txOut + +genPoolTxOut :: Integer -> Integer -> Integer -> Integer -> Integer -> SLMP.LMPoolConfig -> TxOut +genPoolTxOut poolNftQty poolXQty poolLQQty poolVLQQty poolTMPQty cfg@SLMP.LMPoolConfig{..} = + let + value = + mkValues + [ mkValue poolNft poolNftQty + , mkValue poolX poolXQty + , mkValue poolLQ poolLQQty + , mkValue poolVLQ poolVLQQty + , mkValue poolTMP poolTMPQty + , mkAdaValue 1000 + ] mempty + + poolDatum = OutputDatum $ mkDatum cfg + in mkTxOut poolDatum value mkLMPoolValidator + +mkLMPoolTxInfo :: [TxInInfo] -> [TxOut] -> Integer -> Integer -> TxInfo +mkLMPoolTxInfo txIns txOuts validRangeStart validRangeEnd = + let + lower = (POSIXTime validRangeStart) + upper = (POSIXTime validRangeEnd) + in TxInfo + { txInfoInputs = txIns + , txInfoOutputs = txOuts + , txInfoReferenceInputs = mempty + , txInfoRedeemers = fromList [] + , txInfoFee = mempty + , txInfoMint = mempty + , txInfoDCert = [] + , txInfoWdrl = fromList [] + , txInfoValidRange = PInterval.interval lower upper + , txInfoSignatories = [] + , txInfoData = fromList [] + , txInfoId = "b0" + } \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/test/Gen/LqMining/Simple/RedeemGen.hs b/cardano-dex-contracts-onchain/test/Gen/LqMining/Simple/RedeemGen.hs new file mode 100644 index 0000000..dff50a3 --- /dev/null +++ b/cardano-dex-contracts-onchain/test/Gen/LqMining/Simple/RedeemGen.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Gen.LqMining.Simple.RedeemGen where + +import Hedgehog + +import Gen.Models + +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V1.Value +import PlutusTx.Builtins.Internal + +import qualified PlutusLedgerApi.V1.Interval as PInterval + +import qualified ErgoDex.Contracts.Proxy.LqMining.Simple.Redeem as R + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Hex +import qualified Data.Text.Encoding as E +import qualified Data.Text as T + +genRedeemConfig :: AssetClass -> Integer -> PubKeyHash -> R.RedeemConfig +genRedeemConfig = R.RedeemConfig + +genRedeemTxIn :: TxOutRef -> OutputDatum -> TxInInfo +genRedeemTxIn txOutRef redeemDatum = + let + value = mkValues [mkAdaValue 1000] mempty + txOut = mkTxOut redeemDatum value mkLMRedeemValidator + in mkTxIn txOutRef txOut + +genUserTxOut :: AssetClass -> Integer -> PubKeyHash -> TxOut +genUserTxOut redeemAC redeemQty userPkh = + let + value = mkValues [mkValue redeemAC redeemQty, mkAdaValue 1000] mempty + in mkTxOut' NoOutputDatum value userPkh + +mkLQRedeemTxInfo :: [TxInInfo] -> [TxOut] -> TxInfo +mkLQRedeemTxInfo txIns txOuts = + TxInfo + { txInfoInputs = txIns + , txInfoOutputs = txOuts + , txInfoReferenceInputs = mempty + , txInfoRedeemers = fromList [] + , txInfoFee = mempty + , txInfoMint = mempty + , txInfoDCert = [] + , txInfoWdrl = fromList [] + , txInfoValidRange = PInterval.always + , txInfoSignatories = [] + , txInfoData = fromList [] + , txInfoId = "b0" + } diff --git a/cardano-dex-contracts-onchain/test/Gen/LqMining/Simple/StakingBundleGen.hs b/cardano-dex-contracts-onchain/test/Gen/LqMining/Simple/StakingBundleGen.hs new file mode 100644 index 0000000..67505fa --- /dev/null +++ b/cardano-dex-contracts-onchain/test/Gen/LqMining/Simple/StakingBundleGen.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Gen.LqMining.Simple.StakingBundleGen where + +import Hedgehog + +import Gen.Models + +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V1.Value +import PlutusTx.Builtins.Internal + +import qualified PlutusLedgerApi.V1.Interval as PInterval + +import qualified ErgoDex.Contracts.Proxy.LqMining.Simple.Deposit as D +import qualified ErgoDex.Contracts.Proxy.LqMining.Simple.StakingBundle as SB + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Hex +import qualified Data.Text.Encoding as E +import qualified Data.Text as T + +genStakingBundleTxOut :: AssetClass -> Integer -> AssetClass -> Integer -> OutputDatum -> TxOut +genStakingBundleTxOut vlqAC vlqQty tmpAC tmpQty od = + let + value = mkValues [mkValue vlqAC vlqQty, mkValue tmpAC tmpQty, mkAdaValue 1000] mempty + in mkTxOut od value mkLMStakingBundleValidator + +genStakingBundleConfig :: AssetClass -> AssetClass -> AssetClass -> AssetClass -> AssetClass -> PubKeyHash -> SB.StakingBundleConfig +genStakingBundleConfig bundleAC poolAC bundleLQAC bundleVLQAC bundleTMPAC pkh = + SB.StakingBundleConfig bundleAC poolAC bundleLQAC bundleVLQAC bundleTMPAC pkh + +genUserTxOut :: AssetClass -> Integer -> PubKeyHash -> TxOut +genUserTxOut redeemAC redeemQty userPkh = + let + value = mkValues [mkValue redeemAC redeemQty, mkAdaValue 1000] mempty + in mkTxOut' NoOutputDatum value userPkh + +mkLMStakingBundleTxInfo :: [TxInInfo] -> [TxOut] -> TxInfo +mkLMStakingBundleTxInfo inputs outputs = + TxInfo + { txInfoInputs = inputs + , txInfoOutputs = outputs + , txInfoReferenceInputs = mempty + , txInfoRedeemers = fromList [] + , txInfoFee = mempty + , txInfoMint = mempty + , txInfoDCert = [] + , txInfoWdrl = fromList [] + , txInfoValidRange = PInterval.always + , txInfoSignatories = [] + , txInfoData = fromList [] + , txInfoId = "b0" + } diff --git a/cardano-dex-contracts-onchain/test/Gen/Models.hs b/cardano-dex-contracts-onchain/test/Gen/Models.hs index 9fdaab0..73ffd05 100644 --- a/cardano-dex-contracts-onchain/test/Gen/Models.hs +++ b/cardano-dex-contracts-onchain/test/Gen/Models.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Gen.Models ( genTokenName @@ -26,6 +27,12 @@ module Gen.Models , mkDepositValidator , mkSwapValidator , mkPoolValidator + , mkLMRedeemValidator + , mkLMDepositValidator + , mkLMPoolValidator + , mkLMStakingBundleValidator + , mintingPolicyHash + , scriptCurrencySymbol , mkTxOut , mkTxOut' , mkTxIn @@ -49,7 +56,7 @@ import qualified PlutusLedgerApi.V1.Value as Value import PlutusLedgerApi.V2.Tx import PlutusLedgerApi.V2 import qualified PlutusLedgerApi.V1.Interval as Interval -import Plutarch.Api.V2 ( validatorHash, datumHash) +import Plutarch.Api.V2 ( validatorHash, datumHash, scriptHash) import qualified ErgoDex.PValidators as PScripts import qualified ErgoDex.Contracts.Pool as P @@ -58,11 +65,14 @@ import qualified ErgoDex.Contracts.Proxy.Order as O import PlutusTx.Builtins as Builtins genBuiltinByteString :: MonadGen f => Int -> f BuiltinByteString -genBuiltinByteString s = bytes (Range.singleton s) <&> BuiltinByteString +genBuiltinByteString s = Gen.bytes (Range.singleton s) <&> BuiltinByteString random32bs :: MonadGen f => f BuiltinByteString random32bs = genBuiltinByteString 32 +random28bs :: MonadGen f => f BuiltinByteString +random28bs = genBuiltinByteString 28 + genTxId :: MonadGen f => f TxId genTxId = prune $ random32bs <&> TxId @@ -74,12 +84,12 @@ genTxOutRef = do genTokenName :: MonadGen f => f TokenName genTokenName = do - bs <- random32bs + bs <- prune $ random32bs return $ TokenName bs genCurrencySymbol :: MonadGen f => f CurrencySymbol genCurrencySymbol = do - bs <- random32bs + bs <- prune $ random28bs return $ CurrencySymbol bs mkAssetClass :: CurrencySymbol -> TokenName -> AssetClass @@ -138,7 +148,7 @@ mkScriptCredential :: Credential mkScriptCredential = ScriptCredential $ validatorHash PScripts.poolValidator genPkh :: MonadGen f => f PubKeyHash -genPkh = genBuiltinByteString 28 <&> PubKeyHash +genPkh = prune $ genBuiltinByteString 28 <&> PubKeyHash mkDepositValidator :: ValidatorHash mkDepositValidator = validatorHash PScripts.depositValidator @@ -149,6 +159,29 @@ mkPoolValidator = validatorHash PScripts.poolValidator mkSwapValidator :: ValidatorHash mkSwapValidator = validatorHash PScripts.swapValidator +mkLMRedeemValidator :: ValidatorHash +mkLMRedeemValidator = validatorHash PScripts.lmRedeemValidator + +mkLMStakingBundleValidator :: ValidatorHash +mkLMStakingBundleValidator = validatorHash PScripts.lmStakingBundleValidator + +mkLMDepositValidator :: ValidatorHash +mkLMDepositValidator = validatorHash PScripts.lmDepositValidator + +mkLMPoolValidator :: ValidatorHash +mkLMPoolValidator = validatorHash PScripts.lmPoolValidator + +scriptCurrencySymbol :: MintingPolicy -> CurrencySymbol +scriptCurrencySymbol scrpt = + let (MintingPolicyHash hsh) = mintingPolicyHash scrpt in CurrencySymbol hsh + +mintingPolicyHash :: MintingPolicy -> MintingPolicyHash +mintingPolicyHash = + MintingPolicyHash + . getScriptHash + . scriptHash + . getMintingPolicy + mkTxOut :: OutputDatum -> Value -> ValidatorHash -> TxOut mkTxOut od v vh = TxOut @@ -178,6 +211,7 @@ mkPoolTxInfo :: TxInInfo -> TxOut -> TxInfo mkPoolTxInfo pIn pOut = TxInfo { txInfoInputs = [pIn] + , txInfoReferenceInputs = [] , txInfoOutputs = [pOut] , txInfoFee = mempty , txInfoMint = mempty @@ -185,6 +219,7 @@ mkPoolTxInfo pIn pOut = , txInfoWdrl = fromList [] , txInfoValidRange = Interval.always , txInfoSignatories = mempty + , txInfoRedeemers = fromList [] , txInfoData = fromList [] , txInfoId = "b0" } @@ -194,6 +229,7 @@ mkTxInfo :: TxInInfo -> TxInInfo -> TxOut -> TxOut -> TxInfo mkTxInfo pIn oIn pOut oOut = TxInfo { txInfoInputs = [pIn, oIn] + , txInfoReferenceInputs = [] , txInfoOutputs = [pOut, oOut] , txInfoFee = mempty , txInfoMint = mempty @@ -201,6 +237,7 @@ mkTxInfo pIn oIn pOut oOut = , txInfoWdrl = fromList [] , txInfoValidRange = Interval.always , txInfoSignatories = mempty + , txInfoRedeemers = fromList [] , txInfoData = fromList [] , txInfoId = "b0" } diff --git a/cardano-dex-contracts-onchain/test/Spec.hs b/cardano-dex-contracts-onchain/test/Spec.hs index 6444853..4c9fb92 100644 --- a/cardano-dex-contracts-onchain/test/Spec.hs +++ b/cardano-dex-contracts-onchain/test/Spec.hs @@ -4,6 +4,10 @@ import Tests.Deposit import Tests.Pool import Tests.Swap import Tests.Redeem +import Tests.LqMining.Simple.StakingBundle +import Tests.LqMining.Simple.Redeem +import Tests.LqMining.Simple.Deposit +import Tests.LqMining.Simple.LMPool import Test.Tasty import Test.Tasty.HUnit @@ -13,19 +17,23 @@ main = do defaultMain tests tests = testGroup "Contracts" - [ checkPool - , checkPoolRedeemer - , checkRedeem - , checkRedeemIdentity - , checkRedeemIsFair - , checkRedeemRedeemer - , checkDeposit - , checkDepositChange - , checkDepositRedeemer - , checkDepositIdentity - , checkDepositLq - , checkDepositTokenReward - , checkSwap - , checkSwapRedeemer - , checkSwapIdentity + [ checkLMPool + -- checkLMStakingBundle + -- checkLMDeposit + --checkLMRedeem + --checkPool + -- , checkPoolRedeemer + -- , checkRedeem + -- , checkRedeemIdentity + -- , checkRedeemIsFair + -- , checkRedeemRedeemer + -- , checkDeposit + -- , checkDepositChange + -- , checkDepositRedeemer + -- , checkDepositIdentity + -- , checkDepositLq + -- , checkDepositTokenReward + -- , checkSwap + -- , checkSwapRedeemer + -- , checkSwapIdentity ] \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/test/Tests/LqMining/Simple/Deposit.hs b/cardano-dex-contracts-onchain/test/Tests/LqMining/Simple/Deposit.hs new file mode 100644 index 0000000..70591c5 --- /dev/null +++ b/cardano-dex-contracts-onchain/test/Tests/LqMining/Simple/Deposit.hs @@ -0,0 +1,396 @@ +module Tests.LqMining.Simple.Deposit where + +import ErgoDex.PValidators +import ErgoDex.PMintingValidators +import ErgoDex.Contracts.Proxy.LqMining.Simple.Deposit as D +import ErgoDex.PContracts.LqMining.Simple.PDeposit as PD + +import Eval +import Gen.Utils +import Gen.Models (scriptCurrencySymbol) +import PlutusTx.Builtins.Internal +import qualified Data.ByteString as BS + +import Hedgehog +import Hedgehog.Range +import Hedgehog.Gen + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog as HH + +import Gen.Models +import Gen.DepositGen +import Gen.PoolGen +import Gen.LqMining.Simple.DepositGen +import Gen.LqMining.Simple.StakingBundleGen + +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V1.Value + +import Plutarch +import Plutarch.Prelude +import Plutarch.DataRepr +import Plutarch.Api.V2.Contexts +import Plutarch.Lift +import PExtra.Ada +import qualified PExtra.API as API +import Debug.Trace + +checkLMDeposit = testGroup "CheckLMDepositContract" + [ HH.testProperty "deposit_is_correct" successDeposit + , HH.testProperty "incorrect_user_redeemer_value" incorrectRedeemerValue + , HH.testProperty "incorrect_user_redeemer_bundle_ac" incorrectRedeemerBundleAC + , HH.testProperty "incorrect_staking_bandle_datum_bundle_ac" incorrectStakingBundleDatumBundleAC + , HH.testProperty "incorrect_staking_bandle_datum_redeemer_pkh" incorrectStakingBundleDatumRedeemerPkh + , HH.testProperty "incorrect_staking_bandle_invalid_tmp_qty" incorrectStakingBundleInvalidTmpQty + , HH.testProperty "incorrect_staking_bandle_invalid_vlq_qty" incorrectStakingBundleInvalidVLQQty + ] + +successDeposit :: Property +successDeposit = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + vlqAC <- forAll genAssetClass + tmpAC <- forAll genAssetClass + poolNft <- forAll genAssetClass + + bundleIdAC <- forAll genAssetClass + + poolInTxRef <- forAll genTxOutRef + depositInTxRef <- forAll genTxOutRef + + vlqQtyInt <- forAll $ int range + + expectedNumEpochsInt <- forAll $ int range + let + expectedNumEpochs = toInteger expectedNumEpochsInt + + bundleLqMP = lmPoolLqMintValidator poolNft 0x7fffffffffffffff + bundleLQCS = scriptCurrencySymbol bundleLqMP + + vlqQty = toInteger vlqQtyInt + tmpQty = vlqQty * expectedNumEpochs + + depositCfg = genDepositConfig expectedNumEpochs bundleLQCS pkh vlqAC tmpAC + depositCfgData = toData depositCfg + depositDatum = OutputDatum $ mkDatum depositCfg + depositTxIn = genDepositTxInInfo depositInTxRef vlqAC vlqQty tmpAC tmpQty depositDatum + + (redeemTxOut, bundleAC) = genRedeemerTxOut poolInTxRef bundleLQCS 0x7fffffffffffffff pkh + + fakePoolTxIn = genFakePoolTxInInfo poolInTxRef + + stakingBundleCfg = genStakingBundleConfig bundleIdAC poolNft bundleAC vlqAC tmpAC pkh + stakingBundleDatum = OutputDatum $ mkDatum stakingBundleCfg + stakingBundleTxOut = genStakingBundleTxOut vlqAC vlqQty tmpAC tmpQty stakingBundleDatum + + txInfo = mkLMDepositTxInfo [fakePoolTxIn, depositTxIn] [redeemTxOut, stakingBundleTxOut] + purpose = mkPurpose depositInTxRef + cxtData = toData $ mkContext txInfo purpose + + depositRedeemConfigToData = toData $ D.DepositRedeemer 0 1 0 1 + + result = eraseRight $ evalWithArgs (wrapValidator PD.depositValidatorT) [depositCfgData, depositRedeemConfigToData, cxtData] + result === Right () + +incorrectRedeemerValue :: Property +incorrectRedeemerValue = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + vlqAC <- forAll genAssetClass + tmpAC <- forAll genAssetClass + poolNft <- forAll genAssetClass + + bundleIdAC <- forAll genAssetClass + + poolInTxRef <- forAll genTxOutRef + depositInTxRef <- forAll genTxOutRef + + vlqQtyInt <- forAll $ int range + + expectedNumEpochsInt <- forAll $ int range + let + expectedNumEpochs = toInteger expectedNumEpochsInt + + bundleLqMP = lmPoolLqMintValidator poolNft 0x7fffffffffffffff + bundleLQCS = scriptCurrencySymbol bundleLqMP + + vlqQty = toInteger vlqQtyInt + tmpQty = vlqQty * expectedNumEpochs + + depositCfg = genDepositConfig expectedNumEpochs bundleLQCS pkh vlqAC tmpAC + depositCfgData = toData depositCfg + depositDatum = OutputDatum $ mkDatum depositCfg + depositTxIn = genDepositTxInInfo depositInTxRef vlqAC vlqQty tmpAC tmpQty depositDatum + + (redeemTxOut, bundleAC) = genRedeemerTxOut poolInTxRef bundleLQCS 10 pkh + + fakePoolTxIn = genFakePoolTxInInfo poolInTxRef + + stakingBundleCfg = genStakingBundleConfig bundleIdAC poolNft bundleAC vlqAC tmpAC pkh + stakingBundleDatum = OutputDatum $ mkDatum stakingBundleCfg + stakingBundleTxOut = genStakingBundleTxOut vlqAC vlqQty tmpAC tmpQty stakingBundleDatum + + txInfo = mkLMDepositTxInfo [fakePoolTxIn, depositTxIn] [redeemTxOut, stakingBundleTxOut] + purpose = mkPurpose depositInTxRef + cxtData = toData $ mkContext txInfo purpose + + depositRedeemConfigToData = toData $ D.DepositRedeemer 0 1 0 1 + + result = eraseLeft $ evalWithArgs (wrapValidator PD.depositValidatorT) [depositCfgData, depositRedeemConfigToData, cxtData] + result === Left () + +incorrectRedeemerBundleAC :: Property +incorrectRedeemerBundleAC = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + vlqAC <- forAll genAssetClass + tmpAC <- forAll genAssetClass + poolNft <- forAll genAssetClass + + bundleIdAC <- forAll genAssetClass + + poolInTxRef <- forAll genTxOutRef + depositInTxRef <- forAll genTxOutRef + + incorrectBundleCS <- forAll genCurrencySymbol + + vlqQtyInt <- forAll $ int range + + expectedNumEpochsInt <- forAll $ int range + let + expectedNumEpochs = toInteger expectedNumEpochsInt + + bundleLqMP = lmPoolLqMintValidator poolNft 0x7fffffffffffffff + bundleLQCS = scriptCurrencySymbol bundleLqMP + + vlqQty = toInteger vlqQtyInt + tmpQty = vlqQty * expectedNumEpochs + + depositCfg = genDepositConfig expectedNumEpochs bundleLQCS pkh vlqAC tmpAC + depositCfgData = toData depositCfg + depositDatum = OutputDatum $ mkDatum depositCfg + depositTxIn = genDepositTxInInfo depositInTxRef vlqAC vlqQty tmpAC tmpQty depositDatum + + (redeemTxOut, bundleAC) = genRedeemerTxOut poolInTxRef incorrectBundleCS 0x7fffffffffffffff pkh + + fakePoolTxIn = genFakePoolTxInInfo poolInTxRef + + stakingBundleCfg = genStakingBundleConfig bundleIdAC poolNft bundleAC vlqAC tmpAC pkh + stakingBundleDatum = OutputDatum $ mkDatum stakingBundleCfg + stakingBundleTxOut = genStakingBundleTxOut vlqAC vlqQty tmpAC tmpQty stakingBundleDatum + + txInfo = mkLMDepositTxInfo [fakePoolTxIn, depositTxIn] [redeemTxOut, stakingBundleTxOut] + purpose = mkPurpose depositInTxRef + cxtData = toData $ mkContext txInfo purpose + + depositRedeemConfigToData = toData $ D.DepositRedeemer 0 1 0 1 + + result = eraseLeft $ evalWithArgs (wrapValidator PD.depositValidatorT) [depositCfgData, depositRedeemConfigToData, cxtData] + result === Left () + +incorrectStakingBundleDatumBundleAC :: Property +incorrectStakingBundleDatumBundleAC = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + vlqAC <- forAll genAssetClass + tmpAC <- forAll genAssetClass + poolNft <- forAll genAssetClass + + incorrectBundleAC <- forAll genAssetClass + + bundleIdAC <- forAll genAssetClass + + poolInTxRef <- forAll genTxOutRef + depositInTxRef <- forAll genTxOutRef + + vlqQtyInt <- forAll $ int range + + expectedNumEpochsInt <- forAll $ int range + let + expectedNumEpochs = toInteger expectedNumEpochsInt + + bundleLqMP = lmPoolLqMintValidator poolNft 0x7fffffffffffffff + bundleLQCS = scriptCurrencySymbol bundleLqMP + + vlqQty = toInteger vlqQtyInt + tmpQty = vlqQty * expectedNumEpochs + + depositCfg = genDepositConfig expectedNumEpochs bundleLQCS pkh vlqAC tmpAC + depositCfgData = toData depositCfg + depositDatum = OutputDatum $ mkDatum depositCfg + depositTxIn = genDepositTxInInfo depositInTxRef vlqAC vlqQty tmpAC tmpQty depositDatum + + (redeemTxOut, bundleAC) = genRedeemerTxOut poolInTxRef bundleLQCS 0x7fffffffffffffff pkh + + fakePoolTxIn = genFakePoolTxInInfo poolInTxRef + + stakingBundleCfg = genStakingBundleConfig bundleIdAC poolNft incorrectBundleAC vlqAC tmpAC pkh + stakingBundleDatum = OutputDatum $ mkDatum stakingBundleCfg + stakingBundleTxOut = genStakingBundleTxOut vlqAC vlqQty tmpAC tmpQty stakingBundleDatum + + txInfo = mkLMDepositTxInfo [fakePoolTxIn, depositTxIn] [redeemTxOut, stakingBundleTxOut] + purpose = mkPurpose depositInTxRef + cxtData = toData $ mkContext txInfo purpose + + depositRedeemConfigToData = toData $ D.DepositRedeemer 0 1 0 1 + + result = eraseLeft $ evalWithArgs (wrapValidator PD.depositValidatorT) [depositCfgData, depositRedeemConfigToData, cxtData] + result === Left () + +incorrectStakingBundleDatumRedeemerPkh :: Property +incorrectStakingBundleDatumRedeemerPkh = property $ do + pkh <- forAll genPkh + invalidPkh <- forAll genPkh + let + range = exponential 10 512 + + vlqAC <- forAll genAssetClass + tmpAC <- forAll genAssetClass + poolNft <- forAll genAssetClass + + bundleIdAC <- forAll genAssetClass + + poolInTxRef <- forAll genTxOutRef + depositInTxRef <- forAll genTxOutRef + + vlqQtyInt <- forAll $ int range + + expectedNumEpochsInt <- forAll $ int range + let + expectedNumEpochs = toInteger expectedNumEpochsInt + + bundleLqMP = lmPoolLqMintValidator poolNft 0x7fffffffffffffff + bundleLQCS = scriptCurrencySymbol bundleLqMP + + vlqQty = toInteger vlqQtyInt + tmpQty = vlqQty * expectedNumEpochs + + depositCfg = genDepositConfig expectedNumEpochs bundleLQCS pkh vlqAC tmpAC + depositCfgData = toData depositCfg + depositDatum = OutputDatum $ mkDatum depositCfg + depositTxIn = genDepositTxInInfo depositInTxRef vlqAC vlqQty tmpAC tmpQty depositDatum + + (redeemTxOut, bundleAC) = genRedeemerTxOut poolInTxRef bundleLQCS 0x7fffffffffffffff pkh + + fakePoolTxIn = genFakePoolTxInInfo poolInTxRef + + stakingBundleCfg = genStakingBundleConfig bundleIdAC poolNft bundleAC vlqAC tmpAC invalidPkh + stakingBundleDatum = OutputDatum $ mkDatum stakingBundleCfg + stakingBundleTxOut = genStakingBundleTxOut vlqAC vlqQty tmpAC tmpQty stakingBundleDatum + + txInfo = mkLMDepositTxInfo [fakePoolTxIn, depositTxIn] [redeemTxOut, stakingBundleTxOut] + purpose = mkPurpose depositInTxRef + cxtData = toData $ mkContext txInfo purpose + + depositRedeemConfigToData = toData $ D.DepositRedeemer 0 1 0 1 + + result = eraseLeft $ evalWithArgs (wrapValidator PD.depositValidatorT) [depositCfgData, depositRedeemConfigToData, cxtData] + result === Left () + +incorrectStakingBundleInvalidTmpQty :: Property +incorrectStakingBundleInvalidTmpQty = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + vlqAC <- forAll genAssetClass + tmpAC <- forAll genAssetClass + poolNft <- forAll genAssetClass + + bundleIdAC <- forAll genAssetClass + + poolInTxRef <- forAll genTxOutRef + depositInTxRef <- forAll genTxOutRef + + vlqQtyInt <- forAll $ int range + + expectedNumEpochsInt <- forAll $ int range + let + expectedNumEpochs = toInteger expectedNumEpochsInt + + bundleLqMP = lmPoolLqMintValidator poolNft 0x7fffffffffffffff + bundleLQCS = scriptCurrencySymbol bundleLqMP + + vlqQty = toInteger vlqQtyInt + tmpQty = vlqQty * expectedNumEpochs + + depositCfg = genDepositConfig expectedNumEpochs bundleLQCS pkh vlqAC tmpAC + depositCfgData = toData depositCfg + depositDatum = OutputDatum $ mkDatum depositCfg + depositTxIn = genDepositTxInInfo depositInTxRef vlqAC vlqQty tmpAC tmpQty depositDatum + + (redeemTxOut, bundleAC) = genRedeemerTxOut poolInTxRef bundleLQCS 0x7fffffffffffffff pkh + + fakePoolTxIn = genFakePoolTxInInfo poolInTxRef + + stakingBundleCfg = genStakingBundleConfig bundleIdAC poolNft bundleAC vlqAC tmpAC pkh + stakingBundleDatum = OutputDatum $ mkDatum stakingBundleCfg + stakingBundleTxOut = genStakingBundleTxOut vlqAC vlqQty tmpAC 1 stakingBundleDatum + + txInfo = mkLMDepositTxInfo [fakePoolTxIn, depositTxIn] [redeemTxOut, stakingBundleTxOut] + purpose = mkPurpose depositInTxRef + cxtData = toData $ mkContext txInfo purpose + + depositRedeemConfigToData = toData $ D.DepositRedeemer 0 1 0 1 + + result = eraseLeft $ evalWithArgs (wrapValidator PD.depositValidatorT) [depositCfgData, depositRedeemConfigToData, cxtData] + result === Left () + +incorrectStakingBundleInvalidVLQQty :: Property +incorrectStakingBundleInvalidVLQQty = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + vlqAC <- forAll genAssetClass + tmpAC <- forAll genAssetClass + poolNft <- forAll genAssetClass + + bundleIdAC <- forAll genAssetClass + + poolInTxRef <- forAll genTxOutRef + depositInTxRef <- forAll genTxOutRef + + vlqQtyInt <- forAll $ int range + + expectedNumEpochsInt <- forAll $ int range + let + expectedNumEpochs = toInteger expectedNumEpochsInt + + bundleLqMP = lmPoolLqMintValidator poolNft 0x7fffffffffffffff + bundleLQCS = scriptCurrencySymbol bundleLqMP + + vlqQty = toInteger vlqQtyInt + tmpQty = vlqQty * expectedNumEpochs + + depositCfg = genDepositConfig expectedNumEpochs bundleLQCS pkh vlqAC tmpAC + depositCfgData = toData depositCfg + depositDatum = OutputDatum $ mkDatum depositCfg + depositTxIn = genDepositTxInInfo depositInTxRef vlqAC vlqQty tmpAC tmpQty depositDatum + + (redeemTxOut, bundleAC) = genRedeemerTxOut poolInTxRef bundleLQCS 0x7fffffffffffffff pkh + + fakePoolTxIn = genFakePoolTxInInfo poolInTxRef + + stakingBundleCfg = genStakingBundleConfig bundleIdAC poolNft bundleAC vlqAC tmpAC pkh + stakingBundleDatum = OutputDatum $ mkDatum stakingBundleCfg + stakingBundleTxOut = genStakingBundleTxOut vlqAC 1 tmpAC tmpQty stakingBundleDatum + + txInfo = mkLMDepositTxInfo [fakePoolTxIn, depositTxIn] [redeemTxOut, stakingBundleTxOut] + purpose = mkPurpose depositInTxRef + cxtData = toData $ mkContext txInfo purpose + + depositRedeemConfigToData = toData $ D.DepositRedeemer 0 1 0 1 + + result = eraseLeft $ evalWithArgs (wrapValidator PD.depositValidatorT) [depositCfgData, depositRedeemConfigToData, cxtData] + result === Left () \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/test/Tests/LqMining/Simple/LMPool.hs b/cardano-dex-contracts-onchain/test/Tests/LqMining/Simple/LMPool.hs new file mode 100644 index 0000000..5cc9c80 --- /dev/null +++ b/cardano-dex-contracts-onchain/test/Tests/LqMining/Simple/LMPool.hs @@ -0,0 +1,239 @@ +module Tests.LqMining.Simple.LMPool where + +import ErgoDex.PValidators +import ErgoDex.PMintingValidators +import ErgoDex.Contracts.Proxy.LqMining.Simple.LMPool as PLM +import ErgoDex.PContracts.LqMining.Simple.PLMPool as LM + +import Eval +import Gen.Utils +import Gen.Models (scriptCurrencySymbol) +import PlutusTx.Builtins.Internal +import qualified Data.ByteString as BS + +import Hedgehog +import Hedgehog.Range +import Hedgehog.Gen +import Hedgehog.Internal.Property + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog as HH + +import Gen.Models +import Gen.DepositGen +import Gen.PoolGen +import Gen.LqMining.Simple.DepositGen +import Gen.LqMining.Simple.StakingBundleGen +import Gen.LqMining.Simple.LMPoolGen + +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V1.Value + +import Plutarch +import Plutarch.Prelude +import Plutarch.DataRepr +import Plutarch.Api.V2.Contexts +import Plutarch.Lift +import PExtra.Ada +import qualified PExtra.API as API +import Debug.Trace + +checkLMPool = testGroup "CheckLMPoolContract" + [ HH.testProperty "deposit_is_correct" successDeposit + , HH.testProperty "redeem_is_correct" successRedeem + ] + +successDeposit :: Property +successDeposit = withTests (TestLimit 1) $ property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + poolX <- forAll genAssetClass + poolNft <- forAll genAssetClass + poolLQAC <- forAll genAssetClass + bundleLQAC <- forAll genAssetClass + bundleVLQAC <- forAll genAssetClass + bundleTMPAC <- forAll genAssetClass + + epochLenInt <- forAll $ int range + epochNumInt <- forAll $ int range + programStartInt <- forAll $ int range + programBudgetInt <- forAll $ int range + execBudgetInt <- forAll $ int range + epochBudgetInt <- forAll $ int range + + initLqInt <- forAll $ int range + afterDepositLqInt <- forAll $ int range + + poolInTxRef <- forAll genTxOutRef + let + epochBudget = toInteger epochBudgetInt + + epochLen = toInteger epochLenInt + epochNum = (toInteger epochNumInt) + 2 + programStart = toInteger programStartInt + programBudget = epochNum * epochBudget + 1 + execBudget = toInteger execBudgetInt + reserveXInit = epochNum * epochBudget + + initLq = toInteger initLqInt + afterDepositLq = (toInteger afterDepositLqInt) + initLq + + compoundEpoch = 2 + + poolInCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget 1 poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolDatumToData = toData poolInCfg + poolTxIn = genPoolTxInInfo poolInTxRef 1 reserveXInit initLq 0x7fffffffffffffff 0x7fffffffffffffff poolInCfg + + curTimeIdx = 1 + + + let curEpochIxRem = curTimeIdx `mod` epochLen + + traceM ("initLq:" ++ show initLq) + traceM ("afterDepositLq:" ++ show afterDepositLq) + traceM ("curEpochIxRem:" ++ show curEpochIxRem) + + let curEpochIxR = curTimeIdx `div` epochLen + + traceM ("curEpochIxR:" ++ show curEpochIxR) + + let curEpochIx = if (0 < curEpochIxRem) then curEpochIxR + 1 else curEpochIxR + + traceM ("curEpochIx:" ++ show curEpochIx) + + let curEpochMax = max 0 curEpochIx + + traceM ("curEpochMax:" ++ show curEpochMax) + + let releasedVLQ = afterDepositLq - initLq + + traceM ("releasedVLQ:" ++ show releasedVLQ) + + let epochsAllocated = epochNum - curEpochMax + + traceM ("epochsAllocated:" ++ show epochsAllocated) + + let releasedTMP = releasedVLQ * epochsAllocated + + traceM ("releasedTMP:" ++ show releasedTMP) + --curEpochToCalc = if (curEpochIx <= epochNum) then curEpochIx else epochNum + 1 + --prevEpochsCompoundedForDeposit = ((programBudget - reservesX) + MaxRoundingError0) >= (curEpochToCalc - 1) * epochAlloc + + let + poolOutCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget compoundEpoch poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolTxOut = genPoolTxOut 1 (reserveXInit - epochsAllocated) afterDepositLq (0x7fffffffffffffff - releasedVLQ) (0x7fffffffffffffff - releasedTMP) poolOutCfg + + poolRedeemerToData = toData $ PLM.LMPoolRedeemer 0 0 + + traceM ("poolNft:" ++ show poolNft) + traceM ("poolOutCfg:" ++ show poolOutCfg) + traceM ("poolTxIn:" ++ show poolTxIn) + traceM ("poolTxOut:" ++ show poolTxOut) + let + txInfo = mkLMPoolTxInfo [poolTxIn] [poolTxOut] (programStart) (programStart + epochLen + 10) + purpose = mkPurpose poolInTxRef + cxtData = toData $ mkContext txInfo purpose + + result = eraseRight $ evalWithArgs (wrapValidator LM.lmPoolValidatorT) [poolDatumToData, poolRedeemerToData, cxtData] + + result === Right () + +successRedeem :: Property +successRedeem = withTests (TestLimit 1) $ property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + poolX <- forAll genAssetClass + poolNft <- forAll genAssetClass + poolLQAC <- forAll genAssetClass + bundleLQAC <- forAll genAssetClass + bundleVLQAC <- forAll genAssetClass + bundleTMPAC <- forAll genAssetClass + + epochLenInt <- forAll $ int range + epochNumInt <- forAll $ int range + programStartInt <- forAll $ int range + programBudgetInt <- forAll $ int range + execBudgetInt <- forAll $ int range + epochBudgetInt <- forAll $ int range + + initLqInt <- forAll $ int range + afterDepositLqInt <- forAll $ int range + + poolInTxRef <- forAll genTxOutRef + let + epochBudget = toInteger epochBudgetInt + + epochLen = toInteger epochLenInt + epochNum = (toInteger epochNumInt) + 2 + programStart = toInteger programStartInt + programBudget = epochNum * epochBudget + 1 + execBudget = toInteger execBudgetInt + reserveXInit = epochNum * epochBudget + + initLq = toInteger initLqInt + afterDepositLq = (toInteger afterDepositLqInt) + initLq + + compoundEpoch = 2 + + poolInCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget 1 poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolDatumToData = toData poolInCfg + poolTxIn = genPoolTxInInfo poolInTxRef 1 reserveXInit initLq 0x7fffffffffffffff 0x7fffffffffffffff poolInCfg + + curTimeIdx = 1 + + + let curEpochIxRem = curTimeIdx `mod` epochLen + + traceM ("initLq:" ++ show initLq) + traceM ("afterDepositLq:" ++ show afterDepositLq) + traceM ("curEpochIxRem:" ++ show curEpochIxRem) + + let curEpochIxR = curTimeIdx `div` epochLen + + traceM ("curEpochIxR:" ++ show curEpochIxR) + + let curEpochIx = if (0 < curEpochIxRem) then curEpochIxR + 1 else curEpochIxR + + traceM ("curEpochIx:" ++ show curEpochIx) + + let curEpochMax = max 0 curEpochIx + + traceM ("curEpochMax:" ++ show curEpochMax) + + let releasedVLQ = afterDepositLq - initLq + + traceM ("releasedVLQ:" ++ show releasedVLQ) + + let epochsAllocated = epochNum - curEpochMax + + traceM ("epochsAllocated:" ++ show epochsAllocated) + + let releasedTMP = releasedVLQ * epochsAllocated + + traceM ("releasedTMP:" ++ show releasedTMP) + --curEpochToCalc = if (curEpochIx <= epochNum) then curEpochIx else epochNum + 1 + --prevEpochsCompoundedForDeposit = ((programBudget - reservesX) + MaxRoundingError0) >= (curEpochToCalc - 1) * epochAlloc + + let + poolOutCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget compoundEpoch poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolTxOut = genPoolTxOut 1 (reserveXInit - epochsAllocated) afterDepositLq (0x7fffffffffffffff - releasedVLQ) (0x7fffffffffffffff - releasedTMP) poolOutCfg + + poolRedeemerToData = toData $ PLM.LMPoolRedeemer 0 0 + + traceM ("poolNft:" ++ show poolNft) + traceM ("poolOutCfg:" ++ show poolOutCfg) + traceM ("poolTxIn:" ++ show poolTxIn) + traceM ("poolTxOut:" ++ show poolTxOut) + let + txInfo = mkLMPoolTxInfo [poolTxIn] [poolTxOut] (programStart) (programStart + epochLen + 10) + purpose = mkPurpose poolInTxRef + cxtData = toData $ mkContext txInfo purpose + + result = eraseRight $ evalWithArgs (wrapValidator LM.lmPoolValidatorT) [poolDatumToData, poolRedeemerToData, cxtData] + + result === Right () \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/test/Tests/LqMining/Simple/Redeem.hs b/cardano-dex-contracts-onchain/test/Tests/LqMining/Simple/Redeem.hs new file mode 100644 index 0000000..bfdefb3 --- /dev/null +++ b/cardano-dex-contracts-onchain/test/Tests/LqMining/Simple/Redeem.hs @@ -0,0 +1,187 @@ +module Tests.LqMining.Simple.Redeem where + +import ErgoDex.PValidators +import ErgoDex.Contracts.Proxy.LqMining.Simple.Redeem as PR +import ErgoDex.PContracts.LqMining.Simple.PRedeem as R + +import Eval +import Gen.Utils + +import Hedgehog +import Hedgehog.Range +import Hedgehog.Gen + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog as HH + +import Gen.Models +import Gen.DepositGen +import Gen.PoolGen +import Gen.LqMining.Simple.RedeemGen + +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V1.Value + +import Plutarch +import Plutarch.Prelude +import Plutarch.DataRepr +import Plutarch.Api.V2.Contexts +import Plutarch.Lift +import PExtra.Ada +import qualified PExtra.API as API + +checkLMRedeem = testGroup "CheckLMRedeemContract" + [ HH.testProperty "redeem_is_correct" successRedeem + , HH.testProperty "redeem_incorrect_lq_ac" incorrectLqACRedeem + , HH.testProperty "redeem_incorrect_lq_qty" incorrectLqQtyRedeem + , HH.testProperty "redeem_incorrect_redeemer" incorrectRedeemer + , HH.testProperty "redeem_incorrect_pkh" incorrectPkhRedeem + ] + +successRedeem :: Property +successRedeem = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + expectedLQAC <- forAll genAssetClass + poolNFTAC <- forAll genAssetClass + redeemOutTxRef <- forAll genTxOutRef + + expectedLQAmountInt <- forAll $ int range + let + expectedLQAmount = toInteger expectedLQAmountInt + + redeemCfg = genRedeemConfig expectedLQAC expectedLQAmount pkh + redeemCfgData = toData redeemCfg + redeemDatum = OutputDatum $ mkDatum redeemCfg + redeemTxIn = genRedeemTxIn redeemOutTxRef redeemDatum + userTxOut = genUserTxOut expectedLQAC expectedLQAmount pkh + + txInfo = mkLQRedeemTxInfo [redeemTxIn] [userTxOut] + purpose = mkPurpose redeemOutTxRef + + cxtData = toData $ mkContext txInfo purpose + redeemConfigToData = toData $ PR.RedeemRedeemerConfig 0 + + result = eraseRight $ evalWithArgs (wrapValidator R.redeemValidatorT) [redeemCfgData, redeemConfigToData, cxtData] + result === Right () + +incorrectLqACRedeem :: Property +incorrectLqACRedeem = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + expectedLQAC <- forAll genAssetClass + incorrectLQAC <- forAll genAssetClass + redeemOutTxRef <- forAll genTxOutRef + + expectedLQAmountInt <- forAll $ int range + let + expectedLQAmount = toInteger expectedLQAmountInt + + redeemCfg = genRedeemConfig expectedLQAC expectedLQAmount pkh + redeemCfgData = toData redeemCfg + redeemDatum = OutputDatum $ mkDatum redeemCfg + redeemTxIn = genRedeemTxIn redeemOutTxRef redeemDatum + userTxOut = genUserTxOut incorrectLQAC expectedLQAmount pkh + + txInfo = mkLQRedeemTxInfo [redeemTxIn] [userTxOut] + purpose = mkPurpose redeemOutTxRef + + cxtData = toData $ mkContext txInfo purpose + redeemConfigToData = toData $ PR.RedeemRedeemerConfig 0 + + result = eraseLeft $ evalWithArgs (wrapValidator R.redeemValidatorT) [redeemCfgData, redeemConfigToData, cxtData] + result === Left () + +incorrectPkhRedeem :: Property +incorrectPkhRedeem = property $ do + pkh <- forAll genPkh + + incorrectPkh <- forAll genPkh + let + range = exponential 10 512 + + expectedLQAC <- forAll genAssetClass + redeemOutTxRef <- forAll genTxOutRef + + expectedLQAmountInt <- forAll $ int range + let + expectedLQAmount = toInteger expectedLQAmountInt + + redeemCfg = genRedeemConfig expectedLQAC expectedLQAmount pkh + redeemCfgData = toData redeemCfg + redeemDatum = OutputDatum $ mkDatum redeemCfg + redeemTxIn = genRedeemTxIn redeemOutTxRef redeemDatum + userTxOut = genUserTxOut expectedLQAC expectedLQAmount incorrectPkh + + txInfo = mkLQRedeemTxInfo [redeemTxIn] [userTxOut] + purpose = mkPurpose redeemOutTxRef + + cxtData = toData $ mkContext txInfo purpose + redeemConfigToData = toData $ PR.RedeemRedeemerConfig 0 + + result = eraseLeft $ evalWithArgs (wrapValidator R.redeemValidatorT) [redeemCfgData, redeemConfigToData, cxtData] + result === Left () + +incorrectLqQtyRedeem :: Property +incorrectLqQtyRedeem = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + expectedLQAC <- forAll genAssetClass + redeemOutTxRef <- forAll genTxOutRef + + expectedLQAmountInt <- forAll $ int range + let + expectedLQAmount = toInteger expectedLQAmountInt + + redeemCfg = genRedeemConfig expectedLQAC expectedLQAmount pkh + redeemCfgData = toData redeemCfg + redeemDatum = OutputDatum $ mkDatum redeemCfg + redeemTxIn = genRedeemTxIn redeemOutTxRef redeemDatum + userTxOut = genUserTxOut expectedLQAC (expectedLQAmount - 1) pkh + + txInfo = mkLQRedeemTxInfo [redeemTxIn] [userTxOut] + purpose = mkPurpose redeemOutTxRef + + cxtData = toData $ mkContext txInfo purpose + redeemConfigToData = toData $ PR.RedeemRedeemerConfig 0 + + result = eraseLeft $ evalWithArgs (wrapValidator R.redeemValidatorT) [redeemCfgData, redeemConfigToData, cxtData] + result === Left () + +incorrectRedeemer :: Property +incorrectRedeemer = property $ do + pkh <- forAll genPkh + anotherPkh <- forAll genPkh + let + range = exponential 10 512 + + expectedLQAC <- forAll genAssetClass + nonLQAC <- forAll genAssetClass + redeemOutTxRef <- forAll genTxOutRef + + expectedLQAmountInt <- forAll $ int range + let + expectedLQAmount = toInteger expectedLQAmountInt + + redeemCfg = genRedeemConfig expectedLQAC expectedLQAmount pkh + redeemCfgData = toData redeemCfg + redeemDatum = OutputDatum $ mkDatum redeemCfg + redeemTxIn = genRedeemTxIn redeemOutTxRef redeemDatum + userTxOut = genUserTxOut expectedLQAC expectedLQAmount pkh + anotherTxOut = genUserTxOut nonLQAC 100 anotherPkh + + txInfo = mkLQRedeemTxInfo [redeemTxIn] [userTxOut, anotherTxOut] + purpose = mkPurpose redeemOutTxRef + + cxtData = toData $ mkContext txInfo purpose + redeemConfigToData = toData $ PR.RedeemRedeemerConfig 1 + + result = eraseLeft $ evalWithArgs (wrapValidator R.redeemValidatorT) [redeemCfgData, redeemConfigToData, cxtData] + result === Left () \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/test/Tests/LqMining/Simple/StakingBundle.hs b/cardano-dex-contracts-onchain/test/Tests/LqMining/Simple/StakingBundle.hs new file mode 100644 index 0000000..7933cf2 --- /dev/null +++ b/cardano-dex-contracts-onchain/test/Tests/LqMining/Simple/StakingBundle.hs @@ -0,0 +1,463 @@ +module Tests.LqMining.Simple.StakingBundle where + +import ErgoDex.PValidators +import ErgoDex.PContracts.LqMining.Simple.PStakingBundle as SB +import ErgoDex.Contracts.Proxy.LqMining.Simple.StakingBundle as PSB + +import Eval +import Gen.Utils + +import Hedgehog +import Hedgehog.Range +import Hedgehog.Gen +import Hedgehog.Internal.Property (TestLimit(..)) + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog as HH + +import Gen.Models +import Gen.DepositGen +import Gen.PoolGen +import Gen.LqMining.Simple.LMPoolGen +import Gen.LqMining.Simple.StakingBundleGen + +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V1.Value + +import Plutarch +import Plutarch.Prelude +import Plutarch.DataRepr +import Plutarch.Api.V2.Contexts +import Plutarch.Lift +import PExtra.Ada +import qualified PExtra.API as API +import Debug.Trace + +checkLMStakingBundle = testGroup "CheckLMStakingBundleContract" + [ HH.testProperty "success_compound" successCompound + , HH.testProperty "incorrect_tmp_qty_in_successor" incorrectTmpQtyInSuccessor + , HH.testProperty "incorrect_vlq_qty_in_successor" incorrectVLQQtyInSuccessor + , HH.testProperty "success_redeem" successRedeem + , HH.testProperty "incorrect_redeem" incorrectRedeem + ] + +successCompound :: Property +successCompound = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + -- common acs + bundleIdAC <- forAll genAssetClass + poolNft <- forAll genAssetClass + poolLQAC <- forAll genAssetClass + bundleLQAC <- forAll genAssetClass + bundleVLQAC <- forAll genAssetClass + bundleTMPAC <- forAll genAssetClass + + -- poolConfig + epochLenInt <- forAll $ int range + epochNumInt <- forAll $ int range + programStartInt <- forAll $ int range + programBudgetInt <- forAll $ int range + execBudgetInt <- forAll $ int range + + vlqQtyInt <- forAll $ int range + + poolX <- forAll genAssetClass + + poolInTxRef <- forAll genTxOutRef + + stakingBundleTxRef <- forAll genTxOutRef + let + epochLen = toInteger epochLenInt + epochNum = (toInteger epochNumInt) + 2 + programStart = toInteger programStartInt + programBudget = (toInteger programBudgetInt) + epochNum + execBudget = toInteger execBudgetInt + + vlqQty = toInteger vlqQtyInt + + expectedNumEpochs = epochNum - 1 + + tmpQty = vlqQty * expectedNumEpochs + + stakingBundleCfg = genStakingBundleConfig bundleIdAC poolNft bundleLQAC bundleVLQAC bundleTMPAC pkh + stakingBundleDatum = OutputDatum $ mkDatum stakingBundleCfg + + stakingBundleDatumToData = toData stakingBundleCfg + + stakingBundleTxOutForTxIn = genStakingBundleTxOut bundleVLQAC vlqQty bundleTMPAC tmpQty stakingBundleDatum + stakingBundleTxIn = mkTxIn stakingBundleTxRef stakingBundleTxOutForTxIn + + compoundEpoch = 2 + + releasedTMP = tmpQty - ((epochNum - compoundEpoch) * vlqQty) + + stakingBundleTxOut = genStakingBundleTxOut bundleVLQAC vlqQty bundleTMPAC (tmpQty - releasedTMP) stakingBundleDatum + + poolInCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget 1 poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolTxIn = genPoolTxInInfo poolInTxRef 1 900000000000 10 10 0 poolInCfg + + poolOutCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget compoundEpoch poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolTxOut = genPoolTxOut 1 800000000000 10 10 0 poolOutCfg + + epochRewardTotal = programBudget `div` epochNum + + epochsToCompound = epochNum - compoundEpoch + + epochsBurned = (tmpQty `div` vlqQty) - epochsToCompound + + reward = (epochRewardTotal * vlqQty * epochsBurned) `div` 10 + + userRewardOut = genUserTxOut poolX reward pkh + + txInfo = mkLMStakingBundleTxInfo [stakingBundleTxIn, poolTxIn] [poolTxOut, stakingBundleTxOut, userRewardOut] + purpose = mkPurpose stakingBundleTxRef + cxtData = toData $ mkContext txInfo purpose + + stakingBundleConfigToData = toData $ PSB.StakingBundleRedeemer 1 0 0 2 1 + + result = eraseRight $ evalWithArgs (wrapValidator SB.stakingBundleValidatorT) [stakingBundleDatumToData, stakingBundleConfigToData, cxtData] + + result === Right () + +incorrectTmpQtyInSuccessor :: Property +incorrectTmpQtyInSuccessor = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + -- common acs + bundleIdAC <- forAll genAssetClass + poolNft <- forAll genAssetClass + poolLQAC <- forAll genAssetClass + bundleLQAC <- forAll genAssetClass + bundleVLQAC <- forAll genAssetClass + bundleTMPAC <- forAll genAssetClass + + -- poolConfig + epochLenInt <- forAll $ int range + epochNumInt <- forAll $ int range + programStartInt <- forAll $ int range + programBudgetInt <- forAll $ int range + execBudgetInt <- forAll $ int range + + vlqQtyInt <- forAll $ int range + + expectedNumEpochsInt <- forAll $ int range + + poolX <- forAll genAssetClass + + poolInTxRef <- forAll genTxOutRef + + stakingBundleTxRef <- forAll genTxOutRef + let + epochLen = toInteger epochLenInt + epochNum = (toInteger epochNumInt) + 2 + programStart = toInteger programStartInt + programBudget = toInteger programBudgetInt + execBudget = toInteger execBudgetInt + + vlqQty = toInteger vlqQtyInt + + expectedNumEpochs = epochNum - 1 + + tmpQty = vlqQty * expectedNumEpochs + + stakingBundleCfg = genStakingBundleConfig bundleIdAC poolNft bundleLQAC bundleVLQAC bundleTMPAC pkh + stakingBundleDatum = OutputDatum $ mkDatum stakingBundleCfg + + stakingBundleDatumToData = toData stakingBundleCfg + + stakingBundleTxOutForTxIn = genStakingBundleTxOut bundleVLQAC vlqQty bundleTMPAC tmpQty stakingBundleDatum + stakingBundleTxIn = mkTxIn stakingBundleTxRef stakingBundleTxOutForTxIn + + compoundEpoch = 2 + + releasedTMP = tmpQty - ((epochNum - compoundEpoch) * vlqQty) + + stakingBundleTxOut = genStakingBundleTxOut bundleVLQAC vlqQty bundleTMPAC (tmpQty - releasedTMP - 2) stakingBundleDatum + + poolInCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget 1 poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolTxIn = genPoolTxInInfo poolInTxRef 1 900000000000 100 0x7fffffffffffffff 0 poolInCfg + + poolOutCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget compoundEpoch poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolTxOut = genPoolTxOut 1 800000000000 100 0x7fffffffffffffff 0 poolOutCfg + + epochRewardTotal = programBudget `div` epochNum + + epochsToCompound = epochNum - compoundEpoch + + epochsBurned = (tmpQty `div` vlqQty) - epochsToCompound + + reward = (epochRewardTotal * vlqQty * epochsBurned) `div` 0x7fffffffffffffff + + userRewardOut = genUserTxOut poolX reward pkh + + txInfo = mkLMStakingBundleTxInfo [stakingBundleTxIn, poolTxIn] [poolTxOut, stakingBundleTxOut, userRewardOut] + purpose = mkPurpose stakingBundleTxRef + cxtData = toData $ mkContext txInfo purpose + + stakingBundleConfigToData = toData $ PSB.StakingBundleRedeemer 1 0 0 2 1 + + result = eraseLeft $ evalWithArgs (wrapValidator SB.stakingBundleValidatorT) [stakingBundleDatumToData, stakingBundleConfigToData, cxtData] + + result === Left () + +incorrectVLQQtyInSuccessor :: Property +incorrectVLQQtyInSuccessor = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + -- common acs + bundleIdAC <- forAll genAssetClass + poolNft <- forAll genAssetClass + poolLQAC <- forAll genAssetClass + bundleLQAC <- forAll genAssetClass + bundleVLQAC <- forAll genAssetClass + bundleTMPAC <- forAll genAssetClass + + -- poolConfig + epochLenInt <- forAll $ int range + epochNumInt <- forAll $ int range + programStartInt <- forAll $ int range + programBudgetInt <- forAll $ int range + execBudgetInt <- forAll $ int range + + vlqQtyInt <- forAll $ int range + + expectedNumEpochsInt <- forAll $ int range + + poolX <- forAll genAssetClass + + poolInTxRef <- forAll genTxOutRef + + stakingBundleTxRef <- forAll genTxOutRef + let + epochLen = toInteger epochLenInt + epochNum = (toInteger epochNumInt) + 2 + programStart = toInteger programStartInt + programBudget = toInteger programBudgetInt + execBudget = toInteger execBudgetInt + + vlqQty = toInteger vlqQtyInt + + expectedNumEpochs = epochNum - 1 + + tmpQty = vlqQty * expectedNumEpochs + + stakingBundleCfg = genStakingBundleConfig bundleIdAC poolNft bundleLQAC bundleVLQAC bundleTMPAC pkh + stakingBundleDatum = OutputDatum $ mkDatum stakingBundleCfg + + stakingBundleDatumToData = toData stakingBundleCfg + + stakingBundleTxOutForTxIn = genStakingBundleTxOut bundleVLQAC vlqQty bundleTMPAC tmpQty stakingBundleDatum + stakingBundleTxIn = mkTxIn stakingBundleTxRef stakingBundleTxOutForTxIn + + compoundEpoch = 2 + + releasedTMP = tmpQty - ((epochNum - compoundEpoch) * vlqQty) + + stakingBundleTxOut = genStakingBundleTxOut bundleVLQAC (vlqQty - 1) bundleTMPAC (tmpQty - releasedTMP) stakingBundleDatum + + poolInCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget 1 poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolTxIn = genPoolTxInInfo poolInTxRef 1 900000000000 100 0x7fffffffffffffff 0 poolInCfg + + poolOutCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget compoundEpoch poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolTxOut = genPoolTxOut 1 800000000000 100 0x7fffffffffffffff 0 poolOutCfg + + epochRewardTotal = programBudget `div` epochNum + epochsToCompound = epochNum - compoundEpoch + + epochsBurned = (tmpQty `div` vlqQty) - epochsToCompound + + reward = (epochRewardTotal * vlqQty * epochsBurned) `div` 0x7fffffffffffffff + + userRewardOut = genUserTxOut poolX reward pkh + + txInfo = mkLMStakingBundleTxInfo [stakingBundleTxIn, poolTxIn] [poolTxOut, stakingBundleTxOut, userRewardOut] + purpose = mkPurpose stakingBundleTxRef + cxtData = toData $ mkContext txInfo purpose + + stakingBundleConfigToData = toData $ PSB.StakingBundleRedeemer 1 0 0 2 1 + + result = eraseLeft $ evalWithArgs (wrapValidator SB.stakingBundleValidatorT) [stakingBundleDatumToData, stakingBundleConfigToData, cxtData] + + result === Left () + +successRedeem :: Property +successRedeem = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + -- common acs + bundleIdAC <- forAll genAssetClass + poolNft <- forAll genAssetClass + poolLQAC <- forAll genAssetClass + bundleLQAC <- forAll genAssetClass + bundleVLQAC <- forAll genAssetClass + bundleTMPAC <- forAll genAssetClass + + -- poolConfig + epochLenInt <- forAll $ int range + epochNumInt <- forAll $ int range + programStartInt <- forAll $ int range + programBudgetInt <- forAll $ int range + execBudgetInt <- forAll $ int range + + vlqQtyInt <- forAll $ int range + + expectedNumEpochsInt <- forAll $ int range + + poolX <- forAll genAssetClass + + poolInTxRef <- forAll genTxOutRef + userInTxRef <- forAll genTxOutRef + + stakingBundleTxRef <- forAll genTxOutRef + let + epochLen = toInteger epochLenInt + epochNum = (toInteger epochNumInt) + 2 + programStart = toInteger programStartInt + programBudget = toInteger programBudgetInt + execBudget = toInteger execBudgetInt + + vlqQty = toInteger vlqQtyInt + + expectedNumEpochs = epochNum - 1 + + tmpQty = vlqQty * expectedNumEpochs + + stakingBundleCfg = genStakingBundleConfig bundleIdAC poolNft bundleLQAC bundleVLQAC bundleTMPAC pkh + stakingBundleDatum = OutputDatum $ mkDatum stakingBundleCfg + + stakingBundleDatumToData = toData stakingBundleCfg + + stakingBundleTxOutForTxIn = genStakingBundleTxOut bundleVLQAC vlqQty bundleTMPAC tmpQty stakingBundleDatum + stakingBundleTxIn = mkTxIn stakingBundleTxRef stakingBundleTxOutForTxIn + + compoundEpoch = 2 + + releasedTMP = tmpQty - ((epochNum - compoundEpoch) * vlqQty) + + stakingBundleTxOut = genStakingBundleTxOut bundleVLQAC vlqQty bundleTMPAC (tmpQty - releasedTMP) stakingBundleDatum + + poolInCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget 1 poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolTxIn = genPoolTxInInfo poolInTxRef 1 900000000000 100 0x7fffffffffffffff 0 poolInCfg + + poolOutCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget compoundEpoch poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolTxOut = genPoolTxOut 1 900000000000 90 0x7fffffffffffffff 0 poolOutCfg + + epochRewardTotal = programBudget `div` epochNum + + epochsToCompound = epochNum - compoundEpoch + + epochsBurned = (tmpQty `div` vlqQty) - epochsToCompound + + reward = (epochRewardTotal * vlqQty * epochsBurned) `div` 0x7fffffffffffffff + + userRewardOut = genUserTxOut poolX reward pkh + + userTxOutForTxIn = genUserTxOut bundleLQAC 0x7fffffffffffffff pkh + userUserTxIn = mkTxIn userInTxRef userTxOutForTxIn + + txInfo = mkLMStakingBundleTxInfo [stakingBundleTxIn, poolTxIn, userUserTxIn] [poolTxOut, stakingBundleTxOut, userRewardOut] + purpose = mkPurpose stakingBundleTxRef + cxtData = toData $ mkContext txInfo purpose + + stakingBundleConfigToData = toData $ PSB.StakingBundleRedeemer 1 2 0 2 1 + + result = eraseRight $ evalWithArgs (wrapValidator SB.stakingBundleValidatorT) [stakingBundleDatumToData, stakingBundleConfigToData, cxtData] + + result === Right () + +incorrectRedeem :: Property +incorrectRedeem = property $ do + pkh <- forAll genPkh + let + range = exponential 10 512 + + -- common acs + bundleIdAC <- forAll genAssetClass + poolNft <- forAll genAssetClass + poolLQAC <- forAll genAssetClass + bundleLQAC <- forAll genAssetClass + bundleVLQAC <- forAll genAssetClass + bundleTMPAC <- forAll genAssetClass + + -- poolConfig + epochLenInt <- forAll $ int range + epochNumInt <- forAll $ int range + programStartInt <- forAll $ int range + programBudgetInt <- forAll $ int range + execBudgetInt <- forAll $ int range + + vlqQtyInt <- forAll $ int range + + expectedNumEpochsInt <- forAll $ int range + + poolX <- forAll genAssetClass + + poolInTxRef <- forAll genTxOutRef + userInTxRef <- forAll genTxOutRef + + stakingBundleTxRef <- forAll genTxOutRef + let + epochLen = toInteger epochLenInt + epochNum = (toInteger epochNumInt) + 2 + programStart = toInteger programStartInt + programBudget = toInteger programBudgetInt + execBudget = toInteger execBudgetInt + + vlqQty = toInteger vlqQtyInt + + expectedNumEpochs = epochNum - 1 + + tmpQty = vlqQty * expectedNumEpochs + + stakingBundleCfg = genStakingBundleConfig bundleIdAC poolNft bundleLQAC bundleVLQAC bundleTMPAC pkh + stakingBundleDatum = OutputDatum $ mkDatum stakingBundleCfg + + stakingBundleDatumToData = toData stakingBundleCfg + + stakingBundleTxOutForTxIn = genStakingBundleTxOut bundleVLQAC vlqQty bundleTMPAC tmpQty stakingBundleDatum + stakingBundleTxIn = mkTxIn stakingBundleTxRef stakingBundleTxOutForTxIn + + compoundEpoch = 2 + + releasedTMP = tmpQty - ((epochNum - compoundEpoch) * vlqQty) + + stakingBundleTxOut = genStakingBundleTxOut bundleVLQAC vlqQty bundleTMPAC (tmpQty - releasedTMP) stakingBundleDatum + + poolInCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget 1 poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolTxIn = genPoolTxInInfo poolInTxRef 1 900000000000 100 0x7fffffffffffffff 0 poolInCfg + + poolOutCfg = genLMPoolConfig epochLen epochNum programStart programBudget execBudget compoundEpoch poolNft poolX poolLQAC bundleVLQAC bundleTMPAC + poolTxOut = genPoolTxOut 1 900000000000 500 0x7fffffffffffffff 0 poolOutCfg + + epochRewardTotal = programBudget `div` epochNum + + epochsToCompound = epochNum - compoundEpoch + + epochsBurned = (tmpQty `div` vlqQty) - epochsToCompound + + reward = (epochRewardTotal * vlqQty * epochsBurned) `div` 0x7fffffffffffffff + + userRewardOut = genUserTxOut poolX reward pkh + + userTxOutForTxIn = genUserTxOut bundleLQAC 1 pkh + userUserTxIn = mkTxIn userInTxRef userTxOutForTxIn + + txInfo = mkLMStakingBundleTxInfo [stakingBundleTxIn, poolTxIn, userUserTxIn] [poolTxOut, stakingBundleTxOut, userRewardOut] + purpose = mkPurpose stakingBundleTxRef + cxtData = toData $ mkContext txInfo purpose + + stakingBundleConfigToData = toData $ PSB.StakingBundleRedeemer 1 2 0 2 1 + + result = eraseLeft $ evalWithArgs (wrapValidator SB.stakingBundleValidatorT) [stakingBundleDatumToData, stakingBundleConfigToData, cxtData] + + result === Left () \ No newline at end of file