Skip to content

Commit fd20e6a

Browse files
Add risk parameters
1 parent 95b5e4d commit fd20e6a

File tree

18 files changed

+736
-306
lines changed

18 files changed

+736
-306
lines changed

MetaLamp/lending-pool/client/src/Component/MainPage.purs

+5-2
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@ import Business.Aave as Aave
55
import Business.AaveInfo as AaveInfo
66
import Business.AaveUser (UserContractId)
77
import Business.AaveUser as AaveUser
8-
import Capability.LogMessages (class LogMessages)
8+
import Capability.LogMessages (class LogMessages, logInfo)
99
import Capability.PollContract (class PollContract)
1010
import Component.Contract as Contract
1111
import Component.Contract as ContractComponent
@@ -148,7 +148,10 @@ component =
148148
RD.maybe (throwError "contracts are missing") pure
149149
$ state.contracts
150150
case catMaybes (AaveInfo.getInfoContractId <$> contracts) of
151-
[ cid ] -> lift (AaveInfo.reserves cid) >>= either (throwError <<< show) pure
151+
[ cid ] -> do
152+
result <- lift (AaveInfo.reserves cid) >>= either (throwError <<< show) pure
153+
lift <<< logInfo <<< show $ result
154+
pure result
152155
_ -> throwError "Info contract not found"
153156

154157
content = BEM.block "content"
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,26 @@
11
module View.ReserveInfo where
22

33
import Prelude
4-
import Data.BigInteger (BigInteger)
4+
import Data.BigInteger (BigInteger, fromInt, toNumber)
55
import Halogen.HTML as HH
66
import Plutus.Contracts.LendingPool.OnChain.Core.Script (Reserve(..))
77
import Plutus.V1.Ledger.Value (AssetClass)
88
import View.Utils (assetName)
9+
import Data.Json.JsonTuple (JsonTuple(..))
10+
import Data.Tuple (Tuple(..))
911

1012
reserveInfo :: forall props act. AssetClass -> Reserve -> HH.HTML props act
11-
reserveInfo asset (Reserve { rAmount }) = poolTab asset rAmount
13+
reserveInfo asset (Reserve { rAmount, rCurrentStableBorrowRate, rLiquidityRate }) =
14+
HH.div_ [poolBalance asset rAmount, poolRates rCurrentStableBorrowRate rLiquidityRate]
1215

13-
poolTab :: forall props act. AssetClass -> BigInteger -> HH.HTML props act
14-
poolTab asset amount = HH.div_ $ [ HH.h4_ [ HH.text (assetName asset <> " pool balance") ], HH.text $ show amount ]
16+
poolBalance :: forall props act. AssetClass -> BigInteger -> HH.HTML props act
17+
poolBalance asset amount = HH.div_ $ [ HH.h4_ [ HH.text (assetName asset <> " pool balance") ], HH.text $ show amount ]
18+
19+
poolRates :: forall props act. JsonTuple BigInteger BigInteger -> JsonTuple BigInteger BigInteger -> HH.HTML props act
20+
poolRates borrowRate incomeRate = HH.div_ $ [ HH.text $ "Borrow rate: " <> showPercent borrowRate <> " Income rate: " <> showPercent incomeRate ]
21+
22+
showPercent :: JsonTuple BigInteger BigInteger -> String
23+
showPercent = (_ <> "%") <<< show <<< ratioToPercent
24+
25+
ratioToPercent :: JsonTuple BigInteger BigInteger -> Number
26+
ratioToPercent (JsonTuple (Tuple a b)) = toNumber (a * (fromInt 100)) / (toNumber b)

MetaLamp/lending-pool/generate-purs/AaveTypes.hs

+1
Original file line numberDiff line numberDiff line change
@@ -61,6 +61,7 @@ aaveTypes = [ (equal <*> (genericShow <*> mkSumType)) (Proxy @AaveContracts)
6161
, (order <*> (equal <*> (genericShow <*> mkSumType))) (Proxy @AssetClass)
6262
, (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.UserContractState)
6363
, (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.InfoContractState)
64+
, (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.InterestRateModel)
6465
, (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.Reserve)
6566
, (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.UserConfig)
6667
, (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.DepositParams)

MetaLamp/lending-pool/plutus-starter.cabal

+2-2
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,7 @@ maintainer: Your email
2323

2424
library
2525
exposed-modules:
26-
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
26+
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.InterestRate 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
2727
build-depends:
2828
base >= 4.9 && < 5,
2929
aeson,
@@ -102,7 +102,7 @@ test-suite test
102102
main-is: Main.hs
103103
hs-source-dirs: test
104104
other-modules:
105-
Spec.Start Spec.Deposit Spec.Withdraw Spec.ProvideCollateral Spec.RevokeCollateral Spec.Borrow Spec.Repay Spec.Shared Utils.Data Utils.Trace Fixtures Fixtures.Symbol Fixtures.Aave Fixtures.Asset Fixtures.Init Fixtures.Wallet
105+
Spec.Start Spec.Deposit Spec.Withdraw Spec.ProvideCollateral Spec.RevokeCollateral Spec.Borrow Spec.Repay Spec.Shared Plutus.Contracts.LendingPool.InterestRate Utils.Data Utils.Trace Fixtures Fixtures.Symbol Fixtures.Aave Fixtures.Asset Fixtures.Init Fixtures.Wallet
106106
default-language: Haskell2010
107107
ghc-options: -Wall -Wnoncanonical-monad-instances
108108
-Wincomplete-uni-patterns -Wincomplete-record-updates

MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Contexts.hs

+1-2
Original file line numberDiff line numberDiff line change
@@ -47,8 +47,7 @@ findValueByDatum :: PlutusTx.IsData a => ScriptContext -> a -> Maybe Value
4747
findValueByDatum ctx datum = (`findValueByDatumHash` scriptOutputs) <$> findDatumHash (Datum $ PlutusTx.toData datum) txInfo
4848
where
4949
txInfo = scriptContextTxInfo ctx
50-
(scriptsHash, _) = ownHashes ctx
51-
scriptOutputs = scriptOutputsAt scriptsHash txInfo
50+
scriptOutputs = getScriptOutputs ctx
5251

5352
{-# INLINABLE findValueByDatumHash #-}
5453
-- | Concat value of the script's outputs that have the specified hash of a datum

MetaLamp/lending-pool/src/Plutus/Abstract/OutputValue.hs

+6-1
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,14 @@
11
{-# LANGUAGE DeriveFunctor #-}
22
{-# LANGUAGE FlexibleInstances #-}
33
{-# LANGUAGE FunctionalDependencies #-}
4+
{-# LANGUAGE RecordWildCards #-}
45
{-# LANGUAGE TemplateHaskell #-}
56

67
module Plutus.Abstract.OutputValue where
78

89
import Control.Lens (makeClassy_)
9-
import Ledger (TxOutRef, TxOutTx)
10+
import Ledger (TxOutRef, TxOutTx, Value)
11+
import Ledger.Tx (txOutTxOut, txOutValue)
1012
import qualified PlutusTx.Prelude as PlutuxTx
1113

1214
data OutputValue a =
@@ -17,3 +19,6 @@ data OutputValue a =
1719
} deriving (Prelude.Show, Prelude.Functor)
1820

1921
makeClassy_ ''OutputValue
22+
23+
getOutputValue :: OutputValue a -> Value
24+
getOutputValue OutputValue {..} = txOutValue . txOutTxOut $ ovOutTx

MetaLamp/lending-pool/src/Plutus/Abstract/State/Select.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -40,8 +40,8 @@ getDatum o = case txOutDatumHash $ txOutTxOut o of
4040
Nothing -> throwError "datum has wrong type"
4141
Just d -> return d
4242

43-
getState :: (PlutusTx.IsData datum) => Address -> Contract w s Text [OutputValue datum]
44-
getState address = do
43+
getOutputsAt :: (PlutusTx.IsData datum) => Address -> Contract w s Text [OutputValue datum]
44+
getOutputsAt address = do
4545
utxos <- utxoAt address
4646
traverse getDatum' . Map.toList $ utxos
4747
where
@@ -54,7 +54,7 @@ findOutputsBy :: (PlutusTx.IsData datum) =>
5454
AssetClass ->
5555
(datum -> Maybe a) ->
5656
Contract w s Text [OutputValue a]
57-
findOutputsBy address stateToken mapDatum = mapMaybe checkStateToken <$> getState address
57+
findOutputsBy address stateToken mapDatum = mapMaybe checkStateToken <$> getOutputsAt address
5858
where
5959
checkStateToken (OutputValue oref outTx datum) =
6060
if assetClassValueOf (txOutValue $ txOutTxOut outTx) stateToken == 1
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,134 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
3+
{-# LANGUAGE DeriveGeneric #-}
4+
{-# LANGUAGE DerivingStrategies #-}
5+
{-# LANGUAGE FlexibleContexts #-}
6+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+
{-# LANGUAGE LambdaCase #-}
8+
{-# LANGUAGE MultiParamTypeClasses #-}
9+
{-# LANGUAGE NoImplicitPrelude #-}
10+
{-# LANGUAGE OverloadedStrings #-}
11+
{-# LANGUAGE RecordWildCards #-}
12+
{-# LANGUAGE ScopedTypeVariables #-}
13+
{-# LANGUAGE StandaloneDeriving #-}
14+
{-# LANGUAGE TemplateHaskell #-}
15+
{-# LANGUAGE TypeApplications #-}
16+
{-# LANGUAGE TypeFamilies #-}
17+
{-# LANGUAGE TypeOperators #-}
18+
{-# OPTIONS_GHC -fno-specialise #-}
19+
{-# OPTIONS_GHC -fno-strictness #-}
20+
{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
21+
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
22+
{-# OPTIONS_GHC -fobject-code #-}
23+
24+
module Plutus.Contracts.LendingPool.InterestRate where
25+
26+
import Plutus.Abstract.IncentivizedAmount (IncentivizedAmount (..))
27+
import Plutus.Contracts.LendingPool.OnChain.Core.Script (InterestRateModel (..),
28+
Reserve (..),
29+
UserConfig (..))
30+
import Plutus.V1.Ledger.Slot (Slot (..))
31+
import Plutus.V1.Ledger.Value (AssetClass)
32+
import PlutusTx.Prelude
33+
import PlutusTx.Ratio (Ratio,
34+
Rational,
35+
denominator,
36+
numerator,
37+
reduce)
38+
import qualified Prelude
39+
40+
{-# INLINABLE updateCumulativeIndices #-}
41+
updateCumulativeIndices :: Reserve -> [UserConfig] -> Slot -> Reserve
42+
updateCumulativeIndices reserve@Reserve{..} userConfigs currentSlot =
43+
if totalBorrows > (fromInteger 0)
44+
then
45+
if rLastLiquidityCumulativeIndex == fromInteger 0
46+
then
47+
reserve {
48+
rLastLiquidityCumulativeIndex = cumulatedLiquidityInterest,
49+
rLastUpdated = currentSlot
50+
}
51+
else
52+
reserve {
53+
rLastLiquidityCumulativeIndex = rLastLiquidityCumulativeIndex * cumulatedLiquidityInterest,
54+
rLastUpdated = currentSlot
55+
}
56+
else reserve
57+
where
58+
totalBorrows = getTotalBorrows userConfigs
59+
cumulatedLiquidityInterest = calculateLinearInterest rLastUpdated currentSlot rLiquidityRate
60+
61+
{-# INLINABLE getTotalBorrows #-}
62+
getTotalBorrows :: [UserConfig] -> Rational
63+
getTotalBorrows = foldr (\acc cur -> cur + (iaAmount . ucDebt $ acc)) (fromInteger 0)
64+
65+
{-# INLINABLE calculateLinearInterest #-}
66+
calculateLinearInterest :: Slot -> Slot -> Rational -> Rational
67+
calculateLinearInterest last current rate = rate * timeDelta
68+
where
69+
timeDifference = current - last
70+
timeDelta = getSlot timeDifference % getSlot slotsPerYear
71+
72+
slotsPerYear :: Slot
73+
slotsPerYear = Slot 31536000
74+
75+
data RateParams = RateParams {
76+
rpAvailableLiquidity :: Integer,
77+
rpTotalBorrows :: Rational
78+
}
79+
80+
{-# INLINABLE updateReserveInterestRates #-}
81+
updateReserveInterestRates :: RateParams -> Slot -> Rational -> Reserve -> Reserve
82+
updateReserveInterestRates rateParams currentSlot averageStableBorrowRate reserve@Reserve{..} =
83+
reserve {
84+
rLiquidityRate = getCurrentLiqudityRate rateParams averageStableBorrowRate,
85+
rCurrentStableBorrowRate = getCurrentStableBorrowRate rInterestRateModel rateParams,
86+
rLastUpdated = currentSlot }
87+
88+
{-# INLINABLE getCurrentLiqudityRate #-}
89+
getCurrentLiqudityRate :: RateParams -> Rational -> Rational
90+
getCurrentLiqudityRate rateParams averageStableBorrowRate =
91+
if utilizationRate == fromInteger 0
92+
then fromInteger 0
93+
else borrowRate `divideRatio` utilizationRate
94+
where
95+
utilizationRate = getUtilizationRate rateParams
96+
borrowRate = if (rpTotalBorrows rateParams) == (fromInteger 0) then (fromInteger 0) else averageStableBorrowRate
97+
98+
defaultRateModel :: InterestRateModel
99+
defaultRateModel = InterestRateModel {
100+
irmOptimalUtilizationRate = 8 % 10,
101+
irmExcessUtilizationRate = 2 % 10,
102+
irmStableRateSlope1 = 4 % 100,
103+
irmStableRateSlope2 = 1 % 1,
104+
irmMarketBorrowRate = 4 % 100
105+
}
106+
107+
-- TODO: figure out the right way to do it
108+
{-# INLINABLE divideRatio #-}
109+
divideRatio :: Rational -> Rational -> Rational
110+
divideRatio a b = reduce (numerator a * denominator b) (denominator a * numerator b)
111+
112+
{-# INLINABLE getCurrentStableBorrowRate #-}
113+
getCurrentStableBorrowRate :: InterestRateModel -> RateParams -> Rational
114+
getCurrentStableBorrowRate InterestRateModel{..} rateParams =
115+
if utilizationRate > irmOptimalUtilizationRate
116+
then
117+
let excessUtilizationRateRatio = (utilizationRate - irmOptimalUtilizationRate) `divideRatio` irmExcessUtilizationRate
118+
in irmMarketBorrowRate + irmStableRateSlope1 + irmStableRateSlope2 * excessUtilizationRateRatio
119+
else
120+
irmMarketBorrowRate + irmStableRateSlope1 * utilizationRate `divideRatio` irmOptimalUtilizationRate
121+
where
122+
utilizationRate = getUtilizationRate rateParams
123+
124+
{-# INLINABLE getUtilizationRate #-}
125+
getUtilizationRate :: RateParams -> Rational
126+
getUtilizationRate RateParams{..} =
127+
if rpTotalBorrows == (fromInteger 0) || rpAvailableLiquidity == 0
128+
then fromInteger 0
129+
else rpTotalBorrows `divideRatio` (rpTotalBorrows + fromInteger rpAvailableLiquidity)
130+
131+
{-# INLINABLE getNormalizedIncome #-}
132+
getNormalizedIncome :: Reserve -> Slot -> Slot -> Rational
133+
getNormalizedIncome Reserve{..} previous current =
134+
rLastLiquidityCumulativeIndex * calculateLinearInterest previous current rLiquidityRate

MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/AToken.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -48,7 +48,7 @@ import qualified Prelude
4848
forgeATokensFrom :: forall w s. Aave -> Reserve -> PubKeyHash -> Integer -> Contract w s Text (TxUtils.TxPair AaveScript)
4949
forgeATokensFrom aave reserve pkh amount = do
5050
let policy = makeLiquidityPolicy (Core.aaveHash aave) (rCurrency reserve)
51-
aTokenAmount = amount -- / rLiquidityIndex reserve -- TODO: how should we divide?
51+
aTokenAmount = amount
5252
forgeValue = assetClassValue (rAToken reserve) aTokenAmount
5353
let payment = assetClassValue (rCurrency reserve) amount
5454
pure $

MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Info.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -74,7 +74,7 @@ fundsAt pkh = utxoValue <$> utxoAt (pubKeyHashAddress pkh)
7474

7575
-- | Gets all UTxOs belonging to the Lending Pool script and concats them into one Value
7676
poolFunds :: Aave -> Contract w s Text Value
77-
poolFunds aave = utxoValue <$> utxoAt (Core.aaveAddress aave)
77+
poolFunds aave = utxoValue <$> utxoAt (Core.aaveAddress aave)
7878

7979
type AaveInfoSchema =
8080
Endpoint "fundsAt" PubKeyHash

MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs

+25-12
Original file line numberDiff line numberDiff line change
@@ -40,10 +40,12 @@ import Plutus.Abstract.OutputValue (OutputValue (..))
4040
import qualified Plutus.Abstract.TxUtils as TxUtils
4141
import Plutus.Contract hiding (when)
4242
import Plutus.Contracts.Currency as Currency
43+
import qualified Plutus.Contracts.LendingPool.InterestRate as InterestRate
4344
import qualified Plutus.Contracts.LendingPool.OffChain.State as State
4445
import qualified Plutus.Contracts.LendingPool.OnChain.AToken as AToken
4546
import Plutus.Contracts.LendingPool.OnChain.Core (Aave,
4647
AaveDatum (..),
48+
AaveNewState (..),
4749
AaveRedeemer (..),
4850
Reserve (..),
4951
UserConfig (..))
@@ -76,17 +78,29 @@ data CreateParams =
7678

7779
PlutusTx.makeLift ''CreateParams
7880

79-
createReserve :: Aave -> CreateParams -> Reserve
80-
createReserve aave CreateParams {..} =
81+
createReserve :: Aave -> Slot -> CreateParams -> Reserve
82+
createReserve aave currentSlot CreateParams {..} =
8183
Reserve
8284
{ rCurrency = cpAsset,
8385
rAmount = 0,
8486
rAToken = AToken.makeAToken (Core.aaveHash aave) cpAsset,
85-
rLiquidityIndex = 1,
86-
rCurrentStableBorrowRate = 101 % 100,
87-
rCurrentStableAccrualRate = 101 % 100,
88-
rTrustedOracle = Oracle.toTuple cpOracle
87+
rCurrentStableBorrowRate =
88+
InterestRate.getCurrentStableBorrowRate
89+
interestModel
90+
rateParams,
91+
rLiquidityRate = fromInteger 0,
92+
rTrustedOracle = Oracle.toTuple cpOracle,
93+
rLastUpdated = currentSlot,
94+
rLastLiquidityCumulativeIndex = fromInteger 0,
95+
rMarketBorrowRate = 180 % 100,
96+
rInterestRateModel = interestModel
8997
}
98+
where
99+
rateParams = InterestRate.RateParams
100+
{ InterestRate.rpAvailableLiquidity = 0,
101+
InterestRate.rpTotalBorrows = fromInteger 0
102+
}
103+
interestModel = InterestRate.defaultRateModel
90104

91105
-- | Starts the Lending Pool protocol: minting pool NFTs, creating empty user configuration state and all specified liquidity reserves
92106
start :: [CreateParams] -> Contract w s Text Aave
@@ -106,12 +120,11 @@ start' getAaveToken params = do
106120
ledgerTx <- TxUtils.submitTxPair aaveTokenTx
107121
void $ awaitTxConfirmed $ txId ledgerTx
108122

109-
let reserveMap = AssocMap.fromList $ fmap (\params -> (cpAsset params, createReserve aave params)) params
110-
reservesTx <- State.putReserves aave Core.StartRedeemer reserveMap
111-
ledgerTx <- TxUtils.submitTxPair reservesTx
112-
void $ awaitTxConfirmed $ txId ledgerTx
113-
userConfigsTx <- State.putUserConfigs aave Core.StartRedeemer AssocMap.empty
114-
ledgerTx <- TxUtils.submitTxPair userConfigsTx
123+
slot <- currentSlot
124+
let reserveMap = AssocMap.fromList $ fmap (\params -> (cpAsset params, createReserve aave slot params)) params
125+
126+
stateTx <- State.putAaveState aave Core.StartRedeemer AaveNewState { ansReserves = reserveMap, ansUserConfigs = AssocMap.empty }
127+
ledgerTx <- TxUtils.submitTxPair stateTx
115128
void $ awaitTxConfirmed $ txId ledgerTx
116129

117130
logInfo @Prelude.String $ printf "started Aave %s at address %s" (show aave) (show $ Core.aaveAddress aave)

0 commit comments

Comments
 (0)