Stable T2T V1 deposit/redeem.

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

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)

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