Change Decommit server outputs to be more in-line with TxValid/TxInvalid

This resolves a TODO (REVIEW) comment

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

@@ -77,6 +77,7 @@ import HydraNode (
   getSnapshotUTxO,
   input,
   output,
+  postDecommit,
   requestCommitTx,
   send,
   waitFor,
@@ -103,7 +104,7 @@ import Network.HTTP.Req (
 import Network.HTTP.Simple (httpLbs, setRequestBodyJSON)
 import System.Directory (removeDirectoryRecursive)
 import System.FilePath ((</>))
-import Test.QuickCheck (choose, generate, oneof)
+import Test.QuickCheck (choose, elements, generate)
 
 data EndToEndLog
   = ClusterOptions {options :: Options}
@@ -610,7 +611,7 @@ canDecommit tracer workDir node hydraScriptsTxId =
         <&> \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
+    withHydraNode hydraTracer aliceChainConfig workDir 1 aliceSk [] [1] $ \n1 -> do
       -- Initialize & open head
       send n1 $ input "Init" []
       headId <- waitMatch 10 n1 $ headIsInitializingWith (Set.fromList [alice])
@@ -648,20 +649,14 @@ canDecommit tracer workDir node hydraScriptsTxId =
           buildTransaction networkId nodeSocket aliceAddress commitUTxO2 (fst <$> UTxO.pairs commitUTxO2) decommitOutput >>= \case
             Left e -> failure $ show e
             Right body2 -> do
-              let callDecommitHttpEndpoint tx =
-                    void $
-                      L.parseUrlThrow ("POST http://127.0.0.1:" <> show (4000 + hydraNodeId) <> "/decommit")
-                        <&> setRequestBodyJSON tx
-                          >>= httpLbs
-
               -- Send unsigned decommit tx and expect failure
-              expectFailureOnUnsignedDecommitTx n1 headId body1 callDecommitHttpEndpoint
+              expectFailureOnUnsignedDecommitTx n1 headId body1
 
               -- Sign and re-send the decommit tx
-              expectSuccessOnSignedDecommitTx n1 headId walletSk body1 callDecommitHttpEndpoint
+              expectSuccessOnSignedDecommitTx n1 headId walletSk body1
 
               -- Decommit the second utxo
-              expectSuccessOnSignedDecommitTx n1 headId walletSk body2 callDecommitHttpEndpoint
+              expectSuccessOnSignedDecommitTx n1 headId walletSk body2
 
               -- Close and Fanout put whatever is left in the Head back to L1
               closeAndFanout headId n1 headUTxO (headAmount + (2 * decommitAmount)) walletVk
@@ -689,29 +684,36 @@ canDecommit tracer workDir node hydraScriptsTxId =
     let walletBalance = sum $ selectLovelace . txOutValue . snd <$> UTxO.pairs walletUTxO
     walletBalance `shouldBe` expectedFinalBalance
 
-  expectSuccessOnSignedDecommitTx n headId sk body httpCall = do
+  expectSuccessOnSignedDecommitTx n headId sk body = do
     let signedDecommitTx = makeSignedTransaction [makeShelleyKeyWitness body (WitnessPaymentKey sk)] body
-    let signedDecommitClientInput = send n $ input "Decommit" ["decommitTx" .= signedDecommitTx]
-    join . generate $ oneof [pure signedDecommitClientInput, pure $ httpCall signedDecommitTx]
+    join . generate $
+      elements
+        [ send n $ input "Decommit" ["decommitTx" .= signedDecommitTx]
+        , postDecommit n signedDecommitTx
+        ]
     let decommitUTxO = utxoFromTx signedDecommitTx
+        decommitTxId = txId signedDecommitTx
 
     waitFor hydraTracer 10 [n] $
-      output "DecommitRequested" ["headId" .= headId, "utxoToDecommit" .= decommitUTxO]
+      output "DecommitRequested" ["headId" .= headId, "decommitTx" .= signedDecommitTx, "utxoToDecommit" .= decommitUTxO]
     waitFor hydraTracer 10 [n] $
-      output "DecommitApproved" ["headId" .= headId, "utxoToDecommit" .= decommitUTxO]
+      output "DecommitApproved" ["headId" .= headId, "decommitTxId" .= decommitTxId, "utxoToDecommit" .= decommitUTxO]
     failAfter 10 $ waitForUTxO node decommitUTxO
     waitFor hydraTracer 10 [n] $
-      output "DecommitFinalized" ["headId" .= headId]
+      output "DecommitFinalized" ["headId" .= headId, "decommitTxId" .= decommitTxId]
 
-  expectFailureOnUnsignedDecommitTx n headId body httpCall = do
+  expectFailureOnUnsignedDecommitTx n headId body = do
     let unsignedDecommitTx = makeSignedTransaction [] body
-    let unsignedDecommitClientInput = send n $ input "Decommit" ["decommitTx" .= unsignedDecommitTx]
-    join . generate $ oneof [pure unsignedDecommitClientInput, pure $ httpCall unsignedDecommitTx]
+    join . generate $
+      elements
+        [ send n $ input "Decommit" ["decommitTx" .= unsignedDecommitTx]
+        , postDecommit n unsignedDecommitTx
+        ]
 
     validationError <- waitMatch 10 n $ \v -> do
       guard $ v ^? key "headId" == Just (toJSON headId)
       guard $ v ^? key "tag" == Just (Aeson.String "DecommitInvalid")
-      guard $ v ^? key "decommitInvalidReason" . key "decommitTx" == Just (toJSON unsignedDecommitTx)
+      guard $ v ^? key "decommitTx" == Just (toJSON unsignedDecommitTx)
       v ^? key "decommitInvalidReason" . key "validationError" . key "reason" . _JSON
 
     validationError `shouldContain` "MissingVKeyWitnessesUTXOW"
@@ -803,14 +805,17 @@ canCloseWithPendingDecommit tracer workDir node hydraScriptsTxId =
 
   submitSignedDecommitTx n headId sk body httpCall = do
     let signedDecommitTx = makeSignedTransaction [makeShelleyKeyWitness body (WitnessPaymentKey sk)] body
-    let signedDecommitClientInput = send n $ input "Decommit" ["decommitTx" .= signedDecommitTx]
-    join . generate $ oneof [pure signedDecommitClientInput, pure $ httpCall signedDecommitTx]
+    join . generate $
+      elements
+        [ send n $ input "Decommit" ["decommitTx" .= signedDecommitTx]
+        , httpCall signedDecommitTx
+        ]
     let decommitUTxO = utxoFromTx signedDecommitTx
 
     waitFor hydraTracer 10 [n] $
-      output "DecommitRequested" ["headId" .= headId, "utxoToDecommit" .= decommitUTxO]
+      output "DecommitRequested" ["headId" .= headId, "decommitTx" .= signedDecommitTx, "utxoToDecommit" .= decommitUTxO]
     waitFor hydraTracer 10 [n] $
-      output "DecommitApproved" ["headId" .= headId, "utxoToDecommit" .= decommitUTxO]
+      output "DecommitApproved" ["headId" .= headId, "decommitTxId" .= txId signedDecommitTx, "utxoToDecommit" .= decommitUTxO]
 
   hydraTracer = contramap FromHydraNode tracer
 
@@ -837,7 +842,7 @@ canFanoutWithDecommitRecorded tracer workDir node hydraScriptsTxId =
           Direct cfg -> Direct cfg{networkId, startChainFrom = Just tip}
           _ -> error "Should not be in offline mode"
 
-    withHydraNode hydraTracer aliceChainConfig workDir 1 aliceSk [bobVk] [1, 2] $ \n1@HydraClient{hydraNodeId} ->
+    withHydraNode hydraTracer aliceChainConfig workDir 1 aliceSk [bobVk] [1, 2] $ \n1 ->
       withHydraNode hydraTracer bobChainConfig workDir 2 bobSk [aliceVk] [1, 2] $ \n2 -> do
         -- Initialize & open head
         send n1 $ input "Init" []
@@ -865,15 +870,13 @@ canFanoutWithDecommitRecorded tracer workDir node hydraScriptsTxId =
         buildTransaction networkId nodeSocket aliceWalletAddress commitUTxO (fst <$> UTxO.pairs commitUTxO) decommitOutput >>= \case
           Left e -> failure $ show e
           Right body -> do
-            let callDecommitHttpEndpoint tx =
-                  void $
-                    L.parseUrlThrow ("POST http://127.0.0.1:" <> show (4000 + hydraNodeId) <> "/decommit")
-                      <&> setRequestBodyJSON tx
-                        >>= httpLbs
             let signedDecommitTx = makeSignedTransaction [makeShelleyKeyWitness body (WitnessPaymentKey aliceWalletSk)] body
-            let signedDecommitClientInput = send n1 $ input "Decommit" ["decommitTx" .= signedDecommitTx]
 
-            join . generate $ oneof [pure signedDecommitClientInput, pure $ callDecommitHttpEndpoint signedDecommitTx]
+            join . generate $
+              elements
+                [ send n1 $ input "Decommit" ["decommitTx" .= signedDecommitTx]
+                , postDecommit n1 signedDecommitTx
+                ]
 
             let decommitUTxO = utxoFromTx signedDecommitTx
             waitForAllMatch (10 * blockTime) [n1] $ \v -> do

hydra-cluster/src/HydraNode.hs

@@ -28,8 +28,10 @@ import Hydra.Logging (Tracer, Verbosity (..), traceWith)
 import Hydra.Network (Host (Host), NodeId (NodeId))
 import Hydra.Network qualified as Network
 import Hydra.Options (ChainConfig (..), DirectChainConfig (..), LedgerConfig (..), RunOptions (..), defaultDirectChainConfig, toArgs)
+import Network.HTTP.Conduit (parseUrlThrow)
 import Network.HTTP.Req (GET (..), HttpException, JsonResponse, NoReqBody (..), POST (..), ReqBodyJson (..), defaultHttpConfig, responseBody, runReq, (/:))
 import Network.HTTP.Req qualified as Req
+import Network.HTTP.Simple (httpLbs, setRequestBodyJSON)
 import Network.WebSockets (Connection, ConnectionException, HandshakeException, receiveData, runClient, sendClose, sendTextData)
 import System.FilePath ((<.>), (</>))
 import System.IO.Temp (withSystemTempDirectory)
@@ -181,6 +183,14 @@ requestCommitTx HydraClient{hydraNodeId} utxos =
       (Proxy :: Proxy (JsonResponse (DraftCommitTxResponse Tx)))
       (Req.port $ 4_000 + hydraNodeId)
 
+-- | Submit a decommit transaction to the hydra-node.
+postDecommit :: HydraClient -> Tx -> IO ()
+postDecommit HydraClient{hydraNodeId} decommitTx = do
+  void $
+    parseUrlThrow ("POST http://127.0.0.1:" <> show (4000 + hydraNodeId) <> "/decommit")
+      <&> setRequestBodyJSON decommitTx
+        >>= httpLbs
+
 -- | Get the latest snapshot UTxO from the hydra-node. NOTE: While we usually
 -- avoid parsing responses using the same data types as the system under test,
 -- this parses the response as a 'UTxO' type as we often need to pick it apart.

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

@@ -14,7 +14,7 @@ import Hydra.ContestationPeriod (ContestationPeriod)
 import Hydra.Crypto (MultiSignature)
 import Hydra.HeadId (HeadId)
 import Hydra.HeadLogic.State (HeadState)
-import Hydra.Ledger (IsTx, UTxOType, ValidationError)
+import Hydra.Ledger (IsTx, TxIdType, UTxOType, ValidationError)
 import Hydra.Network (Host, NodeId)
 import Hydra.OnChainId (OnChainId)
 import Hydra.Party (Party)
@@ -49,23 +49,20 @@ instance IsChainState tx => FromJSON (TimedServerOutput tx) where
     TimedServerOutput <$> parseJSON v <*> o .: "seq" <*> o .: "timestamp"
 
 data DecommitInvalidReason tx
-  = DecommitTxInvalid {confirmedUTxO :: UTxOType tx, decommitTx :: tx, validationError :: ValidationError}
-  | DecommitAlreadyInFlight {decommitTx :: tx}
+  = DecommitTxInvalid {confirmedUTxO :: UTxOType tx, validationError :: ValidationError}
+  | DecommitAlreadyInFlight {otherDecommitTxId :: TxIdType tx}
   deriving stock (Generic)
 
-deriving stock instance (Eq tx, Eq (UTxOType tx)) => Eq (DecommitInvalidReason tx)
-deriving stock instance (Show tx, Show (UTxOType tx)) => Show (DecommitInvalidReason tx)
+deriving stock instance (Eq (TxIdType tx), Eq (UTxOType tx)) => Eq (DecommitInvalidReason tx)
+deriving stock instance (Show (TxIdType tx), Show (UTxOType tx)) => Show (DecommitInvalidReason tx)
 
-instance (ToJSON tx, ToJSON (UTxOType tx)) => ToJSON (DecommitInvalidReason tx) where
+instance (ToJSON (TxIdType tx), ToJSON (UTxOType tx)) => ToJSON (DecommitInvalidReason tx) where
   toJSON = genericToJSON defaultOptions
 
-instance (FromJSON tx, FromJSON (UTxOType tx)) => FromJSON (DecommitInvalidReason tx) where
+instance (FromJSON (TxIdType tx), FromJSON (UTxOType tx)) => FromJSON (DecommitInvalidReason tx) where
   parseJSON = genericParseJSON defaultOptions
 
-instance
-  IsTx tx =>
-  Arbitrary (DecommitInvalidReason tx)
-  where
+instance IsTx tx => Arbitrary (DecommitInvalidReason tx) where
   arbitrary = genericArbitrary
 
 -- | Individual server output messages as produced by the 'Hydra.HeadLogic' in
@@ -123,10 +120,10 @@ data ServerOutput tx
       , parties :: [Party]
       , participants :: [OnChainId]
       }
-  | DecommitRequested {headId :: HeadId, utxoToDecommit :: UTxOType tx}
-  | DecommitInvalid {headId :: HeadId, decommitInvalidReason :: DecommitInvalidReason tx}
-  | DecommitApproved {headId :: HeadId, utxoToDecommit :: UTxOType tx}
-  | DecommitFinalized {headId :: HeadId}
+  | DecommitRequested {headId :: HeadId, decommitTx :: tx, utxoToDecommit :: UTxOType tx}
+  | DecommitInvalid {headId :: HeadId, decommitTx :: tx, decommitInvalidReason :: DecommitInvalidReason tx}
+  | DecommitApproved {headId :: HeadId, decommitTxId :: TxIdType tx, utxoToDecommit :: UTxOType tx}
+  | DecommitFinalized {headId :: HeadId, decommitTxId :: TxIdType tx}
   deriving stock (Generic)
 
 deriving stock instance IsChainState tx => Eq (ServerOutput tx)
@@ -183,10 +180,10 @@ instance
         <*> shrink hydraNodeVersion
     PostTxOnChainFailed p e -> PostTxOnChainFailed <$> shrink p <*> shrink e
     IgnoredHeadInitializing{} -> []
-    DecommitRequested headId u -> DecommitRequested <$> shrink headId <*> shrink u
-    DecommitInvalid headId reason -> DecommitInvalid <$> shrink headId <*> shrink reason
-    DecommitApproved headId u -> DecommitApproved <$> shrink headId <*> shrink u
-    DecommitFinalized headId -> DecommitFinalized <$> shrink headId
+    DecommitRequested headId txid u -> DecommitRequested headId txid <$> shrink u
+    DecommitInvalid{} -> []
+    DecommitApproved headId txid u -> DecommitApproved headId txid <$> shrink u
+    DecommitFinalized{} -> []
 
 -- | Whether or not to include full UTxO in server outputs.
 data WithUTxO = WithUTxO | WithoutUTxO

hydra-node/src/Hydra/HeadLogic.hs

@@ -29,6 +29,7 @@ import Data.Set ((\\))
 import Data.Set qualified as Set
 import GHC.Records (getField)
 import Hydra.API.ClientInput (ClientInput (..))
+import Hydra.API.ServerOutput (DecommitInvalidReason (..))
 import Hydra.API.ServerOutput qualified as ServerOutput
 import Hydra.Chain (
   ChainEvent (..),
@@ -501,7 +502,7 @@ onOpenNetworkReqSn env ledger st otherParty sv sn requestedTxIds mDecommitTx =
         -- Spec: require S⁻.𝑈 ◦ txω /= ⊥
         case applyTransactions ledger currentSlot confirmedUTxO [decommitTx] of
           Left (_, err) ->
-            Error $ RequireFailed $ DecommitDoesNotApply decommitTx err
+            Error $ RequireFailed $ DecommitDoesNotApply (txId decommitTx) err
           Right newConfirmedUTxO -> do
             -- Spec: ηω ← combine(outputs(txω))
             let utxoToDecommit = utxoFromTx decommitTx
@@ -654,11 +655,16 @@ onOpenNetworkAckSn Environment{party} openState otherParty snapshotSignature sn
       else outcome
 
   maybeEmitDecrementTx snapshot@Snapshot{utxoToDecommit} signatures outcome =
-    case utxoToDecommit of
-      Just utxoToDecommit' ->
+    case (decommitTx, utxoToDecommit) of
+      (Just tx, Just utxo) ->
         outcome
           <> causes
-            [ ClientEffect $ ServerOutput.DecommitApproved{headId, utxoToDecommit = utxoToDecommit'}
+            [ ClientEffect $
+                ServerOutput.DecommitApproved
+                  { headId
+                  , decommitTxId = txId tx
+                  , utxoToDecommit = utxo
+                  }
             , OnChainEffect
                 { postChainTx =
                     DecrementTx
@@ -669,7 +675,7 @@ onOpenNetworkAckSn Environment{party} openState otherParty snapshotSignature sn
                       }
                 }
             ]
-      Nothing -> outcome
+      _ -> outcome
 
   nextSn = sn + 1
 
@@ -688,7 +694,7 @@ onOpenNetworkAckSn Environment{party} openState otherParty snapshotSignature sn
 -- | Decide to output 'ReqDec' effect by checking first if there is no decommit
 -- _in flight_ and if the tx applies cleanly to the local ledger state.
 onOpenClientDecommit ::
-  Monoid (UTxOType tx) =>
+  IsTx tx =>
   Environment ->
   HeadId ->
   Ledger tx ->
@@ -708,7 +714,11 @@ onOpenClientDecommit env headId ledger currentSlot coordinatedHeadState decommit
           ( ClientEffect
               ServerOutput.DecommitInvalid
                 { headId
-                , decommitInvalidReason = ServerOutput.DecommitAlreadyInFlight{decommitTx = existingDecommitTx}
+                , decommitTx
+                , decommitInvalidReason =
+                    ServerOutput.DecommitAlreadyInFlight
+                      { otherDecommitTxId = txId existingDecommitTx
+                      }
                 }
           )
       Nothing -> continue
@@ -720,10 +730,10 @@ onOpenClientDecommit env headId ledger currentSlot coordinatedHeadState decommit
           ( ClientEffect
               ServerOutput.DecommitInvalid
                 { headId
+                , decommitTx
                 , decommitInvalidReason =
                     ServerOutput.DecommitTxInvalid
                       { confirmedUTxO
-                      , decommitTx
                       , validationError = err
                       }
                 }
@@ -775,7 +785,14 @@ onOpenNetworkReqDec env ledger ttl openState decommitTx =
      in -- Spec: L̂   ← L̂ \ inputs(tx)
         --       txω ← tx
         newState (DecommitRecorded decommitTx activeUTxO)
-          <> cause (ClientEffect $ ServerOutput.DecommitRequested headId decommitUTxO)
+          <> cause
+            ( ClientEffect $
+                ServerOutput.DecommitRequested
+                  { headId
+                  , decommitTx = decommitTx
+                  , utxoToDecommit = decommitUTxO
+                  }
+            )
           -- Spec: if ŝ = S⁻.s ∧ leader(S⁻.s + 1) = i
           --         multicast (reqSn, vˆ, S⁻.s + 1, T̂ , txω )
           <> maybeEmitSnapshot
@@ -792,19 +809,26 @@ onOpenNetworkReqDec env ledger ttl openState decommitTx =
                 cause . ClientEffect $
                   ServerOutput.DecommitInvalid
                     { headId
+                    , decommitTx
                     , decommitInvalidReason =
                         ServerOutput.DecommitTxInvalid
                           { confirmedUTxO
-                          , decommitTx
                           , validationError = err
                           }
                     }
       Just existingDecommitTx
         | ttl > 0 ->
             wait $ WaitOnNotApplicableDecommitTx decommitTx
         | otherwise ->
-            -- REVIW: cause . ClientEffect $ ServerOutput.DecommitInvalid
-            Error $ RequireFailed $ DecommitTxInFlight{decommitTx = existingDecommitTx}
+            cause . ClientEffect $
+              ServerOutput.DecommitInvalid
+                { headId
+                , decommitTx
+                , decommitInvalidReason =
+                    DecommitAlreadyInFlight
+                      { otherDecommitTxId = txId existingDecommitTx
+                      }
+                }
 
   maybeEmitSnapshot =
     if isLeader parameters party nextSn
@@ -860,7 +884,7 @@ onOpenChainDecrementTx Environment{party} openState newVersion distributedTxOuts
           -- Spec: txω ← ⊥
           --       vˆ  ← v
           newState DecommitFinalized{newVersion}
-            <> cause (ClientEffect $ ServerOutput.DecommitFinalized{headId})
+            <> cause (ClientEffect $ ServerOutput.DecommitFinalized{headId, decommitTxId = txId tx})
             -- Spec: if ŝ = S⁻.s ∧ leader(S⁻.s + 1) = i
             --         multicast (reqSn, vˆ, S⁻.s + 1, T̂ , txω )
             & maybeEmitSnapshot