From 448ba1f3292a6cc481af099fc80445a4eb1daaa9 Mon Sep 17 00:00:00 2001 From: megakaban Date: Thu, 22 Jul 2021 14:00:59 +0700 Subject: [PATCH] Implement incentivized tokens --- .../lending-pool/generate-purs/AaveTypes.hs | 2 + MetaLamp/lending-pool/plutus-starter.cabal | 2 +- .../src/Ext/Plutus/Ledger/Contexts.hs | 30 +- .../src/Plutus/Abstract/IncentivizedAmount.hs | 48 +++ .../Contracts/LendingPool/OffChain/Owner.hs | 3 +- .../Contracts/LendingPool/OffChain/State.hs | 20 +- .../Contracts/LendingPool/OffChain/User.hs | 97 +++-- .../Contracts/LendingPool/OnChain/Core.hs | 15 +- .../LendingPool/OnChain/Core/Logic.hs | 174 +++++---- .../LendingPool/OnChain/Core/Script.hs | 100 ++--- .../LendingPool/OnChain/Core/Validator.hs | 344 +++++++----------- .../Plutus/Contracts/LendingPool/Shared.hs | 31 ++ MetaLamp/lending-pool/test/Spec/Shared.hs | 2 + 13 files changed, 485 insertions(+), 383 deletions(-) create mode 100644 MetaLamp/lending-pool/src/Plutus/Abstract/IncentivizedAmount.hs create mode 100644 MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/Shared.hs diff --git a/MetaLamp/lending-pool/generate-purs/AaveTypes.hs b/MetaLamp/lending-pool/generate-purs/AaveTypes.hs index 47cc56afd..ba5f68abf 100644 --- a/MetaLamp/lending-pool/generate-purs/AaveTypes.hs +++ b/MetaLamp/lending-pool/generate-purs/AaveTypes.hs @@ -31,6 +31,7 @@ import Language.PureScript.Bridge.Builder (BridgeData) import Language.PureScript.Bridge.TypeParameters (A, E) import qualified PSGenerator.Common import Plutus.Abstract.ContractResponse (ContractResponse) +import Plutus.Abstract.IncentivizedAmount (IncentivizedAmount) import qualified Plutus.Contracts.LendingPool.OffChain.Info as Aave import qualified Plutus.Contracts.LendingPool.OffChain.Owner as Aave import qualified Plutus.Contracts.LendingPool.OffChain.User as Aave @@ -52,6 +53,7 @@ psRatio = expand <$> psTypeParameters aaveTypes :: [SumType 'Haskell] aaveTypes = [ (equal <*> (genericShow <*> mkSumType)) (Proxy @AaveContracts) + , (equal <*> (genericShow <*> mkSumType)) (Proxy @IncentivizedAmount) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.Aave) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Oracle.Oracle) , (equal <*> (genericShow <*> mkSumType)) (Proxy @(ContractResponse E A)) diff --git a/MetaLamp/lending-pool/plutus-starter.cabal b/MetaLamp/lending-pool/plutus-starter.cabal index 919955258..056cd3f6f 100644 --- a/MetaLamp/lending-pool/plutus-starter.cabal +++ b/MetaLamp/lending-pool/plutus-starter.cabal @@ -23,7 +23,7 @@ maintainer: Your email library exposed-modules: - Plutus.Abstract.State Plutus.Abstract.State.Select Plutus.Abstract.State.Update Plutus.Abstract.ContractResponse Plutus.Abstract.OutputValue Plutus.Abstract.TxUtils Plutus.Contracts.Service.FungibleToken Plutus.Contracts.Service.Oracle Plutus.Contracts.LendingPool.OnChain.Core Plutus.Contracts.LendingPool.OnChain.Core.Script Plutus.Contracts.LendingPool.OnChain.Core.Validator Plutus.Contracts.LendingPool.OnChain.Core.Logic Plutus.Contracts.LendingPool.OnChain.AToken Plutus.Contracts.LendingPool.OffChain.AToken Plutus.Contracts.LendingPool.OffChain.Info Plutus.Contracts.LendingPool.OffChain.Owner Plutus.Contracts.LendingPool.OffChain.State Plutus.Contracts.LendingPool.OffChain.User Plutus.PAB.Simulation Ext.Plutus.Ledger.Value Ext.Plutus.Ledger.Contexts + Plutus.Abstract.State Plutus.Abstract.State.Select Plutus.Abstract.State.Update Plutus.Abstract.ContractResponse Plutus.Abstract.OutputValue Plutus.Abstract.TxUtils Plutus.Abstract.IncentivizedAmount Plutus.Contracts.Service.FungibleToken Plutus.Contracts.Service.Oracle Plutus.Contracts.LendingPool.Shared Plutus.Contracts.LendingPool.OnChain.Core Plutus.Contracts.LendingPool.OnChain.Core.Script Plutus.Contracts.LendingPool.OnChain.Core.Validator Plutus.Contracts.LendingPool.OnChain.Core.Logic Plutus.Contracts.LendingPool.OnChain.AToken Plutus.Contracts.LendingPool.OffChain.AToken Plutus.Contracts.LendingPool.OffChain.Info Plutus.Contracts.LendingPool.OffChain.Owner Plutus.Contracts.LendingPool.OffChain.State Plutus.Contracts.LendingPool.OffChain.User Plutus.PAB.Simulation Ext.Plutus.Ledger.Value Ext.Plutus.Ledger.Contexts build-depends: base >= 4.9 && < 5, aeson, diff --git a/MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Contexts.hs b/MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Contexts.hs index 6a699ec23..f4b44c08a 100644 --- a/MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Contexts.hs +++ b/MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Contexts.hs @@ -4,13 +4,17 @@ module Ext.Plutus.Ledger.Contexts where -import Ledger (Address (Address), - Datum (getDatum), DatumHash, - PubKeyHash, +import Ledger (Address (Address), Datum (..), + DatumHash, PubKeyHash, + ScriptContext, TxInInfo (txInInfoResolved), TxInfo (txInfoInputs), TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue), - ValidatorHash, Value, findDatum) + ValidatorHash, Value, findDatum, + findDatumHash, ownHashes, + scriptContextTxInfo, + scriptOutputsAt) +import Plutus.V1.Ledger.Contexts (ScriptContext) import Plutus.V1.Ledger.Credential (Credential (PubKeyCredential, ScriptCredential)) import qualified PlutusTx import PlutusTx.Prelude (Eq ((==)), Maybe (..), filter, @@ -18,6 +22,10 @@ import PlutusTx.Prelude (Eq ((==)), Maybe (..), filter, otherwise, snd, ($), (.), (<$>), (>>=)) +{-# INLINABLE findOnlyOneDatumByValue #-} +findOnlyOneDatumByValue :: PlutusTx.IsData a => ScriptContext -> Value -> Maybe a +findOnlyOneDatumByValue ctx value = findOnlyOneDatumHashByValue value (getScriptOutputs ctx) >>= parseDatum (scriptContextTxInfo ctx) + {-# INLINABLE findOnlyOneDatumHashByValue #-} -- | Find the hash of a datum, if it is part of the script's outputs. -- Assume search failed if more than one correspondence is found. @@ -28,6 +36,20 @@ findOnlyOneDatumHashByValue val outs = fst <$> case filter f outs of where f (_, val') = val' == val +{-# INLINABLE getScriptOutputs #-} +getScriptOutputs :: ScriptContext -> [(DatumHash, Value)] +getScriptOutputs ctx = scriptOutputsAt scriptsHash (scriptContextTxInfo ctx) + where + (scriptsHash, _) = ownHashes ctx + +{-# INLINABLE findValueByDatum #-} +findValueByDatum :: PlutusTx.IsData a => ScriptContext -> a -> Maybe Value +findValueByDatum ctx datum = (`findValueByDatumHash` scriptOutputs) <$> findDatumHash (Datum $ PlutusTx.toData datum) txInfo + where + txInfo = scriptContextTxInfo ctx + (scriptsHash, _) = ownHashes ctx + scriptOutputs = scriptOutputsAt scriptsHash txInfo + {-# INLINABLE findValueByDatumHash #-} -- | Concat value of the script's outputs that have the specified hash of a datum findValueByDatumHash :: DatumHash -> [(DatumHash, Value)] -> Value diff --git a/MetaLamp/lending-pool/src/Plutus/Abstract/IncentivizedAmount.hs b/MetaLamp/lending-pool/src/Plutus/Abstract/IncentivizedAmount.hs new file mode 100644 index 000000000..cdcdee6f1 --- /dev/null +++ b/MetaLamp/lending-pool/src/Plutus/Abstract/IncentivizedAmount.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fobject-code #-} + +module Plutus.Abstract.IncentivizedAmount where + +import qualified Control.Lens as Lens +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics +import qualified Plutus.Abstract.TxUtils as TxUtils +import Plutus.V1.Ledger.Slot (Slot (..)) +import qualified PlutusTx +import PlutusTx.Prelude +import PlutusTx.Ratio (Ratio) +import qualified Prelude +import Schema (ToSchema) + +data IncentivizedAmount = IncentivizedAmount{ iaSlot :: Slot, iaRate :: Rational, iaAmount :: Rational } + deriving stock (Prelude.Eq, Prelude.Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +Lens.makeClassy_ ''IncentivizedAmount + +instance Eq IncentivizedAmount where + a == b = iaSlot a == iaSlot b && iaAmount a == iaAmount b && iaRate a == iaRate b + +{-# INLINABLE accrue #-} +accrue :: Rational -> Slot -> IncentivizedAmount -> IncentivizedAmount +accrue newRate newSlot (IncentivizedAmount oldSlot oldRate amount) = IncentivizedAmount newSlot newRate (amount * oldRate) + +{-(worker amount (getSlot $ newSlot - oldSlot)) + where + worker amount slot = if slot > 0 then worker (rate * amount) (slot - 1) else amount-} diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs index 4430f7c93..96310db7a 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs @@ -83,7 +83,8 @@ createReserve aave CreateParams {..} = rAmount = 0, rAToken = AToken.makeAToken (Core.aaveHash aave) cpAsset, rLiquidityIndex = 1, - rCurrentStableBorrowRate = 11 % 10, -- TODO configure borrow rate when lending core will be ready + rCurrentStableBorrowRate = 101 % 100, + rCurrentStableAccrualRate = 101 % 100, rTrustedOracle = Oracle.toTuple cpOracle } diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/State.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/State.hs index 7b53bb1c5..e7984222a 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/State.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/State.hs @@ -26,6 +26,7 @@ import Ledger.Constraints.TxConstraints as Constraints import qualified Ledger.Scripts as Scripts import qualified Ledger.Typed.Scripts as Scripts import Playground.Contract +import Plutus.Abstract.IncentivizedAmount (accrue) import Plutus.Abstract.OutputValue (OutputValue (..), _ovValue) import qualified Plutus.Abstract.State as State @@ -40,7 +41,10 @@ import Plutus.Contracts.LendingPool.OnChain.Core (Aave (..), AaveScript, Reserve (..), UserConfig (..), - UserConfigId) + UserConfigId, + getAaveState, + reserveStateToken, + userStateToken) import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken import Plutus.V1.Ledger.Ada (adaValueOf, @@ -64,10 +68,6 @@ findOutputBy aave = State.findOutputBy (Core.aaveAddress aave) findAaveOwnerToken :: Aave -> Contract w s Text (OutputValue PubKeyHash) findAaveOwnerToken aave@Aave{..} = findOutputBy aave aaveProtocolInst (^? Core._LendingPoolDatum) -reserveStateToken, userStateToken :: Aave -> AssetClass -reserveStateToken aave = State.makeStateToken (Core.aaveHash aave) (aaveProtocolInst aave) "aaveReserve" -userStateToken aave = State.makeStateToken (Core.aaveHash aave) (aaveProtocolInst aave) "aaveUser" - findAaveReserves :: Aave -> Contract w s Text (OutputValue (AssocMap.Map AssetClass Reserve)) findAaveReserves aave = findOutputBy aave (reserveStateToken aave) (^? Core._ReservesDatum . _2) @@ -97,10 +97,9 @@ updateState aave = State.updateState (Core.aaveInstance aave) makeReserveHandle :: Aave -> (AssocMap.Map AssetClass Reserve -> AaveRedeemer) -> StateHandle AaveScript (AssocMap.Map AssetClass Reserve) makeReserveHandle aave toRedeemer = - let stateToken = reserveStateToken aave in StateHandle { - stateToken = stateToken, - toDatum = Core.ReservesDatum stateToken, + stateToken = reserveStateToken aave, + toDatum = Core.ReservesDatum (getAaveState aave), toRedeemer = toRedeemer } @@ -124,10 +123,9 @@ roundtripReserves aave redeemer = do makeUserHandle :: Aave -> (AssocMap.Map UserConfigId UserConfig -> AaveRedeemer) -> StateHandle AaveScript (AssocMap.Map UserConfigId UserConfig) makeUserHandle aave toRedeemer = - let stateToken = userStateToken aave in StateHandle { - stateToken = stateToken, - toDatum = Core.UserConfigsDatum stateToken, + stateToken = userStateToken aave, + toDatum = Core.UserConfigsDatum (getAaveState aave), toRedeemer = toRedeemer } diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs index 7bd81b162..608334f98 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs @@ -37,6 +37,9 @@ import qualified Ledger.Typed.Scripts as Scripts import Playground.Contract import Plutus.Abstract.ContractResponse (ContractResponse, withContractResponse) +import Plutus.Abstract.IncentivizedAmount (IncentivizedAmount (..), + _iaAmount, + accrue) import Plutus.Abstract.OutputValue (OutputValue (..)) import qualified Plutus.Abstract.TxUtils as TxUtils import Plutus.Contract hiding (when) @@ -47,13 +50,17 @@ import Plutus.Contracts.LendingPool.OnChain.Core (Aave, AaveDatum (..), AaveRedeemer (..), Reserve (..), - UserConfig (..)) + UserConfig (..), + _ucCollateralizedInvestment, + _ucDebt) import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core +import Plutus.Contracts.LendingPool.Shared (updateConfigAmounts) import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken import qualified Plutus.Contracts.Service.Oracle as Oracle import Plutus.V1.Ledger.Ada (adaValueOf, lovelaceValueOf) import qualified Plutus.V1.Ledger.Address as Addr +import qualified Plutus.V1.Ledger.Interval as Interval import Plutus.V1.Ledger.Value as Value import qualified PlutusTx import qualified PlutusTx.AssocMap as AssocMap @@ -89,12 +96,16 @@ deposit aave DepositParams {..} = do (userConfigsTx, _) <- do userConfigs <- ovValue <$> State.findAaveUserConfigs aave case AssocMap.lookup userConfigId userConfigs of - Nothing -> + Nothing -> do + slot <- currentSlot State.addUserConfig aave (Core.DepositRedeemer userConfigId) userConfigId - UserConfig { ucDebt = 0, ucCollateralizedInvestment = 0 } + UserConfig { + ucDebt = IncentivizedAmount slot (rCurrentStableBorrowRate reserve) (fromInteger 0), + ucCollateralizedInvestment = IncentivizedAmount slot (rCurrentStableAccrualRate reserve) (fromInteger 0) + } Just userConfig -> pure (mempty, userConfigs) @@ -148,15 +159,29 @@ borrow aave BorrowParams {..} = do reserves <- ovValue <$> State.findAaveReserves aave reserve <- maybe (throwError "Reserve not found") pure $ AssocMap.lookup bpAsset reserves let userConfigId = (rCurrency reserve, bpOnBehalfOf) + slot <- currentSlot userConfigs <- do userConfigs <- ovValue <$> State.findAaveUserConfigs aave - pure $ case AssocMap.lookup userConfigId userConfigs of - Nothing -> - AssocMap.insert userConfigId UserConfig { ucDebt = bpAmount, ucCollateralizedInvestment = 0 } userConfigs - Just userConfig -> - AssocMap.insert userConfigId userConfig { ucDebt = ucDebt userConfig + bpAmount} userConfigs + case AssocMap.lookup userConfigId userConfigs of + Nothing -> do + pure $ AssocMap.insert + userConfigId + UserConfig { + ucDebt = IncentivizedAmount slot (rCurrentStableBorrowRate reserve) (fromInteger bpAmount), + ucCollateralizedInvestment = IncentivizedAmount slot (rCurrentStableAccrualRate reserve) (fromInteger 0) + } + userConfigs + Just userConfig -> do + pure $ AssocMap.insert + userConfigId + ( + Lens.over (_ucDebt . _iaAmount) (+ fromInteger bpAmount) + . updateConfigAmounts reserve slot + $ userConfig + ) + userConfigs oracles <- either throwError pure $ findOraclesForUser bpOnBehalfOf reserves userConfigs - let redeemer = Core.BorrowRedeemer userConfigId oracles + let redeemer = Core.BorrowRedeemer userConfigId oracles slot utxos <- Map.filter ((> 0) . flip assetClassValueOf bpAsset . txOutValue . txOutTxOut) @@ -167,7 +192,7 @@ borrow aave BorrowParams {..} = do let disbursementTx = TxUtils.mustSpendFromScript (Core.aaveInstance aave) inputs bpOnBehalfOf payment <> TxUtils.mustPayToScript (Core.aaveInstance aave) bpOnBehalfOf Core.ReserveFundsDatum remainder - (userConfigsTx, _) <- do + userConfigsTx <- (<> (mempty, mustValidateIn (Interval.from slot))) . fst <$> do configsOutput <- State.findAaveUserConfigs aave State.updateUserConfigs aave redeemer $ userConfigs Prelude.<$ configsOutput @@ -215,15 +240,25 @@ repay aave RepayParams {..} = do let reimbursementTx = TxUtils.mustPayToScript (Core.aaveInstance aave) rpOnBehalfOf Core.ReserveFundsDatum payment let userConfigId = (rCurrency reserve, rpOnBehalfOf) - (userConfigsTx, _) <- do + slot <- currentSlot + userConfigsTx <- (<> (mempty, mustValidateIn (Interval.from slot))) . fst <$> do userConfigs <- ovValue <$> State.findAaveUserConfigs aave case AssocMap.lookup userConfigId userConfigs of Nothing -> throwError "User does not have any debt." - Just userConfig -> - State.updateUserConfig aave (Core.RepayRedeemer userConfigId) userConfigId $ userConfig { ucDebt = ucDebt userConfig - rpAmount } + Just userConfig -> do + State.updateUserConfig + aave + (Core.RepayRedeemer userConfigId slot) + userConfigId + ( + Lens.over (_ucDebt . _iaAmount) (\e -> e - fromInteger rpAmount) + . updateConfigAmounts reserve slot + $ userConfig + ) - (reservesTx, _) <- State.updateReserve aave (Core.RepayRedeemer userConfigId) rpAsset (reserve { rAmount = rAmount reserve + rpAmount }) + reservesTx <- (<> (mempty, mustValidateIn (Interval.from slot))) . fst <$> + State.updateReserve aave (Core.RepayRedeemer userConfigId slot) rpAsset (reserve { rAmount = rAmount reserve + rpAmount }) ledgerTx <- TxUtils.submitTxPair $ reimbursementTx <> reservesTx <> userConfigsTx _ <- awaitTxConfirmed $ txId ledgerTx @@ -261,6 +296,7 @@ provideCollateral aave ProvideCollateralParams {..} = do <> (Prelude.mempty, mustPayToPubKey pcpOnBehalfOf remainder) let userConfigId = (rCurrency reserve, pcpOnBehalfOf) + slot <- currentSlot (userConfigsTx, _) <- do userConfigs <- ovValue <$> State.findAaveUserConfigs aave case AssocMap.lookup userConfigId userConfigs of @@ -269,10 +305,20 @@ provideCollateral aave ProvideCollateralParams {..} = do aave (Core.ProvideCollateralRedeemer userConfigId) userConfigId - UserConfig { ucDebt = 0, ucCollateralizedInvestment = pcpAmount } + UserConfig { + ucDebt = IncentivizedAmount slot (rCurrentStableBorrowRate reserve) (fromInteger 0), + ucCollateralizedInvestment = IncentivizedAmount slot (rCurrentStableAccrualRate reserve) (fromInteger pcpAmount) + } Just userConfig -> - State.updateUserConfig aave (Core.ProvideCollateralRedeemer userConfigId) userConfigId $ - userConfig { ucCollateralizedInvestment = ucCollateralizedInvestment userConfig + pcpAmount } + State.updateUserConfig + aave + (Core.ProvideCollateralRedeemer userConfigId) + userConfigId + ( + Lens.over (_ucCollateralizedInvestment . _iaAmount) (+ fromInteger pcpAmount) + . updateConfigAmounts reserve slot + $ userConfig + ) ledgerTx <- TxUtils.submitTxPair $ fundsLockingTx <> userConfigsTx _ <- awaitTxConfirmed $ txId ledgerTx @@ -296,16 +342,25 @@ revokeCollateral aave RevokeCollateralParams {..} = do reserves <- ovValue <$> State.findAaveReserves aave reserve <- maybe (throwError "Reserve not found") pure $ AssocMap.lookup rcpUnderlyingAsset reserves let userConfigId = (rCurrency reserve, rcpOnBehalfOf) + slot <- currentSlot userConfigs <- do userConfigs <- ovValue <$> State.findAaveUserConfigs aave case AssocMap.lookup userConfigId userConfigs of Nothing -> throwError "User does not have any collateral." - Just userConfig -> pure $ - AssocMap.insert userConfigId userConfig { ucCollateralizedInvestment = ucCollateralizedInvestment userConfig - rcpAmount } userConfigs + Just userConfig -> + pure $ + AssocMap.insert + userConfigId + ( + Lens.over (_ucCollateralizedInvestment . _iaAmount) (\e -> e - fromInteger rcpAmount) + . updateConfigAmounts reserve slot + $ userConfig + ) + userConfigs oracles <- either throwError pure $ findOraclesForUser rcpOnBehalfOf reserves userConfigs let aTokenAsset = rAToken reserve - let redeemer = Core.RevokeCollateralRedeemer userConfigId aTokenAsset oracles + let redeemer = Core.RevokeCollateralRedeemer userConfigId aTokenAsset oracles slot utxos <- Map.filter (getUsersCollateral aTokenAsset) @@ -317,7 +372,7 @@ revokeCollateral aave RevokeCollateralParams {..} = do let fundsUnlockingTx = TxUtils.mustSpendFromScript (Core.aaveInstance aave) inputs rcpOnBehalfOf payment <> TxUtils.mustPayToScript (Core.aaveInstance aave) rcpOnBehalfOf (userDatum aTokenAsset) remainder - (userConfigsTx, _) <- do + userConfigsTx <- (<> (mempty, mustValidateIn (Interval.from slot))) . fst <$> do configsOutput <- State.findAaveUserConfigs aave State.updateUserConfigs aave redeemer $ userConfigs Prelude.<$ configsOutput diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core.hs index afd3312c1..bc2eabdfe 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core.hs @@ -37,11 +37,13 @@ import Ledger.Constraints.TxConstraints as Constrai import qualified Ledger.Scripts as UntypedScripts import qualified Ledger.Typed.Scripts as Scripts import Playground.Contract +import qualified Plutus.Abstract.State as State import Plutus.Contract hiding (when) import Plutus.Contracts.LendingPool.OnChain.Core.Script (AaveDatum, AaveRedeemer, - AaveScript) + AaveScript, + AaveState (..)) import Plutus.Contracts.LendingPool.OnChain.Core.Script as Export import Plutus.Contracts.LendingPool.OnChain.Core.Validator (Aave (..), aaveInstance) @@ -69,3 +71,14 @@ aaveAddress = Ledger.scriptAddress . aaveValidator aave :: CurrencySymbol -> Aave aave protocol = Aave (assetClass protocol aaveProtocolName) + +reserveStateToken, userStateToken :: Aave -> AssetClass +reserveStateToken aave = State.makeStateToken (aaveHash aave) (aaveProtocolInst aave) "aaveReserve" +userStateToken aave = State.makeStateToken (aaveHash aave) (aaveProtocolInst aave) "aaveUser" + +-- use to get state lookups in validators and stuff +getAaveState :: Aave -> AaveState +getAaveState aave = AaveState { + asReserves = reserveStateToken aave, + asUserConfigs = userStateToken aave +} diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Logic.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Logic.hs index 438e7fdc0..1d9173bf1 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Logic.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Logic.hs @@ -19,11 +19,13 @@ module Plutus.Contracts.LendingPool.OnChain.Core.Logic where import Control.Lens ((^?)) import qualified Control.Lens as Lens import Control.Monad hiding (fmap) +import qualified Data.Bifunctor as Bifunctor import qualified Data.ByteString as BS import qualified Data.Map as Map import Data.Text (Text, pack) import Data.Void (Void) -import Ext.Plutus.Ledger.Contexts (findOnlyOneDatumHashByValue, +import Ext.Plutus.Ledger.Contexts (findOnlyOneDatumByValue, + findValueByDatum, findValueByDatumHash, parseDatum, scriptInputsAt, @@ -34,68 +36,82 @@ import Ledger.Constraints as Constraints import Ledger.Constraints.OnChain as Constraints import Ledger.Constraints.TxConstraints as Constraints import qualified Ledger.Scripts as UntypedScripts +import Ledger.TimeSlot (posixTimeRangeToSlotRange) import qualified Ledger.Typed.Scripts as Scripts import Playground.Contract +import Plutus.Abstract.IncentivizedAmount (IncentivizedAmount (..)) import Plutus.Contract hiding (when) import Plutus.Contracts.LendingPool.OnChain.Core.Script (AaveDatum (..), AaveRedeemer (..), + AaveState (..), Oracles, Reserve (..), UserConfig (..), UserConfigId) import qualified Plutus.Contracts.Service.Oracle as Oracle +import qualified Plutus.V1.Ledger.Interval as Interval import Plutus.V1.Ledger.Value import qualified PlutusTx import qualified PlutusTx.AssocMap as AssocMap +import qualified PlutusTx.Builtins as Builtins import PlutusTx.Prelude hiding (Semigroup (..), unless) import Prelude (Semigroup (..)) import qualified Prelude -assertMapChange :: (Eq k, Eq a) => ((k, a) -> Bool) -> AssocMap.Map k a -> AssocMap.Map k a -> Bool -assertMapChange filterChanged old new = traceIfFalse "Unexpected datum change" $ f old == f new +assertMapChange :: (Eq k, Eq a) => ((k, a) -> Bool) -> AssocMap.Map k a -> AssocMap.Map k a -> Either Builtins.String () +assertMapChange filterChanged old new = unless (f old == f new) (throwError "Unexpected datum change") where f = filter filterChanged . AssocMap.toList -assertInsertAt :: (Eq k, Eq a) => k -> AssocMap.Map k a -> AssocMap.Map k a -> Bool +assertInsertAt :: (Eq k, Eq a) => k -> AssocMap.Map k a -> AssocMap.Map k a -> Either Builtins.String () assertInsertAt key = assertMapChange $ (/= key) . fst {-# INLINABLE pickUserConfigs #-} -pickUserConfigs :: AaveDatum -> Maybe (AssetClass, AssocMap.Map UserConfigId UserConfig) -pickUserConfigs (UserConfigsDatum stateToken configs) = Just (stateToken, configs) -pickUserConfigs _ = Nothing +pickUserConfigs :: AaveDatum -> Maybe (AaveState, AssocMap.Map UserConfigId UserConfig) +pickUserConfigs (UserConfigsDatum state configs) = Just (state, configs) +pickUserConfigs _ = Nothing {-# INLINABLE pickReserves #-} -pickReserves :: AaveDatum -> Maybe (AssetClass, AssocMap.Map AssetClass Reserve) -pickReserves (ReservesDatum stateToken configs) = Just (stateToken, configs) -pickReserves _ = Nothing +pickReserves :: AaveDatum -> Maybe (AaveState, AssocMap.Map AssetClass Reserve) +pickReserves (ReservesDatum state configs) = Just (state, configs) +pickReserves _ = Nothing {-# INLINABLE pickUserCollateralFunds #-} pickUserCollateralFunds :: AaveDatum -> Maybe (PubKeyHash, AssetClass) pickUserCollateralFunds (UserCollateralFundsDatum user aTokenAsset) = Just (user, aTokenAsset) pickUserCollateralFunds _ = Nothing -{-# INLINABLE totalDebtAndCollateralInLovelace #-} -totalDebtAndCollateralInLovelace :: - PubKeyHash - -> Oracles - -> AssocMap.Map UserConfigId UserConfig - -> Maybe UserConfig -totalDebtAndCollateralInLovelace actor oracles userConfigs = - foldrM addCollateral (UserConfig 0 0) $ AssocMap.toList userConfigs - where - addCollateral :: - (UserConfigId, UserConfig) - -> UserConfig - -> Maybe UserConfig - addCollateral ((asset, user), userConfig) currentTotal - | user == actor = - (\rate -> UserConfig { - ucCollateralizedInvestment = rate * ucCollateralizedInvestment userConfig + ucCollateralizedInvestment currentTotal, - ucDebt = rate * ucDebt userConfig + ucDebt currentTotal } - ) <$> - AssocMap.lookup asset oracles - | otherwise = Just currentTotal +toBool :: Either Builtins.String () -> Bool +toBool (Left m) = traceError m +toBool (Right m) = True + +fromBool :: Builtins.String -> Bool -> Either Builtins.String () +fromBool _ True = pure () +fromBool e False = Left e + +toBoolPrefixed :: Builtins.String -> Either Builtins.String () -> Bool +toBoolPrefixed prefix = toBool . Bifunctor.first (Builtins.appendString prefix) + +assertValidCurrentSlot :: ScriptContext -> Slot -> Either Builtins.String () +assertValidCurrentSlot ctx slot = fromBool "Invalid current slot value" $ + Interval.member slot (posixTimeRangeToSlotRange . txInfoValidRange . scriptContextTxInfo $ ctx) + +findUserConfigs :: ScriptContext -> AaveState -> Either Builtins.String (AssocMap.Map UserConfigId UserConfig) +findUserConfigs ctx state@AaveState{..} = do + let txInfo = scriptContextTxInfo ctx + (newState, newUserConfigs) <- maybe (throwError "User configs not found") pure $ + findOnlyOneDatumByValue ctx (assetClassValue asUserConfigs 1) >>= pickUserConfigs + unless (newState == state) $ throwError "Invalid state address change" + pure newUserConfigs + +findReserves :: ScriptContext -> AaveState -> Either Builtins.String (AssocMap.Map AssetClass Reserve) +findReserves ctx state@AaveState{..} = do + let txInfo = scriptContextTxInfo ctx + (newState, newReserves) <- maybe (throwError "Reserves not found") pure $ + findOnlyOneDatumByValue ctx (assetClassValue asReserves 1) >>= pickReserves + unless (newState == state) $ throwError "Invalid state address change" + pure newReserves {-# INLINABLE doesCollateralCoverDebt #-} doesCollateralCoverDebt :: @@ -103,8 +119,17 @@ doesCollateralCoverDebt :: -> Oracles -> AssocMap.Map UserConfigId UserConfig -> Bool -doesCollateralCoverDebt actor oracles userConfigs = maybe False (\UserConfig{..} -> ucDebt <= ucCollateralizedInvestment) $ - totalDebtAndCollateralInLovelace actor oracles userConfigs +doesCollateralCoverDebt actor oracles userConfigs = Just True == do + let byUser = filter (\((_, pkh), _) -> pkh == actor) . AssocMap.toList $ userConfigs + debt <- totalInLovelace oracles $ fmap (\((asset, _), config) -> (asset, iaAmount . ucDebt $ config)) byUser + investement <- totalInLovelace oracles $ fmap (\((asset, _), config) -> (asset, iaAmount . ucCollateralizedInvestment $ config)) byUser + pure $ debt <= investement + +{-# INLINABLE totalInLovelace #-} +totalInLovelace :: Oracles -> [(AssetClass, Rational)] -> Maybe Rational +totalInLovelace oracles = foldrM reducer (fromInteger 0) + where + reducer (asset, amount) acc = (\rate -> fromInteger rate * amount + acc) <$> AssocMap.lookup asset oracles {-# INLINABLE areOraclesTrusted #-} areOraclesTrusted :: [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] @@ -135,75 +160,40 @@ checkNegativeFundsTransformation ctx asset actor = isValidFundsChange in fundsChange == paidAmout && fundsChange > 0 && paidAmout > 0 {-# INLINABLE checkNegativeReservesTransformation #-} -checkNegativeReservesTransformation :: AssetClass +checkNegativeReservesTransformation :: AaveState -> AssocMap.Map AssetClass Reserve -> ScriptContext -> UserConfigId -> Bool -checkNegativeReservesTransformation stateToken reserves ctx (reserveId, _) = - maybe False (checkReserves reserves) reservesOutputDatum - where - txInfo = scriptContextTxInfo ctx - (scriptsHash, scriptsDatumHash) = ownHashes ctx - scriptOutputs = scriptOutputsAt scriptsHash txInfo - - reservesOutputDatumHash = - findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs - reservesOutputDatum :: - Maybe (AssetClass, AssocMap.Map AssetClass Reserve) - reservesOutputDatum = - reservesOutputDatumHash >>= parseDatum txInfo >>= pickReserves - - remainderDatumHash = findDatumHash (Datum $ PlutusTx.toData ReserveFundsDatum) txInfo - remainderValue = (`findValueByDatumHash` scriptOutputs) <$> remainderDatumHash - - checkReserves :: AssocMap.Map AssetClass Reserve -> (AssetClass, AssocMap.Map AssetClass Reserve) -> Bool - checkReserves reserves (newStateToken, newReserves) = - newStateToken == stateToken && - assertInsertAt reserveId reserves newReserves && - maybe - False - checkReserveState - ((,,) <$> remainderValue <*> AssocMap.lookup reserveId reserves <*> AssocMap.lookup reserveId newReserves) - checkReserveState :: (Value, Reserve, Reserve) -> Bool - checkReserveState (value, oldState, newState) = - let fundsAmount = rAmount newState - in assetClassValueOf value reserveId == fundsAmount && fundsAmount >= 0 && checkReservesConsistency oldState newState +checkNegativeReservesTransformation state@AaveState{..} reserves ctx (reserveId, _) = + toBool $ do + newReserves <- findReserves ctx state + assertInsertAt reserveId reserves newReserves + remainderValue <- maybe (throwError "Remainder not found") pure . findValueByDatum ctx $ ReserveFundsDatum + oldState <- maybe (throwError "Reserve not found") pure . AssocMap.lookup reserveId $ reserves + newState <- maybe (throwError "Reserve not found") pure . AssocMap.lookup reserveId $ newReserves + let fundsAmount = rAmount newState + unless + (assetClassValueOf remainderValue reserveId == fundsAmount && fundsAmount >= 0 && checkReservesConsistency oldState newState) + (throwError "") {-# INLINABLE checkPositiveReservesTransformation #-} -checkPositiveReservesTransformation :: AssetClass +checkPositiveReservesTransformation :: AaveState -> AssocMap.Map AssetClass Reserve -> ScriptContext -> UserConfigId -> Bool -checkPositiveReservesTransformation stateToken reserves ctx (reserveId, _) = maybe False (checkReserves reserves) reservesOutputDatum - where - txInfo = scriptContextTxInfo ctx - (scriptsHash, scriptsDatumHash) = ownHashes ctx - scriptOutputs = scriptOutputsAt scriptsHash txInfo - - reservesOutputDatumHash = - findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs - reservesOutputDatum :: - Maybe (AssetClass, AssocMap.Map AssetClass Reserve) - reservesOutputDatum = - reservesOutputDatumHash >>= parseDatum txInfo >>= pickReserves - - investmentDatumHash = findDatumHash (Datum $ PlutusTx.toData ReserveFundsDatum) txInfo - investmentValue = (`findValueByDatumHash` scriptOutputs) <$> investmentDatumHash - - checkReserves :: AssocMap.Map AssetClass Reserve -> (AssetClass, AssocMap.Map AssetClass Reserve) -> Bool - checkReserves reserves (newStateToken, newReserves) = - newStateToken == stateToken && - assertInsertAt reserveId reserves newReserves && - maybe - False - checkReserveState - ((,,) <$> investmentValue <*> AssocMap.lookup reserveId reserves <*> AssocMap.lookup reserveId newReserves) - checkReserveState :: (Value, Reserve, Reserve) -> Bool - checkReserveState (value, oldState, newState) = - let fundsChange = rAmount newState - rAmount oldState - in assetClassValueOf value reserveId == fundsChange && fundsChange > 0 && checkReservesConsistency oldState newState +checkPositiveReservesTransformation state@AaveState{..}reserves ctx (reserveId, _) = + toBool $ do + newReserves <- findReserves ctx state + assertInsertAt reserveId reserves newReserves + investmentValue <- maybe (throwError "Investment not found") pure . findValueByDatum ctx $ ReserveFundsDatum + oldState <- maybe (throwError "Reserve not found") pure . AssocMap.lookup reserveId $ reserves + newState <- maybe (throwError "Reserve not found") pure . AssocMap.lookup reserveId $ newReserves + let fundsChange = rAmount newState - rAmount oldState + unless + (assetClassValueOf investmentValue reserveId == fundsChange && fundsChange > 0 && checkReservesConsistency oldState newState) + (throwError "") {-# INLINABLE checkReservesConsistency #-} checkReservesConsistency :: Reserve -> Reserve -> Bool diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Script.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Script.hs index c6de2db66..4022dcb09 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Script.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Script.hs @@ -22,39 +22,49 @@ module Plutus.Contracts.LendingPool.OnChain.Core.Script where -import Control.Lens ((^?)) -import qualified Control.Lens as Lens -import Control.Monad hiding (fmap) -import qualified Data.ByteString as BS -import qualified Data.Map as Map -import Data.Text (Text, pack) -import Data.Void (Void) -import Ext.Plutus.Ledger.Contexts (findOnlyOneDatumHashByValue, - findValueByDatumHash, - parseDatum, scriptInputsAt, - valueSpentFrom) -import Ledger hiding (singleton) -import Ledger.Constraints as Constraints -import Ledger.Constraints.OnChain as Constraints -import Ledger.Constraints.TxConstraints as Constraints -import qualified Ledger.Scripts as UntypedScripts -import qualified Ledger.Typed.Scripts as Scripts +import Control.Lens ((^?)) +import qualified Control.Lens as Lens +import Control.Monad hiding (fmap) +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import Data.Text (Text, pack) +import Data.Void (Void) +import Ext.Plutus.Ledger.Contexts (findOnlyOneDatumHashByValue, + findValueByDatumHash, + parseDatum, scriptInputsAt, + valueSpentFrom) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Scripts as UntypedScripts +import qualified Ledger.Typed.Scripts as Scripts import Playground.Contract -import Plutus.Contract hiding (when) -import qualified Plutus.Contracts.Service.Oracle as Oracle +import Plutus.Abstract.IncentivizedAmount (IncentivizedAmount (..)) +import qualified Plutus.Abstract.State as State +import Plutus.Contract hiding (when) +import qualified Plutus.Contracts.Service.Oracle as Oracle import Plutus.V1.Ledger.Value import qualified PlutusTx -import qualified PlutusTx.AssocMap as AssocMap -import PlutusTx.Prelude hiding (Semigroup (..), - unless) -import Prelude (Semigroup (..)) +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding (Semigroup (..), + unless) +import Prelude (Semigroup (..)) import qualified Prelude +newtype Aave = Aave + { aaveProtocolInst :: AssetClass + } deriving stock (Prelude.Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON, ToSchema) + +PlutusTx.makeLift ''Aave + data Reserve = Reserve { rCurrency :: AssetClass, -- reserve id rAToken :: AssetClass, rAmount :: Integer, rLiquidityIndex :: Integer, + rCurrentStableAccrualRate :: Rational, rCurrentStableBorrowRate :: Rational, rTrustedOracle :: (CurrencySymbol, PubKeyHash, Integer, AssetClass) } @@ -63,9 +73,9 @@ data Reserve = Reserve -- seems like the only way to define PlutusTx's Eq for data that doesn't break validators instance Eq Reserve where - a == b = - rCurrency a == rCurrency b && rAToken a == rAToken b && - rAmount a == rAmount b && rLiquidityIndex a == rLiquidityIndex b + a == b = + rCurrency a == rCurrency b && rAToken a == rAToken b && + rAmount a == rAmount b && rLiquidityIndex a == rLiquidityIndex b && rCurrentStableBorrowRate a == rCurrentStableBorrowRate b && rTrustedOracle a == rTrustedOracle b instance Eq (CurrencySymbol, PubKeyHash, Integer, AssetClass) where @@ -75,21 +85,15 @@ PlutusTx.unstableMakeIsData ''Reserve PlutusTx.makeLift ''Reserve Lens.makeClassy_ ''Reserve --- TODO (?) only aTokens pledged as collateral should accumulate interest --- data UserConfig = UserConfig --- { ucDebt :: [IncentivizedAmount] --- , ucCollateralizedInvestment :: [IncentivizedAmount] --- } --- data IncentivizedAmount = IncentivizedAmount --- { iaAmount :: Integer --- , iaRate :: Rational --- , iaSlot :: Slot --- } +deriving anyclass instance ToSchema IncentivizedAmount + +PlutusTx.unstableMakeIsData ''IncentivizedAmount +PlutusTx.makeLift ''IncentivizedAmount data UserConfig = UserConfig { - ucDebt :: Integer, - ucCollateralizedInvestment :: Integer + ucDebt :: IncentivizedAmount, + ucCollateralizedInvestment :: IncentivizedAmount } deriving stock (Prelude.Eq, Show, Generic) deriving anyclass (ToJSON, FromJSON, ToSchema) @@ -107,10 +111,10 @@ data AaveRedeemer = StartRedeemer | DepositRedeemer UserConfigId | WithdrawRedeemer UserConfigId - | BorrowRedeemer UserConfigId [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] - | RepayRedeemer UserConfigId + | BorrowRedeemer UserConfigId [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] Slot + | RepayRedeemer UserConfigId Slot | ProvideCollateralRedeemer UserConfigId - | RevokeCollateralRedeemer UserConfigId AssetClass [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] + | RevokeCollateralRedeemer UserConfigId AssetClass [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] Slot deriving Show PlutusTx.unstableMakeIsData ''AaveRedeemer @@ -120,11 +124,21 @@ type LendingPoolOperator = PubKeyHash type Oracles = AssocMap.Map AssetClass Integer -- Shows how many lovelaces should be paid for a specific asset +data AaveState = AaveState { asReserves :: AssetClass, asUserConfigs :: AssetClass } + deriving stock (Prelude.Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance Eq AaveState where + a == b = asReserves a == asReserves b && asUserConfigs a == asUserConfigs b + +PlutusTx.unstableMakeIsData ''AaveState +PlutusTx.makeLift ''AaveState + data AaveDatum = LendingPoolDatum LendingPoolOperator - | ReservesDatum AssetClass (AssocMap.Map AssetClass Reserve) -- State token and reserve currency -> reserve map + | ReservesDatum AaveState (AssocMap.Map AssetClass Reserve) -- State token and reserve currency -> reserve map | ReserveFundsDatum - | UserConfigsDatum AssetClass (AssocMap.Map UserConfigId UserConfig) -- State token and UserConfigId -> user config map + | UserConfigsDatum AaveState (AssocMap.Map UserConfigId UserConfig) -- State token and UserConfigId -> user config map | UserCollateralFundsDatum PubKeyHash AssetClass -- User pub key and aToken asset type deriving stock (Show) diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Validator.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Validator.hs index f83f2b541..c277d7569 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Validator.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Validator.hs @@ -22,14 +22,15 @@ module Plutus.Contracts.LendingPool.OnChain.Core.Validator (Aave(..), aaveInstance) where -import Control.Lens ((^?)) +import Control.Lens (over, (^?)) import qualified Control.Lens as Lens import Control.Monad hiding (fmap) import qualified Data.ByteString as BS import qualified Data.Map as Map import Data.Text (Text, pack) import Data.Void (Void) -import Ext.Plutus.Ledger.Contexts (findOnlyOneDatumHashByValue, +import Ext.Plutus.Ledger.Contexts (findOnlyOneDatumByValue, + findOnlyOneDatumHashByValue, findValueByDatumHash, parseDatum, scriptInputsAt, @@ -42,39 +43,45 @@ import Ledger.Constraints.TxConstraints as Constraints import qualified Ledger.Scripts as UntypedScripts import qualified Ledger.Typed.Scripts as Scripts import Playground.Contract +import Plutus.Abstract.IncentivizedAmount (IncentivizedAmount (..), + accrue) import Plutus.Contract hiding (when) import Plutus.Contracts.LendingPool.OnChain.Core.Logic (areOraclesTrusted, + assertInsertAt, + assertValidCurrentSlot, checkNegativeFundsTransformation, checkNegativeReservesTransformation, checkPositiveReservesTransformation, doesCollateralCoverDebt, + findReserves, + findUserConfigs, pickReserves, pickUserCollateralFunds, pickUserConfigs, - assertInsertAt) -import Plutus.Contracts.LendingPool.OnChain.Core.Script (AaveDatum (..), + toBool, + toBoolPrefixed) +import Plutus.Contracts.LendingPool.OnChain.Core.Script (Aave (..), + AaveDatum (..), AaveRedeemer (..), AaveScript, + AaveState (..), Reserve (..), UserConfig (..), - UserConfigId) + UserConfigId, + _ucCollateralizedInvestment) +import Plutus.Contracts.LendingPool.Shared (updateConfigAmounts) import qualified Plutus.Contracts.Service.Oracle as Oracle import Plutus.V1.Ledger.Value import qualified PlutusTx import qualified PlutusTx.AssocMap as AssocMap +import qualified PlutusTx.Builtins as Builtins import PlutusTx.Prelude hiding (Semigroup (..), unless) +import PlutusTx.Ratio as Ratio import Prelude (Semigroup (..)) import qualified Prelude -newtype Aave = Aave - { aaveProtocolInst :: AssetClass - } deriving stock (Prelude.Eq, Show, Generic) - deriving anyclass (ToJSON, FromJSON, ToSchema) - -PlutusTx.makeLift ''Aave - aaveInstance :: Aave -> Scripts.TypedValidator AaveScript aaveInstance aave = Scripts.mkTypedValidator @AaveScript ($$(PlutusTx.compile [|| makeAaveValidator ||]) @@ -95,10 +102,10 @@ makeAaveValidator :: Aave makeAaveValidator aave datum StartRedeemer ctx = trace "StartRedeemer" $ validateStart aave datum ctx makeAaveValidator aave datum (DepositRedeemer userConfigId) ctx = trace "DepositRedeemer" $ validateDeposit aave datum ctx userConfigId makeAaveValidator aave datum (WithdrawRedeemer userConfigId) ctx = trace "WithdrawRedeemer" $ validateWithdraw aave datum ctx userConfigId -makeAaveValidator aave datum (BorrowRedeemer userConfigId oracles) ctx = trace "BorrowRedeemer" $ validateBorrow aave datum ctx userConfigId oracles -makeAaveValidator aave datum (RepayRedeemer userConfigId) ctx = trace "RepayRedeemer" $ validateRepay aave datum ctx userConfigId +makeAaveValidator aave datum (BorrowRedeemer userConfigId oracles slot) ctx = trace "BorrowRedeemer" $ validateBorrow aave datum ctx userConfigId oracles slot +makeAaveValidator aave datum (RepayRedeemer userConfigId slot) ctx = trace "RepayRedeemer" $ validateRepay aave datum ctx userConfigId slot makeAaveValidator aave datum (ProvideCollateralRedeemer userConfigId) ctx = trace "ProvideCollateralRedeemer" $ validateProvideCollateral aave datum ctx userConfigId -makeAaveValidator aave datum (RevokeCollateralRedeemer userConfigId aTokenAsset oracles) ctx = trace "RevokeCollateralRedeemer" $ validateRevokeCollateral aave datum ctx userConfigId aTokenAsset oracles +makeAaveValidator aave datum (RevokeCollateralRedeemer userConfigId aTokenAsset oracles slot) ctx = trace "RevokeCollateralRedeemer" $ validateRevokeCollateral aave datum ctx userConfigId aTokenAsset oracles slot {-# INLINABLE validateStart #-} validateStart :: Aave -> AaveDatum -> ScriptContext -> Bool @@ -114,40 +121,21 @@ validateStart aave (LendingPoolDatum operator) ctx = outs -> isJust $ AssocMap.lookup scriptsDatumHash $ AssocMap.fromList outs validateStart aave _ ctx = trace "validateStart: Lending Pool Datum management is not allowed" False - {-# INLINABLE validateDeposit #-} validateDeposit :: Aave -> AaveDatum -> ScriptContext -> UserConfigId -> Bool -validateDeposit aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId = - traceIfFalse "validateDeposit: User Configs Datum change is not valid" isValidUserConfigsTransformation - where - txInfo = scriptContextTxInfo ctx - (scriptsHash, scriptsDatumHash) = ownHashes ctx - userConfigsOutputDatumHash = - findOnlyOneDatumHashByValue (assetClassValue stateToken 1) $ scriptOutputsAt scriptsHash txInfo - userConfigsOutputDatum :: - Maybe (AssetClass, AssocMap.Map UserConfigId UserConfig) - userConfigsOutputDatum = - userConfigsOutputDatumHash >>= parseDatum txInfo >>= pickUserConfigs - - isValidUserConfigsTransformation :: Bool - isValidUserConfigsTransformation = - maybe False checkUserConfigs userConfigsOutputDatum - checkUserConfigs :: (AssetClass, AssocMap.Map UserConfigId UserConfig) -> Bool - checkUserConfigs (newStateToken, newUserConfigs) = - newStateToken == stateToken && - assertInsertAt userConfigId userConfigs newUserConfigs && - maybe - False - (checkRedeemerConfig (AssocMap.lookup userConfigId userConfigs)) - (AssocMap.lookup userConfigId newUserConfigs) - - checkRedeemerConfig :: Maybe UserConfig -> UserConfig -> Bool - checkRedeemerConfig oldState newState = - maybe (ucCollateralizedInvestment newState == 0) ((ucCollateralizedInvestment newState ==) . ucCollateralizedInvestment) oldState && - ucDebt newState == 0 && maybe True ((== 0) . ucDebt) oldState - -validateDeposit aave (ReservesDatum stateToken reserves) ctx userConfigId = - traceIfFalse "validateDeposit: Reserves Datum change is not valid" $ checkPositiveReservesTransformation stateToken reserves ctx userConfigId +validateDeposit aave (UserConfigsDatum state@AaveState{..} userConfigs) ctx userConfigId = + toBoolPrefixed "validateDeposit: " $ do + newUserConfigs <- findUserConfigs ctx state + assertInsertAt userConfigId userConfigs newUserConfigs + let oldState = AssocMap.lookup userConfigId userConfigs + newState <- maybe (throwError "User config not found") pure (AssocMap.lookup userConfigId newUserConfigs) + unless + (maybe ((iaAmount . ucCollateralizedInvestment) newState == (fromInteger 0)) ((ucCollateralizedInvestment newState ==) . ucCollateralizedInvestment) oldState && + (iaAmount . ucDebt $ newState) == (fromInteger 0) && maybe True ((== (fromInteger 0)) . iaAmount . ucDebt) oldState) + (throwError "") + +validateDeposit aave (ReservesDatum state reserves) ctx userConfigId = + traceIfFalse "validateDeposit: Reserves Datum change is not valid" $ checkPositiveReservesTransformation state reserves ctx userConfigId validateDeposit _ _ _ _ = trace "validateDeposit: Lending Pool Datum management is not allowed" False @@ -165,185 +153,123 @@ validateWithdraw aave ReserveFundsDatum ctx (reserveId, actor) = validateWithdraw _ _ _ _ = trace "validateWithdraw: Lending Pool Datum management is not allowed" False {-# INLINABLE validateBorrow #-} -validateBorrow :: Aave -> AaveDatum -> ScriptContext -> UserConfigId -> [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] -> Bool -validateBorrow aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(reserveId, actor) oracles = - traceIfFalse "validateBorrow: User Configs Datum change is not valid" isValidUserConfigsTransformation - where - txInfo = scriptContextTxInfo ctx - (scriptsHash, scriptsDatumHash) = ownHashes ctx - scriptOutputs = scriptOutputsAt scriptsHash txInfo - userConfigsOutputDatumHash = - findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs - userConfigsOutputDatum :: - Maybe (AssetClass, AssocMap.Map UserConfigId UserConfig) - userConfigsOutputDatum = - userConfigsOutputDatumHash >>= parseDatum txInfo >>= pickUserConfigs - - actorSpentValue = valueSpentFrom txInfo actor - actorRemainderValue = valuePaidTo txInfo actor - - oracleValues = +validateBorrow :: Aave -> AaveDatum -> ScriptContext -> UserConfigId -> [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] -> Slot -> Bool +validateBorrow aave (UserConfigsDatum state@AaveState{..} userConfigs) ctx userConfigId@(reserveId, actor) oracles slot = + toBoolPrefixed "validateBorrow: " $ do + assertValidCurrentSlot ctx slot + newUserConfigs <- findUserConfigs ctx state + assertInsertAt userConfigId userConfigs newUserConfigs + + let txInfo = scriptContextTxInfo ctx + oracleValues <- case foldrM (\o@(_, _, _, oAsset) acc -> fmap ((: acc) . (oAsset, )) (Oracle.findOracleValueInTxInputs txInfo o)) [] oracles of - Just vs -> AssocMap.fromList vs - _ -> traceError "validateBorrow: Oracles have not been provided" - - isValidUserConfigsTransformation :: Bool - isValidUserConfigsTransformation = - maybe False checkUserConfigs userConfigsOutputDatum - checkUserConfigs :: - (AssetClass, AssocMap.Map UserConfigId UserConfig) -> Bool - checkUserConfigs (newStateToken, newUserConfigs) = - newStateToken == stateToken && - assertInsertAt userConfigId userConfigs newUserConfigs && - doesCollateralCoverDebt actor oracleValues newUserConfigs && - maybe False (checkRedeemerConfig $ AssocMap.lookup userConfigId userConfigs) (AssocMap.lookup userConfigId newUserConfigs) - checkRedeemerConfig :: Maybe UserConfig -> UserConfig -> Bool - checkRedeemerConfig oldState newState = - let debtAmount = (ucDebt newState -) $ maybe 0 ucDebt oldState - disbursementAmount = assetClassValueOf actorRemainderValue reserveId - assetClassValueOf actorSpentValue reserveId - in debtAmount == disbursementAmount && debtAmount > 0 && disbursementAmount > 0 && - ucCollateralizedInvestment newState == 0 && maybe True ((== 0) . ucCollateralizedInvestment) oldState - -validateBorrow aave (ReservesDatum stateToken reserves) ctx userConfigId oracles = + Just vs -> pure . AssocMap.fromList $ vs + _ -> throwError "Oracles have not been provided" + reserve <- findReserves ctx state >>= maybe (throwError "Reserve not found") pure . AssocMap.lookup reserveId + unless (doesCollateralCoverDebt actor oracleValues newUserConfigs) $ throwError "Not enough collateral" + + let oldState = AssocMap.lookup userConfigId userConfigs + newState <- maybe (throwError "User config not found") pure $ AssocMap.lookup userConfigId newUserConfigs + let accState = fmap (updateConfigAmounts reserve slot) oldState + actorSpentValue = valueSpentFrom txInfo actor + actorRemainderValue = valuePaidTo txInfo actor + debtAmount = ((iaAmount . ucDebt) newState -) $ maybe (fromInteger 0) (iaAmount . ucDebt) accState + disbursementAmount = fromInteger $ assetClassValueOf actorRemainderValue reserveId - assetClassValueOf actorSpentValue reserveId + unless + (debtAmount == disbursementAmount && debtAmount > fromInteger 0 && disbursementAmount > fromInteger 0 && + (iaAmount . ucCollateralizedInvestment $ newState) == (fromInteger 0) && maybe True ((== (fromInteger 0)) . iaAmount . ucCollateralizedInvestment) oldState) + (throwError "") + +validateBorrow aave (ReservesDatum stateToken reserves) ctx userConfigId oracles _ = traceIfFalse "validateBorrow: Reserves Datum change is not valid" $ checkNegativeReservesTransformation stateToken reserves ctx userConfigId && areOraclesTrusted oracles reserves -validateBorrow aave ReserveFundsDatum ctx (reserveId, actor) oracles = +validateBorrow aave ReserveFundsDatum ctx (reserveId, actor) oracles _ = traceIfFalse "validateBorrow: Reserve Funds Datum change is not valid" $ checkNegativeFundsTransformation ctx reserveId actor -validateBorrow _ _ _ _ _ = trace "validateBorrow: Lending Pool Datum management is not allowed" False +validateBorrow _ _ _ _ _ _ = trace "validateBorrow: Lending Pool Datum management is not allowed" False {-# INLINABLE validateRepay #-} -validateRepay :: Aave -> AaveDatum -> ScriptContext -> UserConfigId -> Bool -validateRepay aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(reserveId, actor) = - traceIfFalse "validateRepay: User Configs Datum change is not valid" isValidUserConfigsTransformation - where - txInfo = scriptContextTxInfo ctx - (scriptsHash, scriptsDatumHash) = ownHashes ctx - scriptOutputs = scriptOutputsAt scriptsHash txInfo - userConfigsOutputDatumHash = - findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs - userConfigsOutputDatum :: - Maybe (AssetClass, AssocMap.Map UserConfigId UserConfig) - userConfigsOutputDatum = - userConfigsOutputDatumHash >>= parseDatum txInfo >>= pickUserConfigs - - actorSpentValue = valueSpentFrom txInfo actor - actorRemainderValue = valuePaidTo txInfo actor - - isValidUserConfigsTransformation :: Bool - isValidUserConfigsTransformation = - maybe False checkUserConfigs userConfigsOutputDatum - checkUserConfigs :: (AssetClass, AssocMap.Map UserConfigId UserConfig) -> Bool - checkUserConfigs (newStateToken, newUserConfigs) = - newStateToken == stateToken && - assertInsertAt userConfigId userConfigs newUserConfigs && - (Just True == - (checkRedeemerConfig <$> AssocMap.lookup userConfigId userConfigs <*> AssocMap.lookup userConfigId newUserConfigs)) - checkRedeemerConfig :: UserConfig -> UserConfig -> Bool - checkRedeemerConfig oldState newState = - let newDebt = ucDebt newState - debtChange = ucDebt oldState - newDebt - reimbursementAmount = assetClassValueOf actorSpentValue reserveId - assetClassValueOf actorRemainderValue reserveId - in debtChange == reimbursementAmount && debtChange > 0 && reimbursementAmount > 0 && newDebt >= 0 && - ucCollateralizedInvestment newState == ucCollateralizedInvestment oldState - -validateRepay aave (ReservesDatum stateToken reserves) ctx userConfigId = +validateRepay :: Aave -> AaveDatum -> ScriptContext -> UserConfigId -> Slot -> Bool +validateRepay aave (UserConfigsDatum state@AaveState{..} userConfigs) ctx userConfigId@(reserveId, actor) slot = + toBoolPrefixed "validateRepay: " $ do + assertValidCurrentSlot ctx slot + newUserConfigs <- findUserConfigs ctx state + assertInsertAt userConfigId userConfigs newUserConfigs + reserve <- findReserves ctx state >>= maybe (throwError "Reserve not found") pure . AssocMap.lookup reserveId + oldState <- maybe (throwError "User config not found") pure $ AssocMap.lookup userConfigId userConfigs + newState <- maybe (throwError "User config not found") pure $ AssocMap.lookup userConfigId newUserConfigs + let accState = updateConfigAmounts reserve slot oldState + txInfo = scriptContextTxInfo ctx + actorSpentValue = valueSpentFrom txInfo actor + actorRemainderValue = valuePaidTo txInfo actor + newDebt = iaAmount . ucDebt $ newState + debtChange = (iaAmount . ucDebt) accState - newDebt + reimbursementAmount = fromInteger $ assetClassValueOf actorSpentValue reserveId - assetClassValueOf actorRemainderValue reserveId + unless + (debtChange == reimbursementAmount && debtChange > fromInteger 0 && reimbursementAmount > fromInteger 0 && newDebt >= (fromInteger 0) && + ucCollateralizedInvestment newState == ucCollateralizedInvestment accState) + (throwError "") + +validateRepay aave (ReservesDatum stateToken reserves) ctx userConfigId _ = traceIfFalse "validateRepay: Reserves Datum change is not valid" $ checkPositiveReservesTransformation stateToken reserves ctx userConfigId -validateRepay _ _ _ _ = trace "validateRepay: Lending Pool Datum management is not allowed" False +validateRepay _ _ _ _ _ = trace "validateRepay: Lending Pool Datum management is not allowed" False {-# INLINABLE validateProvideCollateral #-} validateProvideCollateral :: Aave -> AaveDatum -> ScriptContext -> UserConfigId -> Bool -validateProvideCollateral aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(reserveId, actor) = - traceIfFalse "validateProvideCollateral: User Configs Datum change is not valid" isValidUserConfigsTransformation - where - txInfo = scriptContextTxInfo ctx - (scriptsHash, scriptsDatumHash) = ownHashes ctx - scriptOutputs = scriptOutputsAt scriptsHash txInfo - - userConfigsOutputDatumHash = - findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs - userConfigsOutputDatum :: - Maybe (AssetClass, AssocMap.Map UserConfigId UserConfig) - userConfigsOutputDatum = - userConfigsOutputDatumHash >>= parseDatum txInfo >>= pickUserConfigs - - actorSpentValue = valueSpentFrom txInfo actor - actorRemainderValue = valuePaidTo txInfo actor - - collateralOutputDatumHash = - findOnlyOneDatumHashByValue (actorSpentValue - actorRemainderValue - txInfoFee txInfo) scriptOutputs - collateralOutputDatum :: - Maybe (PubKeyHash, AssetClass) - collateralOutputDatum = - collateralOutputDatumHash >>= parseDatum txInfo >>= pickUserCollateralFunds - - isValidUserConfigsTransformation :: Bool - isValidUserConfigsTransformation = - fromMaybe False $ checkUserConfigs <$> userConfigsOutputDatum <*> collateralOutputDatum - checkUserConfigs :: - (AssetClass, AssocMap.Map UserConfigId UserConfig) -> (PubKeyHash, AssetClass) -> Bool - checkUserConfigs (newStateToken, newUserConfigs) (user, aTokenAsset) = - newStateToken == stateToken && - assertInsertAt userConfigId userConfigs newUserConfigs && - user == actor && - maybe False (checkRedeemerConfig aTokenAsset $ AssocMap.lookup userConfigId userConfigs) (AssocMap.lookup userConfigId newUserConfigs) - checkRedeemerConfig :: AssetClass -> Maybe UserConfig -> UserConfig -> Bool - checkRedeemerConfig asset oldState newState = - let investmentAmount = (ucCollateralizedInvestment newState -) $ maybe 0 ucCollateralizedInvestment oldState - disbursementAmount = assetClassValueOf actorSpentValue asset - assetClassValueOf actorRemainderValue asset - in investmentAmount == disbursementAmount && investmentAmount > 0 && disbursementAmount > 0 && - ucDebt newState == 0 && maybe True ((== 0) . ucDebt) oldState - -validateProvideCollateral _ _ _ _ = trace "validateProvideCollateral: Lending Pool Datum management is not allowed" False +validateProvideCollateral aave (UserConfigsDatum state@AaveState{..} userConfigs) ctx userConfigId@(reserveId, actor) = + toBoolPrefixed "validateProvideCollateral: " $ do + newUserConfigs <- findUserConfigs ctx state + assertInsertAt userConfigId userConfigs newUserConfigs + let txInfo = scriptContextTxInfo ctx + actorSpentValue = valueSpentFrom txInfo actor + actorRemainderValue = valuePaidTo txInfo actor + (user, asset) <- maybe (throwError "Collateral not found") pure $ + findOnlyOneDatumByValue ctx (actorSpentValue - actorRemainderValue - txInfoFee txInfo) >>= pickUserCollateralFunds + + let oldState = AssocMap.lookup userConfigId userConfigs + newState <- maybe (throwError "User config not found") pure $ AssocMap.lookup userConfigId newUserConfigs + let investmentAmount = ((iaAmount . ucCollateralizedInvestment) newState -) $ maybe (fromInteger 0) (iaAmount . ucCollateralizedInvestment) oldState + disbursementAmount = fromInteger $ assetClassValueOf actorSpentValue asset - assetClassValueOf actorRemainderValue asset + unless + (user == actor && investmentAmount == disbursementAmount && investmentAmount > fromInteger 0 && disbursementAmount > fromInteger 0 && + (iaAmount . ucDebt $ newState) == (fromInteger 0) && maybe True ((== (fromInteger 0)) . iaAmount . ucDebt) oldState) + (throwError "") + +validateProvideCollateral _ _ _ _ = trace "Lending Pool Datum management is not allowed" False {-# INLINABLE validateRevokeCollateral #-} -validateRevokeCollateral :: Aave -> AaveDatum -> ScriptContext -> UserConfigId -> AssetClass -> [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] -> Bool -validateRevokeCollateral aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(reserveId, actor) aTokenAsset oracles = - traceIfFalse "validateRevokeCollateral: User Configs Datum change is not valid" isValidUserConfigsTransformation - where - txInfo = scriptContextTxInfo ctx - (scriptsHash, scriptsDatumHash) = ownHashes ctx - scriptOutputs = scriptOutputsAt scriptsHash txInfo - - userConfigsOutputDatumHash = - findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs - userConfigsOutputDatum :: - Maybe (AssetClass, AssocMap.Map UserConfigId UserConfig) - userConfigsOutputDatum = - userConfigsOutputDatumHash >>= parseDatum txInfo >>= pickUserConfigs - - actorSpentValue = valueSpentFrom txInfo actor - actorRemainderValue = valuePaidTo txInfo actor - - oracleValues = +validateRevokeCollateral :: Aave -> AaveDatum -> ScriptContext -> UserConfigId -> AssetClass -> [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] -> Slot -> Bool +validateRevokeCollateral aave (UserConfigsDatum state@AaveState{..} userConfigs) ctx userConfigId@(reserveId, actor) aTokenAsset oracles slot = + toBoolPrefixed "validateRevokeCollateral: " $ do + assertValidCurrentSlot ctx slot + newUserConfigs <- findUserConfigs ctx state + let txInfo = scriptContextTxInfo ctx + oracleValues <- case foldrM (\o@(_, _, _, oAsset) acc -> fmap ((: acc) . (oAsset, )) (Oracle.findOracleValueInTxInputs txInfo o)) [] oracles of - Just vs -> AssocMap.fromList vs - _ -> traceError "validateRevokeCollateral: Oracles have not been provided" - - isValidUserConfigsTransformation :: Bool - isValidUserConfigsTransformation = - maybe False checkUserConfigs userConfigsOutputDatum - checkUserConfigs :: - (AssetClass, AssocMap.Map UserConfigId UserConfig) -> Bool - checkUserConfigs (newStateToken, newUserConfigs) = - newStateToken == stateToken && - assertInsertAt userConfigId userConfigs newUserConfigs && - doesCollateralCoverDebt actor oracleValues newUserConfigs && - fromMaybe False (checkRedeemerConfig <$> (AssocMap.lookup userConfigId userConfigs) <*> (AssocMap.lookup userConfigId newUserConfigs)) - checkRedeemerConfig :: UserConfig -> UserConfig -> Bool - checkRedeemerConfig oldState newState = - let newInvestmentAmount = ucCollateralizedInvestment newState - investmentShrinkedBy = ucCollateralizedInvestment oldState - newInvestmentAmount - disbursementAmount = assetClassValueOf actorRemainderValue aTokenAsset - assetClassValueOf actorSpentValue aTokenAsset - in investmentShrinkedBy == disbursementAmount && investmentShrinkedBy > 0 && disbursementAmount > 0 && newInvestmentAmount >= 0 && - (ucDebt newState == ucDebt oldState) - -validateRevokeCollateral aave (UserCollateralFundsDatum owner aTokenAsset) ctx (reserveId, actor) revokedAsset oracles = + Just vs -> pure . AssocMap.fromList $ vs + _ -> throwError "Oracles have not been provided" + unless (doesCollateralCoverDebt actor oracleValues newUserConfigs) $ throwError "Not enough collateral" + + oldState <- maybe (throwError "") pure $ AssocMap.lookup userConfigId userConfigs + newState <- maybe (throwError "") pure $ AssocMap.lookup userConfigId newUserConfigs + reserve <- findReserves ctx state >>= maybe (throwError "Reserve not found") pure . AssocMap.lookup reserveId + let accState = updateConfigAmounts reserve slot oldState + newInvestmentAmount = iaAmount . ucCollateralizedInvestment $ newState + investmentShrinkedBy = (iaAmount . ucCollateralizedInvestment) accState - newInvestmentAmount + actorSpentValue = valueSpentFrom txInfo actor + actorRemainderValue = valuePaidTo txInfo actor + disbursementAmount = fromInteger $ assetClassValueOf actorRemainderValue aTokenAsset - assetClassValueOf actorSpentValue aTokenAsset + unless + (investmentShrinkedBy == disbursementAmount && investmentShrinkedBy > fromInteger 0 && + disbursementAmount > fromInteger 0 && ucDebt newState == IncentivizedAmount slot (rCurrentStableBorrowRate reserve) (iaAmount . ucDebt $ accState)) + (throwError "") + +validateRevokeCollateral aave (UserCollateralFundsDatum owner aTokenAsset) ctx (reserveId, actor) revokedAsset oracles _ = traceIfFalse "validateRevokeCollateral: UserCollateralFundsDatum change is not valid" $ owner == actor && revokedAsset == aTokenAsset && checkNegativeFundsTransformation ctx aTokenAsset actor -validateRevokeCollateral aave (ReservesDatum stateToken reserves) ctx userConfigId revokedAsset oracles = +validateRevokeCollateral aave (ReservesDatum stateToken reserves) ctx userConfigId revokedAsset oracles _ = traceIfFalse "validateRevokeCollateral: Reserves Datum change is not valid" $ areOraclesTrusted oracles reserves -validateRevokeCollateral _ _ _ _ _ _ = trace "validateRevokeCollateral: Lending Pool Datum management is not allowed" False +validateRevokeCollateral _ _ _ _ _ _ _ = trace "validateRevokeCollateral: Lending Pool Datum management is not allowed" False diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/Shared.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/Shared.hs new file mode 100644 index 000000000..ce4720293 --- /dev/null +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/Shared.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Plutus.Contracts.LendingPool.Shared where + +import Plutus.Abstract.IncentivizedAmount (accrue) +import Plutus.Contracts.LendingPool.OnChain.Core.Script (Reserve (..), + UserConfig (..)) +import Plutus.V1.Ledger.Slot (Slot) + +updateConfigAmounts :: Reserve -> Slot -> UserConfig -> UserConfig +updateConfigAmounts Reserve{..} slot UserConfig{..} = + UserConfig { + ucDebt = accrue rCurrentStableBorrowRate slot ucDebt, + ucCollateralizedInvestment = accrue rCurrentStableAccrualRate slot ucCollateralizedInvestment + } diff --git a/MetaLamp/lending-pool/test/Spec/Shared.hs b/MetaLamp/lending-pool/test/Spec/Shared.hs index 5de4c67ec..ef8265908 100644 --- a/MetaLamp/lending-pool/test/Spec/Shared.hs +++ b/MetaLamp/lending-pool/test/Spec/Shared.hs @@ -22,3 +22,5 @@ userConfigsChange configs = Utils.datumsAtAddress Fixtures.aaveAddress (Utils.on where check (Aave.UserConfigsDatum _ configs') = configs' == configs check _ = False + +--getConfigWith :: Aave.Reserve -> Aave.UserConfig