Merge pull request #1387 from crytic/ui-responsiveness

Improve UI responsiveness

Author: elopez

lib/Echidna.hs

@@ -125,9 +125,10 @@ mkEnv cfg buildOutput tests world slitherInfo = do
   (contractCache, slotCache) <- Onchain.loadRpcCache cfg
   fetchContractCache <- newIORef contractCache
   fetchSlotCache <- newIORef slotCache
+  contractNameCache <- newIORef mempty
   -- TODO put in real path
   let dapp = dappInfo "/" buildOutput
-  pure $ Env { cfg, dapp, codehashMap, fetchContractCache, fetchSlotCache
+  pure $ Env { cfg, dapp, codehashMap, fetchContractCache, fetchSlotCache, contractNameCache
              , chainId, eventQueue, coverageRefInit, coverageRefRuntime, corpusRef, testRefs, world
              , slitherInfo
              }

lib/Echidna/Types/Config.hs

@@ -80,6 +80,7 @@ data Env = Env
   , codehashMap :: CodehashMap
   , fetchContractCache :: IORef (Map Addr (Maybe Contract))
   , fetchSlotCache :: IORef (Map Addr (Map W256 (Maybe W256)))
+  , contractNameCache :: IORef (Map W256 Text)
   , chainId :: Maybe W256
   , world :: World
   }

lib/Echidna/UI.hs

@@ -122,8 +122,8 @@ ui vm dict initialCorpus cliSelectedContract = do
       liftIO $ do
         tests <- traverse readIORef env.testRefs
         now <- getTimestamp
-        void $ app UIState
-          { campaigns = [initialWorkerState] -- ugly, fix me
+        let uiState = UIState {
+            campaigns = [initialWorkerState] -- ugly, fix me
           , workersAlive = nworkers
           , status = Uninitialized
           , timeStarted = now
@@ -143,7 +143,10 @@ ui vm dict initialCorpus cliSelectedContract = do
           , numCodehashes = 0
           , lastNewCov = now
           , tests
+          , campaignWidget = emptyWidget -- temporary, will be overwritten below
           }
+        initialCampaignWidget <- runReaderT (campaignStatus uiState) env
+        void $ app uiState { campaignWidget = initialCampaignWidget }
 
       -- Exited from the UI, stop the workers, not needed anymore
       stopWorkers workers
@@ -260,12 +263,12 @@ vtyConfig = do
 monitor :: MonadReader Env m => m (App UIState UIEvent Name)
 monitor = do
   let
-    drawUI :: Env -> UIState -> [Widget Name]
-    drawUI conf uiState =
+    drawUI :: UIState -> [Widget Name]
+    drawUI uiState =
       [ if uiState.displayFetchedDialog
            then fetchedDialogWidget uiState
            else emptyWidget
-      , runReader (campaignStatus uiState) conf ]
+      , uiState.campaignWidget ]
 
     toggleFocus :: UIState -> UIState
     toggleFocus state =
@@ -280,9 +283,18 @@ monitor = do
       (state.focusedPane == LogPane && not state.displayLogPane)
       then toggleFocus state else state
 
-    onEvent = \case
-      AppEvent (CampaignUpdated now tests c') ->
-        modify' $ \state -> state { campaigns = c', status = Running, now, tests }
+    focusedViewportScroll :: UIState -> ViewportScroll Name
+    focusedViewportScroll state = case state.focusedPane of
+      TestsPane -> viewportScroll TestsViewPort
+      LogPane   -> viewportScroll LogViewPort
+
+    onEvent env = \case
+      AppEvent (CampaignUpdated now tests c') -> do
+        state <- get
+        let updatedState = state { campaigns = c', status = Running, now, tests }
+        newWidget <- liftIO $ runReaderT (campaignStatus updatedState) env
+        -- purposedly using lazy modify here, so unnecesary widget states don't get computed
+        modify $ const updatedState { campaignWidget = newWidget }
       AppEvent (FetchCacheUpdated contracts slots) ->
         modify' $ \state ->
           state { fetchedContracts = contracts
@@ -317,10 +329,12 @@ monitor = do
           refocusIfNeeded $ state { displayTestsPane = not state.displayTestsPane }
       VtyEvent (EvKey direction _) | direction == KPageUp || direction == KPageDown -> do
         state <- get
-        let vp = case state.focusedPane of
-              TestsPane -> viewportScroll TestsViewPort
-              LogPane   -> viewportScroll LogViewPort
-        vScrollBy vp (if direction == KPageDown then 10 else -10)
+        let vp = focusedViewportScroll state
+        vScrollPage vp (if direction == KPageDown then Down else Up)
+      VtyEvent (EvKey direction _) | direction == KUp || direction == KDown -> do
+        state <- get
+        let vp = focusedViewportScroll state
+        vScrollBy vp (if direction == KDown then 1 else -1)
       VtyEvent (EvKey k []) | k == KChar '\t' || k ==  KBackTab ->
         -- just two panes, so both keybindings just toggle the active one
         modify' toggleFocus
@@ -350,9 +364,9 @@ monitor = do
       _ -> pure ()
 
   env <- ask
-  pure $ App { appDraw = drawUI env
+  pure $ App { appDraw = drawUI
              , appStartEvent = pure ()
-             , appHandleEvent = onEvent
+             , appHandleEvent = onEvent env
              , appAttrMap = const attrs
              , appChooseCursor = neverShowCursor
              }

lib/Echidna/UI/Report.hs

@@ -3,7 +3,7 @@ module Echidna.UI.Report where
 import Control.Monad (forM)
 import Control.Monad.Reader (MonadReader, MonadIO (liftIO), asks, ask)
 import Control.Monad.ST (RealWorld)
-import Data.IORef (readIORef)
+import Data.IORef (readIORef, atomicModifyIORef')
 import Data.List (intercalate, nub, sortOn)
 import Data.Map (toList)
 import Data.Map qualified as Map
@@ -15,7 +15,8 @@ import Optics
 
 import Echidna.ABI (GenDict(..), encodeSig)
 import Echidna.Pretty (ppTxCall)
-import Echidna.SourceMapping (findSrcByMetadata)
+import Echidna.SourceMapping (findSrcByMetadata, lookupCodehash)
+import Echidna.Symbolic (forceWord)
 import Echidna.Types (Gas)
 import Echidna.Types.Campaign
 import Echidna.Types.Config
@@ -27,17 +28,17 @@ import Echidna.Utility (timePrefix)
 
 import EVM.Format (showTraceTree, contractNamePart)
 import EVM.Solidity (SolcContract(..))
-import EVM.Types (W256, VM(labels), VMType(Concrete), Addr, Expr (LitAddr))
+import EVM.Types (W256, VM(labels), VMType(Concrete), Addr, Expr (LitAddr), Contract(..))
 
-ppLogLine :: MonadReader Env m => VM Concrete RealWorld -> (LocalTime, CampaignEvent) -> m String
+ppLogLine :: (MonadReader Env m, MonadIO m) => VM Concrete RealWorld -> (LocalTime, CampaignEvent) -> m String
 ppLogLine vm (time, event@(WorkerEvent workerId FuzzWorker _)) =
   ((timePrefix time <> "[Worker " <> show workerId <> "] ") <>) <$> ppCampaignEventLog vm event
 ppLogLine vm (time, event@(WorkerEvent workerId SymbolicWorker _)) =
   ((timePrefix time <> "[Worker " <> show workerId <> ", symbolic] ") <>) <$> ppCampaignEventLog vm event
 ppLogLine vm (time, event) =
   ((timePrefix time <> " ") <>) <$> ppCampaignEventLog vm event
 
-ppCampaignEventLog :: MonadReader Env m => VM Concrete RealWorld -> CampaignEvent -> m String
+ppCampaignEventLog :: (MonadReader Env m, MonadIO m) => VM Concrete RealWorld -> CampaignEvent -> m String
 ppCampaignEventLog vm ev = (ppCampaignEvent ev <>) <$> ppTxIfHas where
   ppTxIfHas = case ev of
     (WorkerEvent _ _ (TestFalsified test)) -> ("\n  Call sequence:\n" <>) . unlines <$> mapM (ppTx vm $ length (nub $ (.src) <$> test.reproducer) /= 1) test.reproducer
@@ -68,7 +69,7 @@ ppCampaign vm workerStates = do
 
 -- | Given rules for pretty-printing associated addresses, and whether to print
 -- them, pretty-print a 'Transaction'.
-ppTx :: MonadReader Env m => VM Concrete RealWorld -> Bool -> Tx -> m String
+ppTx :: (MonadReader Env m, MonadIO m) => VM Concrete RealWorld -> Bool -> Tx -> m String
 ppTx _ _ Tx { call = NoCall, delay } =
   pure $ "*wait*" <> ppDelay delay
 ppTx vm printName tx = do
@@ -92,16 +93,30 @@ ppTx vm printName tx = do
       Nothing -> ""
       Just l -> " «" <> T.unpack l <> "»"
 
-contractNameForAddr :: MonadReader Env m => VM Concrete RealWorld -> Addr -> m Text
+contractNameForAddr :: (MonadReader Env m, MonadIO m) => VM Concrete RealWorld -> Addr -> m Text
 contractNameForAddr vm addr = do
-  dapp <- asks (.dapp)
-  maybeName <- case Map.lookup (LitAddr addr) (vm ^. #env % #contracts) of
-    Just contract ->
-      case findSrcByMetadata contract dapp of
-        Just solcContract -> pure $ Just $ contractNamePart solcContract.contractName
-        Nothing -> pure Nothing
-    Nothing -> pure Nothing
-  pure $ fromMaybe (T.pack $ show addr) maybeName
+  case Map.lookup (LitAddr addr) (vm ^. #env % #contracts) of
+    Just contract -> do
+      -- Figure out contract compile-time codehash
+      codehashMap <- asks (.codehashMap)
+      dapp <- asks (.dapp)
+      let codehash = forceWord contract.codehash
+      compileTimeCodehash <- liftIO $ lookupCodehash codehashMap codehash contract dapp
+      -- See if we know the name
+      cache <- asks (.contractNameCache)
+      nameMap <- liftIO $ readIORef cache
+      case Map.lookup compileTimeCodehash nameMap of
+        Just name -> pure name
+        Nothing -> do
+          -- Cache miss, compute and store the name
+          let maybeName = case findSrcByMetadata contract dapp of
+                Just solcContract -> Just $ contractNamePart solcContract.contractName
+                Nothing -> Nothing
+              finalName = fromMaybe (T.pack $ show addr) maybeName
+          -- Store in cache using compile-time codehash as key
+          liftIO $ atomicModifyIORef' cache $ \m -> (Map.insert compileTimeCodehash finalName m, ())
+          pure finalName
+    Nothing -> pure $ T.pack $ show addr
 
 ppDelay :: (W256, W256) -> [Char]
 ppDelay (time, block) =
@@ -123,14 +138,14 @@ ppCorpus = do
   pure $ "Corpus size: " <> show (corpusSize corpus)
 
 -- | Pretty-print the gas usage information a 'Campaign' has obtained.
-ppGasInfo :: MonadReader Env m => VM Concrete RealWorld -> [WorkerState] -> m String
+ppGasInfo :: (MonadReader Env m, MonadIO m) => VM Concrete RealWorld -> [WorkerState] -> m String
 ppGasInfo vm workerStates = do
   let gasInfo = Map.unionsWith max ((.gasInfo) <$> workerStates)
   items <- mapM (ppGasOne vm) $ sortOn (\(_, (n, _)) -> n) $ toList gasInfo
   pure $ intercalate "" items
 
 -- | Pretty-print the gas usage for a function.
-ppGasOne :: MonadReader Env m => VM Concrete RealWorld -> (Text, (Gas, [Tx])) -> m String
+ppGasOne :: (MonadReader Env m, MonadIO m) => VM Concrete RealWorld -> (Text, (Gas, [Tx])) -> m String
 ppGasOne _  ("", _)      = pure ""
 ppGasOne vm (func, (gas, txs)) = do
   let header = "\n" <> unpack func <> " used a maximum of " <> show gas <> " gas\n"
@@ -139,7 +154,7 @@ ppGasOne vm (func, (gas, txs)) = do
   pure $ header <> unlines (("    " <>) <$> prettyTxs)
 
 -- | Pretty-print the status of a solved test.
-ppFail :: MonadReader Env m => Maybe (Int, Int) -> VM Concrete RealWorld -> [Tx] -> m String
+ppFail :: (MonadReader Env m, MonadIO m) => Maybe (Int, Int) -> VM Concrete RealWorld -> [Tx] -> m String
 ppFail _ _ []  = pure "failed with no transactions made ⁉️ "
 ppFail b vm xs = do
   let status = case b of
@@ -152,7 +167,7 @@ ppFail b vm xs = do
          <> "Traces: \n" <> T.unpack (showTraceTree dappInfo vm)
 
 -- | Pretty-print the status of a solved test.
-ppFailWithTraces :: MonadReader Env m => Maybe (Int, Int) -> VM Concrete RealWorld -> [(Tx, VM Concrete RealWorld)] -> m String
+ppFailWithTraces :: (MonadReader Env m, MonadIO m) => Maybe (Int, Int) -> VM Concrete RealWorld -> [(Tx, VM Concrete RealWorld)] -> m String
 ppFailWithTraces  _ _ []  = pure "failed with no transactions made ⁉️ "
 ppFailWithTraces b finalVM results = do
   dappInfo <- asks (.dapp)
@@ -170,7 +185,7 @@ ppFailWithTraces b finalVM results = do
 
 -- | Pretty-print the status of a test.
 
-ppTS :: MonadReader Env m => TestState -> VM Concrete RealWorld -> [Tx] -> m String
+ppTS :: (MonadReader Env m, MonadIO m) => TestState -> VM Concrete RealWorld -> [Tx] -> m String
 ppTS (Failed e) _ _  = pure $ "could not evaluate ☣\n  " <> show e
 ppTS Solved     vm l = ppFail Nothing vm l
 ppTS Passed     _ _  = pure " passed! 🎉"
@@ -180,7 +195,7 @@ ppTS (Large n) vm l  = do
   m <- asks (.cfg.campaignConf.shrinkLimit)
   ppFail (if n < m then Just (n, m) else Nothing) vm l
 
-ppOPT :: MonadReader Env m => TestState -> VM Concrete RealWorld -> [Tx] -> m String
+ppOPT :: (MonadReader Env m, MonadIO m) => TestState -> VM Concrete RealWorld -> [Tx] -> m String
 ppOPT (Failed e) _ _  = pure $ "could not evaluate ☣\n  " <> show e
 ppOPT Solved     vm l = ppOptimized Nothing vm l
 ppOPT Passed     _ _  = pure " passed! 🎉"
@@ -190,7 +205,7 @@ ppOPT (Large n) vm l  = do
   ppOptimized (if n < m then Just (n, m) else Nothing) vm l
 
 -- | Pretty-print the status of an optimized test.
-ppOptimized :: MonadReader Env m => Maybe (Int, Int) -> VM Concrete RealWorld -> [Tx] -> m String
+ppOptimized :: (MonadReader Env m, MonadIO m) => Maybe (Int, Int) -> VM Concrete RealWorld -> [Tx] -> m String
 ppOptimized _ _ []  = pure "Call sequence:\n(no transactions)"
 ppOptimized b vm xs = do
   let status = case b of
@@ -203,7 +218,7 @@ ppOptimized b vm xs = do
          <> "Traces: \n" <> T.unpack (showTraceTree dappInfo vm)
 
 -- | Pretty-print the status of all 'SolTest's in a 'Campaign'.
-ppTests :: MonadReader Env m => [EchidnaTest] -> m String
+ppTests :: (MonadReader Env m, MonadIO m) => [EchidnaTest] -> m String
 ppTests tests = do
   unlines . catMaybes <$> mapM pp tests
   where

lib/Echidna/UI/Widgets.hs

@@ -8,6 +8,7 @@ import Brick.Widgets.Border
 import Brick.Widgets.Center
 import Brick.Widgets.Dialog qualified as B
 import Control.Monad.Reader (MonadReader, asks, ask)
+import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.ST (RealWorld)
 import Data.List (nub, intersperse, sortBy)
 import Data.Map (Map)
@@ -60,6 +61,9 @@ data UIState = UIState
   , lastNewCov :: LocalTime
   -- ^ last timestamp of 'NewCoverage' event
 
+  , campaignWidget :: Widget Name
+  -- ^ Pre-computed widget to avoid IO in drawing
+
   , tests :: [EchidnaTest]
   }
 
@@ -101,7 +105,7 @@ data Name
   deriving (Ord, Show, Eq)
 
 -- | Render 'Campaign' progress as a 'Widget'.
-campaignStatus :: MonadReader Env m => UIState -> m (Widget Name)
+campaignStatus :: (MonadReader Env m, MonadIO m) => UIState -> m (Widget Name)
 campaignStatus uiState = do
   tests <- testsWidget uiState.tests
 
@@ -299,7 +303,7 @@ failedFirst :: EchidnaTest -> EchidnaTest -> Ordering
 failedFirst t1 _ | didFail t1 = LT
                  | otherwise  = GT
 
-testsWidget :: MonadReader Env m => [EchidnaTest] -> m (Widget Name)
+testsWidget :: (MonadReader Env m, MonadIO m) => [EchidnaTest] -> m (Widget Name)
 testsWidget tests' =
   withClickableVScrollBars SBClick .
   withVScrollBars OnRight .
@@ -308,7 +312,7 @@ testsWidget tests' =
   foldl (<=>) emptyWidget . intersperse hBorder <$>
     traverse testWidget (sortBy failedFirst tests')
 
-testWidget :: MonadReader Env m => EchidnaTest -> m (Widget Name)
+testWidget :: (MonadReader Env m, MonadIO m) => EchidnaTest -> m (Widget Name)
 testWidget test =
   case test.testType of
     Exploration          -> widget tsWidget "exploration" ""
@@ -325,7 +329,7 @@ testWidget test =
   name n = bold $ str (T.unpack n)
 
 tsWidget
-  :: MonadReader Env m
+  :: (MonadReader Env m, MonadIO m)
   => TestState
   -> EchidnaTest
   -> m (Widget Name, Widget Name)
@@ -352,7 +356,7 @@ tracesWidget vm = do
     else str "Traces" <+> str ":" <=> txtBreak traces
 
 failWidget
-  :: MonadReader Env m
+  :: (MonadReader Env m, MonadIO m)
   => Maybe (Int, Int)
   -> EchidnaTest
   -> m (Widget Name, Widget Name)
@@ -370,7 +374,7 @@ failWidget b test = do
     )
 
 optWidget
-  :: MonadReader Env m
+  :: (MonadReader Env m, MonadIO m)
   => TestState
   -> EchidnaTest
   -> m (Widget Name, Widget Name)
@@ -385,7 +389,7 @@ optWidget (Large n)  test = do
   maxWidget (if n < m then Just (n,m) else Nothing) test
 
 maxWidget
-  :: MonadReader Env m
+  :: (MonadReader Env m, MonadIO m)
   => Maybe (Int, Int)
   -> EchidnaTest
   -> m (Widget Name, Widget Name)
@@ -411,7 +415,7 @@ shrinkWidget b test =
   where
   showWorker = maybe "" (\i -> " (worker " <> show i <> ")") test.workerId
 
-seqWidget :: MonadReader Env m => VM Concrete RealWorld -> [Tx] -> m (Widget Name)
+seqWidget :: (MonadReader Env m, MonadIO m) => VM Concrete RealWorld -> [Tx] -> m (Widget Name)
 seqWidget vm xs = do
   ppTxs <- mapM (ppTx vm $ length (nub $ (.src) <$> xs) /= 1) xs
   let ordinals = str . printf "%d. " <$> [1 :: Int ..]