Display contract names in UI (#1181)

pull/1184/head
Artur Cygan 9 months ago committed by GitHub
parent 09b86445c9
commit 1d0c937e88
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
  1. 4
      lib/Echidna/UI.hs
  2. 57
      lib/Echidna/UI/Report.hs
  3. 10
      lib/Echidna/UI/Widgets.hs

@ -149,7 +149,7 @@ ui vm world dict initialCorpus = do
liftIO $ killThread ticker
states <- workerStates workers
liftIO . putStrLn =<< ppCampaign states
liftIO . putStrLn =<< ppCampaign vm states
pure states
#else
@ -203,7 +203,7 @@ ui vm world dict initialCorpus = do
JSON ->
liftIO $ BS.putStr =<< Echidna.Output.JSON.encodeCampaign env states
Text -> do
liftIO . putStrLn =<< ppCampaign states
liftIO . putStrLn =<< ppCampaign vm states
None ->
pure ()
pure states

@ -7,13 +7,15 @@ import Data.IORef (readIORef)
import Data.List (intercalate, nub, sortOn)
import Data.Map (toList)
import Data.Map qualified as Map
import Data.Maybe (catMaybes, fromJust)
import Data.Maybe (catMaybes, fromJust, fromMaybe)
import Data.Text (Text, unpack)
import Data.Text qualified as T
import Data.Time (LocalTime)
import Optics
import Echidna.ABI (GenDict(..), encodeSig)
import Echidna.Pretty (ppTxCall)
import Echidna.SourceMapping (findSrcByMetadata)
import Echidna.Types (Gas)
import Echidna.Types.Campaign
import Echidna.Types.Config
@ -23,8 +25,9 @@ import Echidna.Types.Test (EchidnaTest(..), TestState(..), TestType(..))
import Echidna.Types.Tx (Tx(..), TxCall(..), TxConf(..))
import Echidna.Utility (timePrefix)
import EVM.Format (showTraceTree)
import EVM.Types (W256, VM)
import EVM.Format (showTraceTree, contractNamePart)
import EVM.Solidity (SolcContract(..))
import EVM.Types (W256, VM, Addr, Expr (LitAddr))
ppLogLine :: (LocalTime, CampaignEvent) -> String
ppLogLine (time, event@(WorkerEvent workerId _)) =
@ -32,11 +35,11 @@ ppLogLine (time, event@(WorkerEvent workerId _)) =
ppLogLine (time, event) =
timePrefix time <> " " <> ppCampaignEvent event
ppCampaign :: (MonadIO m, MonadReader Env m) => [WorkerState] -> m String
ppCampaign workerStates = do
ppCampaign :: (MonadIO m, MonadReader Env m) => VM RealWorld -> [WorkerState] -> m String
ppCampaign vm workerStates = do
tests <- liftIO . readIORef =<< asks (.testsRef)
testsPrinted <- ppTests tests
gasInfoPrinted <- ppGasInfo workerStates
gasInfoPrinted <- ppGasInfo vm workerStates
coveragePrinted <- ppCoverage
let seedPrinted = "Seed: " <> show (head workerStates).genDict.defSeed
corpusPrinted <- ppCorpus
@ -50,20 +53,34 @@ ppCampaign workerStates = do
-- | Given rules for pretty-printing associated address, and whether to print
-- them, pretty-print a 'Transaction'.
ppTx :: MonadReader Env m => Bool -> Tx -> m String
ppTx _ Tx { call = NoCall, delay } =
ppTx :: MonadReader Env m => VM RealWorld -> Bool -> Tx -> m String
ppTx _ _ Tx { call = NoCall, delay } =
pure $ "*wait*" <> ppDelay delay
ppTx printName tx = do
ppTx vm printName tx = do
contractName <- case tx.call of
SolCall _ -> Just <$> contractNameForAddr vm tx.dst
_ -> pure Nothing
names <- asks (.cfg.namesConf)
tGas <- asks (.cfg.txConf.txGas)
pure $
ppTxCall tx.call
unpack (maybe "" (<> ".") contractName) <> ppTxCall tx.call
<> (if not printName then "" else names Sender tx.src <> names Receiver tx.dst)
<> (if tx.gas == tGas then "" else " Gas: " <> show tx.gas)
<> (if tx.gasprice == 0 then "" else " Gas price: " <> show tx.gasprice)
<> (if tx.value == 0 then "" else " Value: " <> show tx.value)
<> ppDelay tx.delay
contractNameForAddr :: MonadReader Env m => VM 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
ppDelay :: (W256, W256) -> [Char]
ppDelay (time, block) =
(if time == 0 then "" else " Time delay: " <> show (toInteger time) <> " seconds")
@ -84,19 +101,19 @@ ppCorpus = do
pure $ "Corpus size: " <> show (corpusSize corpus)
-- | Pretty-print the gas usage information a 'Campaign' has obtained.
ppGasInfo :: MonadReader Env m => [WorkerState] -> m String
ppGasInfo workerStates = do
ppGasInfo :: MonadReader Env m => VM RealWorld -> [WorkerState] -> m String
ppGasInfo vm workerStates = do
let gasInfo = Map.unionsWith max ((.gasInfo) <$> workerStates)
items <- mapM ppGasOne $ sortOn (\(_, (n, _)) -> n) $ toList gasInfo
items <- mapM (ppGasOne vm) $ sortOn (\(_, (n, _)) -> n) $ toList gasInfo
pure $ intercalate "" items
-- | Pretty-print the gas usage for a function.
ppGasOne :: MonadReader Env m => (Text, (Gas, [Tx])) -> m String
ppGasOne ("", _) = pure ""
ppGasOne (func, (gas, txs)) = do
ppGasOne :: MonadReader Env m => VM 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"
<> " Call sequence:\n"
prettyTxs <- mapM (ppTx $ length (nub $ (.src) <$> txs) /= 1) txs
prettyTxs <- mapM (ppTx vm $ length (nub $ (.src) <$> txs) /= 1) txs
pure $ header <> unlines ((" " <>) <$> prettyTxs)
-- | Pretty-print the status of a solved test.
@ -106,7 +123,7 @@ ppFail b vm xs = do
let status = case b of
Nothing -> ""
Just (n,m) -> ", shrinking " <> progress n m
prettyTxs <- mapM (ppTx $ length (nub $ (.src) <$> xs) /= 1) xs
prettyTxs <- mapM (ppTx vm $ length (nub $ (.src) <$> xs) /= 1) xs
dappInfo <- asks (.dapp)
pure $ "failed!💥 \n Call sequence" <> status <> ":\n"
<> unlines ((" " <>) <$> prettyTxs) <> "\n"
@ -123,7 +140,7 @@ ppFailWithTraces b finalVM results = do
Just (n,m) -> ", shrinking " <> progress n m
let printName = length (nub $ (.src) <$> xs) /= 1
prettyTxs <- forM results $ \(tx, vm) -> do
txPrinted <- ppTx printName tx
txPrinted <- ppTx vm printName tx
pure $ txPrinted <> "\nTraces:\n" <> T.unpack (showTraceTree dappInfo vm)
pure $ "failed!💥 \n Call sequence" <> status <> ":\n"
<> unlines ((" " <>) <$> prettyTxs) <> "\n"
@ -157,7 +174,7 @@ ppOptimized b vm xs = do
let status = case b of
Nothing -> ""
Just (n,m) -> ", shrinking " <> progress n m
prettyTxs <- mapM (ppTx $ length (nub $ (.src) <$> xs) /= 1) xs
prettyTxs <- mapM (ppTx vm $ length (nub $ (.src) <$> xs) /= 1) xs
dappInfo <- asks (.dapp)
pure $ "\n Call sequence" <> status <> ":\n"
<> unlines ((" " <>) <$> prettyTxs) <> "\n"

@ -312,7 +312,7 @@ failWidget
-> m (Widget Name, Widget Name)
failWidget _ [] _ _ _= pure (failureBadge, str "*no transactions made*")
failWidget b xs vm _ r = do
s <- seqWidget xs
s <- seqWidget vm xs
traces <- tracesWidget vm
pure
( failureBadge <+> str (" with " ++ show r)
@ -349,7 +349,7 @@ maxWidget
-> m (Widget Name, Widget Name)
maxWidget _ [] _ _ = pure (failureBadge, str "*no transactions made*")
maxWidget b xs vm v = do
s <- seqWidget xs
s <- seqWidget vm xs
traces <- tracesWidget vm
pure
( maximumBadge <+> str (" max value: " ++ show v)
@ -362,9 +362,9 @@ maxWidget b xs vm v = do
str "Current action: " <+>
withAttr (attrName "working") (str ("shrinking " ++ progress n m))
seqWidget :: MonadReader Env m => [Tx] -> m (Widget Name)
seqWidget xs = do
ppTxs <- mapM (ppTx $ length (nub $ (.src) <$> xs) /= 1) xs
seqWidget :: MonadReader Env m => VM 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 ..]
pure $
foldl (<=>) emptyWidget $

Loading…
Cancel
Save