Reproduce midnight bug (#2134)

Midnight team reported a bug where if you submit unsigned tx on L2 you
can't get to confirmed snapshot later on.
 
This happens because we keep even failing txs inside of `allTxs` in
`CoordinatedHeadState` since they could become valid (there could be a
networking issue rendering a tx1 invalid while in fact we failed to
observe tx2 before the failing one which would make the tx1 valid again;
eg. `BadInputsUTxO` validation error).

To fix this we remove invalid txs from `allTxs` right away and the test
we wrote is green again.

Note: 
- Perhaps we would like to check _why_ the tx failed in the first place
and in case of `BadInputsUTxO` error still keep it in `allTxs`?
---

<!-- Consider each and tick it off one way or the other -->
* [x] CHANGELOG updated or not needed
* [x] Documentation updated or not needed
* [x] Haddocks updated or not needed
* [x] No new TODOs introduced or explained herafter

Author: v0d1ch

CHANGELOG.md

@@ -10,6 +10,8 @@ changes.
 
 ## [0.23.0] - UNRELEASED
 
+- Don't keep around invalid transactions as they could lead to stuck Head.
+
 - Hydra API server responds with the correct `Content-Type` header `application-json`.
 
 - Add `Environment` to `Greetings` message, enabling clients to access runtime settings.

hydra-cluster/hydra-cluster.cabal

@@ -170,6 +170,7 @@ test-suite tests
     , filepath
     , hspec
     , hspec-golden-aeson
+    , http-conduit
     , hydra-cardano-api
     , hydra-cluster
     , hydra-node

hydra-cluster/test/Test/EndToEndSpec.hs

@@ -57,6 +57,7 @@ import Hydra.Cluster.Scenarios (
   canSubmitTransactionThroughAPI,
   checkFanout,
   headIsInitializingWith,
+  hydraNodeBaseUrl,
   initWithWrongKeys,
   nodeCanSupportMultipleEtcdClusters,
   nodeReObservesOnChainTxs,
@@ -98,6 +99,8 @@ import HydraNode (
   withHydraNode,
   withPreparedHydraNode,
  )
+import Network.HTTP.Conduit (parseUrlThrow)
+import Network.HTTP.Simple (getResponseBody, httpJSON)
 import System.Directory (removeDirectoryRecursive, removeFile)
 import System.FilePath ((</>))
 import Test.Hydra.Cluster.Utils (chainPointToSlot)
@@ -419,6 +422,102 @@ spec = around (showLogsOnFailure "EndToEndSpec") $ do
                 send n1 $ input "Fanout" []
                 waitForAllMatch 10 [n1] $ checkFanout headId u0
 
+      it "Head can continue after TxInvalid" $ \tracer ->
+        -- failAfter 60 $
+        withClusterTempDir $ \tmpDir -> do
+          let clusterIx = 0
+          withBackend (contramap FromCardanoNode tracer) tmpDir $ \_ backend -> do
+            let nodeSocket' = case Backend.getOptions backend of
+                  Direct DirectOptions{nodeSocket} -> nodeSocket
+                  _ -> error "Unexpected Blockfrost backend"
+            aliceKeys@(aliceCardanoVk, _) <- generate genKeyPair
+            bobKeys@(bobCardanoVk, _) <- generate genKeyPair
+            carolKeys@(carolCardanoVk, _) <- generate genKeyPair
+
+            let cardanoKeys = [aliceKeys, bobKeys, carolKeys]
+                hydraKeys = [aliceSk, bobSk, carolSk]
+
+            let firstNodeId = clusterIx * 3
+
+            hydraScriptsTxId <- publishHydraScriptsAs backend Faucet
+            let contestationPeriod = 2
+            let hydraTracer = contramap FromHydraNode tracer
+
+            withHydraCluster hydraTracer tmpDir nodeSocket' firstNodeId cardanoKeys hydraKeys hydraScriptsTxId contestationPeriod $ \nodes -> do
+              waitForNodesConnected hydraTracer 20 nodes
+              let [n1, n2, n3] = toList nodes
+
+              -- Funds to be used as fuel by Hydra protocol transactions
+              seedFromFaucet_ backend aliceCardanoVk 100_000_000 (contramap FromFaucet tracer)
+              seedFromFaucet_ backend bobCardanoVk 100_000_000 (contramap FromFaucet tracer)
+              seedFromFaucet_ backend carolCardanoVk 100_000_000 (contramap FromFaucet tracer)
+
+              send n1 $ input "Init" []
+              headId <-
+                waitForAllMatch 10 [n1, n2, n3] $ headIsInitializingWith (Set.fromList [alice, bob, carol])
+
+              -- Get some UTXOs to commit to a head
+              (aliceExternalVk, aliceExternalSk) <- generate genKeyPair
+              committedUTxOByAlice <- seedFromFaucet backend aliceExternalVk aliceCommittedToHead (contramap FromFaucet tracer)
+              requestCommitTx n1 committedUTxOByAlice <&> signTx aliceExternalSk >>= Backend.submitTransaction backend
+
+              (bobExternalVk, bobExternalSk) <- generate genKeyPair
+              committedUTxOByBob <- seedFromFaucet backend bobExternalVk bobCommittedToHead (contramap FromFaucet tracer)
+              requestCommitTx n2 committedUTxOByBob <&> signTx bobExternalSk >>= Backend.submitTransaction backend
+
+              requestCommitTx n3 mempty >>= Backend.submitTransaction backend
+
+              let u0 = committedUTxOByAlice <> committedUTxOByBob
+
+              waitFor hydraTracer 10 [n1, n2, n3] $ output "HeadIsOpen" ["utxo" .= u0, "headId" .= headId]
+
+              let firstCommittedUTxO = Prelude.head $ UTxO.toList committedUTxOByBob
+              let Right tx =
+                    mkSimpleTx
+                      firstCommittedUTxO
+                      (inHeadAddress bobExternalVk, lovelaceToValue paymentFromAliceToBob)
+                      bobExternalSk
+
+              let unsign (Tx body _) = Tx body []
+
+              send n1 $ input "NewTx" ["transaction" .= unsign tx]
+
+              validationError <- waitForAllMatch 10 [n1, n2, n3] $ \v -> do
+                guard $ v ^? key "tag" == Just "TxInvalid"
+                v ^? key "validationError" . key "reason" . _JSON
+
+              validationError `shouldContain` "MissingVKeyWitnessesUTXOW"
+
+              send n3 $ input "NewTx" ["transaction" .= tx]
+
+              waitFor hydraTracer 20 [n1, n2, n3] $
+                output "TxValid" ["transactionId" .= txId tx, "headId" .= headId]
+
+              waitForAllMatch 20 [n1, n2, n3] $ \v -> do
+                guard $ v ^? key "tag" == Just "SnapshotConfirmed"
+
+              headUTxO :: UTxO.UTxO <-
+                parseUrlThrow ("GET " <> hydraNodeBaseUrl n1 <> "/snapshot/utxo")
+                  >>= httpJSON
+                  <&> getResponseBody
+
+              send n1 $ input "Close" []
+
+              deadline <- waitMatch 3 n1 $ \v -> do
+                guard $ v ^? key "tag" == Just "HeadIsClosed"
+                guard $ v ^? key "headId" == Just (toJSON headId)
+                snapshotNumber <- v ^? key "snapshotNumber"
+                guard $ snapshotNumber == Aeson.Number 1
+                v ^? key "contestationDeadline" . _JSON
+
+              -- Expect to see ReadyToFanout within 3 seconds after deadline
+              remainingTime <- diffUTCTime deadline <$> getCurrentTime
+              waitFor hydraTracer (remainingTime + 3) [n1] $
+                output "ReadyToFanout" ["headId" .= headId]
+
+              send n1 $ input "Fanout" []
+              waitForAllMatch 10 [n1] $ checkFanout headId headUTxO
+
       it "supports mirror party" $ \tracer ->
         failAfter 60 $
           withClusterTempDir $ \tmpDir -> do

hydra-node/src/Hydra/HeadLogic.hs

@@ -323,16 +323,15 @@ onOpenNetworkReqTx env ledger st ttl tx =
         | ttl > 0 ->
             wait (WaitOnNotApplicableTx err)
         | otherwise ->
-            -- XXX: We might want to remove invalid txs from allTxs here to
+            -- XXX: We are removing invalid txs from allTxs here to
             -- prevent them piling up infinitely. However, this is not really
             -- covered by the spec and this could be problematic in case of
             -- conflicting transactions paired with network latency and/or
             -- message resubmission. For example: Assume tx2 depends on tx1, but
             -- only tx2 is seen by a participant and eventually times out
             -- because of network latency when receiving tx1. The leader,
             -- however, saw both as valid and requests a snapshot including
-            -- both. This is a valid request and if we would have removed tx2
-            -- from allTxs, we would make the head stuck.
+            -- both. This is a valid request and it could make the head stuck.
             newState TxInvalid{headId, utxo = localUTxO, transaction = tx, validationError = err}
 
   maybeRequestSnapshot nextSn outcome =
@@ -1783,7 +1782,10 @@ aggregate st = \case
       Open ost@OpenState{} -> Open ost{currentSlot = chainSlot}
       _otherState -> st
   IgnoredHeadInitializing{} -> st
-  TxInvalid{} -> st
+  TxInvalid{transaction} -> case st of
+    Open ost@OpenState{coordinatedHeadState = coordState@CoordinatedHeadState{allTxs = allTransactions}} ->
+      Open ost{coordinatedHeadState = coordState{allTxs = foldr Map.delete allTransactions [txId transaction]}}
+    _otherState -> st
   Checkpoint state' -> state'
 
 aggregateState ::