{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Hydra.TUI where

import Hydra.Prelude hiding (Down, State)

import Brick
import Hydra.Cardano.Api

import Brick.BChan (BChan, newBChan, writeBChan)
import Data.Time.LocalTime (getCurrentTimeZone)
import Graphics.Vty (
  Mode (BracketedPaste, Mouse),
  Vty,
  defaultConfig,
  outputIface,
  setMode,
  supportsMode,
 )
import Graphics.Vty.Platform.Unix (mkVty)
import Hydra.Chain.Blockfrost.Client as BF
import Hydra.Chain.CardanoClient as CC
import Hydra.Chain.Direct.State ()
import Hydra.Client (HydraEvent (..), withClient)
import Hydra.Node.Util (readFileTextEnvelopeThrow)
import Hydra.TUI.Config (Theme (..), TuiConfig (..), readConfig)
import Hydra.TUI.Drawing
import Hydra.TUI.Handlers
import Hydra.TUI.Logging.Types
import Hydra.TUI.Model
import Hydra.TUI.Options (Options (..))
import Hydra.TUI.Style (darkStyle, lightStyle)
import Lens.Micro ((^.))

-- | Construct a 'CardanoClient' handle.
mkCardanoClient :: NetworkId -> SocketPath -> CardanoClient
mkCardanoClient :: NetworkId -> SocketPath -> CardanoClient
mkCardanoClient NetworkId
networkId SocketPath
nodeSocket =
  CardanoClient
    { $sel:queryUTxOByAddress:CardanoClient :: [Address ShelleyAddr] -> IO UTxO
queryUTxOByAddress =
        LocalNodeConnectInfo
-> QueryPoint -> [Address ShelleyAddr] -> IO UTxO
CC.queryUTxO (NetworkId -> SocketPath -> LocalNodeConnectInfo
CC.localNodeConnectInfo NetworkId
networkId SocketPath
nodeSocket) QueryPoint
CC.QueryTip
    , NetworkId
networkId :: NetworkId
$sel:networkId:CardanoClient :: NetworkId
networkId
    }

mkBFClient :: NetworkId -> FilePath -> CardanoClient
mkBFClient :: NetworkId -> FilePath -> CardanoClient
mkBFClient NetworkId
networkId FilePath
bfProject =
  CardanoClient
    { $sel:queryUTxOByAddress:CardanoClient :: [Address ShelleyAddr] -> IO UTxO
queryUTxOByAddress = \[Address ShelleyAddr]
address -> do
        Project
prj <- IO Project -> IO Project
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> IO Project) -> IO Project -> IO Project
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Project
BF.projectFromFile FilePath
bfProject
        Project -> BlockfrostClientT IO UTxO -> IO UTxO
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
BF.runBlockfrostM Project
prj (BlockfrostClientT IO UTxO -> IO UTxO)
-> BlockfrostClientT IO UTxO -> IO UTxO
forall a b. (a -> b) -> a -> b
$ NetworkId -> [Address ShelleyAddr] -> BlockfrostClientT IO UTxO
BF.queryUTxO NetworkId
networkId [Address ShelleyAddr]
address
    , NetworkId
$sel:networkId:CardanoClient :: NetworkId
networkId :: NetworkId
networkId
    }

runWithVty :: IO Vty -> Options -> IO RootState
runWithVty :: IO Vty -> Options -> IO RootState
runWithVty IO Vty
buildVty options :: Options
options@Options{Host
hydraNodeHost :: Host
hydraNodeHost :: Options -> Host
hydraNodeHost, NetworkId
cardanoNetworkId :: NetworkId
cardanoNetworkId :: Options -> NetworkId
cardanoNetworkId, Either FilePath SocketPath
cardanoConnection :: Either FilePath SocketPath
cardanoConnection :: Options -> Either FilePath SocketPath
cardanoConnection, Maybe FilePath
fuelVerificationKey :: Maybe FilePath
fuelVerificationKey :: Options -> Maybe FilePath
fuelVerificationKey} = do
  TuiConfig
cfg <- IO TuiConfig
readConfig
  BChan (TUIEvent Tx)
eventChan <- Int -> IO (BChan (TUIEvent Tx))
forall a. Int -> IO (BChan a)
newBChan Int
10
  Maybe (VerificationKey PaymentKey)
fuelVk <- (FilePath -> IO (VerificationKey PaymentKey))
-> Maybe FilePath -> IO (Maybe (VerificationKey PaymentKey))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse FilePath -> IO (VerificationKey PaymentKey)
forall a. HasTextEnvelope a => FilePath -> IO a
readFileTextEnvelopeThrow Maybe FilePath
fuelVerificationKey
  (FilePath, IO ()) -> (Async IO () -> IO RootState) -> IO RootState
forall (m :: * -> *) a b.
MonadAsync m =>
(FilePath, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (FilePath
"run-vty-timer", BChan (TUIEvent Tx) -> IO ()
forall tx. BChan (TUIEvent tx) -> IO ()
timer BChan (TUIEvent Tx)
eventChan) ((Async IO () -> IO RootState) -> IO RootState)
-> (Async IO () -> IO RootState) -> IO RootState
forall a b. (a -> b) -> a -> b
$ \Async IO ()
_ ->
    -- REVIEW(SN): what happens if callback blocks?
    forall tx a. IsChainState tx => Options -> ClientComponent tx IO a
withClient @Tx Options
options (BChan (TUIEvent Tx) -> TUIEvent Tx -> IO ()
forall a. BChan a -> a -> IO ()
writeBChan BChan (TUIEvent Tx)
eventChan (TUIEvent Tx -> IO ())
-> (HydraEvent Tx -> TUIEvent Tx) -> HydraEvent Tx -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HydraEvent Tx -> TUIEvent Tx
forall tx. HydraEvent tx -> TUIEvent tx
NodeEvent) ((Client Tx IO -> IO RootState) -> IO RootState)
-> (Client Tx IO -> IO RootState) -> IO RootState
forall a b. (a -> b) -> a -> b
$ \Client Tx IO
hydraClient -> do
      Vty
initialVty <- IO Vty
buildVty
      UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
      TimeZone
tz <- IO TimeZone
getCurrentTimeZone
      Vty
-> IO Vty
-> Maybe (BChan (TUIEvent Tx))
-> App RootState (TUIEvent Tx) Name
-> RootState
-> IO RootState
forall n e s.
Ord n =>
Vty -> IO Vty -> Maybe (BChan e) -> App s e n -> s -> IO s
customMain Vty
initialVty IO Vty
buildVty (BChan (TUIEvent Tx) -> Maybe (BChan (TUIEvent Tx))
forall a. a -> Maybe a
Just BChan (TUIEvent Tx)
eventChan) (Client Tx IO
-> BChan (TUIEvent Tx) -> App RootState (TUIEvent Tx) Name
app Client Tx IO
hydraClient BChan (TUIEvent Tx)
eventChan) (UTCTime
-> TimeZone
-> TuiConfig
-> Maybe (VerificationKey PaymentKey)
-> RootState
initialState UTCTime
now TimeZone
tz TuiConfig
cfg Maybe (VerificationKey PaymentKey)
fuelVk)
 where
  app :: Client Tx IO
-> BChan (TUIEvent Tx) -> App RootState (TUIEvent Tx) Name
app Client Tx IO
hydraClient BChan (TUIEvent Tx)
chan =
    App
      { appDraw :: RootState -> [Widget Name]
appDraw = CardanoClient -> Client Tx IO -> RootState -> [Widget Name]
draw CardanoClient
cardanoClient Client Tx IO
hydraClient
      , appChooseCursor :: RootState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
appChooseCursor = RootState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
forall s n. s -> [CursorLocation n] -> Maybe (CursorLocation n)
showFirstCursor
      , appHandleEvent :: BrickEvent Name (TUIEvent Tx) -> EventM Name RootState ()
appHandleEvent = CardanoClient
-> Client Tx IO
-> BChan (TUIEvent Tx)
-> BrickEvent Name (TUIEvent Tx)
-> EventM Name RootState ()
handleEvent CardanoClient
cardanoClient Client Tx IO
hydraClient BChan (TUIEvent Tx)
chan
      , appStartEvent :: EventM Name RootState ()
appStartEvent = do
          Vty
vty <- EventM Name RootState Vty
forall n s. EventM n s Vty
getVtyHandle
          let output :: Output
output = Vty -> Output
outputIface Vty
vty
          IO () -> EventM Name RootState ()
forall a. IO a -> EventM Name RootState a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EventM Name RootState ())
-> IO () -> EventM Name RootState ()
forall a b. (a -> b) -> a -> b
$ do
            Output -> Mode -> Bool -> IO ()
setMode Output
output Mode
Mouse Bool
True
            -- Deliver pastes as a single 'EvPaste' event instead of raw
            -- keystrokes, which would trigger keybindings mid-paste.
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Output -> Mode -> Bool
supportsMode Output
output Mode
BracketedPaste) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              Output -> Mode -> Bool -> IO ()
setMode Output
output Mode
BracketedPaste Bool
True
          CardanoClient
-> Client Tx IO -> BChan (TUIEvent Tx) -> EventM Name RootState ()
triggerL1Query CardanoClient
cardanoClient Client Tx IO
hydraClient BChan (TUIEvent Tx)
chan
      , appAttrMap :: RootState -> AttrMap
appAttrMap = \RootState
s -> case RootState
s RootState -> Getting Theme RootState Theme -> Theme
forall s a. s -> Getting a s a -> a
^. Getting Theme RootState Theme
Lens' RootState Theme
themeL of
          Theme
DarkTheme -> RootState -> AttrMap
forall s. s -> AttrMap
darkStyle RootState
s
          Theme
LightTheme -> RootState -> AttrMap
forall s. s -> AttrMap
lightStyle RootState
s
      }
  initialState :: UTCTime
-> TimeZone
-> TuiConfig
-> Maybe (VerificationKey PaymentKey)
-> RootState
initialState UTCTime
now TimeZone
tz TuiConfig
cfg Maybe (VerificationKey PaymentKey)
fuelVk =
    RootState
      { $sel:nodeHost:RootState :: Host
nodeHost = Host
hydraNodeHost
      , UTCTime
now :: UTCTime
$sel:now:RootState :: UTCTime
now
      , $sel:timeZone:RootState :: TimeZone
timeZone = TimeZone
tz
      , $sel:connectedState:RootState :: ConnectedState
connectedState = ConnectedState
Disconnected
      , $sel:logState:RootState :: LogState
logState = LogState{logMessages :: [LogMessage]
logMessages = []}
      , $sel:activeTab:RootState :: ActiveTab
activeTab = ActiveTab
MainTab
      , $sel:eventDetailRaw:RootState :: Bool
eventDetailRaw = Bool
False
      , $sel:eventHistoryList:RootState :: List Name LogMessage
eventHistoryList = List Name LogMessage
emptyEventHistoryList
      , $sel:pendingAction:RootState :: Maybe Name
pendingAction = Maybe Name
forall a. Maybe a
Nothing
      , $sel:l1UTxO:RootState :: Maybe (Map TxIn (TxOut CtxUTxO))
l1UTxO = Maybe (Map TxIn (TxOut CtxUTxO))
forall a. Maybe a
Nothing
      , Maybe (VerificationKey PaymentKey)
fuelVk :: Maybe (VerificationKey PaymentKey)
$sel:fuelVk:RootState :: Maybe (VerificationKey PaymentKey)
fuelVk
      , $sel:fuelUTxO:RootState :: Maybe (Map TxIn (TxOut CtxUTxO))
fuelUTxO = Maybe (Map TxIn (TxOut CtxUTxO))
forall a. Maybe a
Nothing
      , $sel:previousTab:RootState :: ActiveTab
previousTab = ActiveTab
MainTab
      , $sel:theme:RootState :: Theme
theme = TuiConfig
cfg.theme
      , $sel:recoveryForm:RootState :: Maybe (TxIdRadioFieldForm (HydraEvent Tx) Name)
recoveryForm = Maybe (TxIdRadioFieldForm (HydraEvent Tx) Name)
forall a. Maybe a
Nothing
      , $sel:fanoutSelectionForm:RootState :: Maybe (UTxOCheckboxForm (HydraEvent Tx) Name)
fanoutSelectionForm = Maybe (UTxOCheckboxForm (HydraEvent Tx) Name)
forall a. Maybe a
Nothing
      , $sel:eventHistoryFilter:RootState :: EventHistoryFilter
eventHistoryFilter = EventHistoryFilter
ShowAll
      }

  cardanoClient :: CardanoClient
cardanoClient =
    case Either FilePath SocketPath
cardanoConnection of
      Left FilePath
bfProject -> NetworkId -> FilePath -> CardanoClient
mkBFClient NetworkId
cardanoNetworkId FilePath
bfProject
      Right SocketPath
nodeSocket -> NetworkId -> SocketPath -> CardanoClient
mkCardanoClient NetworkId
cardanoNetworkId SocketPath
nodeSocket

  timer :: BChan (TUIEvent tx) -> IO ()
  timer :: forall tx. BChan (TUIEvent tx) -> IO ()
timer BChan (TUIEvent tx)
chan = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
    BChan (TUIEvent tx) -> TUIEvent tx -> IO ()
forall a. BChan a -> a -> IO ()
writeBChan BChan (TUIEvent tx)
chan (TUIEvent tx -> IO ()) -> TUIEvent tx -> IO ()
forall a b. (a -> b) -> a -> b
$ HydraEvent tx -> TUIEvent tx
forall tx. HydraEvent tx -> TUIEvent tx
NodeEvent (HydraEvent tx -> TUIEvent tx) -> HydraEvent tx -> TUIEvent tx
forall a b. (a -> b) -> a -> b
$ UTCTime -> HydraEvent tx
forall tx. UTCTime -> HydraEvent tx
Tick UTCTime
now
    DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1

run :: Options -> IO RootState
run :: Options -> IO RootState
run = IO Vty -> Options -> IO RootState
runWithVty (VtyUserConfig -> IO Vty
mkVty VtyUserConfig
defaultConfig)