From 1d0c937e882cace708f64a6f31f3a9ac339d2bce Mon Sep 17 00:00:00 2001 From: Artur Cygan Date: Fri, 26 Jan 2024 19:22:36 +0100 Subject: [PATCH] Display contract names in UI (#1181) --- lib/Echidna/UI.hs | 4 +-- lib/Echidna/UI/Report.hs | 57 +++++++++++++++++++++++++-------------- lib/Echidna/UI/Widgets.hs | 12 ++++----- 3 files changed, 45 insertions(+), 28 deletions(-) diff --git a/lib/Echidna/UI.hs b/lib/Echidna/UI.hs index 2efdc7a6..d4fc3d01 100644 --- a/lib/Echidna/UI.hs +++ b/lib/Echidna/UI.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 diff --git a/lib/Echidna/UI/Report.hs b/lib/Echidna/UI/Report.hs index 86c49237..2f2d96a2 100644 --- a/lib/Echidna/UI/Report.hs +++ b/lib/Echidna/UI/Report.hs @@ -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" diff --git a/lib/Echidna/UI/Widgets.hs b/lib/Echidna/UI/Widgets.hs index 01401b57..f11da53c 100644 --- a/lib/Echidna/UI/Widgets.hs +++ b/lib/Echidna/UI/Widgets.hs @@ -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,10 +362,10 @@ 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 - let ordinals = str . printf "%d." <$> [1 :: Int ..] +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 $ zipWith (<+>) ordinals (withAttr (attrName "tx") . strBreak <$> ppTxs)