MockChain only includes valid transactions into blocks

As also commented on the scriptLedger, the mock chain should be dropping
transactions that are not valid to emulate a cardano-node mempool

As we are checking transactions now on submission and fail there, this
is not really needed, but it is more consistent to include only
transactions in the mock chain "blocks" which were valid at time of
evaluation.

This is especially important should we switch to a real cardano ledger
which checks validity ranges.

hydra-node/src/Hydra/Ledger.hs

@@ -74,13 +74,13 @@ data Ledger tx = Ledger
       UTxOType tx ->
       [tx] ->
       Either (tx, ValidationError) (UTxOType tx)
-  -- ^ Apply a set of transaction to a given UTXO set. Returns the new UTXO or
+  -- ^ Apply a set of transaction to a given UTxO set. Returns the new UTxO or
   -- validation failures returned from the ledger.
   -- TODO: 'ValidationError' should also include the UTxO, which is not
   -- necessarily the same as the given UTxO after some transactions
   , initUTxO :: UTxOType tx
-  -- ^ Generates an initial UTXO set. This is only temporary as it does not
-  -- allow to initialize the UTXO.
+  -- ^ Generates an initial UTxO set. This is only temporary as it does not
+  -- allow to initialize the UTxO.
   --
   -- TODO: This seems redundant with the `Monoid (UTxOType tx)` constraints
   -- coming with `IsTx`. We probably want to dry this out.
@@ -90,6 +90,17 @@ canApply :: Ledger tx -> ChainSlot -> UTxOType tx -> tx -> ValidationResult
 canApply ledger slot utxo tx =
   either (Invalid . snd) (const Valid) $ applyTransactions ledger slot utxo (pure tx)
 
+-- | Collect applicable transactions and resulting UTxO. In contrast to
+-- 'applyTransactions', this functions continues on validation errors.
+collectTransactions :: Ledger tx -> ChainSlot -> UTxOType tx -> [tx] -> ([tx], UTxOType tx)
+collectTransactions Ledger{applyTransactions} slot utxo =
+  foldr go ([], utxo)
+ where
+  go tx (applicableTxs, u) =
+    case applyTransactions slot u [tx] of
+      Left _ -> (applicableTxs, u)
+      Right u' -> (applicableTxs <> [tx], u')
+
 -- | Either valid or an error which we get from the ledger-specs tx validation.
 data ValidationResult
   = Valid

hydra-node/test/Hydra/Model/MockChain.hs

@@ -5,7 +5,7 @@ module Hydra.Model.MockChain where
 import Hydra.Cardano.Api
 import Hydra.Prelude hiding (Any, label)
 
-import Cardano.Api.UTxO (fromPairs, pairs)
+import Cardano.Api.UTxO (fromPairs)
 import Control.Concurrent.Class.MonadSTM (
   MonadLabelledSTM,
   MonadSTM (newTVarIO, writeTVar),
@@ -62,7 +62,7 @@ import Hydra.HeadLogic.State (
   InitialState (..),
   OpenState (..),
  )
-import Hydra.Ledger (ChainSlot (..), Ledger (..), txId)
+import Hydra.Ledger (ChainSlot (..), Ledger (..), collectTransactions)
 import Hydra.Ledger.Cardano (adjustUTxO, fromChainSlot, genTxOutAdaOnly)
 import Hydra.Ledger.Cardano.Evaluate (eraHistoryWithoutHorizon, evaluateTx)
 import Hydra.Logging (Tracer)
@@ -114,7 +114,7 @@ mockChainAndNetwork tr seedKeys commits = do
   -- TODO: why not use the full 'cardanoLedger'?
   ledger = scriptLedger seedInput
 
-  Ledger{applyTransactions, initUTxO} = ledger
+  Ledger{initUTxO} = ledger
 
   scriptRegistry = genScriptRegistry `generateWith` 42
 
@@ -266,24 +266,12 @@ mockChainAndNetwork tr seedKeys commits = do
         pure ()
 
   addNewBlockToChain chain transactions =
-    modifyTVar chain $ \(slotNum, position, blocks, utxo) ->
+    modifyTVar chain $ \(slotNum, position, blocks, utxo) -> do
       -- NOTE: Assumes 1 slot = 1 second
       let newSlot = slotNum + ChainSlot (truncate blockTime)
           header = genBlockHeaderAt (fromChainSlot newSlot) `generateWith` 42
-       in case applyTransactions newSlot utxo transactions of
-            Left err ->
-              error $
-                toText $
-                  "On-chain transactions are not supposed to fail: "
-                    <> show err
-                    <> "\nTx:\n"
-                    <> (show @String $ txId <$> transactions)
-                    <> "\nUTxO:\n"
-                    <> show (fst <$> pairs utxo)
-            Right utxo' ->
-              -- FIXME: this includes all transactions even if only one of them
-              -- would apply (e.g. concurrent collect transactions in Hydra)
-              (newSlot, position, blocks :|> (header, transactions, utxo'), utxo')
+          (txs', utxo') = collectTransactions ledger newSlot utxo transactions
+       in (newSlot, position, blocks :|> (header, txs', utxo'), utxo')
 
 -- | Construct fixed 'TimeHandle' that starts from 0 and has the era horizon far in the future.
 -- This is used in our 'Model' tests and we want to make sure the tests finish before