{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-unused-local-binds #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}

module Hydra.TUI.Handlers where

import Hydra.Prelude hiding (Down, padLeft)

import Brick
import Hydra.Cardano.Api hiding (Active)
import Hydra.Chain (PostTxError (InternalWalletError, NotEnoughFuel), reason)

import Brick.Forms (Form (formState), editField, editShowableFieldWithValidate, handleFormEvent, newForm)
import Cardano.Api.UTxO qualified as UTxO
import Data.List (nub, (\\))
import Data.Map qualified as Map
import Graphics.Vty (
  Event (EvKey),
  Key (..),
  Modifier (MCtrl),
 )
import Graphics.Vty qualified as Vty
import Hydra.API.ClientInput (ClientInput (..))
import Hydra.API.ServerOutput (ServerOutput (..), TimedServerOutput (..))
import Hydra.Cardano.Api.Prelude ()
import Hydra.Chain.CardanoClient (CardanoClient (..))
import Hydra.Chain.Direct.State ()
import Hydra.Client (Client (..), HydraEvent (..))
import Hydra.Ledger.Cardano (mkSimpleTx)
import Hydra.TUI.Forms
import Hydra.TUI.Logging.Handlers (info, report, warn)
import Hydra.TUI.Logging.Types (LogMessage, LogState, LogVerbosity (..), Severity (..), logMessagesL, logVerbosityL)
import Hydra.TUI.Model
import Hydra.TUI.Style (own)
import Hydra.Tx (IsTx (..), Party, Snapshot (..), balance)
import Lens.Micro.Mtl (use, (%=), (.=))

handleEvent ::
  CardanoClient ->
  Client Tx IO ->
  BrickEvent Name (HydraEvent Tx) ->
  EventM Name RootState ()
handleEvent :: CardanoClient
-> Client Tx IO
-> BrickEvent Name (HydraEvent Tx)
-> EventM Name RootState ()
handleEvent CardanoClient
cardanoClient Client Tx IO
client = \case
  AppEvent HydraEvent Tx
e -> do
    HydraEvent Tx -> EventM Name RootState ()
handleTick HydraEvent Tx
e
    LensLike'
  (Zoomed (EventM Name ConnectedState) ()) RootState ConnectedState
-> EventM Name ConnectedState () -> EventM Name RootState ()
forall c.
LensLike'
  (Zoomed (EventM Name ConnectedState) c) RootState ConnectedState
-> EventM Name ConnectedState c -> EventM Name RootState c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed (EventM Name ConnectedState) ()) RootState ConnectedState
(ConnectedState
 -> Focusing (StateT (EventState Name) IO) () ConnectedState)
-> RootState -> Focusing (StateT (EventState Name) IO) () RootState
Lens' RootState ConnectedState
connectedStateL (EventM Name ConnectedState () -> EventM Name RootState ())
-> EventM Name ConnectedState () -> EventM Name RootState ()
forall a b. (a -> b) -> a -> b
$ do
      HydraEvent Tx -> EventM Name ConnectedState ()
handleHydraEventsConnectedState HydraEvent Tx
e
      LensLike'
  (Zoomed (EventM Name Connection) ()) ConnectedState Connection
-> EventM Name Connection () -> EventM Name ConnectedState ()
forall c.
LensLike'
  (Zoomed (EventM Name Connection) c) ConnectedState Connection
-> EventM Name Connection c -> EventM Name ConnectedState c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed (EventM Name Connection) ()) ConnectedState Connection
(Connection
 -> Focusing (StateT (EventState Name) IO) () Connection)
-> ConnectedState
-> Focusing (StateT (EventState Name) IO) () ConnectedState
Traversal' ConnectedState Connection
connectionL (EventM Name Connection () -> EventM Name ConnectedState ())
-> EventM Name Connection () -> EventM Name ConnectedState ()
forall a b. (a -> b) -> a -> b
$ HydraEvent Tx -> EventM Name Connection ()
handleHydraEventsConnection HydraEvent Tx
e
    LensLike'
  (Zoomed (EventM Name [LogMessage]) ()) RootState [LogMessage]
-> EventM Name [LogMessage] () -> EventM Name RootState ()
forall c.
LensLike'
  (Zoomed (EventM Name [LogMessage]) c) RootState [LogMessage]
-> EventM Name [LogMessage] c -> EventM Name RootState c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom ((LogState -> Focusing (StateT (EventState Name) IO) () LogState)
-> RootState -> Focusing (StateT (EventState Name) IO) () RootState
Lens' RootState LogState
logStateL ((LogState -> Focusing (StateT (EventState Name) IO) () LogState)
 -> RootState
 -> Focusing (StateT (EventState Name) IO) () RootState)
-> (([LogMessage]
     -> Focusing (StateT (EventState Name) IO) () [LogMessage])
    -> LogState -> Focusing (StateT (EventState Name) IO) () LogState)
-> ([LogMessage]
    -> Focusing (StateT (EventState Name) IO) () [LogMessage])
-> RootState
-> Focusing (StateT (EventState Name) IO) () RootState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([LogMessage]
 -> Focusing (StateT (EventState Name) IO) () [LogMessage])
-> LogState -> Focusing (StateT (EventState Name) IO) () LogState
Lens' LogState [LogMessage]
logMessagesL) (EventM Name [LogMessage] () -> EventM Name RootState ())
-> EventM Name [LogMessage] () -> EventM Name RootState ()
forall a b. (a -> b) -> a -> b
$
      HydraEvent Tx -> EventM Name [LogMessage] ()
handleHydraEventsInfo HydraEvent Tx
e
  MouseDown{} -> () -> EventM Name RootState ()
forall a. a -> EventM Name RootState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  MouseUp{} -> () -> EventM Name RootState ()
forall a. a -> EventM Name RootState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  VtyEvent Event
e -> do
    Bool
modalOpen <- (RootState -> Bool) -> EventM Name RootState Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RootState -> Bool
isModalOpen
    case Event
e of
      EvKey (KChar Char
'c') [Modifier
MCtrl] -> EventM Name RootState ()
forall n s. EventM n s ()
halt
      EvKey (KChar Char
'd') [Modifier
MCtrl] -> EventM Name RootState ()
forall n s. EventM n s ()
halt
      EvKey (KChar Char
'q') []
        | Bool -> Bool
not Bool
modalOpen -> EventM Name RootState ()
forall n s. EventM n s ()
halt
      EvKey (KChar Char
'Q') []
        | Bool -> Bool
not Bool
modalOpen -> EventM Name RootState ()
forall n s. EventM n s ()
halt
      Event
_ -> do
        LensLike' (Zoomed (EventM Name HeadState) ()) RootState HeadState
-> EventM Name HeadState () -> EventM Name RootState ()
forall c.
LensLike' (Zoomed (EventM Name HeadState) c) RootState HeadState
-> EventM Name HeadState c -> EventM Name RootState c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom ((ConnectedState
 -> Focusing (StateT (EventState Name) IO) () ConnectedState)
-> RootState -> Focusing (StateT (EventState Name) IO) () RootState
Lens' RootState ConnectedState
connectedStateL ((ConnectedState
  -> Focusing (StateT (EventState Name) IO) () ConnectedState)
 -> RootState
 -> Focusing (StateT (EventState Name) IO) () RootState)
-> ((HeadState
     -> Focusing (StateT (EventState Name) IO) () HeadState)
    -> ConnectedState
    -> Focusing (StateT (EventState Name) IO) () ConnectedState)
-> (HeadState
    -> Focusing (StateT (EventState Name) IO) () HeadState)
-> RootState
-> Focusing (StateT (EventState Name) IO) () RootState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection
 -> Focusing (StateT (EventState Name) IO) () Connection)
-> ConnectedState
-> Focusing (StateT (EventState Name) IO) () ConnectedState
Traversal' ConnectedState Connection
connectionL ((Connection
  -> Focusing (StateT (EventState Name) IO) () Connection)
 -> ConnectedState
 -> Focusing (StateT (EventState Name) IO) () ConnectedState)
-> ((HeadState
     -> Focusing (StateT (EventState Name) IO) () HeadState)
    -> Connection
    -> Focusing (StateT (EventState Name) IO) () Connection)
-> (HeadState
    -> Focusing (StateT (EventState Name) IO) () HeadState)
-> ConnectedState
-> Focusing (StateT (EventState Name) IO) () ConnectedState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeadState -> Focusing (StateT (EventState Name) IO) () HeadState)
-> Connection
-> Focusing (StateT (EventState Name) IO) () Connection
Lens' Connection HeadState
headStateL) (EventM Name HeadState () -> EventM Name RootState ())
-> EventM Name HeadState () -> EventM Name RootState ()
forall a b. (a -> b) -> a -> b
$
          CardanoClient -> Client Tx IO -> Event -> EventM Name HeadState ()
handleVtyEventsHeadState CardanoClient
cardanoClient Client Tx IO
client Event
e

        Bool -> EventM Name RootState () -> EventM Name RootState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
modalOpen (EventM Name RootState () -> EventM Name RootState ())
-> EventM Name RootState () -> EventM Name RootState ()
forall a b. (a -> b) -> a -> b
$ do
          LensLike' (Zoomed (EventM Name LogState) ()) RootState LogState
-> EventM Name LogState () -> EventM Name RootState ()
forall c.
LensLike' (Zoomed (EventM Name LogState) c) RootState LogState
-> EventM Name LogState c -> EventM Name RootState c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike' (Zoomed (EventM Name LogState) ()) RootState LogState
(LogState -> Focusing (StateT (EventState Name) IO) () LogState)
-> RootState -> Focusing (StateT (EventState Name) IO) () RootState
Lens' RootState LogState
logStateL (EventM Name LogState () -> EventM Name RootState ())
-> EventM Name LogState () -> EventM Name RootState ()
forall a b. (a -> b) -> a -> b
$ Event -> EventM Name LogState ()
handleVtyEventsLogState Event
e

-- * AppEvent handlers

handleTick :: HydraEvent Tx -> EventM Name RootState ()
handleTick :: HydraEvent Tx -> EventM Name RootState ()
handleTick = \case
  Tick UTCTime
now -> (UTCTime -> Identity UTCTime) -> RootState -> Identity RootState
Lens' RootState UTCTime
nowL ((UTCTime -> Identity UTCTime) -> RootState -> Identity RootState)
-> UTCTime -> EventM Name RootState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= UTCTime
now
  HydraEvent Tx
_ -> () -> EventM Name RootState ()
forall a. a -> EventM Name RootState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleHydraEventsConnectedState :: HydraEvent Tx -> EventM Name ConnectedState ()
handleHydraEventsConnectedState :: HydraEvent Tx -> EventM Name ConnectedState ()
handleHydraEventsConnectedState = \case
  HydraEvent Tx
ClientConnected -> ConnectedState -> EventM Name ConnectedState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ConnectedState -> EventM Name ConnectedState ())
-> ConnectedState -> EventM Name ConnectedState ()
forall a b. (a -> b) -> a -> b
$ Connection -> ConnectedState
Connected Connection
emptyConnection
  HydraEvent Tx
ClientDisconnected -> ConnectedState -> EventM Name ConnectedState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ConnectedState
Disconnected
  HydraEvent Tx
_ -> () -> EventM Name ConnectedState ()
forall a. a -> EventM Name ConnectedState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleHydraEventsConnection :: HydraEvent Tx -> EventM Name Connection ()
handleHydraEventsConnection :: HydraEvent Tx -> EventM Name Connection ()
handleHydraEventsConnection = \case
  Update TimedServerOutput{$sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = Greetings{Party
me :: Party
$sel:me:PeerConnected :: forall tx. ServerOutput tx -> Party
me}} -> (IdentifiedState -> Identity IdentifiedState)
-> Connection -> Identity Connection
Lens' Connection IdentifiedState
meL ((IdentifiedState -> Identity IdentifiedState)
 -> Connection -> Identity Connection)
-> IdentifiedState -> EventM Name Connection ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Party -> IdentifiedState
Identified Party
me
  Update TimedServerOutput{$sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = PeerConnected NodeId
p} -> ([NodeId] -> Identity [NodeId])
-> Connection -> Identity Connection
Lens' Connection [NodeId]
peersL (([NodeId] -> Identity [NodeId])
 -> Connection -> Identity Connection)
-> ([NodeId] -> [NodeId]) -> EventM Name Connection ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \[NodeId]
cp -> [NodeId] -> [NodeId]
forall a. Eq a => [a] -> [a]
nub ([NodeId] -> [NodeId]) -> [NodeId] -> [NodeId]
forall a b. (a -> b) -> a -> b
$ [NodeId]
cp [NodeId] -> [NodeId] -> [NodeId]
forall a. Semigroup a => a -> a -> a
<> [NodeId
p]
  Update TimedServerOutput{$sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = PeerDisconnected NodeId
p} -> ([NodeId] -> Identity [NodeId])
-> Connection -> Identity Connection
Lens' Connection [NodeId]
peersL (([NodeId] -> Identity [NodeId])
 -> Connection -> Identity Connection)
-> ([NodeId] -> [NodeId]) -> EventM Name Connection ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \[NodeId]
cp -> [NodeId]
cp [NodeId] -> [NodeId] -> [NodeId]
forall a. Eq a => [a] -> [a] -> [a]
\\ [NodeId
p]
  HydraEvent Tx
e -> LensLike' (Zoomed (EventM Name HeadState) ()) Connection HeadState
-> EventM Name HeadState () -> EventM Name Connection ()
forall c.
LensLike' (Zoomed (EventM Name HeadState) c) Connection HeadState
-> EventM Name HeadState c -> EventM Name Connection c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike' (Zoomed (EventM Name HeadState) ()) Connection HeadState
(HeadState -> Focusing (StateT (EventState Name) IO) () HeadState)
-> Connection
-> Focusing (StateT (EventState Name) IO) () Connection
Lens' Connection HeadState
headStateL (EventM Name HeadState () -> EventM Name Connection ())
-> EventM Name HeadState () -> EventM Name Connection ()
forall a b. (a -> b) -> a -> b
$ HydraEvent Tx -> EventM Name HeadState ()
handleHydraEventsHeadState HydraEvent Tx
e

handleHydraEventsHeadState :: HydraEvent Tx -> EventM Name HeadState ()
handleHydraEventsHeadState :: HydraEvent Tx -> EventM Name HeadState ()
handleHydraEventsHeadState HydraEvent Tx
e = do
  case HydraEvent Tx
e of
    Update TimedServerOutput{UTCTime
time :: UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = HeadIsInitializing{[Party]
parties :: [Party]
$sel:parties:PeerConnected :: forall tx. ServerOutput tx -> [Party]
parties, HeadId
headId :: HeadId
$sel:headId:PeerConnected :: forall tx. ServerOutput tx -> HeadId
headId}} ->
      HeadState -> EventM Name HeadState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (HeadState -> EventM Name HeadState ())
-> HeadState -> EventM Name HeadState ()
forall a b. (a -> b) -> a -> b
$ ActiveLink -> HeadState
Active ([Party] -> HeadId -> ActiveLink
newActiveLink ([Party] -> [Party]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [Party]
parties) HeadId
headId)
    Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = HeadIsAborted{}} ->
      HeadState -> EventM Name HeadState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put HeadState
Idle
    HydraEvent Tx
_ -> () -> EventM Name HeadState ()
forall a. a -> EventM Name HeadState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  LensLike' (Zoomed (EventM Name ActiveLink) ()) HeadState ActiveLink
-> EventM Name ActiveLink () -> EventM Name HeadState ()
forall c.
LensLike' (Zoomed (EventM Name ActiveLink) c) HeadState ActiveLink
-> EventM Name ActiveLink c -> EventM Name HeadState c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike' (Zoomed (EventM Name ActiveLink) ()) HeadState ActiveLink
(ActiveLink
 -> Focusing (StateT (EventState Name) IO) () ActiveLink)
-> HeadState -> Focusing (StateT (EventState Name) IO) () HeadState
Traversal' HeadState ActiveLink
activeLinkL (EventM Name ActiveLink () -> EventM Name HeadState ())
-> EventM Name ActiveLink () -> EventM Name HeadState ()
forall a b. (a -> b) -> a -> b
$ HydraEvent Tx -> EventM Name ActiveLink ()
handleHydraEventsActiveLink HydraEvent Tx
e

handleHydraEventsActiveLink :: HydraEvent Tx -> EventM Name ActiveLink ()
handleHydraEventsActiveLink :: HydraEvent Tx -> EventM Name ActiveLink ()
handleHydraEventsActiveLink HydraEvent Tx
e = do
  case HydraEvent Tx
e of
    Update TimedServerOutput{$sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = Committed{Party
party :: Party
$sel:party:PeerConnected :: forall tx. ServerOutput tx -> Party
party, UTxOType Tx
utxo :: UTxOType Tx
$sel:utxo:PeerConnected :: forall tx. ServerOutput tx -> UTxOType tx
utxo}} -> do
      Party -> UTxO -> EventM Name ActiveLink ()
forall n. Party -> UTxO -> EventM n ActiveLink ()
partyCommitted Party
party UTxO
UTxOType Tx
utxo
    Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = HeadIsOpen{UTxOType Tx
$sel:utxo:PeerConnected :: forall tx. ServerOutput tx -> UTxOType tx
utxo :: UTxOType Tx
utxo}} -> do
      (ActiveHeadState -> Identity ActiveHeadState)
-> ActiveLink -> Identity ActiveLink
Lens' ActiveLink ActiveHeadState
activeHeadStateL ((ActiveHeadState -> Identity ActiveHeadState)
 -> ActiveLink -> Identity ActiveLink)
-> ActiveHeadState -> EventM Name ActiveLink ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= OpenScreen -> ActiveHeadState
Open OpenScreen
OpenHome
    Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = SnapshotConfirmed{$sel:snapshot:PeerConnected :: forall tx. ServerOutput tx -> Snapshot tx
snapshot = Snapshot{UTxOType Tx
utxo :: UTxOType Tx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo}}} ->
      (UTxO -> Identity UTxO) -> ActiveLink -> Identity ActiveLink
Lens' ActiveLink UTxO
utxoL ((UTxO -> Identity UTxO) -> ActiveLink -> Identity ActiveLink)
-> UTxO -> EventM Name ActiveLink ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= UTxO
UTxOType Tx
utxo
    Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = HeadIsClosed{HeadId
$sel:headId:PeerConnected :: forall tx. ServerOutput tx -> HeadId
headId :: HeadId
headId, SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:PeerConnected :: forall tx. ServerOutput tx -> SnapshotNumber
snapshotNumber, UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:PeerConnected :: forall tx. ServerOutput tx -> UTCTime
contestationDeadline}} -> do
      (ActiveHeadState -> Identity ActiveHeadState)
-> ActiveLink -> Identity ActiveLink
Lens' ActiveLink ActiveHeadState
activeHeadStateL ((ActiveHeadState -> Identity ActiveHeadState)
 -> ActiveLink -> Identity ActiveLink)
-> ActiveHeadState -> EventM Name ActiveLink ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Closed{$sel:closedState:Initializing :: ClosedState
closedState = ClosedState{UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:ClosedState :: UTCTime
contestationDeadline}}
    Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = ReadyToFanout{}} ->
      (ActiveHeadState -> Identity ActiveHeadState)
-> ActiveLink -> Identity ActiveLink
Lens' ActiveLink ActiveHeadState
activeHeadStateL ((ActiveHeadState -> Identity ActiveHeadState)
 -> ActiveLink -> Identity ActiveLink)
-> ActiveHeadState -> EventM Name ActiveLink ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ActiveHeadState
FanoutPossible
    Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = HeadIsFinalized{UTxOType Tx
$sel:utxo:PeerConnected :: forall tx. ServerOutput tx -> UTxOType tx
utxo :: UTxOType Tx
utxo}} -> do
      (UTxO -> Identity UTxO) -> ActiveLink -> Identity ActiveLink
Lens' ActiveLink UTxO
utxoL ((UTxO -> Identity UTxO) -> ActiveLink -> Identity ActiveLink)
-> UTxO -> EventM Name ActiveLink ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= UTxO
UTxOType Tx
utxo
      (ActiveHeadState -> Identity ActiveHeadState)
-> ActiveLink -> Identity ActiveLink
Lens' ActiveLink ActiveHeadState
activeHeadStateL ((ActiveHeadState -> Identity ActiveHeadState)
 -> ActiveLink -> Identity ActiveLink)
-> ActiveHeadState -> EventM Name ActiveLink ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ActiveHeadState
Final
    Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = DecommitRequested{UTxOType Tx
utxoToDecommit :: UTxOType Tx
$sel:utxoToDecommit:PeerConnected :: forall tx. ServerOutput tx -> UTxOType tx
utxoToDecommit}} ->
      (UTxO -> Identity UTxO) -> ActiveLink -> Identity ActiveLink
Lens' ActiveLink UTxO
pendingUTxOToDecommitL ((UTxO -> Identity UTxO) -> ActiveLink -> Identity ActiveLink)
-> UTxO -> EventM Name ActiveLink ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= UTxO
UTxOType Tx
utxoToDecommit
    Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = DecommitFinalized{}} ->
      (UTxO -> Identity UTxO) -> ActiveLink -> Identity ActiveLink
Lens' ActiveLink UTxO
pendingUTxOToDecommitL ((UTxO -> Identity UTxO) -> ActiveLink -> Identity ActiveLink)
-> UTxO -> EventM Name ActiveLink ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= UTxO
forall a. Monoid a => a
mempty
    HydraEvent Tx
_ -> () -> EventM Name ActiveLink ()
forall a. a -> EventM Name ActiveLink a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleHydraEventsInfo :: HydraEvent Tx -> EventM Name [LogMessage] ()
handleHydraEventsInfo :: HydraEvent Tx -> EventM Name [LogMessage] ()
handleHydraEventsInfo = \case
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = HeadIsInitializing{[Party]
$sel:parties:PeerConnected :: forall tx. ServerOutput tx -> [Party]
parties :: [Party]
parties, HeadId
$sel:headId:PeerConnected :: forall tx. ServerOutput tx -> HeadId
headId :: HeadId
headId}} ->
    UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
info UTCTime
time Name
"Head is initializing"
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = Committed{Party
$sel:party:PeerConnected :: forall tx. ServerOutput tx -> Party
party :: Party
party, UTxOType Tx
$sel:utxo:PeerConnected :: forall tx. ServerOutput tx -> UTxOType tx
utxo :: UTxOType Tx
utxo}} -> do
    UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
info UTCTime
time (Name -> EventM Name [LogMessage] ())
-> Name -> EventM Name [LogMessage] ()
forall a b. (a -> b) -> a -> b
$ Party -> Name
forall b a. (Show a, IsString b) => a -> b
show Party
party Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" committed " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Value -> Name
renderValue (forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance @Tx UTxOType Tx
utxo)
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = HeadIsOpen{UTxOType Tx
$sel:utxo:PeerConnected :: forall tx. ServerOutput tx -> UTxOType tx
utxo :: UTxOType Tx
utxo}} -> do
    UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
info UTCTime
time Name
"Head is now open!"
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = HeadIsAborted{}} -> do
    UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
info UTCTime
time Name
"Head aborted, back to square one."
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = SnapshotConfirmed{$sel:snapshot:PeerConnected :: forall tx. ServerOutput tx -> Snapshot tx
snapshot = Snapshot{SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number}}} ->
    UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
info UTCTime
time (Name
"Snapshot #" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> SnapshotNumber -> Name
forall b a. (Show a, IsString b) => a -> b
show SnapshotNumber
number Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" confirmed.")
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = CommandFailed{ClientInput Tx
clientInput :: ClientInput Tx
$sel:clientInput:PeerConnected :: forall tx. ServerOutput tx -> ClientInput tx
clientInput}} -> do
    UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
warn UTCTime
time (Name -> EventM Name [LogMessage] ())
-> Name -> EventM Name [LogMessage] ()
forall a b. (a -> b) -> a -> b
$ Name
"Invalid command: " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> ClientInput Tx -> Name
forall b a. (Show a, IsString b) => a -> b
show ClientInput Tx
clientInput
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = HeadIsClosed{SnapshotNumber
$sel:snapshotNumber:PeerConnected :: forall tx. ServerOutput tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber}} -> do
    UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
info UTCTime
time (Name -> EventM Name [LogMessage] ())
-> Name -> EventM Name [LogMessage] ()
forall a b. (a -> b) -> a -> b
$ Name
"Head closed with snapshot number " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> SnapshotNumber -> Name
forall b a. (Show a, IsString b) => a -> b
show SnapshotNumber
snapshotNumber
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = HeadIsContested{SnapshotNumber
$sel:snapshotNumber:PeerConnected :: forall tx. ServerOutput tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber, UTCTime
$sel:contestationDeadline:PeerConnected :: forall tx. ServerOutput tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline}} -> do
    UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
info UTCTime
time (Name
"Head contested with snapshot number " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> SnapshotNumber -> Name
forall b a. (Show a, IsString b) => a -> b
show SnapshotNumber
snapshotNumber Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" and deadline " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> UTCTime -> Name
forall b a. (Show a, IsString b) => a -> b
show UTCTime
contestationDeadline)
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = TxValid{}} ->
    Severity -> UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. Severity -> UTCTime -> Name -> EventM n [LogMessage] ()
report Severity
Success UTCTime
time Name
"Transaction submitted successfully"
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = TxInvalid{Tx
transaction :: Tx
$sel:transaction:PeerConnected :: forall tx. ServerOutput tx -> tx
transaction, ValidationError
validationError :: ValidationError
$sel:validationError:PeerConnected :: forall tx. ServerOutput tx -> ValidationError
validationError}} ->
    UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
warn UTCTime
time (Name
"Transaction with id " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> TxId -> Name
forall b a. (Show a, IsString b) => a -> b
show (Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
transaction) Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" is not applicable: " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> ValidationError -> Name
forall b a. (Show a, IsString b) => a -> b
show ValidationError
validationError)
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = DecommitApproved{}} ->
    Severity -> UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. Severity -> UTCTime -> Name -> EventM n [LogMessage] ()
report Severity
Success UTCTime
time Name
"Decommit approved and submitted to Cardano"
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = DecommitInvalid{Tx
decommitTx :: Tx
$sel:decommitTx:PeerConnected :: forall tx. ServerOutput tx -> tx
decommitTx, DecommitInvalidReason Tx
decommitInvalidReason :: DecommitInvalidReason Tx
$sel:decommitInvalidReason:PeerConnected :: forall tx. ServerOutput tx -> DecommitInvalidReason tx
decommitInvalidReason}} ->
    UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
warn UTCTime
time (Name
"Decommit Transaction with id " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> TxId -> Name
forall b a. (Show a, IsString b) => a -> b
show (Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
decommitTx) Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" is not applicable: " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> DecommitInvalidReason Tx -> Name
forall b a. (Show a, IsString b) => a -> b
show DecommitInvalidReason Tx
decommitInvalidReason)
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = HeadIsFinalized{UTxOType Tx
$sel:utxo:PeerConnected :: forall tx. ServerOutput tx -> UTxOType tx
utxo :: UTxOType Tx
utxo}} -> do
    UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
info UTCTime
time Name
"Head is finalized"
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = InvalidInput{String
reason :: String
$sel:reason:PeerConnected :: forall tx. ServerOutput tx -> String
reason}} ->
    UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
warn UTCTime
time (Name
"Invalid input error: " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> String -> Name
forall a. ToText a => a -> Name
toText String
reason)
  Update TimedServerOutput{UTCTime
$sel:time:TimedServerOutput :: forall tx. TimedServerOutput tx -> UTCTime
time :: UTCTime
time, $sel:output:TimedServerOutput :: forall tx. TimedServerOutput tx -> ServerOutput tx
output = PostTxOnChainFailed{PostTxError Tx
postTxError :: PostTxError Tx
$sel:postTxError:PeerConnected :: forall tx. ServerOutput tx -> PostTxError tx
postTxError}} ->
    case PostTxError Tx
postTxError of
      PostTxError Tx
NotEnoughFuel -> do
        UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
warn UTCTime
time Name
"Not enough Fuel. Please provide more to the internal wallet and try again."
      InternalWalletError{Name
$sel:reason:NoSeedInput :: forall tx. PostTxError tx -> Name
reason :: Name
reason} ->
        UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
warn UTCTime
time Name
reason
      PostTxError Tx
_ -> UTCTime -> Name -> EventM Name [LogMessage] ()
forall n. UTCTime -> Name -> EventM n [LogMessage] ()
warn UTCTime
time (Name
"An error happened while trying to post a transaction on-chain: " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> PostTxError Tx -> Name
forall b a. (Show a, IsString b) => a -> b
show PostTxError Tx
postTxError)
  HydraEvent Tx
_ -> () -> EventM Name [LogMessage] ()
forall a. a -> EventM Name [LogMessage] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

partyCommitted :: Party -> UTxO -> EventM n ActiveLink ()
partyCommitted :: forall n. Party -> UTxO -> EventM n ActiveLink ()
partyCommitted Party
party UTxO
commit = do
  LensLike'
  (Zoomed (EventM n InitializingState) ())
  ActiveLink
  InitializingState
-> EventM n InitializingState () -> EventM n ActiveLink ()
forall c.
LensLike'
  (Zoomed (EventM n InitializingState) c)
  ActiveLink
  InitializingState
-> EventM n InitializingState c -> EventM n ActiveLink c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom ((ActiveHeadState
 -> Zoomed (EventM n InitializingState) () ActiveHeadState)
-> ActiveLink -> Zoomed (EventM n InitializingState) () ActiveLink
Lens' ActiveLink ActiveHeadState
activeHeadStateL ((ActiveHeadState
  -> Zoomed (EventM n InitializingState) () ActiveHeadState)
 -> ActiveLink -> Zoomed (EventM n InitializingState) () ActiveLink)
-> ((InitializingState
     -> Zoomed (EventM n InitializingState) () InitializingState)
    -> ActiveHeadState
    -> Zoomed (EventM n InitializingState) () ActiveHeadState)
-> LensLike'
     (Zoomed (EventM n InitializingState) ())
     ActiveLink
     InitializingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializingState
 -> Zoomed (EventM n InitializingState) () InitializingState)
-> ActiveHeadState
-> Zoomed (EventM n InitializingState) () ActiveHeadState
Traversal' ActiveHeadState InitializingState
initializingStateL) (EventM n InitializingState () -> EventM n ActiveLink ())
-> EventM n InitializingState () -> EventM n ActiveLink ()
forall a b. (a -> b) -> a -> b
$ do
    ([Party] -> Identity [Party])
-> InitializingState -> Identity InitializingState
Lens' InitializingState [Party]
remainingPartiesL (([Party] -> Identity [Party])
 -> InitializingState -> Identity InitializingState)
-> ([Party] -> [Party]) -> EventM n InitializingState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ([Party] -> [Party] -> [Party]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Party
party])
  (UTxO -> Identity UTxO) -> ActiveLink -> Identity ActiveLink
Lens' ActiveLink UTxO
utxoL ((UTxO -> Identity UTxO) -> ActiveLink -> Identity ActiveLink)
-> (UTxO -> UTxO) -> EventM n ActiveLink ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
commit)

-- * VtyEvent handlers

handleVtyEventsHeadState :: CardanoClient -> Client Tx IO -> Vty.Event -> EventM Name HeadState ()
handleVtyEventsHeadState :: CardanoClient -> Client Tx IO -> Event -> EventM Name HeadState ()
handleVtyEventsHeadState CardanoClient
cardanoClient Client Tx IO
hydraClient Event
e = do
  HeadState
h <- Getting HeadState HeadState HeadState
-> EventM Name HeadState HeadState
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting HeadState HeadState HeadState
forall a. a -> a
id
  case HeadState
h of
    HeadState
Idle -> case Event
e of
      EvKey (KChar Char
'i') [] -> IO () -> EventM Name HeadState ()
forall a. IO a -> EventM Name HeadState a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Client Tx IO -> ClientInput Tx -> IO ()
forall tx (m :: * -> *). Client tx m -> ClientInput tx -> m ()
sendInput Client Tx IO
hydraClient ClientInput Tx
forall tx. ClientInput tx
Init)
      Event
_ -> () -> EventM Name HeadState ()
forall a. a -> EventM Name HeadState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    HeadState
_ -> () -> EventM Name HeadState ()
forall a. a -> EventM Name HeadState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  LensLike' (Zoomed (EventM Name ActiveLink) ()) HeadState ActiveLink
-> EventM Name ActiveLink () -> EventM Name HeadState ()
forall c.
LensLike' (Zoomed (EventM Name ActiveLink) c) HeadState ActiveLink
-> EventM Name ActiveLink c -> EventM Name HeadState c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike' (Zoomed (EventM Name ActiveLink) ()) HeadState ActiveLink
(ActiveLink
 -> Focusing (StateT (EventState Name) IO) () ActiveLink)
-> HeadState -> Focusing (StateT (EventState Name) IO) () HeadState
Traversal' HeadState ActiveLink
activeLinkL (EventM Name ActiveLink () -> EventM Name HeadState ())
-> EventM Name ActiveLink () -> EventM Name HeadState ()
forall a b. (a -> b) -> a -> b
$ CardanoClient -> Client Tx IO -> Event -> EventM Name ActiveLink ()
handleVtyEventsActiveLink CardanoClient
cardanoClient Client Tx IO
hydraClient Event
e

handleVtyEventsActiveLink :: CardanoClient -> Client Tx IO -> Vty.Event -> EventM Name ActiveLink ()
handleVtyEventsActiveLink :: CardanoClient -> Client Tx IO -> Event -> EventM Name ActiveLink ()
handleVtyEventsActiveLink CardanoClient
cardanoClient Client Tx IO
hydraClient Event
e = do
  UTxO
utxo <- Getting UTxO ActiveLink UTxO -> EventM Name ActiveLink UTxO
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting UTxO ActiveLink UTxO
Lens' ActiveLink UTxO
utxoL
  LensLike'
  (Zoomed (EventM Name ActiveHeadState) ())
  ActiveLink
  ActiveHeadState
-> EventM Name ActiveHeadState () -> EventM Name ActiveLink ()
forall c.
LensLike'
  (Zoomed (EventM Name ActiveHeadState) c) ActiveLink ActiveHeadState
-> EventM Name ActiveHeadState c -> EventM Name ActiveLink c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed (EventM Name ActiveHeadState) ())
  ActiveLink
  ActiveHeadState
(ActiveHeadState
 -> Focusing (StateT (EventState Name) IO) () ActiveHeadState)
-> ActiveLink
-> Focusing (StateT (EventState Name) IO) () ActiveLink
Lens' ActiveLink ActiveHeadState
activeHeadStateL (EventM Name ActiveHeadState () -> EventM Name ActiveLink ())
-> EventM Name ActiveHeadState () -> EventM Name ActiveLink ()
forall a b. (a -> b) -> a -> b
$ CardanoClient
-> Client Tx IO -> UTxO -> Event -> EventM Name ActiveHeadState ()
handleVtyEventsActiveHeadState CardanoClient
cardanoClient Client Tx IO
hydraClient UTxO
utxo Event
e

handleVtyEventsActiveHeadState :: CardanoClient -> Client Tx IO -> UTxO -> Vty.Event -> EventM Name ActiveHeadState ()
handleVtyEventsActiveHeadState :: CardanoClient
-> Client Tx IO -> UTxO -> Event -> EventM Name ActiveHeadState ()
handleVtyEventsActiveHeadState CardanoClient
cardanoClient Client Tx IO
hydraClient UTxO
utxo Event
e = do
  LensLike'
  (Zoomed (EventM Name InitializingScreen) ())
  ActiveHeadState
  InitializingScreen
-> EventM Name InitializingScreen ()
-> EventM Name ActiveHeadState ()
forall c.
LensLike'
  (Zoomed (EventM Name InitializingScreen) c)
  ActiveHeadState
  InitializingScreen
-> EventM Name InitializingScreen c
-> EventM Name ActiveHeadState c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom ((InitializingState
 -> Focusing (StateT (EventState Name) IO) () InitializingState)
-> ActiveHeadState
-> Focusing (StateT (EventState Name) IO) () ActiveHeadState
Traversal' ActiveHeadState InitializingState
initializingStateL ((InitializingState
  -> Focusing (StateT (EventState Name) IO) () InitializingState)
 -> ActiveHeadState
 -> Focusing (StateT (EventState Name) IO) () ActiveHeadState)
-> ((InitializingScreen
     -> Focusing (StateT (EventState Name) IO) () InitializingScreen)
    -> InitializingState
    -> Focusing (StateT (EventState Name) IO) () InitializingState)
-> (InitializingScreen
    -> Focusing (StateT (EventState Name) IO) () InitializingScreen)
-> ActiveHeadState
-> Focusing (StateT (EventState Name) IO) () ActiveHeadState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializingScreen
 -> Focusing (StateT (EventState Name) IO) () InitializingScreen)
-> InitializingState
-> Focusing (StateT (EventState Name) IO) () InitializingState
Lens' InitializingState InitializingScreen
initializingScreenL) (EventM Name InitializingScreen ()
 -> EventM Name ActiveHeadState ())
-> EventM Name InitializingScreen ()
-> EventM Name ActiveHeadState ()
forall a b. (a -> b) -> a -> b
$ CardanoClient
-> Client Tx IO -> Event -> EventM Name InitializingScreen ()
handleVtyEventsInitializingScreen CardanoClient
cardanoClient Client Tx IO
hydraClient Event
e
  LensLike'
  (Zoomed (EventM Name OpenScreen) ()) ActiveHeadState OpenScreen
-> EventM Name OpenScreen () -> EventM Name ActiveHeadState ()
forall c.
LensLike'
  (Zoomed (EventM Name OpenScreen) c) ActiveHeadState OpenScreen
-> EventM Name OpenScreen c -> EventM Name ActiveHeadState c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed (EventM Name OpenScreen) ()) ActiveHeadState OpenScreen
(OpenScreen
 -> Focusing (StateT (EventState Name) IO) () OpenScreen)
-> ActiveHeadState
-> Focusing (StateT (EventState Name) IO) () ActiveHeadState
Traversal' ActiveHeadState OpenScreen
openStateL (EventM Name OpenScreen () -> EventM Name ActiveHeadState ())
-> EventM Name OpenScreen () -> EventM Name ActiveHeadState ()
forall a b. (a -> b) -> a -> b
$ CardanoClient
-> Client Tx IO -> UTxO -> Event -> EventM Name OpenScreen ()
handleVtyEventsOpen CardanoClient
cardanoClient Client Tx IO
hydraClient UTxO
utxo Event
e
  ActiveHeadState
s <- Getting ActiveHeadState ActiveHeadState ActiveHeadState
-> EventM Name ActiveHeadState ActiveHeadState
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ActiveHeadState ActiveHeadState ActiveHeadState
forall a. a -> a
id
  case ActiveHeadState
s of
    ActiveHeadState
FanoutPossible -> Client Tx IO -> Event -> EventM Name ActiveHeadState ()
forall s. Client Tx IO -> Event -> EventM Name s ()
handleVtyEventsFanoutPossible Client Tx IO
hydraClient Event
e
    ActiveHeadState
Final -> Client Tx IO -> Event -> EventM Name ActiveHeadState ()
forall s. Client Tx IO -> Event -> EventM Name s ()
handleVtyEventsFinal Client Tx IO
hydraClient Event
e
    ActiveHeadState
_ -> () -> EventM Name ActiveHeadState ()
forall a. a -> EventM Name ActiveHeadState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleVtyEventsInitializingScreen :: CardanoClient -> Client Tx IO -> Vty.Event -> EventM Name InitializingScreen ()
handleVtyEventsInitializingScreen :: CardanoClient
-> Client Tx IO -> Event -> EventM Name InitializingScreen ()
handleVtyEventsInitializingScreen CardanoClient
cardanoClient Client Tx IO
hydraClient Event
e = do
  case Event
e of
    EvKey (KChar Char
'a') [] ->
      InitializingScreen -> EventM Name InitializingScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (InitializingScreen -> EventM Name InitializingScreen ())
-> InitializingScreen -> EventM Name InitializingScreen ()
forall a b. (a -> b) -> a -> b
$ Form Bool (HydraEvent Tx) Name -> InitializingScreen
ConfirmingAbort Form Bool (HydraEvent Tx) Name
forall s e n. (s ~ Bool, n ~ Name) => Form s e n
confirmRadioField
    Event
_ -> () -> EventM Name InitializingScreen ()
forall a. a -> EventM Name InitializingScreen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  InitializingScreen
initializingScreen <- Getting InitializingScreen InitializingScreen InitializingScreen
-> EventM Name InitializingScreen InitializingScreen
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting InitializingScreen InitializingScreen InitializingScreen
forall a. a -> a
id
  case InitializingScreen
initializingScreen of
    InitializingScreen
InitializingHome -> case Event
e of
      EvKey (KChar Char
'c') [] -> do
        UTxO
utxo <- IO UTxO -> EventM Name InitializingScreen UTxO
forall a. IO a -> EventM Name InitializingScreen a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTxO -> EventM Name InitializingScreen UTxO)
-> IO UTxO -> EventM Name InitializingScreen UTxO
forall a b. (a -> b) -> a -> b
$ CardanoClient -> [Address ShelleyAddr] -> IO UTxO
queryUTxOByAddress CardanoClient
cardanoClient [CardanoClient -> Client Tx IO -> Address ShelleyAddr
mkMyAddress CardanoClient
cardanoClient Client Tx IO
hydraClient]
        InitializingScreen -> EventM Name InitializingScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (InitializingScreen -> EventM Name InitializingScreen ())
-> InitializingScreen -> EventM Name InitializingScreen ()
forall a b. (a -> b) -> a -> b
$ Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name
-> InitializingScreen
CommitMenu (Map TxIn (TxOut CtxUTxO)
-> Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name
forall s e n.
(s ~ Map TxIn (TxOut CtxUTxO, Bool), n ~ Name) =>
Map TxIn (TxOut CtxUTxO) -> Form s e n
utxoCheckboxField (Map TxIn (TxOut CtxUTxO)
 -> Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name)
-> Map TxIn (TxOut CtxUTxO)
-> Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name
forall a b. (a -> b) -> a -> b
$ UTxO -> Map TxIn (TxOut CtxUTxO)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap UTxO
utxo)
      Event
_ -> () -> EventM Name InitializingScreen ()
forall a. a -> EventM Name InitializingScreen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    CommitMenu Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name
i -> do
      case Event
e of
        EvKey Key
KEsc [] -> InitializingScreen -> EventM Name InitializingScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put InitializingScreen
InitializingHome
        EvKey Key
KEnter [] -> do
          let u :: Map TxIn (TxOut CtxUTxO, Bool)
u = Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name
-> Map TxIn (TxOut CtxUTxO, Bool)
forall s e n. Form s e n -> s
formState Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name
i
          let commitUTxO :: UTxO
commitUTxO = Map TxIn (TxOut CtxUTxO) -> UTxO
forall out. Map TxIn out -> UTxO' out
UTxO (Map TxIn (TxOut CtxUTxO) -> UTxO)
-> Map TxIn (TxOut CtxUTxO) -> UTxO
forall a b. (a -> b) -> a -> b
$ ((TxOut CtxUTxO, Bool) -> Maybe (TxOut CtxUTxO))
-> Map TxIn (TxOut CtxUTxO, Bool) -> Map TxIn (TxOut CtxUTxO)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (\(TxOut CtxUTxO
v, Bool
p) -> if Bool
p then TxOut CtxUTxO -> Maybe (TxOut CtxUTxO)
forall a. a -> Maybe a
Just TxOut CtxUTxO
v else Maybe (TxOut CtxUTxO)
forall a. Maybe a
Nothing) Map TxIn (TxOut CtxUTxO, Bool)
u
          IO () -> EventM Name InitializingScreen ()
forall a. IO a -> EventM Name InitializingScreen a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EventM Name InitializingScreen ())
-> IO () -> EventM Name InitializingScreen ()
forall a b. (a -> b) -> a -> b
$ Client Tx IO -> UTxO -> IO ()
forall tx (m :: * -> *). Client tx m -> UTxO -> m ()
externalCommit Client Tx IO
hydraClient UTxO
commitUTxO
          InitializingScreen -> EventM Name InitializingScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put InitializingScreen
InitializingHome
        Event
_ -> () -> EventM Name InitializingScreen ()
forall a. a -> EventM Name InitializingScreen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      LensLike'
  (Zoomed
     (EventM
        Name (Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name))
     ())
  InitializingScreen
  (Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name)
-> EventM
     Name
     (Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name)
     ()
-> EventM Name InitializingScreen ()
forall c.
LensLike'
  (Zoomed
     (EventM
        Name (Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name))
     c)
  InitializingScreen
  (Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name)
-> EventM
     Name (Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name) c
-> EventM Name InitializingScreen c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed
     (EventM
        Name (Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name))
     ())
  InitializingScreen
  (Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name)
(Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name
 -> Focusing
      (StateT (EventState Name) IO)
      ()
      (Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name))
-> InitializingScreen
-> Focusing (StateT (EventState Name) IO) () InitializingScreen
Traversal'
  InitializingScreen
  (Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name)
commitMenuL (EventM
   Name
   (Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name)
   ()
 -> EventM Name InitializingScreen ())
-> EventM
     Name
     (Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name)
     ()
-> EventM Name InitializingScreen ()
forall a b. (a -> b) -> a -> b
$ BrickEvent Name (HydraEvent Tx)
-> EventM
     Name
     (Form (Map TxIn (TxOut CtxUTxO, Bool)) (HydraEvent Tx) Name)
     ()
forall n e s. Eq n => BrickEvent n e -> EventM n (Form s e n) ()
handleFormEvent (Event -> BrickEvent Name (HydraEvent Tx)
forall n e. Event -> BrickEvent n e
VtyEvent Event
e)
    ConfirmingAbort Form Bool (HydraEvent Tx) Name
i -> do
      case Event
e of
        EvKey Key
KEsc [] -> InitializingScreen -> EventM Name InitializingScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put InitializingScreen
InitializingHome
        EvKey Key
KEnter [] -> do
          let selected :: Bool
selected = Form Bool (HydraEvent Tx) Name -> Bool
forall s e n. Form s e n -> s
formState Form Bool (HydraEvent Tx) Name
i
          if Bool
selected
            then IO () -> EventM Name InitializingScreen ()
forall a. IO a -> EventM Name InitializingScreen a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EventM Name InitializingScreen ())
-> IO () -> EventM Name InitializingScreen ()
forall a b. (a -> b) -> a -> b
$ Client Tx IO -> ClientInput Tx -> IO ()
forall tx (m :: * -> *). Client tx m -> ClientInput tx -> m ()
sendInput Client Tx IO
hydraClient ClientInput Tx
forall tx. ClientInput tx
Abort
            else InitializingScreen -> EventM Name InitializingScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put InitializingScreen
InitializingHome
        Event
_ -> () -> EventM Name InitializingScreen ()
forall a. a -> EventM Name InitializingScreen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      LensLike'
  (Zoomed (EventM Name (Form Bool (HydraEvent Tx) Name)) ())
  InitializingScreen
  (Form Bool (HydraEvent Tx) Name)
-> EventM Name (Form Bool (HydraEvent Tx) Name) ()
-> EventM Name InitializingScreen ()
forall c.
LensLike'
  (Zoomed (EventM Name (Form Bool (HydraEvent Tx) Name)) c)
  InitializingScreen
  (Form Bool (HydraEvent Tx) Name)
-> EventM Name (Form Bool (HydraEvent Tx) Name) c
-> EventM Name InitializingScreen c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed (EventM Name (Form Bool (HydraEvent Tx) Name)) ())
  InitializingScreen
  (Form Bool (HydraEvent Tx) Name)
(Form Bool (HydraEvent Tx) Name
 -> Focusing
      (StateT (EventState Name) IO) () (Form Bool (HydraEvent Tx) Name))
-> InitializingScreen
-> Focusing (StateT (EventState Name) IO) () InitializingScreen
Traversal' InitializingScreen (Form Bool (HydraEvent Tx) Name)
confirmingAbortFormL (EventM Name (Form Bool (HydraEvent Tx) Name) ()
 -> EventM Name InitializingScreen ())
-> EventM Name (Form Bool (HydraEvent Tx) Name) ()
-> EventM Name InitializingScreen ()
forall a b. (a -> b) -> a -> b
$ BrickEvent Name (HydraEvent Tx)
-> EventM Name (Form Bool (HydraEvent Tx) Name) ()
forall n e s. Eq n => BrickEvent n e -> EventM n (Form s e n) ()
handleFormEvent (Event -> BrickEvent Name (HydraEvent Tx)
forall n e. Event -> BrickEvent n e
VtyEvent Event
e)

handleVtyEventsOpen :: CardanoClient -> Client Tx IO -> UTxO -> Vty.Event -> EventM Name OpenScreen ()
handleVtyEventsOpen :: CardanoClient
-> Client Tx IO -> UTxO -> Event -> EventM Name OpenScreen ()
handleVtyEventsOpen CardanoClient
cardanoClient Client Tx IO
hydraClient UTxO
utxo Event
e =
  EventM Name OpenScreen OpenScreen
forall s (m :: * -> *). MonadState s m => m s
get EventM Name OpenScreen OpenScreen
-> (OpenScreen -> EventM Name OpenScreen ())
-> EventM Name OpenScreen ()
forall a b.
EventM Name OpenScreen a
-> (a -> EventM Name OpenScreen b) -> EventM Name OpenScreen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    OpenScreen
OpenHome -> do
      case Event
e of
        EvKey (KChar Char
'n') [] -> do
          let utxo' :: Map TxIn (TxOut CtxUTxO)
utxo' = NetworkId
-> VerificationKey PaymentKey -> UTxO -> Map TxIn (TxOut CtxUTxO)
myAvailableUTxO (CardanoClient -> NetworkId
networkId CardanoClient
cardanoClient) (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> SigningKey PaymentKey -> VerificationKey PaymentKey
forall a b. (a -> b) -> a -> b
$ Client Tx IO -> SigningKey PaymentKey
forall tx (m :: * -> *). Client tx m -> SigningKey PaymentKey
sk Client Tx IO
hydraClient) UTxO
utxo
          OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (OpenScreen -> EventM Name OpenScreen ())
-> OpenScreen -> EventM Name OpenScreen ()
forall a b. (a -> b) -> a -> b
$ Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name -> OpenScreen
SelectingUTxO (Map TxIn (TxOut CtxUTxO)
-> Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name
forall s e n.
(s ~ (TxIn, TxOut CtxUTxO), n ~ Name) =>
Map TxIn (TxOut CtxUTxO) -> Form s e n
utxoRadioField Map TxIn (TxOut CtxUTxO)
utxo')
        EvKey (KChar Char
'd') [] -> do
          let utxo' :: Map TxIn (TxOut CtxUTxO)
utxo' = NetworkId
-> VerificationKey PaymentKey -> UTxO -> Map TxIn (TxOut CtxUTxO)
myAvailableUTxO (CardanoClient -> NetworkId
networkId CardanoClient
cardanoClient) (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> SigningKey PaymentKey -> VerificationKey PaymentKey
forall a b. (a -> b) -> a -> b
$ Client Tx IO -> SigningKey PaymentKey
forall tx (m :: * -> *). Client tx m -> SigningKey PaymentKey
sk Client Tx IO
hydraClient) UTxO
utxo
          OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (OpenScreen -> EventM Name OpenScreen ())
-> OpenScreen -> EventM Name OpenScreen ()
forall a b. (a -> b) -> a -> b
$ Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name -> OpenScreen
SelectingUTxOToDecommit (Map TxIn (TxOut CtxUTxO)
-> Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name
forall s e n.
(s ~ (TxIn, TxOut CtxUTxO), n ~ Name) =>
Map TxIn (TxOut CtxUTxO) -> Form s e n
utxoRadioField Map TxIn (TxOut CtxUTxO)
utxo')
        EvKey (KChar Char
'c') [] ->
          OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (OpenScreen -> EventM Name OpenScreen ())
-> OpenScreen -> EventM Name OpenScreen ()
forall a b. (a -> b) -> a -> b
$ Form Bool (HydraEvent Tx) Name -> OpenScreen
ConfirmingClose Form Bool (HydraEvent Tx) Name
forall s e n. (s ~ Bool, n ~ Name) => Form s e n
confirmRadioField
        Event
_ -> () -> EventM Name OpenScreen ()
forall a. a -> EventM Name OpenScreen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ConfirmingClose Form Bool (HydraEvent Tx) Name
i ->
      case Event
e of
        EvKey Key
KEsc [] -> OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put OpenScreen
OpenHome
        EvKey Key
KEnter [] -> do
          let selected :: Bool
selected = Form Bool (HydraEvent Tx) Name -> Bool
forall s e n. Form s e n -> s
formState Form Bool (HydraEvent Tx) Name
i
          if Bool
selected
            then IO () -> EventM Name OpenScreen ()
forall a. IO a -> EventM Name OpenScreen a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EventM Name OpenScreen ())
-> IO () -> EventM Name OpenScreen ()
forall a b. (a -> b) -> a -> b
$ Client Tx IO -> ClientInput Tx -> IO ()
forall tx (m :: * -> *). Client tx m -> ClientInput tx -> m ()
sendInput Client Tx IO
hydraClient ClientInput Tx
forall tx. ClientInput tx
Close
            else OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put OpenScreen
OpenHome
        Event
_ -> LensLike'
  (Zoomed (EventM Name (Form Bool (HydraEvent Tx) Name)) ())
  OpenScreen
  (Form Bool (HydraEvent Tx) Name)
-> EventM Name (Form Bool (HydraEvent Tx) Name) ()
-> EventM Name OpenScreen ()
forall c.
LensLike'
  (Zoomed (EventM Name (Form Bool (HydraEvent Tx) Name)) c)
  OpenScreen
  (Form Bool (HydraEvent Tx) Name)
-> EventM Name (Form Bool (HydraEvent Tx) Name) c
-> EventM Name OpenScreen c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed (EventM Name (Form Bool (HydraEvent Tx) Name)) ())
  OpenScreen
  (Form Bool (HydraEvent Tx) Name)
(Form Bool (HydraEvent Tx) Name
 -> Focusing
      (StateT (EventState Name) IO) () (Form Bool (HydraEvent Tx) Name))
-> OpenScreen
-> Focusing (StateT (EventState Name) IO) () OpenScreen
Traversal' OpenScreen (Form Bool (HydraEvent Tx) Name)
confirmingCloseFormL (EventM Name (Form Bool (HydraEvent Tx) Name) ()
 -> EventM Name OpenScreen ())
-> EventM Name (Form Bool (HydraEvent Tx) Name) ()
-> EventM Name OpenScreen ()
forall a b. (a -> b) -> a -> b
$ BrickEvent Name (HydraEvent Tx)
-> EventM Name (Form Bool (HydraEvent Tx) Name) ()
forall n e s. Eq n => BrickEvent n e -> EventM n (Form s e n) ()
handleFormEvent (Event -> BrickEvent Name (HydraEvent Tx)
forall n e. Event -> BrickEvent n e
VtyEvent Event
e)
    SelectingUTxO Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name
i ->
      case Event
e of
        EvKey Key
KEsc [] -> OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put OpenScreen
OpenHome
        EvKey Key
KEnter [] -> do
          let utxoSelected :: (TxIn, TxOut CtxUTxO)
utxoSelected@(TxIn
_, TxOut{txOutValue :: forall ctx. TxOut ctx -> Value
txOutValue = Value
v}) = Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name
-> (TxIn, TxOut CtxUTxO)
forall s e n. Form s e n -> s
formState Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name
i
          let Coin Integer
limit = Value -> Coin
selectLovelace Value
v
          let enteringAmountForm :: Form Integer (HydraEvent Tx) Name
enteringAmountForm =
                let field :: Integer -> FormFieldState Integer (HydraEvent Tx) Name
field = Lens' Integer Integer
-> Name
-> (Integer -> Bool)
-> Integer
-> FormFieldState Integer (HydraEvent Tx) Name
forall n a s e.
(Ord n, Show n, Read a, Show a) =>
Lens' s a -> n -> (a -> Bool) -> s -> FormFieldState s e n
editShowableFieldWithValidate (Integer -> f Integer) -> Integer -> f Integer
forall a. a -> a
Lens' Integer Integer
id Name
"amount" (\Integer
n -> Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
limit)
                 in [Integer -> FormFieldState Integer (HydraEvent Tx) Name]
-> Integer -> Form Integer (HydraEvent Tx) Name
forall s e n. [s -> FormFieldState s e n] -> s -> Form s e n
newForm [Integer -> FormFieldState Integer (HydraEvent Tx) Name
field] Integer
limit
          OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put EnteringAmount{(TxIn, TxOut CtxUTxO)
utxoSelected :: (TxIn, TxOut CtxUTxO)
$sel:utxoSelected:OpenHome :: (TxIn, TxOut CtxUTxO)
utxoSelected, Form Integer (HydraEvent Tx) Name
enteringAmountForm :: Form Integer (HydraEvent Tx) Name
$sel:enteringAmountForm:OpenHome :: Form Integer (HydraEvent Tx) Name
enteringAmountForm}
        Event
_ -> LensLike'
  (Zoomed
     (EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)) ())
  OpenScreen
  (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)
-> EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name) ()
-> EventM Name OpenScreen ()
forall c.
LensLike'
  (Zoomed
     (EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)) c)
  OpenScreen
  (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)
-> EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name) c
-> EventM Name OpenScreen c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed
     (EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)) ())
  OpenScreen
  (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)
(Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name
 -> Focusing
      (StateT (EventState Name) IO)
      ()
      (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name))
-> OpenScreen
-> Focusing (StateT (EventState Name) IO) () OpenScreen
Traversal'
  OpenScreen (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)
selectingUTxOFormL (EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name) ()
 -> EventM Name OpenScreen ())
-> EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name) ()
-> EventM Name OpenScreen ()
forall a b. (a -> b) -> a -> b
$ BrickEvent Name (HydraEvent Tx)
-> EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name) ()
forall n e s. Eq n => BrickEvent n e -> EventM n (Form s e n) ()
handleFormEvent (Event -> BrickEvent Name (HydraEvent Tx)
forall n e. Event -> BrickEvent n e
VtyEvent Event
e)
    SelectingUTxOToDecommit Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name
i ->
      case Event
e of
        EvKey Key
KEsc [] -> OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put OpenScreen
OpenHome
        EvKey Key
KEnter [] -> do
          let utxoSelected :: (TxIn, TxOut CtxUTxO)
utxoSelected@(TxIn
_, TxOut{txOutValue :: forall ctx. TxOut ctx -> Value
txOutValue = Value
v}) = Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name
-> (TxIn, TxOut CtxUTxO)
forall s e n. Form s e n -> s
formState Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name
i
          let recipient :: AddressInEra
recipient = forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress @Era (CardanoClient -> NetworkId
networkId CardanoClient
cardanoClient) (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> SigningKey PaymentKey -> VerificationKey PaymentKey
forall a b. (a -> b) -> a -> b
$ Client Tx IO -> SigningKey PaymentKey
forall tx (m :: * -> *). Client tx m -> SigningKey PaymentKey
sk Client Tx IO
hydraClient)
          case (TxIn, TxOut CtxUTxO)
-> (AddressInEra, Value)
-> SigningKey PaymentKey
-> Either TxBodyError Tx
mkSimpleTx (TxIn, TxOut CtxUTxO)
utxoSelected (AddressInEra
recipient, Value
v) (Client Tx IO -> SigningKey PaymentKey
forall tx (m :: * -> *). Client tx m -> SigningKey PaymentKey
sk Client Tx IO
hydraClient) of
            Left TxBodyError
_ -> () -> EventM Name OpenScreen ()
forall a. a -> EventM Name OpenScreen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Right Tx
tx -> do
              IO () -> EventM Name OpenScreen ()
forall a. IO a -> EventM Name OpenScreen a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Client Tx IO -> ClientInput Tx -> IO ()
forall tx (m :: * -> *). Client tx m -> ClientInput tx -> m ()
sendInput Client Tx IO
hydraClient (Tx -> ClientInput Tx
forall tx. tx -> ClientInput tx
Decommit Tx
tx))
          OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put OpenScreen
OpenHome
        Event
_ -> LensLike'
  (Zoomed
     (EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)) ())
  OpenScreen
  (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)
-> EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name) ()
-> EventM Name OpenScreen ()
forall c.
LensLike'
  (Zoomed
     (EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)) c)
  OpenScreen
  (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)
-> EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name) c
-> EventM Name OpenScreen c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed
     (EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)) ())
  OpenScreen
  (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)
(Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name
 -> Focusing
      (StateT (EventState Name) IO)
      ()
      (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name))
-> OpenScreen
-> Focusing (StateT (EventState Name) IO) () OpenScreen
Traversal'
  OpenScreen (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name)
selectingUTxOToDecommitFormL (EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name) ()
 -> EventM Name OpenScreen ())
-> EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name) ()
-> EventM Name OpenScreen ()
forall a b. (a -> b) -> a -> b
$ BrickEvent Name (HydraEvent Tx)
-> EventM Name (Form (TxIn, TxOut CtxUTxO) (HydraEvent Tx) Name) ()
forall n e s. Eq n => BrickEvent n e -> EventM n (Form s e n) ()
handleFormEvent (Event -> BrickEvent Name (HydraEvent Tx)
forall n e. Event -> BrickEvent n e
VtyEvent Event
e)
    EnteringAmount (TxIn, TxOut CtxUTxO)
utxoSelected Form Integer (HydraEvent Tx) Name
i ->
      case Event
e of
        EvKey Key
KEsc [] -> OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put OpenScreen
OpenHome
        EvKey Key
KEnter [] -> do
          let
            field :: FormFieldRenderHelper SelectAddressItem Name
-> SelectAddressItem
-> FormFieldState SelectAddressItem (HydraEvent Tx) Name
field =
              Char
-> Char
-> Char
-> Lens' SelectAddressItem SelectAddressItem
-> [(SelectAddressItem, Name, Name)]
-> FormFieldRenderHelper SelectAddressItem Name
-> SelectAddressItem
-> FormFieldState SelectAddressItem (HydraEvent Tx) Name
forall n a s e.
(Ord n, Eq a) =>
Char
-> Char
-> Char
-> Lens' s a
-> [(a, n, Name)]
-> FormFieldRenderHelper a n
-> s
-> FormFieldState s e n
customRadioField Char
'[' Char
'X' Char
']' (SelectAddressItem -> f SelectAddressItem)
-> SelectAddressItem -> f SelectAddressItem
forall a. a -> a
Lens' SelectAddressItem SelectAddressItem
id ([(SelectAddressItem, Name, Name)]
 -> FormFieldRenderHelper SelectAddressItem Name
 -> SelectAddressItem
 -> FormFieldState SelectAddressItem (HydraEvent Tx) Name)
-> [(SelectAddressItem, Name, Name)]
-> FormFieldRenderHelper SelectAddressItem Name
-> SelectAddressItem
-> FormFieldState SelectAddressItem (HydraEvent Tx) Name
forall a b. (a -> b) -> a -> b
$
                [ (SelectAddressItem
u, SelectAddressItem -> Name
forall b a. (Show a, IsString b) => a -> b
show SelectAddressItem
u, Doc Any -> Name
forall b a. (Show a, IsString b) => a -> b
show (Doc Any -> Name) -> Doc Any -> Name
forall a b. (a -> b) -> a -> b
$ SelectAddressItem -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. SelectAddressItem -> Doc ann
pretty SelectAddressItem
u)
                | SelectAddressItem
u <- [SelectAddressItem] -> [SelectAddressItem]
forall a. Eq a => [a] -> [a]
nub ([SelectAddressItem] -> [SelectAddressItem])
-> [SelectAddressItem] -> [SelectAddressItem]
forall a b. (a -> b) -> a -> b
$ NonEmpty SelectAddressItem -> [SelectAddressItem]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty SelectAddressItem
addresses
                ]
            decorator :: FormFieldRenderHelper SelectAddressItem Name
decorator SelectAddressItem
a Name
_ Bool
_ =
              if SelectAddressItem
a SelectAddressItem -> SelectAddressItem -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra -> SelectAddressItem
SelectAddress AddressInEra
ownAddress
                then AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
withAttr AttrName
own
                else Widget Name -> Widget Name
forall a. a -> a
id
            addresses :: NonEmpty SelectAddressItem
addresses =
              SelectAddressItem
ManualEntry
                SelectAddressItem
-> [SelectAddressItem] -> NonEmpty SelectAddressItem
forall a. a -> [a] -> NonEmpty a
:| (AddressInEra -> SelectAddressItem
SelectAddress (AddressInEra -> SelectAddressItem)
-> (TxOut CtxUTxO -> AddressInEra)
-> TxOut CtxUTxO
-> SelectAddressItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress (TxOut CtxUTxO -> SelectAddressItem)
-> [TxOut CtxUTxO] -> [SelectAddressItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> [TxOut CtxUTxO]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList UTxO
utxo)
          OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
            SelectingRecipient
              { (TxIn, TxOut CtxUTxO)
$sel:utxoSelected:OpenHome :: (TxIn, TxOut CtxUTxO)
utxoSelected :: (TxIn, TxOut CtxUTxO)
utxoSelected
              , $sel:amountEntered:OpenHome :: Integer
amountEntered = Form Integer (HydraEvent Tx) Name -> Integer
forall s e n. Form s e n -> s
formState Form Integer (HydraEvent Tx) Name
i
              , $sel:selectingRecipientForm:OpenHome :: Form SelectAddressItem (HydraEvent Tx) Name
selectingRecipientForm = [SelectAddressItem
 -> FormFieldState SelectAddressItem (HydraEvent Tx) Name]
-> SelectAddressItem -> Form SelectAddressItem (HydraEvent Tx) Name
forall s e n. [s -> FormFieldState s e n] -> s -> Form s e n
newForm [FormFieldRenderHelper SelectAddressItem Name
-> SelectAddressItem
-> FormFieldState SelectAddressItem (HydraEvent Tx) Name
field FormFieldRenderHelper SelectAddressItem Name
decorator] SelectAddressItem
ManualEntry
              }
        Event
_ -> LensLike'
  (Zoomed (EventM Name (Form Integer (HydraEvent Tx) Name)) ())
  OpenScreen
  (Form Integer (HydraEvent Tx) Name)
-> EventM Name (Form Integer (HydraEvent Tx) Name) ()
-> EventM Name OpenScreen ()
forall c.
LensLike'
  (Zoomed (EventM Name (Form Integer (HydraEvent Tx) Name)) c)
  OpenScreen
  (Form Integer (HydraEvent Tx) Name)
-> EventM Name (Form Integer (HydraEvent Tx) Name) c
-> EventM Name OpenScreen c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed (EventM Name (Form Integer (HydraEvent Tx) Name)) ())
  OpenScreen
  (Form Integer (HydraEvent Tx) Name)
(Form Integer (HydraEvent Tx) Name
 -> Focusing
      (StateT (EventState Name) IO)
      ()
      (Form Integer (HydraEvent Tx) Name))
-> OpenScreen
-> Focusing (StateT (EventState Name) IO) () OpenScreen
Traversal' OpenScreen (Form Integer (HydraEvent Tx) Name)
enteringAmountFormL (EventM Name (Form Integer (HydraEvent Tx) Name) ()
 -> EventM Name OpenScreen ())
-> EventM Name (Form Integer (HydraEvent Tx) Name) ()
-> EventM Name OpenScreen ()
forall a b. (a -> b) -> a -> b
$ BrickEvent Name (HydraEvent Tx)
-> EventM Name (Form Integer (HydraEvent Tx) Name) ()
forall n e s. Eq n => BrickEvent n e -> EventM n (Form s e n) ()
handleFormEvent (Event -> BrickEvent Name (HydraEvent Tx)
forall n e. Event -> BrickEvent n e
VtyEvent Event
e)
    SelectingRecipient (TxIn, TxOut CtxUTxO)
utxoSelected Integer
amountEntered Form SelectAddressItem (HydraEvent Tx) Name
i ->
      case Event
e of
        EvKey Key
KEsc [] -> OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put OpenScreen
OpenHome
        EvKey Key
KEnter [] -> do
          case Form SelectAddressItem (HydraEvent Tx) Name -> SelectAddressItem
forall s e n. Form s e n -> s
formState Form SelectAddressItem (HydraEvent Tx) Name
i of
            SelectAddress AddressInEra
recipient -> do
              case (TxIn, TxOut CtxUTxO)
-> (AddressInEra, Value)
-> SigningKey PaymentKey
-> Either TxBodyError Tx
mkSimpleTx (TxIn, TxOut CtxUTxO)
utxoSelected (AddressInEra
recipient, Coin -> Value
lovelaceToValue (Coin -> Value) -> Coin -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
amountEntered) (Client Tx IO -> SigningKey PaymentKey
forall tx (m :: * -> *). Client tx m -> SigningKey PaymentKey
sk Client Tx IO
hydraClient) of
                Left TxBodyError
_ -> () -> EventM Name OpenScreen ()
forall a. a -> EventM Name OpenScreen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                Right Tx
tx -> do
                  IO () -> EventM Name OpenScreen ()
forall a. IO a -> EventM Name OpenScreen a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Client Tx IO -> ClientInput Tx -> IO ()
forall tx (m :: * -> *). Client tx m -> ClientInput tx -> m ()
sendInput Client Tx IO
hydraClient (Tx -> ClientInput Tx
forall tx. tx -> ClientInput tx
NewTx Tx
tx))
                  OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put OpenScreen
OpenHome
            SelectAddressItem
ManualEntry ->
              OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (OpenScreen -> EventM Name OpenScreen ())
-> OpenScreen -> EventM Name OpenScreen ()
forall a b. (a -> b) -> a -> b
$
                EnteringRecipientAddress
                  { (TxIn, TxOut CtxUTxO)
$sel:utxoSelected:OpenHome :: (TxIn, TxOut CtxUTxO)
utxoSelected :: (TxIn, TxOut CtxUTxO)
utxoSelected
                  , Integer
$sel:amountEntered:OpenHome :: Integer
amountEntered :: Integer
amountEntered
                  , $sel:enteringRecipientAddressForm:OpenHome :: Form AddressInEra (HydraEvent Tx) Name
enteringRecipientAddressForm =
                      [AddressInEra -> FormFieldState AddressInEra (HydraEvent Tx) Name]
-> AddressInEra -> Form AddressInEra (HydraEvent Tx) Name
forall s e n. [s -> FormFieldState s e n] -> s -> Form s e n
newForm
                        [ Lens' AddressInEra AddressInEra
-> Name
-> Maybe Int
-> (AddressInEra -> Name)
-> ([Name] -> Maybe AddressInEra)
-> ([Name] -> Widget Name)
-> (Widget Name -> Widget Name)
-> AddressInEra
-> FormFieldState AddressInEra (HydraEvent Tx) Name
forall n s a e.
(Ord n, Show n) =>
Lens' s a
-> n
-> Maybe Int
-> (a -> Name)
-> ([Name] -> Maybe a)
-> ([Name] -> Widget n)
-> (Widget n -> Widget n)
-> s
-> FormFieldState s e n
editField
                            (AddressInEra -> f AddressInEra) -> AddressInEra -> f AddressInEra
forall a. a -> a
Lens' AddressInEra AddressInEra
id
                            Name
"manual address entry"
                            (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1)
                            AddressInEra -> Name
forall addr. SerialiseAddress addr => addr -> Name
serialiseAddress
                            ([Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Name] -> Maybe (NonEmpty Name))
-> (NonEmpty Name -> Maybe AddressInEra)
-> [Name]
-> Maybe AddressInEra
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Maybe AddressInEra
parseAddress (Name -> Maybe AddressInEra)
-> (NonEmpty Name -> Name) -> NonEmpty Name -> Maybe AddressInEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Name -> Name
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head)
                            (Name -> Widget Name
forall n. Name -> Widget n
txt (Name -> Widget Name) -> ([Name] -> Name) -> [Name] -> Widget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)
                            Widget Name -> Widget Name
forall a. a -> a
id
                        ]
                        AddressInEra
ownAddress
                  }
        Event
_ -> LensLike'
  (Zoomed
     (EventM Name (Form SelectAddressItem (HydraEvent Tx) Name)) ())
  OpenScreen
  (Form SelectAddressItem (HydraEvent Tx) Name)
-> EventM Name (Form SelectAddressItem (HydraEvent Tx) Name) ()
-> EventM Name OpenScreen ()
forall c.
LensLike'
  (Zoomed
     (EventM Name (Form SelectAddressItem (HydraEvent Tx) Name)) c)
  OpenScreen
  (Form SelectAddressItem (HydraEvent Tx) Name)
-> EventM Name (Form SelectAddressItem (HydraEvent Tx) Name) c
-> EventM Name OpenScreen c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed
     (EventM Name (Form SelectAddressItem (HydraEvent Tx) Name)) ())
  OpenScreen
  (Form SelectAddressItem (HydraEvent Tx) Name)
(Form SelectAddressItem (HydraEvent Tx) Name
 -> Focusing
      (StateT (EventState Name) IO)
      ()
      (Form SelectAddressItem (HydraEvent Tx) Name))
-> OpenScreen
-> Focusing (StateT (EventState Name) IO) () OpenScreen
Traversal' OpenScreen (Form SelectAddressItem (HydraEvent Tx) Name)
selectingRecipientFormL (EventM Name (Form SelectAddressItem (HydraEvent Tx) Name) ()
 -> EventM Name OpenScreen ())
-> EventM Name (Form SelectAddressItem (HydraEvent Tx) Name) ()
-> EventM Name OpenScreen ()
forall a b. (a -> b) -> a -> b
$ BrickEvent Name (HydraEvent Tx)
-> EventM Name (Form SelectAddressItem (HydraEvent Tx) Name) ()
forall n e s. Eq n => BrickEvent n e -> EventM n (Form s e n) ()
handleFormEvent (Event -> BrickEvent Name (HydraEvent Tx)
forall n e. Event -> BrickEvent n e
VtyEvent Event
e)
    EnteringRecipientAddress (TxIn, TxOut CtxUTxO)
utxoSelected Integer
amountEntered Form AddressInEra (HydraEvent Tx) Name
i ->
      case Event
e of
        EvKey Key
KEsc [] -> OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put OpenScreen
OpenHome
        EvKey Key
KEnter [] -> do
          let recipient :: AddressInEra
recipient = Form AddressInEra (HydraEvent Tx) Name -> AddressInEra
forall s e n. Form s e n -> s
formState Form AddressInEra (HydraEvent Tx) Name
i
          case (TxIn, TxOut CtxUTxO)
-> (AddressInEra, Value)
-> SigningKey PaymentKey
-> Either TxBodyError Tx
mkSimpleTx (TxIn, TxOut CtxUTxO)
utxoSelected (AddressInEra
recipient, Coin -> Value
lovelaceToValue (Coin -> Value) -> Coin -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
amountEntered) (Client Tx IO -> SigningKey PaymentKey
forall tx (m :: * -> *). Client tx m -> SigningKey PaymentKey
sk Client Tx IO
hydraClient) of
            Left TxBodyError
_ -> () -> EventM Name OpenScreen ()
forall a. a -> EventM Name OpenScreen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Right Tx
tx -> do
              IO () -> EventM Name OpenScreen ()
forall a. IO a -> EventM Name OpenScreen a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Client Tx IO -> ClientInput Tx -> IO ()
forall tx (m :: * -> *). Client tx m -> ClientInput tx -> m ()
sendInput Client Tx IO
hydraClient (Tx -> ClientInput Tx
forall tx. tx -> ClientInput tx
NewTx Tx
tx))
              OpenScreen -> EventM Name OpenScreen ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put OpenScreen
OpenHome
        Event
_ -> LensLike'
  (Zoomed (EventM Name (Form AddressInEra (HydraEvent Tx) Name)) ())
  OpenScreen
  (Form AddressInEra (HydraEvent Tx) Name)
-> EventM Name (Form AddressInEra (HydraEvent Tx) Name) ()
-> EventM Name OpenScreen ()
forall c.
LensLike'
  (Zoomed (EventM Name (Form AddressInEra (HydraEvent Tx) Name)) c)
  OpenScreen
  (Form AddressInEra (HydraEvent Tx) Name)
-> EventM Name (Form AddressInEra (HydraEvent Tx) Name) c
-> EventM Name OpenScreen c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed (EventM Name (Form AddressInEra (HydraEvent Tx) Name)) ())
  OpenScreen
  (Form AddressInEra (HydraEvent Tx) Name)
(Form AddressInEra (HydraEvent Tx) Name
 -> Focusing
      (StateT (EventState Name) IO)
      ()
      (Form AddressInEra (HydraEvent Tx) Name))
-> OpenScreen
-> Focusing (StateT (EventState Name) IO) () OpenScreen
Traversal' OpenScreen (Form AddressInEra (HydraEvent Tx) Name)
enteringRecipientAddressFormL (EventM Name (Form AddressInEra (HydraEvent Tx) Name) ()
 -> EventM Name OpenScreen ())
-> EventM Name (Form AddressInEra (HydraEvent Tx) Name) ()
-> EventM Name OpenScreen ()
forall a b. (a -> b) -> a -> b
$ BrickEvent Name (HydraEvent Tx)
-> EventM Name (Form AddressInEra (HydraEvent Tx) Name) ()
forall n e s. Eq n => BrickEvent n e -> EventM n (Form s e n) ()
handleFormEvent (Event -> BrickEvent Name (HydraEvent Tx)
forall n e. Event -> BrickEvent n e
VtyEvent Event
e)
 where
  ownAddress :: AddressInEra
ownAddress = forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress @Era (CardanoClient -> NetworkId
networkId CardanoClient
cardanoClient) (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> SigningKey PaymentKey -> VerificationKey PaymentKey
forall a b. (a -> b) -> a -> b
$ Client Tx IO -> SigningKey PaymentKey
forall tx (m :: * -> *). Client tx m -> SigningKey PaymentKey
sk Client Tx IO
hydraClient)

  parseAddress :: Name -> Maybe AddressInEra
parseAddress =
    (Address ShelleyAddr -> AddressInEra)
-> Maybe (Address ShelleyAddr) -> Maybe AddressInEra
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Address ShelleyAddr -> AddressInEra
ShelleyAddressInEra (Maybe (Address ShelleyAddr) -> Maybe AddressInEra)
-> (Name -> Maybe (Address ShelleyAddr))
-> Name
-> Maybe AddressInEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsType (Address ShelleyAddr) -> Name -> Maybe (Address ShelleyAddr)
forall addr.
SerialiseAddress addr =>
AsType addr -> Name -> Maybe addr
deserialiseAddress (AsType ShelleyAddr -> AsType (Address ShelleyAddr)
forall addrtype. AsType addrtype -> AsType (Address addrtype)
AsAddress AsType ShelleyAddr
AsShelleyAddr)

handleVtyEventsFanoutPossible :: Client Tx IO -> Vty.Event -> EventM Name s ()
handleVtyEventsFanoutPossible :: forall s. Client Tx IO -> Event -> EventM Name s ()
handleVtyEventsFanoutPossible Client Tx IO
hydraClient Event
e = do
  case Event
e of
    EvKey (KChar Char
'f') [] ->
      IO () -> EventM Name s ()
forall a. IO a -> EventM Name s a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Client Tx IO -> ClientInput Tx -> IO ()
forall tx (m :: * -> *). Client tx m -> ClientInput tx -> m ()
sendInput Client Tx IO
hydraClient ClientInput Tx
forall tx. ClientInput tx
Fanout)
    Event
_ -> () -> EventM Name s ()
forall a. a -> EventM Name s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleVtyEventsFinal :: Client Tx IO -> Vty.Event -> EventM Name s ()
handleVtyEventsFinal :: forall s. Client Tx IO -> Event -> EventM Name s ()
handleVtyEventsFinal Client Tx IO
hydraClient Event
e = do
  case Event
e of
    EvKey (KChar Char
'i') [] ->
      IO () -> EventM Name s ()
forall a. IO a -> EventM Name s a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Client Tx IO -> ClientInput Tx -> IO ()
forall tx (m :: * -> *). Client tx m -> ClientInput tx -> m ()
sendInput Client Tx IO
hydraClient ClientInput Tx
forall tx. ClientInput tx
Init)
    Event
_ -> () -> EventM Name s ()
forall a. a -> EventM Name s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

handleVtyEventsConnection ::
  CardanoClient ->
  Client Tx IO ->
  Vty.Event ->
  EventM Name Connection ()
handleVtyEventsConnection :: CardanoClient -> Client Tx IO -> Event -> EventM Name Connection ()
handleVtyEventsConnection CardanoClient
cardanoClient Client Tx IO
hydraClient Event
e = do
  LensLike' (Zoomed (EventM Name HeadState) ()) Connection HeadState
-> EventM Name HeadState () -> EventM Name Connection ()
forall c.
LensLike' (Zoomed (EventM Name HeadState) c) Connection HeadState
-> EventM Name HeadState c -> EventM Name Connection c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike' (Zoomed (EventM Name HeadState) ()) Connection HeadState
(HeadState -> Focusing (StateT (EventState Name) IO) () HeadState)
-> Connection
-> Focusing (StateT (EventState Name) IO) () Connection
Lens' Connection HeadState
headStateL (EventM Name HeadState () -> EventM Name Connection ())
-> EventM Name HeadState () -> EventM Name Connection ()
forall a b. (a -> b) -> a -> b
$ CardanoClient -> Client Tx IO -> Event -> EventM Name HeadState ()
handleVtyEventsHeadState CardanoClient
cardanoClient Client Tx IO
hydraClient Event
e

handleVtyEventsLogState :: Vty.Event -> EventM Name LogState ()
handleVtyEventsLogState :: Event -> EventM Name LogState ()
handleVtyEventsLogState = \case
  EvKey (KChar Char
'<') [] -> Direction -> EventM Name LogState ()
scroll Direction
Up
  EvKey (KChar Char
'>') [] -> Direction -> EventM Name LogState ()
scroll Direction
Down
  EvKey (KChar Char
'h') [] -> (LogVerbosity -> Identity LogVerbosity)
-> LogState -> Identity LogState
Lens' LogState LogVerbosity
logVerbosityL ((LogVerbosity -> Identity LogVerbosity)
 -> LogState -> Identity LogState)
-> LogVerbosity -> EventM Name LogState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= LogVerbosity
Full
  EvKey (KChar Char
's') [] -> (LogVerbosity -> Identity LogVerbosity)
-> LogState -> Identity LogState
Lens' LogState LogVerbosity
logVerbosityL ((LogVerbosity -> Identity LogVerbosity)
 -> LogState -> Identity LogState)
-> LogVerbosity -> EventM Name LogState ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= LogVerbosity
Short
  Event
_ -> () -> EventM Name LogState ()
forall a. a -> EventM Name LogState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

scroll :: Direction -> EventM Name LogState ()
scroll :: Direction -> EventM Name LogState ()
scroll Direction
direction = do
  LogVerbosity
x <- Getting LogVerbosity LogState LogVerbosity
-> EventM Name LogState LogVerbosity
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting LogVerbosity LogState LogVerbosity
Lens' LogState LogVerbosity
logVerbosityL
  case LogVerbosity
x of
    LogVerbosity
Full -> do
      let vp :: ViewportScroll Name
vp = Name -> ViewportScroll Name
forall n. n -> ViewportScroll n
viewportScroll Name
fullFeedbackViewportName
      ViewportScroll Name -> forall s. Direction -> EventM Name s ()
forall n. ViewportScroll n -> forall s. Direction -> EventM n s ()
vScrollPage ViewportScroll Name
vp Direction
direction
    LogVerbosity
Short -> do
      let vp :: ViewportScroll Name
vp = Name -> ViewportScroll Name
forall n. n -> ViewportScroll n
viewportScroll Name
shortFeedbackViewportName
      ViewportScroll Name -> forall s. Direction -> EventM Name s ()
forall n. ViewportScroll n -> forall s. Direction -> EventM n s ()
hScrollPage ViewportScroll Name
vp Direction
direction

myAvailableUTxO :: NetworkId -> VerificationKey PaymentKey -> UTxO -> Map TxIn (TxOut CtxUTxO)
myAvailableUTxO :: NetworkId
-> VerificationKey PaymentKey -> UTxO -> Map TxIn (TxOut CtxUTxO)
myAvailableUTxO NetworkId
networkId VerificationKey PaymentKey
vk (UTxO Map TxIn (TxOut CtxUTxO)
u) =
  let myAddress :: AddressInEra
myAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
vk
   in (TxOut CtxUTxO -> Bool)
-> Map TxIn (TxOut CtxUTxO) -> Map TxIn (TxOut CtxUTxO)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\TxOut{txOutAddress :: forall ctx. TxOut ctx -> AddressInEra
txOutAddress = AddressInEra
addr} -> AddressInEra
addr AddressInEra -> AddressInEra -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra
myAddress) Map TxIn (TxOut CtxUTxO)
u

mkMyAddress :: CardanoClient -> Client Tx IO -> Address ShelleyAddr
mkMyAddress :: CardanoClient -> Client Tx IO -> Address ShelleyAddr
mkMyAddress CardanoClient
cardanoClient Client Tx IO
hydraClient =
  NetworkId
-> PaymentCredential
-> StakeAddressReference
-> Address ShelleyAddr
makeShelleyAddress
    (CardanoClient -> NetworkId
networkId CardanoClient
cardanoClient)
    (Hash PaymentKey -> PaymentCredential
PaymentCredentialByKey (Hash PaymentKey -> PaymentCredential)
-> (VerificationKey PaymentKey -> Hash PaymentKey)
-> VerificationKey PaymentKey
-> PaymentCredential
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (VerificationKey PaymentKey -> PaymentCredential)
-> VerificationKey PaymentKey -> PaymentCredential
forall a b. (a -> b) -> a -> b
$ SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey (SigningKey PaymentKey -> VerificationKey PaymentKey)
-> SigningKey PaymentKey -> VerificationKey PaymentKey
forall a b. (a -> b) -> a -> b
$ Client Tx IO -> SigningKey PaymentKey
forall tx (m :: * -> *). Client tx m -> SigningKey PaymentKey
sk Client Tx IO
hydraClient)
    StakeAddressReference
NoStakeAddress