Merge #493

493: CAD-430, CAD-429: live peer list & other TUI improvements r=deepfire a=deepfire TUI changes: 1. give the TUI direct access to the `NodeKernel`, to allow easier & richer data queries 1. added a peer list screen, accessible by the 'p' key 1. minor string changes 1. compressed the mempool bars in one line 1. a bunch of minor refactoring ![Screenshot from 2020-01-30 17-01-48](https://user-images.githubusercontent.com/452652/73456064-42939880-4382-11ea-912d-345162bd8158.png) Co-authored-by: Kosyrev Serge <[email protected]>
IntersectMBO · Jan 30, 2020 · 7421a69 · 7421a69
2 parents 494a27f + 7da74b1
commit 7421a69
Show file tree

Hide file tree

Showing 15 changed files with 269 additions and 105 deletions.
diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal
@@ -71,6 +71,7 @@ library
                      , cardano-prelude
                      , cardano-prelude-test
                      , cardano-shell
+                     , cardano-slotting
                      , contra-tracer
                      , cborg >= 0.2.2 && < 0.3
                      , containers

diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs
@@ -106,34 +106,37 @@ runNode loggingLayer nc nCli = do
                                          (ncUpdate nc)
                                          (ncProtocol nc)
 
-    SomeProtocol p <- case eitherSomeProtocol of
-                        Left err -> (putTextLn . pack $ show err) >> exitFailure
-                        Right (SomeProtocol p) -> pure $ SomeProtocol p
+    SomeProtocol (p :: Consensus.Protocol blk) <-
+      case eitherSomeProtocol of
+        Left err -> (putTextLn . pack $ show err) >> exitFailure
+        Right (SomeProtocol p) -> pure $ SomeProtocol p
 
     tracers <- mkTracers (ncTraceOptions nc) trace
 
     case ncViewMode nc of
-      SimpleView -> handleSimpleNode p trace tracers nCli nc
+      SimpleView -> handleSimpleNode p trace tracers nCli nc (const $ pure ())
       LiveView   -> do
 #ifdef UNIX
         let c = llConfiguration loggingLayer
         -- We run 'handleSimpleNode' as usual and run TUI thread as well.
         -- turn off logging to the console, only forward it through a pipe to a central logging process
         CM.setDefaultBackends c [KatipBK, TraceForwarderBK, UserDefinedBK "LiveViewBackend"]
-        -- User will see a terminal graphics and will be able to interact with it.
-        nodeThread <- Async.async $ handleSimpleNode p trace tracers nCli nc
 
-        be :: LiveViewBackend Text <- realize c
+        be :: LiveViewBackend blk Text <- realize c
         let lvbe = MkBackend { bEffectuate = effectuate be, bUnrealize = unrealize be }
         llAddBackend loggingLayer lvbe (UserDefinedBK "LiveViewBackend")
         let nId = fromMaybe (panic "LiveView not possible for real protocols as yet") (ncNodeId nc)
         setTopology be nId
-        setNodeThread be nodeThread
         captureCounters be trace
 
+        -- User will see a terminal graphics and will be able to interact with it.
+        nodeThread <- Async.async $ handleSimpleNode p trace tracers nCli nc
+                       (setNodeKernel be)
+        setNodeThread be nodeThread
+
         void $ Async.waitAny [nodeThread]
 #else
-        handleSimpleNode p trace tracers nCli nc
+        handleSimpleNode p trace tracers nCli nc (const $ pure ())
 #endif
   where
     hostname = do
@@ -143,14 +146,19 @@ runNode loggingLayer nc nCli = do
 -- | Sets up a simple node, which will run the chain sync protocol and block
 -- fetch protocol, and, if core, will also look at the mempool when trying to
 -- create a new block.
-handleSimpleNode :: forall blk. RunNode blk
-                 => Consensus.Protocol blk
-                 -> Tracer IO (LogObject Text)
-                 -> Tracers ConnectionId blk
-                 -> NodeCLI
-                 -> NodeConfiguration
-                 -> IO ()
-handleSimpleNode p trace nodeTracers nCli nc = do
+handleSimpleNode
+  :: forall blk. RunNode blk
+  => Consensus.Protocol blk
+  -> Tracer IO (LogObject Text)
+  -> Tracers ConnectionId blk
+  -> NodeCLI
+  -> NodeConfiguration
+  -> (NodeKernel IO ConnectionId blk -> IO ())
+  -- ^ Called on the 'NodeKernel' after creating it, but before the network
+  -- layer is initialised.  This implies this function must not block,
+  -- otherwise the node won't actually start.
+  -> IO ()
+handleSimpleNode p trace nodeTracers nCli nc onKernel = do
     NetworkTopology nodeSetups <-
       either error id <$> readTopologyFile (unTopology . topFile $ mscFp nCli)
 
@@ -255,6 +263,7 @@ handleSimpleNode p trace nodeTracers nCli nc = do
         void $ onEachChange registry id Nothing
                             (ChainDB.getTipPoint chainDB) $ \tip ->
           atomically $ writeTVar varTip tip
+        onKernel nodeKernel
   where
     nid :: Int
     nid = case ncNodeId nc of