Return faucet funds

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Hydra.Cluster.Faucet where
 
@@ -9,9 +10,14 @@ import Hydra.Prelude
 import qualified Cardano.Api.UTxO as UTxO
 import CardanoClient (
   QueryPoint (QueryTip),
+  SubmitTransactionException,
+  awaitTransaction,
   buildAddress,
+  buildTransaction,
   queryUTxO,
+  queryUTxOFor,
   sign,
+  submitTransaction,
   waitForPayment,
  )
 import CardanoNode (RunningNode (..))
@@ -20,18 +26,13 @@ import Control.Monad.Class.MonadThrow (Handler (Handler), catches)
 import Control.Tracer (Tracer, traceWith)
 import qualified Data.Map as Map
 import GHC.IO.Exception (IOErrorType (ResourceExhausted), IOException (ioe_type))
-import Hydra.Chain.CardanoClient (
-  SubmitTransactionException,
-  buildTransaction,
-  queryUTxOFor,
-  submitTransaction,
- )
 import Hydra.Chain.Direct.ScriptRegistry (
   publishHydraScripts,
  )
 import Hydra.Chain.Direct.Util (isMarkedOutput, markerDatumHash)
-import Hydra.Cluster.Fixture (Actor (Faucet))
+import Hydra.Cluster.Fixture (Actor (Faucet), actorName)
 import Hydra.Cluster.Util (keysFor)
+import Hydra.Ledger (balance)
 import Hydra.Ledger.Cardano ()
 
 data Marked = Fuel | Normal
@@ -43,8 +44,9 @@ data FaucetException
 
 instance Exception FaucetException
 
-newtype FaucetLog
+data FaucetLog
   = TraceResourceExhaustedHandled Text
+  | ReturnedFunds {actor :: String, returnAmount :: Lovelace}
   deriving stock (Eq, Show, Generic)
   deriving anyclass (ToJSON, FromJSON)
 
@@ -62,28 +64,9 @@ seedFromFaucet ::
   IO UTxO
 seedFromFaucet RunningNode{networkId, nodeSocket} receivingVerificationKey lovelace marked tracer = do
   (faucetVk, faucetSk) <- keysFor Faucet
-  retryOnExceptions $ submitSeedTx faucetVk faucetSk
+  retryOnExceptions tracer $ submitSeedTx faucetVk faucetSk
   waitForPayment networkId nodeSocket lovelace receivingAddress
  where
-  isResourceExhausted ex = case ioe_type ex of
-    ResourceExhausted -> True
-    _ -> False
-
-  retryOnExceptions action =
-    action
-      `catches` [ Handler $ \(_ :: SubmitTransactionException) -> do
-                    threadDelay 1
-                    retryOnExceptions action
-                , Handler $ \(ex :: IOException) -> do
-                    unless (isResourceExhausted ex) $
-                      throwIO ex
-                    traceWith tracer $
-                      TraceResourceExhaustedHandled $
-                        "Expected exception raised from seedFromFaucet: " <> show ex
-                    threadDelay 1
-                    retryOnExceptions action
-                ]
-
   submitSeedTx faucetVk faucetSk = do
     faucetUTxO <- findUTxO faucetVk
     let changeAddress = ShelleyAddressInEra (buildAddress faucetVk networkId)
@@ -126,6 +109,73 @@ seedFromFaucet_ ::
 seedFromFaucet_ node vk ll marked tracer =
   void $ seedFromFaucet node vk ll marked tracer
 
+-- | Return the remaining funds to the faucet
+returnFundsToFaucet ::
+  Tracer IO FaucetLog ->
+  RunningNode ->
+  Actor ->
+  IO ()
+returnFundsToFaucet tracer node@RunningNode{networkId, nodeSocket} sender = do
+  (faucetVk, _) <- keysFor Faucet
+  let faucetAddress = mkVkAddress networkId faucetVk
+
+  (senderVk, senderSk) <- keysFor sender
+  utxo <- queryUTxOFor networkId nodeSocket QueryTip senderVk
+
+  retryOnExceptions tracer $ do
+    let allLovelace = selectLovelace $ balance @Tx utxo
+    -- XXX: Using a hard-coded high-enough value to satisfy the min utxo value.
+    -- NOTE: We use the faucet address as the change deliberately here.
+    fee <- calculateTxFee node senderSk utxo faucetAddress 1_000_000
+    let returnBalance = allLovelace - fee
+    tx <- sign senderSk <$> buildTxBody utxo faucetAddress returnBalance
+    submitTransaction networkId nodeSocket tx
+    void $ awaitTransaction networkId nodeSocket tx
+    traceWith tracer $ ReturnedFunds{actor = actorName sender, returnAmount = returnBalance}
+ where
+  buildTxBody utxo faucetAddress lovelace =
+    let theOutput = TxOut faucetAddress (lovelaceToValue lovelace) TxOutDatumNone ReferenceScriptNone
+     in buildTransaction networkId nodeSocket faucetAddress utxo [] [theOutput] >>= \case
+          Left e -> throwIO $ FaucetFailedToBuildTx{reason = e}
+          Right body -> pure body
+
+-- | Build and sign tx and return the calculated fee.
+-- - Signing key should be the key of a sender
+-- - Address is used as a change address.
+calculateTxFee
+  :: RunningNode
+  -> SigningKey PaymentKey
+  -> UTxO
+  -> AddressInEra
+  -> Lovelace
+  -> IO Lovelace
+calculateTxFee RunningNode{networkId, nodeSocket} secretKey utxo addr lovelace =
+  let theOutput = TxOut addr (lovelaceToValue lovelace) TxOutDatumNone ReferenceScriptNone
+   in buildTransaction networkId nodeSocket addr utxo [] [theOutput] >>= \case
+        Left e -> throwIO $ FaucetFailedToBuildTx{reason = e}
+        Right body -> pure $ txFee' (sign secretKey body)
+
+-- | Try to submit tx and retry when some caught exception/s take place.
+retryOnExceptions :: (MonadCatch m, MonadDelay m) => Tracer m FaucetLog -> m () -> m ()
+retryOnExceptions tracer action =
+  action
+    `catches` [ Handler $ \(_ :: SubmitTransactionException) -> do
+                  threadDelay 1
+                  retryOnExceptions tracer action
+              , Handler $ \(ex :: IOException) -> do
+                  unless (isResourceExhausted ex) $
+                    throwIO ex
+                  traceWith tracer $
+                    TraceResourceExhaustedHandled $
+                      "Expected exception raised from seedFromFaucet: " <> show ex
+                  threadDelay 1
+                  retryOnExceptions tracer action
+              ]
+ where
+  isResourceExhausted ex = case ioe_type ex of
+    ResourceExhausted -> True
+    _other -> False
+
 -- | Publish current Hydra scripts as scripts outputs for later referencing them.
 --
 -- The key of the given Actor is used to pay for fees in required transactions,

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

@@ -15,6 +15,7 @@ import qualified Data.Set as Set
 import Hydra.Cardano.Api (Lovelace, TxId, selectLovelace)
 import Hydra.Chain (HeadId)
 import Hydra.Cluster.Faucet (Marked (Fuel), queryMarkedUTxO, seedFromFaucet, seedFromFaucet_)
+import qualified Hydra.Cluster.Faucet as Faucet
 import Hydra.Cluster.Fixture (Actor (..), actorName, alice, aliceSk, aliceVk, bob, bobSk, bobVk)
 import Hydra.Cluster.Util (chainConfigFor, keysFor)
 import Hydra.ContestationPeriod (ContestationPeriod (UnsafeContestationPeriod))
@@ -94,37 +95,38 @@ singlePartyHeadFullLifeCycle ::
   RunningNode ->
   TxId ->
   IO ()
-singlePartyHeadFullLifeCycle tracer workDir node@RunningNode{networkId} hydraScriptsTxId = do
-  refuelIfNeeded tracer node Alice 100_000_000
-  -- Start hydra-node on chain tip
-  tip <- queryTip networkId nodeSocket
-  let contestationPeriod = UnsafeContestationPeriod 100
-  aliceChainConfig <-
-    chainConfigFor Alice workDir nodeSocket [] contestationPeriod
-      <&> \config -> config{networkId, startChainFrom = Just tip}
-  withHydraNode tracer aliceChainConfig workDir 1 aliceSk [] [1] hydraScriptsTxId $ \n1 -> do
-    -- Initialize & open head
-    send n1 $ input "Init" []
-    headId <- waitMatch 600 n1 $ headIsInitializingWith (Set.fromList [alice])
-    -- Commit nothing for now
-    send n1 $ input "Commit" ["utxo" .= object mempty]
-    waitFor tracer 600 [n1] $
-      output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId]
-    -- Close head
-    send n1 $ input "Close" []
-    deadline <- waitMatch 600 n1 $ \v -> do
-      guard $ v ^? key "tag" == Just "HeadIsClosed"
-      guard $ v ^? key "headId" == Just (toJSON headId)
-      v ^? key "contestationDeadline" . _JSON
-    -- Expect to see ReadyToFanout within 600 seconds after deadline.
-    -- XXX: We still would like to have a network-specific time here
-    remainingTime <- diffUTCTime deadline <$> getCurrentTime
-    waitFor tracer (truncate $ remainingTime + 60) [n1] $
-      output "ReadyToFanout" ["headId" .= headId]
-    send n1 $ input "Fanout" []
-    waitFor tracer 600 [n1] $
-      output "HeadIsFinalized" ["utxo" .= object mempty, "headId" .= headId]
-  traceRemainingFunds Alice
+singlePartyHeadFullLifeCycle tracer workDir node@RunningNode{networkId} hydraScriptsTxId =
+  (`finally` returnFundsToFaucet tracer node Alice) $ do
+    refuelIfNeeded tracer node Alice 100_000_000
+    -- Start hydra-node on chain tip
+    tip <- queryTip networkId nodeSocket
+    let contestationPeriod = UnsafeContestationPeriod 100
+    aliceChainConfig <-
+      chainConfigFor Alice workDir nodeSocket [] contestationPeriod
+        <&> \config -> config{networkId, startChainFrom = Just tip}
+    withHydraNode tracer aliceChainConfig workDir 1 aliceSk [] [1] hydraScriptsTxId $ \n1 -> do
+      -- Initialize & open head
+      send n1 $ input "Init" []
+      headId <- waitMatch 600 n1 $ headIsInitializingWith (Set.fromList [alice])
+      -- Commit nothing for now
+      send n1 $ input "Commit" ["utxo" .= object mempty]
+      waitFor tracer 600 [n1] $
+        output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId]
+      -- Close head
+      send n1 $ input "Close" []
+      deadline <- waitMatch 600 n1 $ \v -> do
+        guard $ v ^? key "tag" == Just "HeadIsClosed"
+        guard $ v ^? key "headId" == Just (toJSON headId)
+        v ^? key "contestationDeadline" . _JSON
+      -- Expect to see ReadyToFanout within 600 seconds after deadline.
+      -- XXX: We still would like to have a network-specific time here
+      remainingTime <- diffUTCTime deadline <$> getCurrentTime
+      waitFor tracer (truncate $ remainingTime + 60) [n1] $
+        output "ReadyToFanout" ["headId" .= headId]
+      send n1 $ input "Fanout" []
+      waitFor tracer 600 [n1] $
+        output "HeadIsFinalized" ["utxo" .= object mempty, "headId" .= headId]
+    traceRemainingFunds Alice
  where
   RunningNode{nodeSocket} = node
 
@@ -188,6 +190,15 @@ refuelIfNeeded tracer node actor amount = do
     utxo <- seedFromFaucet node actorVk amount Fuel (contramap FromFaucet tracer)
     traceWith tracer $ RefueledFunds{actor = actorName actor, refuelingAmount = amount, fuelUTxO = utxo}
 
+-- | Return the remaining funds to the faucet
+returnFundsToFaucet ::
+  Tracer IO EndToEndLog ->
+  RunningNode ->
+  Actor ->
+  IO ()
+returnFundsToFaucet tracer =
+  Faucet.returnFundsToFaucet (contramap FromFaucet tracer)
+
 headIsInitializingWith :: Set Party -> Value -> Maybe HeadId
 headIsInitializingWith expectedParties v = do
   guard $ v ^? key "tag" == Just "HeadIsInitializing"

hydra-cluster/test/Test/Hydra/Cluster/FaucetSpec.hs

@@ -3,16 +3,21 @@ module Test.Hydra.Cluster.FaucetSpec where
 import Hydra.Prelude
 import Test.Hydra.Prelude
 
-import CardanoNode (withCardanoNodeDevnet)
+import CardanoNode (RunningNode (..), withCardanoNodeDevnet)
 import Control.Concurrent.Async (replicateConcurrently_)
-import Hydra.Cluster.Faucet (Marked (Normal), seedFromFaucet_)
+import Hydra.Cardano.Api (AssetId (AdaAssetId), txOutValue)
+import Hydra.Cardano.Api.Prelude (selectAsset)
+import Hydra.Chain.CardanoClient (QueryPoint (..), queryUTxOFor)
+import Hydra.Cluster.Faucet (Marked (Normal), returnFundsToFaucet, seedFromFaucet, seedFromFaucet_)
+import Hydra.Cluster.Fixture (Actor (..))
+import Hydra.Cluster.Util (keysFor)
 import Hydra.Ledger.Cardano (genVerificationKey)
 import Hydra.Logging (showLogsOnFailure)
 import HydraNode (EndToEndLog (FromCardanoNode, FromFaucet))
-import Test.QuickCheck (generate)
+import Test.QuickCheck (elements, generate)
 
 spec :: Spec
-spec =
+spec = do
   describe "seedFromFaucet" $
     it "should work concurrently" $
       showLogsOnFailure $ \tracer ->
@@ -22,3 +27,29 @@ spec =
               replicateConcurrently_ 10 $ do
                 vk <- generate genVerificationKey
                 seedFromFaucet_ node vk 1_000_000 Normal (contramap FromFaucet tracer)
+
+  describe "returnFundsToFaucet" $
+    it "seedFromFaucet and returnFundsToFaucet work together" $ do
+      showLogsOnFailure $ \tracer ->
+        withTempDir "end-to-end-cardano-node" $ \tmpDir ->
+          withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \node@RunningNode{networkId, nodeSocket} -> do
+            let faucetTracer = contramap FromFaucet tracer
+            actor <- generate $ elements [Alice, Bob, Carol]
+            (vk, _) <- keysFor actor
+            (faucetVk, _) <- keysFor Faucet
+            initialFaucetFunds <- queryUTxOFor networkId nodeSocket QueryTip faucetVk
+            seeded <- seedFromFaucet node vk 100_000_000 Normal faucetTracer
+            returnFundsToFaucet faucetTracer node actor
+            remaining <- queryUTxOFor networkId nodeSocket QueryTip vk
+            finalFaucetFunds <- queryUTxOFor networkId nodeSocket QueryTip faucetVk
+            foldMap txOutValue remaining `shouldBe` mempty
+
+            -- check the faucet has one utxo extra in the end
+            length seeded `shouldBe` length remaining + 1
+
+            let initialFaucetValue = selectAsset (foldMap txOutValue initialFaucetFunds) AdaAssetId
+            let finalFaucetValue = selectAsset (foldMap txOutValue finalFaucetFunds) AdaAssetId
+            let difference = initialFaucetValue - finalFaucetValue
+            -- difference between starting faucet amount and final one should
+            -- just be the amount of paid fees
+            difference `shouldSatisfy` (< 340_000)