Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

UI improvements #1032

Merged
merged 2 commits into from
Apr 19, 2023
Merged

UI improvements #1032

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
7148f0f
UI cleanup
arcz Apr 19, 2023
fa2ddcd
Disable unused imports warning for Echidna.UI
arcz Apr 19, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
36 changes: 23 additions & 13 deletions lib/Echidna/UI.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}

module Echidna.UI where

Expand Down Expand Up @@ -28,6 +29,7 @@ import Data.ByteString.Lazy qualified as BS
import Data.IORef
import Data.Map (Map)
import Data.Maybe (fromMaybe, isJust)
import Data.Time (UTCTime, getCurrentTime)
import Data.Vector.Unboxed qualified as VU
import UnliftIO (MonadUnliftIO, hFlush, stdout)
import UnliftIO.Timeout (timeout)
Expand All @@ -50,7 +52,7 @@ import Echidna.UI.Report
import Echidna.Utility (timePrefix)

data UIEvent =
CampaignUpdated FrozenCampaign
CampaignUpdated UTCTime FrozenCampaign
| CampaignTimedout FrozenCampaign
| CampaignCrashed String
| FetchCacheUpdated (Map Addr (Maybe Contract)) (Map Addr (Map W256 (Maybe W256)))
Expand Down Expand Up @@ -96,7 +98,8 @@ ui vm world ts dict initialCorpus = do
-- run UI update every 100ms
forever $ do
threadDelay 100000
updateUI CampaignUpdated
now <- getCurrentTime
updateUI (CampaignUpdated now)
c <- readIORef env.fetchContractCache
s <- readIORef env.fetchSlotCache
writeBChan bc (FetchCacheUpdated c s)
Expand All @@ -105,7 +108,10 @@ ui vm world ts dict initialCorpus = do
catchAll
(runCampaign' >>= \case
Nothing -> liftIO $ updateUI CampaignTimedout
Just _ -> liftIO $ updateUI CampaignUpdated)
Just _ -> liftIO $ do
now <- getCurrentTime
updateUI (CampaignUpdated now)
)
(liftIO . writeBChan bc . CampaignCrashed . show)
)
(const $ liftIO $ killThread ticker)
Expand All @@ -115,14 +121,18 @@ ui vm world ts dict initialCorpus = do
pure v
initialVty <- liftIO buildVty
app <- customMain initialVty buildVty (Just bc) <$> monitor
liftIO $ void $ app UIState
{ campaign = defaultCampaign
, status = Uninitialized
, fetchedContracts = mempty
, fetchedSlots = mempty
, fetchedDialog = B.dialog (Just "Fetched contracts/slots") Nothing 80
, displayFetchedDialog = False
}
liftIO $ do
now <- getCurrentTime
void $ app UIState
{ campaign = defaultCampaign
, status = Uninitialized
, timeStarted = now
, now = now
, fetchedContracts = mempty
, fetchedSlots = mempty
, fetchedDialog = B.dialog (Just "Fetched contracts/slots") Nothing 80
, displayFetchedDialog = False
}
final <- liftIO $ readIORef ref
liftIO . putStrLn =<< ppCampaign final
pure final
Expand Down Expand Up @@ -187,8 +197,8 @@ monitor = do
else emptyWidget
, runReader (campaignStatus uiState) conf ]

onEvent (AppEvent (CampaignUpdated c')) =
modify' $ \state -> state { campaign = c', status = Running }
onEvent (AppEvent (CampaignUpdated now c')) =
modify' $ \state -> state { campaign = c', status = Running, now = now }
onEvent (AppEvent (CampaignTimedout c')) =
modify' $ \state -> state { campaign = c', status = Timedout }
onEvent (AppEvent (CampaignCrashed e)) = do
Expand Down
179 changes: 120 additions & 59 deletions lib/Echidna/UI/Widgets.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,10 @@ import Brick.Widgets.Border
import Brick.Widgets.Center
import Control.Monad.Reader (MonadReader, asks)
import Data.List (nub, intersperse, sortBy)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe, isJust)
import Data.Text qualified as T
import Data.Time (UTCTime, NominalDiffTime, formatTime, defaultTimeLocale, diffUTCTime)
import Data.Version (showVersion)
import Graphics.Vty qualified as V
import Paths_echidna qualified (version)
Expand All @@ -28,13 +31,14 @@ import Echidna.Types.Config
import Data.Map (Map)
import EVM.Types (Addr, W256)
import EVM (Contract)
import qualified Brick.Widgets.Dialog as B
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isJust)
import Brick.Widgets.Dialog qualified as B

data UIState = UIState
{ status :: UIStateStatus
, campaign :: FrozenCampaign
, timeStarted :: UTCTime
, now :: UTCTime

, fetchedContracts :: Map Addr (Maybe Contract)
, fetchedSlots :: Map Addr (Map W256 (Maybe W256))
, fetchedDialog :: B.Dialog ()
Expand All @@ -51,6 +55,8 @@ attrs = A.attrMap (V.white `on` V.black)
, (attrName "tx", fg V.brightWhite)
, (attrName "working", fg V.brightBlue)
, (attrName "success", fg V.brightGreen)
, (attrName "title", fg V.brightYellow `V.withStyle` V.bold)
, (attrName "subtitle", fg V.brightCyan `V.withStyle` V.bold)
]

bold :: Widget n -> Widget n
Expand All @@ -73,65 +79,93 @@ campaignStatus uiState = do
done <- isDone uiState.campaign
case (uiState.status, done) of
(Uninitialized, _) ->
pure $ mainbox (padLeft (Pad 1) $ str "Starting up, please wait...") emptyWidget
mainbox (padLeft (Pad 1) $ str "Starting up, please wait...") emptyWidget
(Crashed e, _) ->
pure $ mainbox (padLeft (Pad 1) $
withAttr (attrName "failure") $ strBreak $ formatCrashReport e) emptyWidget
(Timedout, _) ->
mainbox <$> testsWidget uiState.campaign.tests
<*> pure (finalStatus "Timed out, C-c or esc to exit")
(_, True) ->
mainbox <$> testsWidget uiState.campaign.tests
<*> pure (finalStatus "Campaign complete, C-c or esc to exit")
_ ->
mainbox <$> testsWidget uiState.campaign.tests
<*> pure emptyWidget
mainbox (padLeft (Pad 1) $ failure $ strBreak $ formatCrashReport e) emptyWidget
(Timedout, _) -> do
tests <- testsWidget uiState.campaign.tests
mainbox tests (finalStatus "Timed out, C-c or esc to exit")
(_, True) -> do
tests <- testsWidget uiState.campaign.tests
mainbox tests (finalStatus "Campaign complete, C-c or esc to exit")
_ -> do
tests <- testsWidget uiState.campaign.tests
mainbox tests emptyWidget
where
mainbox :: Widget Name -> Widget Name -> Widget Name
mainbox inner underneath =
hCenter $ hLimit 120 $
wrapInner inner underneath
wrapInner inner underneath =
joinBorders $ borderWithLabel (bold $ str title) $
summaryWidget uiState
<=>
hBorderWithLabel (str "Tests")
<=>
inner
<=>
underneath
title = "Echidna " ++ showVersion Paths_echidna.version
finalStatus s = hBorder <=> hCenter (bold $ str s)
mainbox inner underneath =
hCenter . hLimit 120 <$> wrapInner inner underneath
wrapInner inner underneath = do
chainId <- asks (.chainId)
pure $ joinBorders $ borderWithLabel echidnaTitle $
summaryWidget uiState chainId
<=>
hBorderWithLabel (withAttr (attrName "subtitle") $ str " Tests ")
<=>
inner
<=>
underneath
echidnaTitle =
str "[ " <+>
withAttr (attrName "title")
(str $ "Echidna " <> showVersion Paths_echidna.version) <+>
str " ]"
finalStatus s = hBorder <=> hCenter (bold $ str s)

formatCrashReport :: String -> String
formatCrashReport e =
"Echidna crashed with an error:\n\n" <>
e <>
"\n\nPlease report it to https://github.com/crytic/echidna/issues"

summaryWidget :: UIState -> Widget Name
summaryWidget uiState =
vLimit 5 (hLimitPercent 50 leftSide <+> vBorder <+> rightSide)
summaryWidget :: UIState -> Maybe W256 -> Widget Name
summaryWidget uiState chainId =
vLimit 3 $ -- limit to 3 rows
hLimitPercent 33 leftSide <+> vBorder <+>
hLimitPercent 50 middle <+> vBorder <+>
rightSide
where
leftSide =
let c = uiState.campaign in
padLeft (Pad 1) $
vLimit 1 (str "Tests found: " <+> str (show (length c.tests)) <+> fill ' ')
(timeElapsedWidget uiState) <+> fill ' '
<=>
str ("Seed: " ++ show c.genDict.defSeed)
str ("Tests found: " <> show (length c.tests))
<=>
str (ppFrozenCoverage c.coverage)
str ("Seed: " <> show c.genDict.defSeed)
middle =
let c = uiState.campaign in
padLeft (Pad 1) $
str (ppFrozenCoverage c.coverage) <+> fill ' '
<=>
str (ppCorpus c.corpus)
rightSide = fetchCacheWidget uiState.fetchedContracts uiState.fetchedSlots
rightSide =
padLeft (Pad 1) $
(rpcInfoWidget uiState.fetchedContracts uiState.fetchedSlots chainId)

fetchCacheWidget
:: Map Addr (Maybe Contract) -> Map Addr (Map W256 (Maybe W256)) -> Widget Name
fetchCacheWidget contracts slots =
padLeft (Pad 1) $
(str "Fetched contracts: " <+> countWidget (Map.elems contracts))
<=>
(str "Fetched slots: " <+> countWidget (concat $ Map.elems (Map.elems <$> slots)))
timeElapsedWidget :: UIState -> Widget n
timeElapsedWidget uiState =
str "Time elapsed: " <+>
str ((formatNominalDiffTime . diffUTCTime uiState.now) uiState.timeStarted)

formatNominalDiffTime :: NominalDiffTime -> String
formatNominalDiffTime diff =
let fmt = if | diff < 60 -> "%Ss"
| diff < 60*60 -> "%Mm %Ss"
| diff < 24*60*60 -> "%Hh %Mm %Ss"
| otherwise -> "%dd %Hh %Mm %Ss"
in formatTime defaultTimeLocale fmt diff

rpcInfoWidget
:: Map Addr (Maybe Contract)
-> Map Addr (Map W256 (Maybe W256))
-> Maybe W256
-> Widget Name
rpcInfoWidget contracts slots chainId =
(str "Chain ID: " <+> str (maybe "-" show chainId))
<=>
(str "Fetched contracts: " <+> countWidget (Map.elems contracts))
<=>
(str "Fetched slots: " <+> countWidget (concat $ Map.elems (Map.elems <$> slots)))
where
countWidget fetches =
let successful = filter isJust fetches
Expand Down Expand Up @@ -187,11 +221,14 @@ testWidget test =
<=> padTop (Pad 1) details
name n = bold $ str (T.unpack n)

tsWidget :: MonadReader Env m
=> TestState -> EchidnaTest -> m (Widget Name, Widget Name)
tsWidget
:: MonadReader Env m
=> TestState
-> EchidnaTest
-> m (Widget Name, Widget Name)
tsWidget (Failed e) _ = pure (str "could not evaluate", str $ show e)
tsWidget Solved t = failWidget Nothing t.reproducer t.events t.value t.result
tsWidget Passed _ = pure (withAttr (attrName "success") $ str "PASSED!", emptyWidget)
tsWidget Passed _ = pure (success $ str "PASSED!", emptyWidget)
tsWidget (Open i) t = do
n <- asks (.cfg.campaignConf.testLimit)
if i >= n then
Expand All @@ -211,19 +248,33 @@ eventWidget es =
else str "Event sequence" <+> str ":"
<=> strBreak (T.unpack $ T.intercalate "\n" es)

failWidget :: MonadReader Env m
=> Maybe (Int, Int) -> [Tx] -> Events -> TestValue -> TxResult -> m (Widget Name, Widget Name)
failWidget
:: MonadReader Env m
=> Maybe (Int, Int)
-> [Tx]
-> Events
-> TestValue
-> TxResult
-> m (Widget Name, Widget Name)
failWidget _ [] _ _ _= pure (failureBadge, str "*no transactions made*")
failWidget b xs es _ r = do
s <- seqWidget xs
pure (failureBadge <+> str (" with " ++ show r), status <=> titleWidget <=> s <=> eventWidget es)
pure
( failureBadge <+> str (" with " ++ show r)
, status <=> titleWidget <=> s <=> eventWidget es
)
where
status = case b of
Nothing -> emptyWidget
Just (n,m) -> str "Current action: " <+> withAttr (attrName "working") (str ("shrinking " ++ progress n m))
Nothing -> emptyWidget
Just (n,m) ->
str "Current action: " <+>
withAttr (attrName "working") (str ("shrinking " ++ progress n m))

optWidget :: MonadReader Env m
=> TestState -> EchidnaTest -> m (Widget Name, Widget Name)
optWidget
:: MonadReader Env m
=> TestState
-> EchidnaTest
-> m (Widget Name, Widget Name)
optWidget (Failed e) _ = pure (str "could not evaluate", str $ show e)
optWidget Solved _ = error "optimization tests cannot be solved"
optWidget Passed t = pure (str $ "max value found: " ++ show t.value, emptyWidget)
Expand All @@ -238,16 +289,26 @@ optWidget (Large n) t = do
m <- asks (.cfg.campaignConf.shrinkLimit)
maxWidget (if n < m then Just (n,m) else Nothing) t.reproducer t.events t.value

maxWidget :: MonadReader Env m
=> Maybe (Int, Int) -> [Tx] -> Events -> TestValue -> m (Widget Name, Widget Name)
maxWidget
:: MonadReader Env m
=> Maybe (Int, Int)
-> [Tx]
-> Events
-> TestValue
-> m (Widget Name, Widget Name)
maxWidget _ [] _ _ = pure (failureBadge, str "*no transactions made*")
maxWidget b xs es v = do
s <- seqWidget xs
pure (maximumBadge <+> str (" max value: " ++ show v), status <=> titleWidget <=> s <=> eventWidget es)
pure
( maximumBadge <+> str (" max value: " ++ show v)
, status <=> titleWidget <=> s <=> eventWidget es
)
where
status = case b of
Nothing -> emptyWidget
Just (n,m) -> str "Current action: " <+> withAttr (attrName "working") (str ("shrinking " ++ progress n m))
Nothing -> emptyWidget
Just (n,m) ->
str "Current action: " <+>
withAttr (attrName "working") (str ("shrinking " ++ progress n m))

seqWidget :: MonadReader Env m => [Tx] -> m (Widget Name)
seqWidget xs = do
Expand Down