Add map checks for reserves and configs

input-output-hk · Jul 19, 2021 · c1f2c93 · c1f2c93
1 parent bf474c7
commit c1f2c93
Show file tree

Hide file tree

Showing 4 changed files with 42 additions and 15 deletions.
diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs
@@ -102,7 +102,6 @@ start' getAaveToken params = do
     let aave = Core.aave aaveToken
         payment = assetClassValue (Core.aaveProtocolInst aave) 1
     let aaveTokenTx = TxUtils.mustPayToScript (Core.aaveInstance aave) pkh (Core.LendingPoolDatum pkh) payment
-    -- TODO how to ensure that newly minted owner token is paid to the script before someone else spends it?
     ledgerTx <- TxUtils.submitTxPair aaveTokenTx
     void $ awaitTxConfirmed $ txId ledgerTx
 

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
@@ -53,6 +53,13 @@ import           PlutusTx.Prelude                                 hiding
 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
+  where f = filter filterChanged . AssocMap.toList
+
+assertInsertAt :: (Eq k, Eq a) => k -> AssocMap.Map k a -> AssocMap.Map k a -> Bool
+assertInsertAt key = assertMapChange $ (/= key) . fst
+
 {-# INLINABLE pickUserConfigs #-}
 pickUserConfigs :: AaveDatum -> Maybe (AssetClass, AssocMap.Map UserConfigId UserConfig)
 pickUserConfigs (UserConfigsDatum stateToken configs) = Just (stateToken, configs)
@@ -134,7 +141,7 @@ checkNegativeReservesTransformation :: AssetClass
   -> UserConfigId
   -> Bool
 checkNegativeReservesTransformation stateToken reserves ctx (reserveId, _) =
-      maybe False checkreserves reservesOutputDatum
+      maybe False (checkReserves reserves) reservesOutputDatum
   where
     txInfo = scriptContextTxInfo ctx
     (scriptsHash, scriptsDatumHash) = ownHashes ctx
@@ -150,9 +157,10 @@ checkNegativeReservesTransformation stateToken reserves ctx (reserveId, _) =
     remainderDatumHash = findDatumHash (Datum $ PlutusTx.toData ReserveFundsDatum) txInfo
     remainderValue = (`findValueByDatumHash` scriptOutputs) <$> remainderDatumHash
 
-    checkreserves :: (AssetClass, AssocMap.Map AssetClass Reserve) -> Bool
-    checkreserves (newStateToken, newReserves) =
+    checkReserves :: AssocMap.Map AssetClass Reserve -> (AssetClass, AssocMap.Map AssetClass Reserve) -> Bool
+    checkReserves reserves (newStateToken, newReserves) =
       newStateToken == stateToken &&
+      assertInsertAt reserveId reserves newReserves &&
       maybe
         False
         checkReserveState
@@ -168,7 +176,7 @@ checkPositiveReservesTransformation :: AssetClass
   -> ScriptContext
   -> UserConfigId
   -> Bool
-checkPositiveReservesTransformation stateToken reserves ctx (reserveId, _) = maybe False checkreserves reservesOutputDatum
+checkPositiveReservesTransformation stateToken reserves ctx (reserveId, _) = maybe False (checkReserves reserves) reservesOutputDatum
   where
     txInfo = scriptContextTxInfo ctx
     (scriptsHash, scriptsDatumHash) = ownHashes ctx
@@ -184,9 +192,10 @@ checkPositiveReservesTransformation stateToken reserves ctx (reserveId, _) = may
     investmentDatumHash = findDatumHash (Datum $ PlutusTx.toData ReserveFundsDatum) txInfo
     investmentValue = (`findValueByDatumHash` scriptOutputs) <$> investmentDatumHash
 
-    checkreserves :: (AssetClass, AssocMap.Map AssetClass Reserve) -> Bool
-    checkreserves (newStateToken, newReserves) =
+    checkReserves :: AssocMap.Map AssetClass Reserve -> (AssetClass, AssocMap.Map AssetClass Reserve) -> Bool
+    checkReserves reserves (newStateToken, newReserves) =
       newStateToken == stateToken &&
+      assertInsertAt reserveId reserves newReserves &&
       maybe
         False
         checkReserveState

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
@@ -63,6 +63,16 @@ data Reserve = Reserve
     deriving stock (Prelude.Eq, Show, Generic)
     deriving anyclass (ToJSON, FromJSON)
 
+-- 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 
+    && rCurrentStableBorrowRate a == rCurrentStableBorrowRate b && rTrustedOracle a == rTrustedOracle b
+
+instance Eq (CurrencySymbol, PubKeyHash, Integer, AssetClass) where
+  (a1, b1, c1, d1) == (a2, b2, c2, d2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2
+
 PlutusTx.unstableMakeIsData ''Reserve
 PlutusTx.makeLift ''Reserve
 Lens.makeClassy_ ''Reserve
@@ -86,6 +96,9 @@ data UserConfig = UserConfig
     deriving stock (Prelude.Eq, Show, Generic)
     deriving anyclass (ToJSON, FromJSON, ToSchema)
 
+instance Eq UserConfig where
+  a == b = ucDebt a == ucDebt b && ucCollateralizedInvestment a == ucCollateralizedInvestment b
+
 PlutusTx.unstableMakeIsData ''UserConfig
 PlutusTx.makeLift ''UserConfig
 Lens.makeClassy_ ''UserConfig

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
@@ -50,7 +50,8 @@ import           Plutus.Contracts.LendingPool.OnChain.Core.Logic  (areOraclesTru
                                                                    doesCollateralCoverDebt,
                                                                    pickReserves,
                                                                    pickUserCollateralFunds,
-                                                                   pickUserConfigs)
+                                                                   pickUserConfigs,
+                                                                   assertInsertAt)
 import           Plutus.Contracts.LendingPool.OnChain.Core.Script (AaveDatum (..),
                                                                    AaveRedeemer (..),
                                                                    AaveScript,
@@ -92,10 +93,6 @@ makeAaveValidator :: Aave
                    -> ScriptContext
                    -> Bool
 makeAaveValidator aave datum StartRedeemer ctx    = trace "StartRedeemer" $ validateStart aave datum ctx
--- TODO ? further validators should check that ReservesDatum & UserConfigsDatum transormation happens one time
--- & ReserveFundsDatum transormation happens at least one time
--- TODO ? check that reedeemers contain the same data during transformation
--- TODO validate that userConfigId and reserveId are the only datum changed in trasformation and other users datum is not modified
 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
@@ -117,6 +114,7 @@ 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 =
@@ -137,6 +135,7 @@ validateDeposit aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId
     checkUserConfigs :: (AssetClass, AssocMap.Map UserConfigId UserConfig) -> Bool
     checkUserConfigs (newStateToken, newUserConfigs) =
       newStateToken == stateToken &&
+      assertInsertAt userConfigId userConfigs newUserConfigs &&
       maybe
         False
         (checkRedeemerConfig (AssocMap.lookup userConfigId userConfigs))
@@ -194,7 +193,9 @@ validateBorrow aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(
     checkUserConfigs ::
          (AssetClass, AssocMap.Map UserConfigId UserConfig) -> Bool
     checkUserConfigs (newStateToken, newUserConfigs) =
-      newStateToken == stateToken && doesCollateralCoverDebt actor oracleValues 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 =
@@ -235,6 +236,7 @@ validateRepay aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(r
     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
@@ -282,7 +284,9 @@ validateProvideCollateral aave  (UserConfigsDatum stateToken userConfigs) ctx us
     checkUserConfigs ::
          (AssetClass, AssocMap.Map UserConfigId UserConfig) -> (PubKeyHash, AssetClass) -> Bool
     checkUserConfigs (newStateToken, newUserConfigs) (user, aTokenAsset) =
-      newStateToken == stateToken && user == actor &&
+      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 =
@@ -323,7 +327,9 @@ validateRevokeCollateral aave  (UserConfigsDatum stateToken userConfigs) ctx use
     checkUserConfigs ::
          (AssetClass, AssocMap.Map UserConfigId UserConfig) -> Bool
     checkUserConfigs (newStateToken, newUserConfigs) =
-      newStateToken == stateToken && doesCollateralCoverDebt actor oracleValues 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 =