Incremental decommit changes

CHANGELOG.md

@@ -10,6 +10,9 @@ changes.
 
 ## [0.17.0] - UNRELEASED
 
+- Add withdrawal of UTxO from an open head via a `POST /decommit` request or
+  using dedicated client input.
+
 - Add `GET /snapshot/utxo` API endpoint to query confirmed UTxO set on demand.
   - Always responds with the last confirmed UTxO
 

hydra-cardano-api/src/Cardano/Api/UTxO.hs

@@ -88,6 +88,14 @@ render (k, TxOut _ (txOutValueToValue -> v) _ _) =
 min :: UTxO -> UTxO
 min = UTxO . uncurry Map.singleton . Map.findMin . toMap
 
+-- | Remove the right hand side from the left hand side.
+difference :: UTxO' out -> UTxO' out -> UTxO' out
+difference a b = UTxO $ Map.difference (toMap a) (toMap b)
+
+-- | Infix version of 'difference'.
+(\\) :: UTxO' out -> UTxO' out -> UTxO' out
+a \\ b = difference a b
+
 -- * Type Conversions
 
 -- | Transforms a UTxO containing tx outs from any era into Babbage era.

hydra-chain-observer/src/Hydra/ChainObserver.hs

@@ -92,6 +92,7 @@ data ChainObserverLog
   | HeadInitTx {headId :: HeadId}
   | HeadCommitTx {headId :: HeadId}
   | HeadCollectComTx {headId :: HeadId}
+  | HeadDecrementTx {headId :: HeadId}
   | HeadCloseTx {headId :: HeadId}
   | HeadFanoutTx {headId :: HeadId}
   | HeadAbortTx {headId :: HeadId}
@@ -205,6 +206,7 @@ chainSyncClient tracer networkId startingPoint observerHandler =
     OnInitTx{headId} -> HeadInitTx{headId}
     OnCommitTx{headId} -> HeadCommitTx{headId}
     OnCollectComTx{headId} -> HeadCollectComTx{headId}
+    OnDecrementTx{headId} -> HeadDecrementTx{headId}
     OnCloseTx{headId} -> HeadCloseTx{headId}
     OnFanoutTx{headId} -> HeadFanoutTx{headId}
     OnAbortTx{headId} -> HeadAbortTx{headId}

hydra-chain-observer/test/Hydra/ChainObserverSpec.hs

@@ -25,6 +25,7 @@ spec =
                     Just (Init{}) -> transition === Transition.Init
                     Just (Commit{}) -> transition === Transition.Commit
                     Just (CollectCom{}) -> transition === Transition.Collect
+                    Just (Decrement{}) -> transition === Transition.Decrement
                     Just (Abort{}) -> transition === Transition.Abort
                     Just (Close{}) -> transition === Transition.Close
                     Just (Contest{}) -> transition === Transition.Contest

hydra-cluster/src/CardanoClient.hs

@@ -104,14 +104,17 @@ waitForPayments networkId socket amount addr =
   selectPayments (UTxO utxo) =
     Map.filter ((== amount) . selectLovelace . txOutValue) utxo
 
+-- | Wait for transaction outputs with matching lovelace value and addresses of
+-- the whole given UTxO
 waitForUTxO ::
-  NetworkId ->
-  SocketPath ->
+  RunningNode ->
   UTxO ->
   IO ()
-waitForUTxO networkId nodeSocket utxo =
+waitForUTxO node utxo =
   forM_ (snd <$> UTxO.pairs utxo) forEachUTxO
  where
+  RunningNode{networkId, nodeSocket} = node
+
   forEachUTxO :: TxOut CtxUTxO -> IO ()
   forEachUTxO = \case
     TxOut (ShelleyAddressInEra addr@ShelleyAddress{}) value _ _ -> do

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

@@ -14,6 +14,7 @@ import CardanoClient (
   queryTip,
   queryUTxOFor,
   submitTx,
+  waitForUTxO,
  )
 import CardanoNode (NodeLog)
 import Control.Concurrent.Async (mapConcurrently_)
@@ -24,9 +25,44 @@ import Data.Aeson.Lens (key, values, _JSON)
 import Data.Aeson.Types (parseMaybe)
 import Data.ByteString (isInfixOf)
 import Data.ByteString qualified as B
+import Data.List qualified as List
 import Data.Set qualified as Set
-import Hydra.API.HTTPServer (DraftCommitTxResponse (..), TransactionSubmitted (..))
-import Hydra.Cardano.Api (Coin (..), File (File), Key (SigningKey), PaymentKey, Tx, TxId, UTxO, getVerificationKey, isVkTxOut, lovelaceToValue, makeSignedTransaction, mkVkAddress, selectLovelace, signTx, txOutAddress, txOutValue, writeFileTextEnvelope, pattern ReferenceScriptNone, pattern TxOut, pattern TxOutDatumNone)
+import Hydra.API.HTTPServer (
+  DraftCommitTxRequest (..),
+  DraftCommitTxResponse (..),
+  ScriptInfo (..),
+  TransactionSubmitted (..),
+  TxOutWithWitness (..),
+ )
+import Hydra.Cardano.Api (
+  Coin (..),
+  File (File),
+  Key (SigningKey),
+  PaymentKey,
+  PlutusScriptV2,
+  Tx,
+  TxId,
+  UTxO,
+  fromPlutusScript,
+  getVerificationKey,
+  isVkTxOut,
+  lovelaceToValue,
+  makeSignedTransaction,
+  mkScriptAddress,
+  mkTxOutDatumHash,
+  mkTxOutDatumInline,
+  mkVkAddress,
+  selectLovelace,
+  signTx,
+  toScriptData,
+  txOutAddress,
+  txOutValue,
+  utxoFromTx,
+  writeFileTextEnvelope,
+  pattern ReferenceScriptNone,
+  pattern TxOut,
+  pattern TxOutDatumNone,
+ )
 import Hydra.Chain.Direct.Tx (verificationKeyToOnChainId)
 import Hydra.Cluster.Faucet (FaucetLog, seedFromFaucet, seedFromFaucet_)
 import Hydra.Cluster.Faucet qualified as Faucet
@@ -39,7 +75,7 @@ import Hydra.HeadId (HeadId)
 import Hydra.Ledger (IsTx (balance), txId)
 import Hydra.Ledger.Cardano (genKeyPair, mkSimpleTx)
 import Hydra.Logging (Tracer, traceWith)
-import Hydra.Options (networkId, startChainFrom)
+import Hydra.Options (ChainConfig (Direct), networkId, startChainFrom)
 import Hydra.Party (Party)
 import HydraNode (
   HydraClient (..),
@@ -70,9 +106,11 @@ import Network.HTTP.Req (
   runReq,
   (/:),
  )
+import Network.HTTP.Simple (httpLbs, setRequestBodyJSON)
+import PlutusLedgerApi.Test.Examples qualified as Plutus
 import System.Directory (removeDirectoryRecursive)
 import System.FilePath ((</>))
-import Test.QuickCheck (choose, generate)
+import Test.QuickCheck (choose, generate, oneof)
 
 data EndToEndLog
   = ClusterOptions {options :: Options}
@@ -566,6 +604,65 @@ initWithWrongKeys workDir tracer node@RunningNode{nodeSocket} hydraScriptsTxId =
 
       participants `shouldMatchList` expectedParticipants
 
+-- | Open a a single participant head with some UTxO and decommit parts of it.
+canDecommit :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> TxId -> IO ()
+canDecommit tracer workDir node hydraScriptsTxId =
+  (`finally` returnFundsToFaucet tracer node Alice) $ do
+    refuelIfNeeded tracer node Alice 30_000_000
+    -- Start hydra-node on chain tip
+    tip <- queryTip networkId nodeSocket
+    let contestationPeriod = UnsafeContestationPeriod 100
+    aliceChainConfig <-
+      chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [] contestationPeriod
+        <&> \case
+          Direct cfg -> Direct cfg{networkId, startChainFrom = Just tip}
+          _ -> error "Should not be in offline mode"
+    withHydraNode hydraTracer aliceChainConfig workDir 1 aliceSk [] [1] $ \n1@HydraClient{hydraNodeId} -> do
+      -- Initialize & open head
+      send n1 $ input "Init" []
+      headId <- waitMatch 10 n1 $ headIsInitializingWith (Set.fromList [alice])
+
+      (walletVk, walletSk) <- generate genKeyPair
+
+      commitUTxO <- seedFromFaucet node walletVk 10_000_000 (contramap FromFaucet tracer)
+
+      requestCommitTx n1 commitUTxO <&> signTx walletSk >>= submitTx node
+
+      waitFor hydraTracer 10 [n1] $
+        output "HeadIsOpen" ["utxo" .= commitUTxO, "headId" .= headId]
+
+      decommitTx <-
+        either (failure . show) pure $
+          mkSimpleTx
+            (List.head $ UTxO.pairs commitUTxO)
+            (mkVkAddress networkId walletVk, lovelaceToValue 2_000_000)
+            walletSk
+
+      let decommitClientInput = send n1 $ input "Decommit" ["decommitTx" .= decommitTx]
+
+      let callDecommitHttpEndpoint =
+            void $
+              L.parseUrlThrow ("POST http://127.0.0.1:" <> show (4000 + hydraNodeId) <> "/decommit")
+                <&> setRequestBodyJSON decommitTx
+                  >>= httpLbs
+
+      join . generate $ oneof [pure decommitClientInput, pure callDecommitHttpEndpoint]
+
+      let decommitUTxO = utxoFromTx decommitTx
+      waitFor hydraTracer 10 [n1] $
+        output "DecommitRequested" ["headId" .= headId, "utxoToDecommit" .= decommitUTxO]
+      waitFor hydraTracer 10 [n1] $
+        output "DecommitApproved" ["headId" .= headId, "utxoToDecommit" .= decommitUTxO]
+
+      failAfter 10 $ waitForUTxO node decommitUTxO
+
+      waitFor hydraTracer 10 [n1] $
+        output "DecommitFinalized" ["headId" .= headId]
+ where
+  hydraTracer = contramap FromHydraNode tracer
+
+  RunningNode{networkId, nodeSocket} = node
+
 -- * L2 scenarios
 
 -- | Finds UTxO owned by given key in the head and creates transactions

hydra-cluster/test/Test/ChainObserverSpec.hs

@@ -9,22 +9,26 @@ module Test.ChainObserverSpec where
 import Hydra.Prelude
 import Test.Hydra.Prelude
 
+import Cardano.Api.UTxO qualified as UTxO
 import CardanoClient (RunningNode (..), submitTx)
 import CardanoNode (NodeLog, withCardanoNodeDevnet)
 import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO)
 import Control.Lens ((^?))
 import Data.Aeson as Aeson
 import Data.Aeson.Lens (key, _String)
 import Data.ByteString (hGetLine)
+import Data.List qualified as List
 import Data.Text qualified as T
-import Hydra.Cardano.Api (NetworkId (..), NetworkMagic (..), unFile)
-import Hydra.Cluster.Faucet (FaucetLog, publishHydraScriptsAs, seedFromFaucet_)
+import Hydra.Cardano.Api (NetworkId (..), NetworkMagic (..), lovelaceToValue, mkVkAddress, signTx, unFile)
+import Hydra.Cluster.Faucet (FaucetLog, publishHydraScriptsAs, seedFromFaucet, seedFromFaucet_)
 import Hydra.Cluster.Fixture (Actor (..), aliceSk, cperiod)
 import Hydra.Cluster.Util (chainConfigFor, keysFor)
+import Hydra.Ledger.Cardano (genKeyPair, mkSimpleTx)
 import Hydra.Logging (showLogsOnFailure)
 import HydraNode (HydraNodeLog, input, output, requestCommitTx, send, waitFor, waitMatch, withHydraNode)
 import System.IO.Error (isEOFError, isIllegalOperation)
 import System.Process (CreateProcess (std_out), StdStream (..), proc, withCreateProcess)
+import Test.QuickCheck (generate)
 
 spec :: Spec
 spec = do
@@ -33,16 +37,20 @@ spec = do
       showLogsOnFailure "ChainObserverSpec" $ \tracer -> do
         withTempDir "hydra-cluster" $ \tmpDir -> do
           -- Start a cardano devnet
-          withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket} -> do
+          withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{networkId, nodeSocket} -> do
             -- Prepare a hydra-node
             let hydraTracer = contramap FromHydraNode tracer
             hydraScriptsTxId <- publishHydraScriptsAs cardanoNode Faucet
-            (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice
+            (aliceCardanoVk, _) <- keysFor Alice
             aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod
             withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] $ \hydraNode -> do
               withChainObserver cardanoNode $ \observer -> do
                 seedFromFaucet_ cardanoNode aliceCardanoVk 100_000_000 (contramap FromFaucet tracer)
 
+                (walletVk, walletSk) <- generate genKeyPair
+
+                commitUTxO <- seedFromFaucet cardanoNode walletVk 10_000_000 (contramap FromFaucet tracer)
+
                 send hydraNode $ input "Init" []
 
                 headId <- waitMatch 5 hydraNode $ \v -> do
@@ -51,13 +59,32 @@ spec = do
 
                 chainObserverSees observer "HeadInitTx" headId
 
-                requestCommitTx hydraNode mempty >>= submitTx cardanoNode
+                commitTx <- requestCommitTx hydraNode commitUTxO
+
+                pure (signTx walletSk commitTx) >>= submitTx cardanoNode
+
                 waitFor hydraTracer 5 [hydraNode] $
-                  output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId]
+                  output "HeadIsOpen" ["utxo" .= commitUTxO, "headId" .= headId]
 
                 chainObserverSees observer "HeadCommitTx" headId
                 chainObserverSees observer "HeadCollectComTx" headId
 
+                let walletAddress = mkVkAddress networkId walletVk
+
+                decommitTx <-
+                  either (failure . show) pure $
+                    mkSimpleTx
+                      (List.head $ UTxO.pairs commitUTxO)
+                      (walletAddress, lovelaceToValue 2_000_000)
+                      walletSk
+
+                send hydraNode $ input "Decommit" ["decommitTx" .= decommitTx]
+
+                chainObserverSees observer "HeadDecrementTx" headId
+
+                waitFor hydraTracer 50 [hydraNode] $
+                  output "DecommitFinalized" ["headId" .= headId]
+
                 send hydraNode $ input "Close" []
 
                 chainObserverSees observer "HeadCloseTx" headId

hydra-cluster/test/Test/DirectChainSpec.hs

@@ -281,7 +281,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do
 
   it "can open, close & fanout a Head" $ \tracer -> do
     withTempDir "hydra-cluster" $ \tmp -> do
-      withCardanoNodeDevnet (contramap FromNode tracer) tmp $ \node@RunningNode{nodeSocket, networkId} -> do
+      withCardanoNodeDevnet (contramap FromNode tracer) tmp $ \node@RunningNode{nodeSocket} -> do
         hydraScriptsTxId <- publishHydraScriptsAs node Faucet
         -- Alice setup
         (aliceCardanoVk, _) <- keysFor Alice
@@ -309,6 +309,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do
                     , number = 1
                     , utxo = someUTxO
                     , confirmed = []
+                    , utxoToDecommit = Nothing
                     }
 
             postTx . CloseTx headId headParameters $
@@ -339,7 +340,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do
                 }
             aliceChain `observesInTime` OnFanoutTx headId
             failAfter 5 $
-              waitForUTxO networkId nodeSocket someUTxO
+              waitForUTxO node someUTxO
 
   it "can restart head to point in the past and replay on-chain events" $ \tracer -> do
     withTempDir "hydra-cluster" $ \tmp -> do
@@ -443,6 +444,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do
                     , number = 1
                     , utxo = someUTxO
                     , confirmed = []
+                    , utxoToDecommit = Nothing
                     }
             postTx . ContestTx headId headParameters $
               ConfirmedSnapshot
@@ -458,6 +460,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do
                     , number = 2
                     , utxo = someUTxO
                     , confirmed = []
+                    , utxoToDecommit = Nothing
                     }
             let contestAgain =
                   postTx . ContestTx headId headParameters $