[WIP] Meta lamp/lending pool/risk parameters

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

@@ -5,7 +5,7 @@ import Business.Aave as Aave
 import Business.AaveInfo as AaveInfo
 import Business.AaveUser (UserContractId)
 import Business.AaveUser as AaveUser
-import Capability.LogMessages (class LogMessages)
+import Capability.LogMessages (class LogMessages, logInfo)
 import Capability.PollContract (class PollContract)
 import Component.Contract as Contract
 import Component.Contract as ContractComponent
@@ -148,7 +148,10 @@ component =
               RD.maybe (throwError "contracts are missing") pure
                 $ state.contracts
             case catMaybes (AaveInfo.getInfoContractId <$> contracts) of
-              [ cid ] -> lift (AaveInfo.reserves cid) >>= either (throwError <<< show) pure
+              [ cid ] -> do
+                result <- lift (AaveInfo.reserves cid) >>= either (throwError <<< show) pure
+                lift <<< logInfo <<< show $ result
+                pure result
               _ -> throwError "Info contract not found"
 
   content = BEM.block "content"

MetaLamp/lending-pool/client/src/View/ReserveInfo.purs

@@ -1,14 +1,26 @@
 module View.ReserveInfo where
 
 import Prelude
-import Data.BigInteger (BigInteger)
+import Data.BigInteger (BigInteger, fromInt, toNumber)
 import Halogen.HTML as HH
 import Plutus.Contracts.LendingPool.OnChain.Core.Script (Reserve(..))
 import Plutus.V1.Ledger.Value (AssetClass)
 import View.Utils (assetName)
+import Data.Json.JsonTuple (JsonTuple(..))
+import Data.Tuple (Tuple(..))
 
 reserveInfo :: forall props act. AssetClass -> Reserve -> HH.HTML props act
-reserveInfo asset (Reserve { rAmount }) = poolTab asset rAmount
+reserveInfo asset (Reserve { rAmount, rCurrentStableBorrowRate, rLiquidityRate }) = 
+    HH.div_ [poolBalance asset rAmount, poolRates rCurrentStableBorrowRate rLiquidityRate]
 
-poolTab :: forall props act. AssetClass -> BigInteger -> HH.HTML props act
-poolTab asset amount = HH.div_ $ [ HH.h4_ [ HH.text (assetName asset <> " pool balance") ], HH.text $ show amount ]
+poolBalance :: forall props act. AssetClass -> BigInteger -> HH.HTML props act
+poolBalance asset amount = HH.div_ $ [ HH.h4_ [ HH.text (assetName asset <> " pool balance") ], HH.text $ show amount ]
+
+poolRates :: forall props act. JsonTuple BigInteger BigInteger -> JsonTuple BigInteger BigInteger -> HH.HTML props act
+poolRates borrowRate incomeRate = HH.div_ $ [ HH.text $ "Borrow rate: " <> showPercent borrowRate <> " Income rate: " <> showPercent incomeRate ]
+
+showPercent :: JsonTuple BigInteger BigInteger -> String
+showPercent = (_ <> "%") <<< show <<< ratioToPercent
+
+ratioToPercent :: JsonTuple BigInteger BigInteger -> Number
+ratioToPercent (JsonTuple (Tuple a b)) = toNumber (a * (fromInt 100)) / (toNumber b)

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

@@ -61,6 +61,7 @@ aaveTypes = [ (equal <*> (genericShow <*> mkSumType)) (Proxy @AaveContracts)
           , (order <*> (equal <*> (genericShow <*> mkSumType))) (Proxy @AssetClass)
           , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.UserContractState)
           , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.InfoContractState)
+          , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.InterestRateModel)
           , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.Reserve)
           , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.UserConfig)
           , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.DepositParams)

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.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
+      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
     build-depends:
       base >= 4.9 && < 5,
       aeson,
@@ -102,7 +102,7 @@ test-suite test
     main-is: Main.hs
     hs-source-dirs: test
     other-modules:
-      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
+      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
     default-language: Haskell2010
     ghc-options: -Wall -Wnoncanonical-monad-instances
                  -Wincomplete-uni-patterns -Wincomplete-record-updates

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

@@ -47,8 +47,15 @@ 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
+    scriptOutputs = getScriptOutputs ctx
+
+{-# INLINABLE findInputValueByDatum #-}
+findInputValueByDatum :: PlutusTx.IsData a => ScriptContext -> a -> Maybe Value
+findInputValueByDatum ctx datum = (`findValueByDatumHash` scriptOutputs) <$> findDatumHash (Datum $ PlutusTx.toData datum) txInfo
+  where
+    txInfo = scriptContextTxInfo ctx
+    (validatorHash, _) = ownHashes ctx
+    scriptOutputs = scriptInputsAt validatorHash txInfo
 
 {-# INLINABLE findValueByDatumHash #-}
 -- | Concat value of the script's outputs that have the specified hash of a datum

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

@@ -1,12 +1,14 @@
 {-# LANGUAGE DeriveFunctor          #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE RecordWildCards        #-}
 {-# LANGUAGE TemplateHaskell        #-}
 
 module Plutus.Abstract.OutputValue where
 
 import           Control.Lens     (makeClassy_)
-import           Ledger           (TxOutRef, TxOutTx)
+import           Ledger           (TxOutRef, TxOutTx, Value)
+import           Ledger.Tx        (txOutTxOut, txOutValue)
 import qualified PlutusTx.Prelude as PlutuxTx
 
 data OutputValue a =
@@ -17,3 +19,6 @@ data OutputValue a =
     } deriving (Prelude.Show, Prelude.Functor)
 
 makeClassy_ ''OutputValue
+
+getOutputValue :: OutputValue a -> Value
+getOutputValue OutputValue {..} = txOutValue . txOutTxOut $ ovOutTx

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

@@ -40,8 +40,8 @@ getDatum o = case txOutDatumHash $ txOutTxOut o of
                 Nothing -> throwError "datum has wrong type"
                 Just d  -> return d
 
-getState :: (PlutusTx.IsData datum) => Address -> Contract w s Text [OutputValue datum]
-getState address = do
+getOutputsAt :: (PlutusTx.IsData datum) => Address -> Contract w s Text [OutputValue datum]
+getOutputsAt address = do
     utxos <- utxoAt address
     traverse getDatum' . Map.toList $ utxos
   where
@@ -54,7 +54,7 @@ findOutputsBy :: (PlutusTx.IsData datum) =>
   AssetClass ->
   (datum -> Maybe a) ->
   Contract w s Text [OutputValue a]
-findOutputsBy address stateToken mapDatum = mapMaybe checkStateToken <$> getState address
+findOutputsBy address stateToken mapDatum = mapMaybe checkStateToken <$> getOutputsAt address
     where
         checkStateToken (OutputValue oref outTx datum) =
             if assetClassValueOf (txOutValue $ txOutTxOut outTx) stateToken == 1

MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/InterestRate.hs

@@ -0,0 +1,137 @@
+{-# 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              #-}
+{-# 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.Contracts.LendingPool.InterestRate where
+
+import           Plutus.Abstract.IncentivizedAmount               (IncentivizedAmount (..))
+import           Plutus.Contracts.LendingPool.OnChain.Core.Script (InterestRateModel (..),
+                                                                   Reserve (..),
+                                                                   UserConfig (..))
+import           Plutus.V1.Ledger.Slot                            (Slot (..))
+import           Plutus.V1.Ledger.Value                           (AssetClass)
+import           PlutusTx.Prelude
+import           PlutusTx.Ratio                                   (Ratio,
+                                                                   Rational,
+                                                                   denominator,
+                                                                   numerator,
+                                                                   reduce)
+import qualified Prelude
+
+-- refer to updateCumulativeIndexes
+{-# INLINABLE updateCumulativeIndices #-}
+updateCumulativeIndices :: Reserve -> [UserConfig] -> Slot -> Reserve
+updateCumulativeIndices reserve@Reserve{..} userConfigs currentSlot =
+    if totalBorrows > (fromInteger 0)
+        then
+            if rLastLiquidityCumulativeIndex == fromInteger 0
+                then
+                    reserve {
+                    rLastLiquidityCumulativeIndex = cumulatedLiquidityInterest,
+                    rLastUpdated = currentSlot
+                    }
+                else
+                    reserve {
+                    rLastLiquidityCumulativeIndex = rLastLiquidityCumulativeIndex * cumulatedLiquidityInterest,
+                    rLastUpdated = currentSlot
+                    }
+        else reserve
+    where
+        totalBorrows = getTotalBorrows userConfigs
+        cumulatedLiquidityInterest = calculateLinearInterest rLastUpdated currentSlot rLiquidityRate
+
+{-# INLINABLE getTotalBorrows #-}
+getTotalBorrows :: [UserConfig] -> Rational
+getTotalBorrows = foldr (\acc cur -> cur + (iaAmount . ucDebt $ acc)) (fromInteger 0)
+
+{-# INLINABLE calculateLinearInterest #-}
+calculateLinearInterest :: Slot -> Slot -> Rational -> Rational
+calculateLinearInterest last current rate = rate * timeDelta
+    where
+        timeDifference = current - last
+        timeDelta = getSlot timeDifference % getSlot slotsPerYear
+
+slotsPerYear :: Slot
+slotsPerYear = Slot 31536000
+
+data RateParams = RateParams {
+    rpAvailableLiquidity :: Integer,
+    rpTotalBorrows       :: Rational
+}
+
+-- refer to calculateInterestRates
+{-# INLINABLE updateReserveInterestRates #-}
+updateReserveInterestRates :: RateParams -> Slot -> Rational -> Reserve -> Reserve
+updateReserveInterestRates rateParams currentSlot averageStableBorrowRate reserve@Reserve{..} =
+    reserve {
+        rLiquidityRate = getCurrentLiqudityRate rateParams averageStableBorrowRate,
+        rCurrentStableBorrowRate = getCurrentStableBorrowRate rInterestRateModel rateParams,
+        rLastUpdated = currentSlot }
+
+{-# INLINABLE getCurrentLiqudityRate #-}
+getCurrentLiqudityRate :: RateParams -> Rational -> Rational
+getCurrentLiqudityRate rateParams averageStableBorrowRate =
+    if utilizationRate == fromInteger 0
+        then fromInteger 0
+        else borrowRate `divideRatio` utilizationRate
+    where
+        utilizationRate = getUtilizationRate rateParams
+        borrowRate = if (rpTotalBorrows rateParams) == (fromInteger 0) then (fromInteger 0) else averageStableBorrowRate
+
+{-# INLINABLE getCurrentStableBorrowRate #-}
+getCurrentStableBorrowRate :: InterestRateModel -> RateParams -> Rational
+getCurrentStableBorrowRate InterestRateModel{..} rateParams =
+    if utilizationRate > irmOptimalUtilizationRate
+        then
+            let excessUtilizationRateRatio = (utilizationRate - irmOptimalUtilizationRate) `divideRatio` irmExcessUtilizationRate
+                in irmMarketBorrowRate + irmStableRateSlope1 + irmStableRateSlope2 * excessUtilizationRateRatio
+        else
+            irmMarketBorrowRate + irmStableRateSlope1 * utilizationRate `divideRatio` irmOptimalUtilizationRate
+    where
+        utilizationRate = getUtilizationRate rateParams
+
+{-# INLINABLE getUtilizationRate #-}
+getUtilizationRate :: RateParams -> Rational
+getUtilizationRate RateParams{..} =
+    if rpTotalBorrows == (fromInteger 0) || rpAvailableLiquidity == 0
+        then fromInteger 0
+        else rpTotalBorrows `divideRatio` (rpTotalBorrows + fromInteger rpAvailableLiquidity)
+
+defaultRateModel :: InterestRateModel
+defaultRateModel = InterestRateModel {
+    irmOptimalUtilizationRate = 8 % 10,
+    irmExcessUtilizationRate = 2 % 10,
+    irmStableRateSlope1 = 4 % 100,
+    irmStableRateSlope2 = 1 % 1,
+    irmMarketBorrowRate = 4 % 100
+}
+
+-- TODO: figure out the right way to do it - the numbers are constantly growing
+{-# INLINABLE divideRatio #-}
+divideRatio :: Rational -> Rational -> Rational
+divideRatio a b = reduce (numerator a * denominator b) (denominator a * numerator b)
+
+-- refer to getNormalizedIncome
+{-# INLINABLE getNormalizedIncome #-}
+getNormalizedIncome :: Reserve -> Slot -> Slot -> Rational
+getNormalizedIncome Reserve{..} previous current =
+    rLastLiquidityCumulativeIndex * calculateLinearInterest previous current rLiquidityRate

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

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

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

@@ -74,7 +74,7 @@ fundsAt pkh = utxoValue <$> utxoAt (pubKeyHashAddress pkh)
 
 -- | Gets all UTxOs belonging to the Lending Pool script and concats them into one Value
 poolFunds :: Aave -> Contract w s Text Value
-poolFunds aave =  utxoValue <$> utxoAt (Core.aaveAddress aave)
+poolFunds aave = utxoValue <$> utxoAt (Core.aaveAddress aave)
 
 type AaveInfoSchema =
     Endpoint "fundsAt" PubKeyHash

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

@@ -40,10 +40,12 @@ import           Plutus.Abstract.OutputValue                 (OutputValue (..))
 import qualified Plutus.Abstract.TxUtils                     as TxUtils
 import           Plutus.Contract                             hiding (when)
 import           Plutus.Contracts.Currency                   as Currency
+import qualified Plutus.Contracts.LendingPool.InterestRate   as InterestRate
 import qualified Plutus.Contracts.LendingPool.OffChain.State as State
 import qualified Plutus.Contracts.LendingPool.OnChain.AToken as AToken
 import           Plutus.Contracts.LendingPool.OnChain.Core   (Aave,
                                                               AaveDatum (..),
+                                                              AaveState (..),
                                                               AaveRedeemer (..),
                                                               Reserve (..),
                                                               UserConfig (..))
@@ -76,17 +78,29 @@ data CreateParams =
 
 PlutusTx.makeLift ''CreateParams
 
-createReserve :: Aave -> CreateParams -> Reserve
-createReserve aave CreateParams {..} =
+createReserve :: Aave -> Slot -> CreateParams -> Reserve
+createReserve aave currentSlot CreateParams {..} =
     Reserve
         { rCurrency = cpAsset,
           rAmount = 0,
           rAToken = AToken.makeAToken (Core.aaveHash aave) cpAsset,
-          rLiquidityIndex = 1,
-          rCurrentStableBorrowRate = 101 % 100,
-          rCurrentStableAccrualRate = 101 % 100,
-          rTrustedOracle = Oracle.toTuple cpOracle
+          rCurrentStableBorrowRate =
+              InterestRate.getCurrentStableBorrowRate
+                interestModel
+                rateParams,
+          rLiquidityRate = fromInteger 0,
+          rTrustedOracle = Oracle.toTuple cpOracle,
+          rLastUpdated = currentSlot,
+          rLastLiquidityCumulativeIndex = fromInteger 0,
+          rMarketBorrowRate = 180 % 100,
+          rInterestRateModel = interestModel
            }
+    where
+        rateParams = InterestRate.RateParams
+            { InterestRate.rpAvailableLiquidity = 0,
+              InterestRate.rpTotalBorrows = fromInteger 0
+             }
+        interestModel = InterestRate.defaultRateModel
 
 -- | Starts the Lending Pool protocol: minting pool NFTs, creating empty user configuration state and all specified liquidity reserves
 start :: [CreateParams] -> Contract w s Text Aave
@@ -106,12 +120,11 @@ start' getAaveToken params = do
     ledgerTx <- TxUtils.submitTxPair aaveTokenTx
     void $ awaitTxConfirmed $ txId ledgerTx
 
-    let reserveMap = AssocMap.fromList $ fmap (\params -> (cpAsset params, createReserve aave params)) params
-    reservesTx <- State.putReserves aave Core.StartRedeemer reserveMap
-    ledgerTx <- TxUtils.submitTxPair reservesTx
-    void $ awaitTxConfirmed $ txId ledgerTx
-    userConfigsTx <- State.putUserConfigs aave Core.StartRedeemer AssocMap.empty
-    ledgerTx <- TxUtils.submitTxPair userConfigsTx
+    slot <- currentSlot
+    let reserveMap = AssocMap.fromList $ fmap (\params -> (cpAsset params, createReserve aave slot params)) params
+
+    stateTx <- State.putAaveState aave Core.StartRedeemer AaveState { asReserves = reserveMap, asUserConfigs = AssocMap.empty }
+    ledgerTx <- TxUtils.submitTxPair stateTx
     void $ awaitTxConfirmed $ txId ledgerTx
 
     logInfo @Prelude.String $ printf "started Aave %s at address %s" (show aave) (show $ Core.aaveAddress aave)