Various UI improvements, colors replace emojis

pull/339/head
Artur Cygan 5 years ago
parent ba75af8f54
commit 643ca42509
  1. 121
      lib/Echidna/UI.hs

@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
@ -19,10 +20,11 @@ import Control.Monad.Reader (MonadReader, runReader)
import Control.Monad.Random.Strict (MonadRandom)
import Data.Either (either)
import Data.Has (Has(..))
import Data.List (nub)
import Data.List (nub, intersperse)
import Data.Map (Map)
import Data.Maybe (catMaybes, maybe, fromMaybe)
import Data.Set (Set)
import Data.Version (showVersion)
import EVM (VM)
import EVM.Types (Addr, W256)
import Graphics.Vty (Event(..), Key(..), Modifier(..), defaultConfig, mkVty)
@ -31,8 +33,12 @@ import System.Posix.Types (Fd(..))
import System.Timeout (timeout)
import UnliftIO (MonadUnliftIO)
import UnliftIO.Concurrent (killThread, forkIO)
import Text.Printf (printf)
import qualified Brick.AttrMap as A
import qualified Data.Text as T
import qualified Graphics.Vty as V
import qualified Paths_echidna (version)
import Echidna.Campaign
import Echidna.ABI
@ -88,7 +94,7 @@ ppTS (Solved l) = ppFail Nothing l
ppTS Passed = pure "passed! 🎉"
ppTS (Open i) = view hasLens >>= \(CampaignConf t _ _ _ _ _ _) ->
if i >= t then ppTS Passed else pure $ "fuzzing " ++ progress i t
ppTS (Large n l) = view (hasLens . to shrinkLimit) >>= \m -> ppFail (if n < m then Just (n,m)
ppTS (Large n l) = view (hasLens . to shrinkLimit) >>= \m -> ppFail (if n < m then Just (n,m)
else Nothing) l
-- | Pretty-print the status of all 'SolTest's in a 'Campaign'.
@ -100,7 +106,7 @@ ppTests (Campaign ts _ _) = unlines . catMaybes <$> mapM pp ts where
-- | Pretty-print the coverage a 'Campaign' has obtained.
ppCoverage :: Map W256 (Set Int) -> Maybe String
ppCoverage s | s == mempty = Nothing
ppCoverage s | s == mempty = Nothing
| otherwise = Just $ "Unique instructions: " ++ show (coveragePoints s)
++ "\nUnique codehashes: " ++ show (length s)
@ -110,16 +116,90 @@ ppCampaign c = (++) <$> ppTests c <*> pure (maybe "" ("\n" ++) . ppCoverage $ c
-- | Render 'Campaign' progress as a 'Widget'.
campaignStatus :: (MonadReader x m, Has CampaignConf x, Has Names x, Has TxConf x)
=> (Campaign, UIState) -> m (Widget ())
campaignStatus (c, s) = do
let mSection = flip (<=>) . maybe emptyWidget ((hBorder <=>) . padLeft (Pad 2))
mainbox = hCenter . hLimit 120 . joinBorders . borderWithLabel (str "Echidna") . padLeft (Pad 2)
status <- mainbox . mSection (fmap str . ppCoverage $ c ^. coverage) . str <$> ppTests c
let bl msg = status <=> hCenter (str msg)
(s,) <$> isDone c <&> \case
(Uninitialized, _) -> mainbox $ str "Starting up, please wait "
(Timedout, _) -> bl "Timed out, C-c or esc to print report"
(_, True) -> bl "Campaign complete, C-c or esc to print report"
_ -> status
campaignStatus (c@Campaign{_tests, _coverage}, uiState) = do
done <- isDone c
case (uiState, done) of
(Uninitialized, _) -> pure $ mainbox (padLeft (Pad 1) $ str "Starting up, please wait...") emptyWidget
(Timedout, _) -> mainbox <$> testsWidget <*> pure (str "Timed out, C-c or esc to print report")
(_, True) -> mainbox <$> testsWidget <*> pure (str "Campaign complete, C-c or esc to print report")
_ -> mainbox <$> testsWidget <*> pure emptyWidget
where
mainbox :: Widget () -> Widget () -> Widget ()
mainbox inner underneath =
padTop (Pad 1) $ hCenter $ hLimit 120 $
(
borderWithLabel (withAttr "bold" $ str title) $
summaryWidget
<=>
hBorderWithLabel (str "Tests")
<=>
inner
)
<=>
hCenter underneath
title = "Echidna " ++ showVersion Paths_echidna.version
summaryWidget =
padLeft (Pad 1) (
str ("Tests found: " ++ show (length _tests))
<=>
maybe emptyWidget str (ppCoverage _coverage)
)
testsWidget :: (MonadReader x m, Has CampaignConf x, Has Names x, Has TxConf x)
=> m (Widget())
testsWidget = foldl (<=>) emptyWidget . intersperse hBorder <$> traverse testWidget _tests
testWidget :: (MonadReader x m, Has CampaignConf x, Has Names x, Has TxConf x)
=> (SolTest, TestState) -> m (Widget ())
testWidget (test, testState) =
case test of
Left (n, _) -> widget n ""
Right (n, _) -> widget n "assertion in "
where
widget n infront = do
(status, details) <- tsWidget testState
pure $ padLeft (Pad 1) $
str infront <+> name n <+> str ": " <+> status
<=> padTop (Pad 1) details
name n = withAttr "bold" $ str (T.unpack n)
tsWidget :: (MonadReader x m, Has CampaignConf x, Has Names x, Has TxConf x)
=> TestState -> m (Widget (), Widget ())
tsWidget (Failed e) = pure (str "could not evaluate", str $ show e)
tsWidget (Solved l) = failWidget Nothing l
tsWidget Passed = pure (withAttr "success" $ str "PASSED!", emptyWidget)
tsWidget (Open i) = view hasLens >>= \(CampaignConf t _ _ _ _ _ _) ->
if i >= t then
tsWidget Passed
else
pure (withAttr "working" $ str $ "fuzzing " ++ progress i t, emptyWidget)
tsWidget (Large n l) = view (hasLens . to shrinkLimit) >>= \m ->
failWidget (if n < m then Just (n,m) else Nothing) l
failWidget :: (MonadReader x m, Has Names x, Has TxConf x)
=> Maybe (Int, Int) -> [Tx] -> m (Widget (), Widget ())
failWidget _ [] = pure (failureBadge, str "*no transactions made*")
failWidget b xs = do
s <- seqWidget
pure (failureBadge, titleWidget <=> s)
where
titleWidget = str "Call sequence" <+> status <+> str ":"
status = case b of
Nothing -> emptyWidget
Just (n,m) -> str ", " <+> withAttr "working" (str ("shrinking " ++ progress n m))
seqWidget = do
ppTxs <- mapM (ppTx $ length (nub $ view src <$> xs) /= 1) xs
let ordinals = str . printf "%d." <$> [1 :: Int ..]
pure $
foldl (<=>) emptyWidget $
zipWith (<+>) ordinals (withAttr "tx" . str <$> ppTxs)
failureBadge :: Widget ()
failureBadge = withAttr "failure" $ str "FAILED!"
-- | Check if we should stop drawing (or updating) the dashboard, then do the right thing.
monitor :: (MonadReader x m, Has CampaignConf x, Has Names x, Has TxConf x)
@ -131,9 +211,18 @@ monitor = let
se _ (AppEvent c') = continue (c', Running)
se c (VtyEvent (EvKey KEsc _)) = halt c
se c (VtyEvent (EvKey (KChar 'c') l)) | MCtrl `elem` l = halt c
se c _ = continue c in
se c _ = continue c
attrs = A.attrMap (V.white `on` V.black)
[ ("failure", fg V.brightRed)
, ("bold", fg V.white `V.withStyle` V.bold)
, ("tx", fg V.brightWhite)
, ("working", fg V.brightBlue)
, ("success", fg V.brightGreen)
]
in
liftM3 (,,) (view hasLens) (view hasLens) (view hasLens) <&> \s ->
App (pure . cs s) neverShowCursor se pure (const $ forceAttrMap mempty)
App (pure . cs s) neverShowCursor se pure (const attrs)
-- | Heuristic check that we're in a sensible terminal (not a pipe)
isTerminal :: MonadIO m => m Bool
@ -160,7 +249,7 @@ ui v w ts d = let xfer bc = use hasLens >>= liftIO . writeBChan bc
res <- liftIO . time $ if dash
then fst <$> app (defaultCampaign, Uninitialized)
else let go = readBChan bc >>= \c -> if done c then pure c else go in go
final <- maybe (do c <- liftIO (readBChan bc)
final <- maybe (do c <- liftIO (readBChan bc)
killThread t
when dash . liftIO . void $ app (c, Timedout)
return c)

Loading…
Cancel
Save