Incremental decommit in tui (#1518)

Fixes #1517

---

* [x] CHANGELOG updated
* [x] Documentation updated
* [x] Haddocks updated
* [x] No new TODOs introduced

hydra-node/test/Hydra/Model.hs

@@ -246,24 +246,22 @@ instance StateModel WorldState where
     party `Map.member` pendingCommits
   precondition WorldState{hydraState = Initial{commits, pendingCommits}} (Abort party) =
     party `Set.member` (Map.keysSet pendingCommits <> Map.keysSet commits)
-  precondition WorldState{hydraState = Open{headParameters = HeadParameters{parties}}} (Close party) =
-    party `elem` parties
-  precondition WorldState{hydraState = Open{offChainState, headParameters = HeadParameters{parties}}} (NewTx party tx) =
-    party `List.elem` parties
-      && (from tx, value tx) `List.elem` confirmedUTxO offChainState
+  precondition WorldState{hydraState = Open{}} (Close _) =
+    True
+  precondition WorldState{hydraState = Open{offChainState}} (NewTx _ tx) =
+    (from tx, value tx) `List.elem` confirmedUTxO offChainState
   precondition _ Wait{} =
     True
-  precondition WorldState{hydraState = Open{offChainState, headParameters = HeadParameters{parties}}} (Decommit party tx) =
-    party `elem` parties
-      && (from tx, value tx) `List.elem` confirmedUTxO offChainState
+  precondition WorldState{hydraState = Open{offChainState}} (Decommit _ tx) =
+    (from tx, value tx) `List.elem` confirmedUTxO offChainState
   precondition WorldState{hydraState = Open{}} (ObserveConfirmedTx _) =
     True
   precondition WorldState{hydraState = Open{}} ObserveHeadIsOpen =
     True
-  precondition WorldState{hydraState = Closed{headParameters = HeadParameters{parties}}} (Fanout p) =
-    p `elem` parties
-  precondition WorldState{hydraState = Open{headParameters = HeadParameters{parties}}} (CloseWithInitialSnapshot p) =
-    p `elem` parties
+  precondition WorldState{hydraState = Closed{}} (Fanout _) =
+    True
+  precondition WorldState{hydraState = Open{}} (CloseWithInitialSnapshot _) =
+    True
   precondition WorldState{hydraState} (RollbackAndForward _) =
     case hydraState of
       Start{} -> False

hydra-tui/hydra-tui.cabal

@@ -1,6 +1,6 @@
 cabal-version: 2.2
 name:          hydra-tui
-version:       0.17.0
+version:       0.18.0
 synopsis:      TUI for managing a Hydra node
 description:   TUI for managing a Hydra node
 author:        IOG

hydra-tui/src/Hydra/TUI/Drawing.hs

@@ -72,7 +72,9 @@ drawScreenShortLog CardanoClient{networkId} Client{sk} s =
               , hLimit 20 $ joinBorders $ drawCommandPanel s
               ]
           , hBorder
-          , viewport shortFeedbackViewportName Horizontal $ maybeWidget drawUserFeedbackShort (s ^? logStateL . logMessagesL . _head)
+          , vLimit 1 $
+              viewport shortFeedbackViewportName Horizontal $
+                maybeWidget drawUserFeedbackShort (s ^? logStateL . logMessagesL . _head)
           ]
 
 drawCommandPanel :: RootState -> Widget n
@@ -105,7 +107,7 @@ drawCommandList s = vBox . fmap txt $ case s ^. connectedStateL of
     Idle -> ["[I]nit", "[Q]uit"]
     Active (ActiveLink{activeHeadState}) -> case activeHeadState of
       Initializing{} -> ["[C]ommit", "[A]bort", "[Q]uit"]
-      Open{} -> ["[N]ew Transaction", "[C]lose", "[Q]uit"]
+      Open{} -> ["[N]ew Transaction", "[D]ecommit", "[C]lose", "[Q]uit"]
       Closed{} -> ["[Q]uit"]
       FanoutPossible{} -> ["[F]anout", "[Q]uit"]
       Final{} -> ["[I]nit", "[Q]uit"]
@@ -129,10 +131,18 @@ drawFocusPanelInitializing me InitializingState{remainingParties, initializingSc
   CommitMenu x -> vBox [txt "Select UTxOs to commit:", renderForm x]
   ConfirmingAbort x -> vBox [txt "Confirm Abort action:", renderForm x]
 
-drawFocusPanelOpen :: NetworkId -> VerificationKey PaymentKey -> UTxO -> OpenScreen -> Widget Name
-drawFocusPanelOpen networkId vk utxo = \case
-  OpenHome -> drawUTxO (highlightOwnAddress ownAddress) utxo
+drawFocusPanelOpen :: NetworkId -> VerificationKey PaymentKey -> UTxO -> UTxO -> OpenScreen -> Widget Name
+drawFocusPanelOpen networkId vk utxo pendingUTxOToDecommit = \case
+  OpenHome ->
+    vBox
+      [ txt "Active UTxO: "
+      , drawUTxO (highlightOwnAddress ownAddress) utxo
+      , hBorder
+      , txt "Pending UTxO to decommit: "
+      , drawUTxO (highlightOwnAddress ownAddress) pendingUTxOToDecommit
+      ]
   SelectingUTxO x -> renderForm x
+  SelectingUTxOToDecommit x -> renderForm x
   EnteringAmount _ x -> renderForm x
   SelectingRecipient _ _ x -> renderForm x
   ConfirmingClose x -> vBox [txt "Confirm Close action:", renderForm x]
@@ -159,9 +169,9 @@ highlightOwnAddress ownAddress a =
 drawFocusPanel :: NetworkId -> VerificationKey PaymentKey -> UTCTime -> Connection -> Widget Name
 drawFocusPanel networkId vk now (Connection{me, headState}) = case headState of
   Idle -> emptyWidget
-  Active (ActiveLink{utxo, activeHeadState}) -> case activeHeadState of
+  Active (ActiveLink{utxo, pendingUTxOToDecommit, activeHeadState}) -> case activeHeadState of
     Initializing x -> drawFocusPanelInitializing me x
-    Open x -> drawFocusPanelOpen networkId vk utxo x
+    Open x -> drawFocusPanelOpen networkId vk utxo pendingUTxOToDecommit x
     Closed x -> drawFocusPanelClosed now x
     FanoutPossible -> txt "Ready to fanout!"
     Final -> drawFocusPanelFinal networkId vk utxo

hydra-tui/src/Hydra/TUI/Handlers.hs

@@ -164,6 +164,9 @@ handleVtyEventsOpen cardanoClient hydraClient utxo e = do
         EvKey (KChar 'n') [] -> do
           let utxo' = myAvailableUTxO (networkId cardanoClient) (getVerificationKey $ sk hydraClient) utxo
           id .= SelectingUTxO (utxoRadioField utxo')
+        EvKey (KChar 'd') [] -> do
+          let utxo' = myAvailableUTxO (networkId cardanoClient) (getVerificationKey $ sk hydraClient) utxo
+          id .= SelectingUTxOToDecommit (utxoRadioField utxo')
         _ -> pure ()
     SelectingUTxO i -> do
       case e of
@@ -177,6 +180,19 @@ handleVtyEventsOpen cardanoClient hydraClient utxo e = do
           id .= EnteringAmount{utxoSelected, enteringAmountForm}
         _ -> pure ()
       zoom selectingUTxOFormL $ handleFormEvent (VtyEvent e)
+    SelectingUTxOToDecommit i -> do
+      case e of
+        EvKey KEsc [] -> id .= OpenHome
+        EvKey KEnter [] -> do
+          let utxoSelected@(_, TxOut{txOutValue = v}) = formState i
+          let recipient = mkVkAddress @Era (networkId cardanoClient) (getVerificationKey $ sk hydraClient)
+          case mkSimpleTx utxoSelected (recipient, v) (sk hydraClient) of
+            Left _ -> pure ()
+            Right tx -> do
+              liftIO (sendInput hydraClient (Decommit tx))
+          id .= OpenHome
+        _ -> pure ()
+      zoom selectingUTxOToDecommitFormL $ handleFormEvent (VtyEvent e)
     EnteringAmount utxoSelected i -> do
       case e of
         EvKey KEsc [] -> id .= OpenHome
@@ -258,6 +274,10 @@ handleHydraEventsActiveLink e = do
     Update TimedServerOutput{time, output = HeadIsFinalized{utxo}} -> do
       utxoL .= utxo
       activeHeadStateL .= Final
+    Update TimedServerOutput{time, output = DecommitRequested{utxoToDecommit}} ->
+      pendingUTxOToDecommitL .= utxoToDecommit
+    Update TimedServerOutput{time, output = DecommitFinalized{}} ->
+      pendingUTxOToDecommitL .= mempty
     _ -> pure ()
 
 handleHydraEventsInfo :: HydraEvent Tx -> EventM Name [LogMessage] ()
@@ -279,9 +299,13 @@ handleHydraEventsInfo = \case
   Update TimedServerOutput{time, output = HeadIsContested{snapshotNumber, contestationDeadline}} -> do
     info time ("Head contested with snapshot number " <> show snapshotNumber <> " and deadline " <> show contestationDeadline)
   Update TimedServerOutput{time, output = TxValid{}} ->
-    report Success time "Transaction submitted successfully!"
+    report Success time "Transaction submitted successfully"
   Update TimedServerOutput{time, output = TxInvalid{transaction, validationError}} ->
     warn time ("Transaction with id " <> show (txId transaction) <> " is not applicable: " <> show validationError)
+  Update TimedServerOutput{time, output = DecommitApproved{}} ->
+    report Success time "Decommit approved and submitted to Cardano"
+  Update TimedServerOutput{time, output = DecommitInvalid{decommitTx, decommitInvalidReason}} ->
+    warn time ("Decommit Transaction with id " <> show (txId decommitTx) <> " is not applicable: " <> show decommitInvalidReason)
   Update TimedServerOutput{time, output = HeadIsFinalized{utxo}} -> do
     info time "Head is finalized"
   Update TimedServerOutput{time, output = InvalidInput{reason}} ->

hydra-tui/src/Hydra/TUI/Model.hs

@@ -57,6 +57,7 @@ data InitializingScreen
 data OpenScreen
   = OpenHome
   | SelectingUTxO {selectingUTxOForm :: UTxORadioFieldForm (HydraEvent Tx) Name}
+  | SelectingUTxOToDecommit {selectingUTxOToDecommitForm :: UTxORadioFieldForm (HydraEvent Tx) Name}
   | EnteringAmount {utxoSelected :: (TxIn, TxOut CtxUTxO), enteringAmountForm :: Form Integer (HydraEvent Tx) Name}
   | SelectingRecipient {utxoSelected :: (TxIn, TxOut CtxUTxO), amountEntered :: Integer, selectingRecipientForm :: Form AddressInEra (HydraEvent Tx) Name}
   | ConfirmingClose {confirmingCloseForm :: ConfirmingRadioFieldForm (HydraEvent Tx) Name}
@@ -69,6 +70,7 @@ data HeadState
 
 data ActiveLink = ActiveLink
   { utxo :: UTxO
+  , pendingUTxOToDecommit :: UTxO
   , parties :: [Party]
   , headId :: HeadId
   , activeHeadState :: ActiveHeadState
@@ -85,6 +87,7 @@ type Name = Text
 
 makeLensesFor
   [ ("selectingUTxOForm", "selectingUTxOFormL")
+  , ("selectingUTxOToDecommitForm", "selectingUTxOToDecommitFormL")
   , ("enteringAmountForm", "enteringAmountFormL")
   , ("selectingRecipientForm", "selectingRecipientFormL")
   , ("confirmingCloseForm", "confirmingCloseFormL")
@@ -137,6 +140,7 @@ makeLensesFor
 
 makeLensesFor
   [ ("utxo", "utxoL")
+  , ("pendingUTxOToDecommit", "pendingUTxOToDecommitL")
   , ("parties", "partiesL")
   , ("activeHeadState", "activeHeadStateL")
   , ("headId", "headIdL")
@@ -170,5 +174,6 @@ newActiveLink parties headId =
                 }
           }
     , utxo = mempty
+    , pendingUTxOToDecommit = mempty
     , headId
     }