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. 12
      lib/Echidna/UI/Widgets.hs

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

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

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

Loading…
Cancel
Save