Remove NoOutcome and make Outcome a Semigroup

The NoOutcome identity is not needed and now all update outcomes must be any of the other data constructors. Also make Combine the mappend of Outcome to make the code a bit easier to read.
input-output-hk · Jul 28, 2023 · 6214abb · 6214abb
1 parent 781f6e8
commit 6214abb
Show file tree

Hide file tree

Showing 3 changed files with 31 additions and 33 deletions.
diff --git a/hydra-node/src/Hydra/HeadLogic.hs b/hydra-node/src/Hydra/HeadLogic.hs
@@ -135,7 +135,7 @@ onIdleChainInitTx newChainState parties contestationPeriod headId =
         , headId
         }
     )
-    `Combined` Effects [ClientEffect $ ServerOutput.HeadIsInitializing headId (fromList parties)]
+    <> Effects [ClientEffect $ ServerOutput.HeadIsInitializing headId (fromList parties)]
 
 -- | Client request to commit a UTxO entry to the head. Provided the client
 -- hasn't committed yet, this leads to a commit transaction on-chain containing
@@ -177,9 +177,8 @@ onInitialChainCommitTx ::
   UTxOType tx ->
   Outcome tx
 onInitialChainCommitTx st newChainState pt utxo =
-  StateChanged
-    (CommittedUTxO{party = pt, committedUTxO = utxo, chainState = newChainState})
-    `Combined` Effects
+  StateChanged CommittedUTxO{party = pt, committedUTxO = utxo, chainState = newChainState}
+    <> Effects
       ( notifyClient
           : [postCollectCom | canCollectCom]
       )
@@ -224,9 +223,8 @@ onInitialChainAbortTx ::
   HeadId ->
   Outcome tx
 onInitialChainAbortTx newChainState committed headId =
-  StateChanged
-    HeadAborted{chainState = newChainState}
-    `Combined` Effects [ClientEffect $ ServerOutput.HeadIsAborted{headId, utxo = fold committed}]
+  StateChanged HeadAborted{chainState = newChainState}
+    <> Effects [ClientEffect $ ServerOutput.HeadIsAborted{headId, utxo = fold committed}]
 
 -- | Observe a collectCom transaction. We initialize the 'OpenState' using the
 -- head parameters from 'IdleState' and construct an 'InitialSnapshot' holding
@@ -240,9 +238,8 @@ onInitialChainCollectTx ::
   ChainStateType tx ->
   Outcome tx
 onInitialChainCollectTx st newChainState =
-  StateChanged
-    HeadOpened{chainState = newChainState, initialUTxO = u0}
-    `Combined` Effects [ClientEffect $ ServerOutput.HeadIsOpen{headId, utxo = u0}]
+  StateChanged HeadOpened{chainState = newChainState, initialUTxO = u0}
+    <> Effects [ClientEffect $ ServerOutput.HeadIsOpen{headId, utxo = u0}]
  where
   u0 = fold committed
 
@@ -282,7 +279,7 @@ onOpenNetworkReqTx ::
   Outcome tx
 onOpenNetworkReqTx env ledger st ttl tx =
   -- Spec: Tall ← ̂Tall ∪ { (hash(tx), tx) }
-  (StateChanged TransactionReceived{tx} `Combined`) $
+  (StateChanged TransactionReceived{tx} <>) $
     -- Spec: wait L̂ ◦ tx ≠ ⊥ combined with L̂ ← L̂ ◦ tx
     waitApplyTx $ \newLocalUTxO ->
       -- Spec: if ŝ = s̄ ∧ leader(s̄ + 1) = i
@@ -292,11 +289,11 @@ onOpenNetworkReqTx env ledger st ttl tx =
               -- XXX: This state update has no equivalence in the
               -- spec. Do we really need to store that we have
               -- requested a snapshot? If yes, should update spec.
-              `Combined` StateChanged SnapshotRequestDecided{snapshotNumber = nextSn}
-              `Combined` Effects [NetworkEffect (ReqSn nextSn (txId <$> localTxs'))]
+              <> StateChanged SnapshotRequestDecided{snapshotNumber = nextSn}
+              <> Effects [NetworkEffect (ReqSn nextSn (txId <$> localTxs'))]
           else StateChanged (TransactionAppliedToLocalUTxO{tx, newLocalUTxO})
       )
-        `Combined` Effects [ClientEffect $ ServerOutput.TxValid headId tx]
+        <> Effects [ClientEffect $ ServerOutput.TxValid headId tx]
  where
   waitApplyTx cont =
     case applyTransactions currentSlot localUTxO [tx] of
@@ -379,7 +376,7 @@ onOpenNetworkReqSn env ledger st otherParty sn requestedTxIds =
           let nextSnapshot = Snapshot (confSn + 1) u requestedTxIds
           -- Spec: σᵢ
           let snapshotSignature = sign signingKey nextSnapshot
-          (Effects [NetworkEffect $ AckSn snapshotSignature sn] `Combined`) $
+          (Effects [NetworkEffect $ AckSn snapshotSignature sn] <>) $
             do
               -- Spec: for loop which updates T̂ and L̂
               let (newLocalTxs, newLocalUTxO) = pruneTransactions u
@@ -484,14 +481,9 @@ onOpenNetworkAckSn Environment{party} openState otherParty snapshotSignature sn
           -- Spec: σ̃ ← MS-ASig(k_H, ̂Σ̂)
           let multisig = aggregateInOrder sigs' parties
           requireVerifiedMultisignature multisig snapshot $ do
-            let nextSn = sn + 1
             Effects [ClientEffect $ ServerOutput.SnapshotConfirmed headId snapshot multisig]
-              `Combined` StateChanged SnapshotConfirmed{snapshot, signatures = multisig}
-              `Combined` if isLeader parameters party nextSn && not (null localTxs)
-                then
-                  StateChanged SnapshotRequestDecided{snapshotNumber = nextSn}
-                    `Combined` Effects [NetworkEffect (ReqSn nextSn (txId <$> localTxs))]
-                else NoOutcome
+              <> StateChanged SnapshotConfirmed{snapshot, signatures = multisig}
+              & maybeEmitSnapshot
  where
   seenSn = seenSnapshotNumber seenSnapshot
 
@@ -535,6 +527,16 @@ onOpenNetworkAckSn Environment{party} openState otherParty snapshotSignature sn
           RequireFailed $
             InvalidMultisignature{multisig = show multisig, vkeys}
 
+  maybeEmitSnapshot outcome =
+    if isLeader parameters party nextSn && not (null localTxs)
+      then
+        outcome
+          <> StateChanged SnapshotRequestDecided{snapshotNumber = nextSn}
+          <> Effects [NetworkEffect (ReqSn nextSn (txId <$> localTxs))]
+      else outcome
+
+  nextSn = sn + 1
+
   vkeys = vkey <$> parties
 
   OpenState
@@ -577,7 +579,7 @@ onOpenChainCloseTx ::
   Outcome tx
 onOpenChainCloseTx openState newChainState closedSnapshotNumber contestationDeadline =
   StateChanged (HeadClosed newChainState contestationDeadline)
-    `Combined` Effects
+    <> Effects
       ( notifyClient
           : [ OnChainEffect
               { postChainTx = ContestTx{confirmedSnapshot}
@@ -655,7 +657,7 @@ onClosedChainFanoutTx ::
 onClosedChainFanoutTx closedState newChainState =
   StateChanged
     HeadFannedOut{chainState = newChainState}
-    `Combined` Effects [ClientEffect $ ServerOutput.HeadIsFinalized{headId, utxo}]
+    <> Effects [ClientEffect $ ServerOutput.HeadIsFinalized{headId, utxo}]
  where
   Snapshot{utxo} = getSnapshot confirmedSnapshot
 
@@ -722,7 +724,7 @@ update env ledger st ev = case (st, ev) of
     | chainTime > contestationDeadline && not readyToFanoutSent ->
         StateChanged
           HeadIsReadyToFanout
-          `Combined` Effects [ClientEffect $ ServerOutput.ReadyToFanout headId]
+          <> Effects [ClientEffect $ ServerOutput.ReadyToFanout headId]
   (Closed closedState, ClientEvent Fanout) ->
     onClosedClientFanout closedState
   (Closed closedState, OnChainEvent Observation{observedTx = OnFanoutTx{}, newChainState}) ->
@@ -928,7 +930,6 @@ aggregateState s outcome =
   recoverState s $ collectStateChanged outcome
  where
   collectStateChanged = \case
-    NoOutcome -> []
     Error{} -> []
     Wait{} -> []
     StateChanged change -> [change]

diff --git a/hydra-node/src/Hydra/HeadLogic/Outcome.hs b/hydra-node/src/Hydra/HeadLogic/Outcome.hs
@@ -88,14 +88,16 @@ deriving instance (IsTx tx, ToJSON (ChainStateType tx)) => ToJSON (StateChanged
 deriving instance (IsTx tx, FromJSON (HeadState tx), FromJSON (ChainStateType tx)) => FromJSON (StateChanged tx)
 
 data Outcome tx
-  = NoOutcome
-  | Effects {effects :: [Effect tx]}
+  = Effects {effects :: [Effect tx]}
   | StateChanged (StateChanged tx)
   | Wait {reason :: WaitReason tx}
   | Error {error :: LogicError tx}
   | Combined {left :: Outcome tx, right :: Outcome tx}
   deriving stock (Generic)
 
+instance Semigroup (Outcome tx) where
+  (<>) = Combined
+
 deriving instance (IsChainState tx) => Eq (Outcome tx)
 deriving instance (IsChainState tx) => Show (Outcome tx)
 deriving instance (IsChainState tx) => ToJSON (Outcome tx)
@@ -106,7 +108,6 @@ instance (IsTx tx, Arbitrary (ChainStateType tx)) => Arbitrary (Outcome tx) wher
 
 collectEffects :: Outcome tx -> [Effect tx]
 collectEffects = \case
-  NoOutcome -> []
   Error _ -> []
   Wait _ -> []
   StateChanged _ -> []
@@ -115,7 +116,6 @@ collectEffects = \case
 
 collectWaits :: Outcome tx -> [WaitReason tx]
 collectWaits = \case
-  NoOutcome -> []
   Error _ -> []
   Wait w -> [w]
   StateChanged _ -> []

diff --git a/hydra-node/src/Hydra/Node.hs b/hydra-node/src/Hydra/Node.hs
@@ -111,9 +111,6 @@ stepHydraNode tracer node = do
   traceWith tracer EndEvent{by = party, eventId}
  where
   handleOutcome e = \case
-    -- TODO(SN): Handling of 'Left' is untested, i.e. the fact that it only
-    -- does trace and not throw!
-    NoOutcome -> pure ()
     Error _ -> pure ()
     Wait _reason -> putEventAfter eq waitDelay (decreaseTTL e)
     StateChanged sc -> do