Check if specified amount exceeds UTxO balance

Signed-off-by: Sasha Bogicevic <[email protected]>

Author: v0d1ch

hydra-cluster/src/Hydra/Cluster/Scenarios.hs

@@ -1334,8 +1334,11 @@ canDepositPartially tracer workDir blockTime backend hydraScriptsTxId =
           -- Get some L1 funds
           (walletVk, walletSk) <- generate genKeyPair
           commitUTxO <- seedFromFaucet backend walletVk 5_000_000 (contramap FromFaucet tracer)
-          commitUTxO2 <- seedFromFaucet backend walletVk 5_000_000 (contramap FromFaucet tracer)
+          -- This one is expected to fail since there is 5 ADA at the wallet address but we specified 6 ADA to commit
+          sendRequest 2 commitUTxO (Just 6_000_000)
+            `shouldThrow` expectErrorStatus 400 (Just "AmountTooLow")
 
+          commitUTxO2 <- seedFromFaucet backend walletVk 5_000_000 (contramap FromFaucet tracer)
           let expectedCommit = fst $ capUTxO commitUTxO 2_000_000
           let expectedCommit2 = fst $ capUTxO commitUTxO2 3_000_000
 
@@ -1383,6 +1386,16 @@ canDepositPartially tracer workDir blockTime backend hydraScriptsTxId =
  where
   hydraTracer = contramap FromHydraNode tracer
 
+  sendRequest :: MonadIO m => Int -> UTxO.UTxO -> Maybe Coin -> m (JsonResponse Aeson.Value)
+  sendRequest hydraNodeId utxo amt =
+    runReq defaultHttpConfig $
+      req
+        POST
+        (http "127.0.0.1" /: "commit")
+        (ReqBodyJson $ SimpleCommitRequest @Tx utxo amt)
+        (Proxy :: Proxy (JsonResponse Aeson.Value))
+        (port $ 4000 + hydraNodeId)
+
 rejectCommit :: ChainBackend backend => Tracer IO EndToEndLog -> FilePath -> NominalDiffTime -> backend -> [TxId] -> IO ()
 rejectCommit tracer workDir blockTime backend hydraScriptsTxId =
   (`finally` returnFundsToFaucet tracer backend Alice) $ do

hydra-node/src/Hydra/API/HTTPServer.hs

@@ -279,7 +279,6 @@ handleDraftCommitUtxo env pparams directChain getCommitInfo body = do
             FullCommitRequest{blueprintTx, utxo} -> do
               draftCommit headId utxo blueprintTx Nothing
             SimpleCommitRequest{utxoToCommit, amount} -> do
-              -- TODO: check if the provided amount is actually possible to extract from the utxoToCommit
               let blueprintTx = txSpendingUTxO utxoToCommit
               draftCommit headId utxoToCommit blueprintTx amount
         IncrementalCommit headId -> do
@@ -309,6 +308,7 @@ handleDraftCommitUtxo env pparams directChain getCommitInfo body = do
           UnsupportedLegacyOutput _ -> badRequest e
           CannotFindOwnInitial _ -> badRequest e
           DepositTooLow _ _ -> badRequest e
+          AmountTooLow _ _ -> badRequest e
           _ -> responseLBS status500 [] (Aeson.encode $ toJSON e)
       Right commitTx ->
         okJSON $ DraftCommitTxResponse commitTx

hydra-node/src/Hydra/Chain.hs

@@ -203,6 +203,7 @@ data PostTxError tx
   | FailedToConstructDecrementTx {failureReason :: Text}
   | FailedToConstructFanoutTx
   | DepositTooLow {providedValue :: Coin, minimumValue :: Coin}
+  | AmountTooLow {providedValue :: Coin, totalUTxOValue :: Coin}
   deriving stock (Generic)
 
 deriving stock instance IsChainState tx => Eq (PostTxError tx)

hydra-node/src/Hydra/Chain/Direct/Handlers.hs

@@ -182,28 +182,32 @@ mkChain tracer queryTimeHandle wallet ctx LocalChainState{getLatest} submitTx =
     , draftCommitTx = \headId commitBlueprintTx amount -> do
         ChainStateAt{spendableUTxO} <- atomically getLatest
         let CommitBlueprintTx{lookupUTxO} = commitBlueprintTx
-        traverse (finalizeTx wallet ctx spendableUTxO lookupUTxO) $
+        traverse (finalizeTx wallet ctx spendableUTxO lookupUTxO) $ do
+          checkAmount lookupUTxO amount
           commit' ctx headId spendableUTxO commitBlueprintTx amount
     , draftDepositTx = \headId pparams commitBlueprintTx deadline amount -> do
         let CommitBlueprintTx{lookupUTxO} = commitBlueprintTx
         ChainStateAt{spendableUTxO} <- atomically getLatest
         TimeHandle{currentPointInTime} <- queryTimeHandle
         -- XXX: What an error handling mess
-        runExceptT $ do
-          liftEither $ rejectLowDeposits pparams lookupUTxO amount
-          (currentSlot, currentTime) <- case currentPointInTime of
-            Left failureReason -> throwError FailedToConstructDepositTx{failureReason}
-            Right (s, t) -> pure (s, t)
-          -- NOTE: Use a smaller upper bound than maxGraceTime to allow for
-          -- shorter than 200 slot deposit periods. This is only important on
-          -- fast moving networks (e.g. in testing). XXX: Making maxGraceTime
-          -- configurable would avoid this.
-          let untilDeadline = diffUTCTime deadline currentTime
-          let graceTime = maxGraceTime `min` untilDeadline / 2
-          -- -- NOTE: But also not make it smaller than 10 slots.
-          let validBeforeSlot = currentSlot + fromInteger (truncate graceTime `max` 10)
-          lift . finalizeTx wallet ctx spendableUTxO lookupUTxO $
-            depositTx (networkId ctx) headId commitBlueprintTx validBeforeSlot deadline amount
+        runExceptT $
+          do
+            liftEither $ do
+              checkAmount lookupUTxO amount
+              rejectLowDeposits pparams lookupUTxO amount
+            (currentSlot, currentTime) <- case currentPointInTime of
+              Left failureReason -> throwError FailedToConstructDepositTx{failureReason}
+              Right (s, t) -> pure (s, t)
+            -- NOTE: Use a smaller upper bound than maxGraceTime to allow for
+            -- shorter than 200 slot deposit periods. This is only important on
+            -- fast moving networks (e.g. in testing). XXX: Making maxGraceTime
+            -- configurable would avoid this.
+            let untilDeadline = diffUTCTime deadline currentTime
+            let graceTime = maxGraceTime `min` untilDeadline / 2
+            -- -- NOTE: But also not make it smaller than 10 slots.
+            let validBeforeSlot = currentSlot + fromInteger (truncate graceTime `max` 10)
+            lift . finalizeTx wallet ctx spendableUTxO lookupUTxO $
+              depositTx (networkId ctx) headId commitBlueprintTx validBeforeSlot deadline amount
     , -- Submit a cardano transaction to the cardano-node using the
       -- LocalTxSubmission protocol.
       submitTx
@@ -228,6 +232,15 @@ rejectLowDeposits pparams utxo amount = do
     [] -> pure ()
     (e : _) -> Left e
 
+checkAmount :: UTxO.UTxO -> Maybe Coin -> Either (PostTxError Tx) ()
+checkAmount utxo amount =
+  case amount of
+    Nothing -> pure ()
+    Just amt -> do
+      let totalLovelace = UTxO.totalLovelace utxo
+      when (totalLovelace < amt) $
+        Left (AmountTooLow{providedValue = amt, totalUTxOValue = totalLovelace} :: PostTxError Tx)
+
 -- | Balance and sign the given partial transaction.
 finalizeTx ::
   MonadThrow m =>

hydra-node/test/Hydra/API/HTTPServerSpec.hs

@@ -31,7 +31,7 @@ import Hydra.Cardano.Api (
   serialiseToTextEnvelope,
  )
 import Hydra.Chain (Chain (draftCommitTx), PostTxError (..), draftDepositTx)
-import Hydra.Chain.Direct.Handlers (rejectLowDeposits)
+import Hydra.Chain.Direct.Handlers (checkAmount, rejectLowDeposits)
 import Hydra.HeadLogic.State (ClosedState (..), HeadState (..), SeenSnapshot (..))
 import Hydra.HeadLogicSpec (inIdleState)
 import Hydra.JSONSchema (SchemaSelector, prop_validateJSONSchema, validateJSON, withJsonSpecifications)
@@ -535,6 +535,16 @@ apiServerSpec = do
                   & counterexample ("Minimum value: " <> show minimumValue <> " Provided value: " <> show providedValue)
             _ -> property True
 
+      prop "reject partial deposits with less ADA then in the UTxO" $ \amt ->
+        forAll (genUTxOAdaOnlyOfSize 1) $ \(utxo :: UTxO.UTxO) -> do
+          let result = checkAmount utxo (Just amt)
+          case result of
+            Left AmountTooLow{providedValue, totalUTxOValue} ->
+              property $
+                providedValue < totalUTxOValue
+                  & counterexample ("Total UTxO value: " <> show totalUTxOValue <> " Provided value: " <> show providedValue)
+            _ -> property True
+
       prop "handles PostTxErrors accordingly" $ \request postTxError -> do
         let coverage = case postTxError of
               CommittedTooMuchADAForMainnet{} -> cover 1 True "CommittedTooMuchADAForMainnet"

hydra-tx/test/Hydra/Tx/Contract/Deposit.hs

@@ -30,6 +30,7 @@ genHealthyDepositTx = do
           (mkSimpleBlueprintTx toDeposit)
           slot
           healthyDeadline
+          Nothing
   pure (tx, toDeposit)
  where
   slot = chooseEnum (0, healthyDeadlineSlot) `generateWith` 42