Implement incentivized tokens

input-output-hk · Jul 22, 2021 · ce23cba · ce23cba
1 parent bbfa664
commit ce23cba
Show file tree

Hide file tree

Showing 13 changed files with 438 additions and 354 deletions.
diff --git a/MetaLamp/lending-pool/generate-purs/AaveTypes.hs b/MetaLamp/lending-pool/generate-purs/AaveTypes.hs
@@ -38,6 +38,7 @@ import qualified Plutus.Contracts.LendingPool.OnChain.Core   as Aave
 import qualified Plutus.Contracts.Service.Oracle             as Oracle
 import           Plutus.PAB.Simulation                       (AaveContracts (..))
 import           Plutus.V1.Ledger.Value                      (AssetClass)
+import Plutus.Abstract.IncentivizedAmount (IncentivizedAmount)
 
 ratioBridge :: BridgePart
 ratioBridge = do
@@ -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
@@ -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
@@ -5,18 +5,23 @@
 module Ext.Plutus.Ledger.Contexts where
 
 import           Ledger                      (Address (Address),
-                                              Datum (getDatum), DatumHash,
+                                              Datum (..), DatumHash,
                                               PubKeyHash,
                                               TxInInfo (txInInfoResolved),
                                               TxInfo (txInfoInputs),
                                               TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue),
-                                              ValidatorHash, Value, findDatum)
+                                              ValidatorHash, Value, findDatum, ScriptContext, scriptOutputsAt, scriptContextTxInfo, ownHashes, findDatumHash)
 import           Plutus.V1.Ledger.Credential (Credential (PubKeyCredential, ScriptCredential))
 import qualified PlutusTx
 import           PlutusTx.Prelude            (Eq ((==)), Maybe (..), filter,
                                               find, fst, mapMaybe, mconcat,
                                               otherwise, snd, ($), (.), (<$>),
                                               (>>=))
+import Plutus.V1.Ledger.Contexts (ScriptContext)
+
+{-# 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.
@@ -28,6 +33,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
@@ -0,0 +1,48 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FlexibleInstances              #-}
+{-# LANGUAGE DeriveFunctor          #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# 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 Plutus.V1.Ledger.Slot (Slot(..))
+import PlutusTx.Prelude
+import qualified Prelude
+import Data.Aeson(ToJSON, FromJSON)
+import GHC.Generics
+import Schema (ToSchema) 
+import qualified PlutusTx
+import PlutusTx.Ratio (Ratio)
+import qualified Plutus.Abstract.TxUtils                      as TxUtils
+import qualified Control.Lens                                 as Lens
+
+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
@@ -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
@@ -40,7 +40,7 @@ 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,
@@ -54,6 +54,7 @@ import           PlutusTx.Prelude                          hiding (Functor (..),
 import           Prelude                                   (Semigroup (..),
                                                             fmap)
 import qualified Prelude
+import Plutus.Abstract.IncentivizedAmount (accrue)
 
 findOutputsBy :: Aave -> AssetClass -> (AaveDatum -> Maybe a) -> Contract w s Text [OutputValue a]
 findOutputsBy aave = State.findOutputsBy (Core.aaveAddress aave)
@@ -64,10 +65,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 +94,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 +120,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
     }