Implement incentivized tokens

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

Hide file tree

Showing 12 changed files with 475 additions and 383 deletions.
diff --git 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
@@ -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
@@ -4,20 +4,28 @@
 
 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,
                                               find, fst, mapMaybe, mconcat,
                                               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
@@ -0,0 +1,44 @@
+{-# 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)
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
     }