diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PDepositStableV1.hs b/plutarch-validators/WhalePoolsDex/PContracts/PDepositStableV1.hs new file mode 100644 index 0000000..b1bfef4 --- /dev/null +++ b/plutarch-validators/WhalePoolsDex/PContracts/PDepositStableV1.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module WhalePoolsDex.PContracts.PDepositStable ( + stableDepositValidatorT, +) where + +import qualified GHC.Generics as GHC +import Generics.SOP (Generic, I (I)) + +import Plutarch +import Plutarch.Api.V2.Contexts +import Plutarch.DataRepr +import Plutarch.Lift +import Plutarch.Prelude +import Plutarch.Api.V1 (PMaybeData, PPubKeyHash, PValue) +import Plutarch.Extra.TermCont + +import PExtra.API +import PExtra.Ada +import PExtra.List (pelemAt) +import PExtra.Monadic (tlet, tletField, tmatch) + +import WhalePoolsDex.PContracts.PApi (containsSignature, getRewardValue', maxLqCap, pmin, tletUnwrap) +import WhalePoolsDex.PContracts.POrder (OrderAction (Apply, Refund), OrderRedeemer) +import WhalePoolsDex.PContracts.PStablePoolV1 (extractStablePoolConfigV1) +import qualified WhalePoolsDex.PContracts.PDeposit as Deposit + +stableDepositValidatorT :: ClosedTerm (Deposit.DepositConfig :--> OrderRedeemer :--> PScriptContext :--> PBool) +stableDepositValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do + ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' + conf <- pletFieldsC @'["x", "y", "lq", "poolNft", "exFee", "rewardPkh", "stakePkh", "collateralAda"] conf' + let + collateralAda = getField @"collateralAda" conf + + rewardPkh = getField @"rewardPkh" conf + stakePkh = getField @"stakePkh" conf + exFee = getField @"exFee" conf + + x = getField @"x" conf + y = getField @"y" conf + lq = getField @"lq" conf + + txInfo' = getField @"txInfo" ctx + + txInfo <- pletFieldsC @'["inputs", "outputs", "signatories"] txInfo' + inputs <- tletUnwrap $ getField @"inputs" txInfo + outputs <- tletUnwrap $ getField @"outputs" txInfo + + redeemer <- pletFieldsC @'["poolInIx", "orderInIx", "rewardOutIx", "action"] redeemer' + let + poolInIx = getField @"poolInIx" redeemer + orderInIx = getField @"orderInIx" redeemer + rewardOutIx = getField @"rewardOutIx" redeemer + action = getField @"action" redeemer + + rewardOut <- tlet $ pelemAt # rewardOutIx # outputs + rewardValue <- tlet $ getRewardValue' # rewardOut # rewardPkh # stakePkh + + poolIn' <- tlet $ pelemAt # poolInIx # inputs + poolIn <- pletFieldsC @'["outRef", "resolved"] poolIn' + let pool = getField @"resolved" poolIn + + poolValue <- tletField @"value" pool + let poolIdentity = -- operation is performed with the pool selected by the user + let requiredNft = pfromData $ getField @"poolNft" conf + nftAmount = assetClassValueOf # poolValue # requiredNft + in nftAmount #== 1 + + ptraceC $ "poolInputDatum 1" + poolInputDatum <- tlet $ extractStablePoolConfigV1 # pool + ptraceC $ "poolInputDatum 2" + poolConf <- pletFieldsC @'["treasuryX", "treasuryY"] poolInputDatum + let + treasuryX = getField @"treasuryX" poolConf + treasuryY = getField @"treasuryY" poolConf + + selfIn' <- tlet $ pelemAt # orderInIx # inputs + selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' + selfValue <- + let self = pfromData $ getField @"resolved" selfIn + in tletField @"value" self + + PSpending selfRef' <- pmatchC $ getField @"purpose" ctx + let + selfIdentity = + let selfRef = pfield @"_0" # selfRef' + selfInRef = getField @"outRef" selfIn + in selfRef #== selfInRef -- check that orderInIx points to the actual order + + strictInputs = -- ensure double satisfaction attack is not possible + let inputsLength = plength # inputs + in inputsLength #== 2 + + liquidity <- + let lqNegative = assetClassValueOf # poolValue # lq + in tlet $ maxLqCap - lqNegative + + reservesX <- tlet $ (assetClassValueOf # poolValue # x) - treasuryX + reservesY <- tlet $ (assetClassValueOf # poolValue # y) - treasuryY + + minRewardByX <- tlet $ minAssetReward # selfValue # x # reservesX # liquidity # exFee # collateralAda + minRewardByY <- tlet $ minAssetReward # selfValue # y # reservesY # liquidity # exFee # collateralAda + let validChange = -- pair excess is returned to user + pif + (minRewardByX #== minRewardByY) + (pcon PTrue) + ( pif + (minRewardByX #< minRewardByY) + (validChange' # rewardValue # y # minRewardByY # minRewardByX # reservesY # liquidity) + (validChange' # rewardValue # x # minRewardByX # minRewardByY # reservesX # liquidity) + ) + minReward = pmin # minRewardByX # minRewardByY + validReward = -- calculated minimal output of LQ tokens is satisfied + let actualReward = assetClassValueOf # rewardValue # lq + in minReward #<= actualReward + + ptraceC $ "poolIdentity" + ptraceC $ pshow poolIdentity + ptraceC $ "selfIdentity" + ptraceC $ pshow selfIdentity + ptraceC $ "strictInputs" + ptraceC $ pshow strictInputs + ptraceC $ "validChange" + ptraceC $ pshow validChange + ptraceC $ "validReward" + ptraceC $ pshow validReward + + pure $ + pmatch action $ \case + Apply -> poolIdentity #&& selfIdentity #&& strictInputs #&& validChange #&& validReward + Refund -> + let sigs = pfromData $ getField @"signatories" txInfo + in containsSignature # sigs # rewardPkh -- user signed the refund + +-- Checks whether an asset overflow is returned back to user +validChange' :: Term s (PValue _ _ :--> PAssetClass :--> PInteger :--> PInteger :--> PInteger :--> PInteger :--> PBool) +validChange' = + phoistAcyclic $ + plam $ \rewardValue overflowAsset overflowAssetInput otherAssetInput overflowAssetReserves liquidity -> + let diff = overflowAssetInput - otherAssetInput + excess = pdiv # (diff * overflowAssetReserves) # liquidity + change = assetClassValueOf # rewardValue # overflowAsset + in excess #<= change + +minAssetReward :: Term s (PValue _ _ :--> PAssetClass :--> PInteger :--> PInteger :--> PInteger :--> PInteger :--> PInteger) +minAssetReward = + phoistAcyclic $ + plam $ \selfValue asset assetReserves liquidity exFee collateralAda -> + unTermCont $ do + assetInput <- tlet $ assetClassValueOf # selfValue # asset + let depositInput = pif (pIsAda # asset) (assetInput - exFee - collateralAda) assetInput + pure $ pdiv # (depositInput * liquidity) # assetReserves diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PRedeemStableV1.hs b/plutarch-validators/WhalePoolsDex/PContracts/PRedeemStableV1.hs new file mode 100644 index 0000000..f85187e --- /dev/null +++ b/plutarch-validators/WhalePoolsDex/PContracts/PRedeemStableV1.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE UndecidableInstances #-} + +module WhalePoolsDex.PContracts.PRedeemStable ( + stableRedeemValidatorT +) where + +import qualified GHC.Generics as GHC + +import Plutarch +import Plutarch.Api.V2 +import Plutarch.Api.V1.Value +import Plutarch.DataRepr +import Plutarch.Lift +import Plutarch.Prelude +import Plutarch.Extra.TermCont + +import PExtra.API +import PExtra.Ada (pIsAda) +import PExtra.Monadic (tlet, tmatch) +import PExtra.PTriple (PTuple3, ptuple3) + +import WhalePoolsDex.PContracts.PApi (containsSignature, getRewardValue', maxLqCap, zeroAsData) +import WhalePoolsDex.PContracts.POrder (OrderAction (Apply, Refund), OrderRedeemer) +import WhalePoolsDex.PContracts.PStablePoolV1 (extractStablePoolConfigV1) +import qualified WhalePoolsDex.PContracts.PRedeem as Redeem + +stableRedeemValidatorT :: ClosedTerm (Redeem.RedeemConfig :--> OrderRedeemer :--> PScriptContext :--> PBool) +stableRedeemValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do + ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' + conf <- pletFieldsC @'["x", "y", "lq", "poolNft", "exFee", "rewardPkh", "stakePkh"] conf' + let + rewardPkh = getField @"rewardPkh" conf + stakePkh = getField @"stakePkh" conf + + x = getField @"x" conf + y = getField @"y" conf + lq = getField @"lq" conf + + exFee = getField @"exFee" conf + txInfo' = getField @"txInfo" ctx + + txInfo <- pletFieldsC @'["inputs", "outputs", "signatories"] txInfo' + inputs <- tletUnwrap $ getField @"inputs" txInfo + outputs <- tletUnwrap $ getField @"outputs" txInfo + + redeemer <- pletFieldsC @'["poolInIx", "orderInIx", "rewardOutIx", "action"] redeemer' + let + poolInIx = getField @"poolInIx" redeemer + orderInIx = getField @"orderInIx" redeemer + rewardOutIx = getField @"rewardOutIx" redeemer + + rewardOut <- tlet $ pelemAt # rewardOutIx # outputs + rewardValue <- tlet $ getRewardValue' # rewardOut # rewardPkh # stakePkh + + poolIn' <- tlet $ pelemAt # poolInIx # inputs + poolIn <- pletFieldsC @'["outRef", "resolved"] poolIn' + let + pool = getField @"resolved" poolIn + poolValue = pfield @"value" # pool + poolIdentity = -- operation is performed with the pool selected by the user + let + requiredNft = pfromData $ getField @"poolNft" conf + nftAmount = assetClassValueOf # poolValue # requiredNft + in nftAmount #== 1 + + poolInputDatum <- tlet $ extractStablePoolConfigV1 # pool + poolConf <- pletFieldsC @'["treasuryX", "treasuryY"] poolInputDatum + let + treasuryX = getField @"treasuryX" poolConf + treasuryY = getField @"treasuryY" poolConf + + selfIn' <- tlet $ pelemAt # orderInIx # inputs + selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' + let selfValue = pfield @"value" # (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 + + collateralAda <- -- we reserve a small amount of ADA to put it into user output later + let inAda = plovelaceValueOf # selfValue + in tlet $ inAda - exFee + + let strictInputs = -- ensure double satisfaction attack is not possible + let inputsLength = plength # inputs + in inputsLength #== 2 + + liquidity <- + let lqNegative = assetClassValueOf # poolValue # lq + in tlet $ maxLqCap - lqNegative + + outs <- tlet $ calcOutput # rewardValue # x # y # collateralAda + inLq <- tlet $ assetClassValueOf # selfValue # lq + + let + outAda = plovelaceValueOf # rewardValue + + minReturnX = calcMinReturn # liquidity # inLq # poolValue # x # treasuryX + minReturnY = calcMinReturn # liquidity # inLq # poolValue # y # treasuryY + + outX = pfromData $ pfield @"_0" # outs + outY = pfromData $ pfield @"_1" # outs + opAda = pfromData $ pfield @"_2" # outs + + fairShare = minReturnX #<= outX #&& minReturnY #<= outY -- output shares are proportional to the total LQ and LQ returned by the user + fairFee = opAda + collateralAda #<= outAda -- output ADA (if present) plus collateral ADA is returned in full to the user + + action <- tletUnwrap $ getField @"action" redeemer + pure $ + pmatch action $ \case + Apply -> poolIdentity #&& selfIdentity #&& strictInputs #&& fairShare #&& fairFee + Refund -> + let sigs = pfromData $ getField @"signatories" txInfo + in containsSignature # sigs # rewardPkh -- user signed the refund + +calcMinReturn :: Term s (PInteger :--> PInteger :--> PValue _ _:--> PAssetClass :--> PInteger :--> PInteger) +calcMinReturn = + phoistAcyclic $ + plam $ \liquidity inLq poolValue ac treasury-> + let reserves = (assetClassValueOf # poolValue # ac) - treasury + in pdiv # (inLq * reserves) # liquidity + +calcOutput :: Term s (PValue _ _:--> PAssetClass :--> PAssetClass :--> PInteger :--> PTuple3 PInteger PInteger PInteger) +calcOutput = plam $ \rewardValue poolX poolY collateralAda -> unTermCont $ do + rx <- tlet $ assetClassValueOf # rewardValue # poolX + ry <- tlet $ assetClassValueOf # rewardValue # poolY + + outX <- tlet $ rx - collateralAda + outY <- tlet $ ry - collateralAda + + let ifX = ptuple3 # pdata outX # pdata ry # pdata outX + ifY = ptuple3 # pdata rx # pdata outY # pdata outY + ifElse = ptuple3 # pdata rx # pdata ry # zeroAsData + pure $ pif (pIsAda # poolX) ifX (pif (pIsAda # poolY) ifY ifElse) diff --git a/plutarch-validators/WhalePoolsDex/PContracts/PStablePoolV1.hs b/plutarch-validators/WhalePoolsDex/PContracts/PStablePoolV1.hs new file mode 100644 index 0000000..dd8b3b9 --- /dev/null +++ b/plutarch-validators/WhalePoolsDex/PContracts/PStablePoolV1.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE UndecidableInstances #-} + +module WhalePoolsDex.PContracts.PStablePoolV1 ( + StablePoolConfigV1 (..), + extractStablePoolConfigV1 +) where + +import qualified GHC.Generics as GHC +import Generics.SOP (Generic, I (I)) + +import Plutarch +import Plutarch.Api.V2 (PScriptHash(..), PMaybeData (..), PTxOut, POutputDatum(..), PAddress(..), PPubKeyHash(..), PDatum(..), PValue(..), KeyGuarantees(..), AmountGuarantees(..), PCurrencySymbol(..), PStakingCredential(..)) +import Plutarch.Api.V2.Contexts (PScriptContext, PScriptPurpose (PSpending), PTxInfo(..)) +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 Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom')) +import Plutarch.Api.V1.Scripts (PValidatorHash) +import Plutarch.Api.V1.AssocMap as Map +import Plutarch.Extra.Maybe as Maybe + +import PExtra.API (PAssetClass, assetClassValueOf, ptryFromData, assetClass, pValueLength) +import PExtra.List (pelemAt) +import PExtra.Monadic (tcon, tlet, tletField, tmatch) + +import qualified WhalePoolsDex.Contracts.StablePool as P +import WhalePoolsDex.PContracts.PApi (burnLqInitial, feeDen, maxLqCap, tletUnwrap, zero, containsSignature) +import WhalePoolsDex.PConstants + +import Plutarch.Trace + +newtype StablePoolConfigV1 (s :: S) + = StablePoolConfigV1 + ( Term + s + ( PDataRecord + '[ "poolNft" ':= PAssetClass + , "an2n" ':= PInteger + , "assetX" ':= PAssetClass + , "assetY" ':= PAssetClass + , "multiplierX" ':= PInteger + , "multiplierY" ':= PInteger + , "lpToken" ':= PAssetClass + , "lpFeeNum" ':= PInteger + , "protocolFeeNum" ':= PInteger + , "daoStabeProxyWitness" ':= PBuiltinList (PByteString) + , "treasuryAddress" ':= PByteString + , "treasuryX" ':= PInteger + , "treasuryY" ':= PInteger + ] + ) + ) + deriving stock (GHC.Generic) + deriving + (PIsData, PDataFields, PlutusType, PEq) + +instance DerivePlutusType StablePoolConfigV1 where type DPTStrat _ = PlutusTypeData + +instance PUnsafeLiftDecl StablePoolConfigV1 where type PLifted StablePoolConfigV1 = P.StablePoolConfigV1 +deriving via (DerivePConstantViaData P.StablePoolConfigV1 StablePoolConfigV1) instance (PConstantDecl P.StablePoolConfigV1) + +instance PTryFrom PData (PAsData StablePoolConfigV1) + +extractStablePoolConfigV1 :: Term s (PTxOut :--> StablePoolConfigV1) +extractStablePoolConfigV1 = plam $ \txOut -> unTermCont $ do + txOutDatum <- tletField @"datum" txOut + + POutputDatum txOutOutputDatum <- pmatchC txOutDatum + + rawDatum <- tletField @"outputDatum" txOutOutputDatum + + PDatum poolDatum <- pmatchC rawDatum + + tletUnwrap $ ptryFromData @(StablePoolConfigV1) $ poolDatum \ No newline at end of file