Save traces for every transaction in reproducer (#1180)

lib/Echidna/Campaign.hs

@@ -16,6 +16,7 @@ import Control.Monad.Trans (lift)
 import Data.Binary.Get (runGetOrFail)
 import Data.ByteString.Lazy qualified as LBS
 import Data.IORef (readIORef, atomicModifyIORef')
+import Data.List qualified as List
 import Data.Map qualified as Map
 import Data.Map (Map, (\\))
 import Data.Maybe (isJust, mapMaybe, fromMaybe)
@@ -47,7 +48,6 @@ import Echidna.Types.Test qualified as Test
 import Echidna.Types.Tx (TxCall(..), Tx(..), call)
 import Echidna.Types.World (World)
 import Echidna.Utility (getTimestamp)
-import qualified Data.List as List
 
 instance MonadThrow m => MonadThrow (RandT g m) where
   throwM = lift . throwM

lib/Echidna/Test.hs

@@ -284,3 +284,23 @@ checkOverflowTest :: DappInfo -> VM RealWorld-> TestValue
 checkOverflowTest dappInfo vm =
   let es = extractEvents False dappInfo vm
   in BoolValue $ null es || not (checkPanicEvent "17" es)
+
+-- | Reproduce a test saving VM snapshot after every transaction
+reproduceTest
+  :: (MonadIO m, MonadThrow m, MonadReader Env m)
+  => VM RealWorld -- ^ Initial VM
+  -> EchidnaTest
+  -> m ([(Tx, VM RealWorld)], VM RealWorld)
+reproduceTest vm0 test = do
+  let txs = test.reproducer
+  (results, vm) <- go vm0 [] txs
+  (_, vm') <- checkETest test vm
+  pure (results, vm')
+  where
+    go vm executedSoFar toExecute =
+      case toExecute of
+        [] -> pure ([], vm)
+        tx:remainingTxs -> do
+          (_, vm') <- execTx vm tx
+          (remaining, _) <- go vm' (tx:executedSoFar) remainingTxs
+          pure ((tx, vm') : remaining, vm')

lib/Echidna/UI/Report.hs

@@ -1,5 +1,6 @@
 module Echidna.UI.Report where
 
+import Control.Monad (forM)
 import Control.Monad.Reader (MonadReader, MonadIO (liftIO), asks)
 import Control.Monad.ST (RealWorld)
 import Data.IORef (readIORef)
@@ -111,6 +112,23 @@ ppFail b vm xs = do
          <> unlines (("    " <>) <$> prettyTxs) <> "\n"
          <> "Traces: \n" <> T.unpack (showTraceTree dappInfo vm)
 
+-- | Pretty-print the status of a solved test.
+ppFailWithTraces :: MonadReader Env m => Maybe (Int, Int) -> VM RealWorld -> [(Tx, VM RealWorld)] -> m String
+ppFailWithTraces  _ _ []  = pure "failed with no transactions made ⁉️ "
+ppFailWithTraces b finalVM results = do
+  dappInfo <- asks (.dapp)
+  let xs = fst <$> results
+  let status = case b of
+        Nothing    -> ""
+        Just (n,m) -> ", shrinking " <> progress n m
+  let printName = length (nub $ (.src) <$> xs) /= 1
+  prettyTxs <- forM results $ \(tx, vm) -> do
+    txPrinted <- ppTx printName tx
+    pure $ txPrinted <> "\nTraces:\n" <> T.unpack (showTraceTree dappInfo vm)
+  pure $ "failed!💥  \n  Call sequence" <> status <> ":\n"
+         <> unlines (("    " <>) <$> prettyTxs) <> "\n"
+         <> "Test traces: \n" <> T.unpack (showTraceTree dappInfo finalVM)
+
 -- | Pretty-print the status of a test.
 
 ppTS :: MonadReader Env m => TestState -> VM RealWorld -> [Tx] -> m String
@@ -166,6 +184,15 @@ ppTests tests = do
         pure $ Just (T.unpack n <> ": max value: " <> show t.value <> "\n" <> status)
       Exploration -> pure Nothing
 
+ppTestName :: EchidnaTest -> String
+ppTestName t =
+  case t.testType of
+    PropertyTest n _ -> T.unpack n
+    CallTest n _ -> T.unpack n
+    AssertionTest _ s _ -> T.unpack (encodeSig s)
+    OptimizationTest n _ -> T.unpack n <> ": max value: " <> show t.value
+    Exploration -> "<exploration>"
+
 -- | Given a number of boxes checked and a number of total boxes, pretty-print
 -- progress in box-checking.
 progress :: Int -> Int -> String

src/Main.hs

@@ -2,15 +2,16 @@
 
 module Main where
 
-import Control.Monad (unless, forM_)
-import Control.Monad.Reader (runReaderT)
+import Control.Monad (unless, forM_, when)
+import Control.Monad.Reader (runReaderT, liftIO)
 import Control.Monad.Random (getRandomR)
 import Data.Aeson.Key qualified as Aeson.Key
 import Data.Function ((&))
+import Data.Hashable (hash)
 import Data.IORef (readIORef)
 import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as Map
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
 import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Time.Clock.System (getSystemTime, systemSeconds)
@@ -19,8 +20,10 @@ import Data.Word (Word8, Word16)
 import Main.Utf8 (withUtf8)
 import Options.Applicative
 import Paths_echidna (version)
+import System.Directory (createDirectoryIfMissing)
+import System.Environment (lookupEnv)
 import System.Exit (exitWith, exitSuccess, ExitCode(..))
-import System.FilePath ((</>))
+import System.FilePath ((</>), (<.>))
 import System.IO (hPutStrLn, stderr)
 import System.IO.CodePage (withCP65001)
 
@@ -35,12 +38,13 @@ import Echidna.Onchain qualified as Onchain
 import Echidna.Output.Corpus
 import Echidna.Output.Source
 import Echidna.Solidity (compileContracts)
-import Echidna.Test (validateTestMode)
+import Echidna.Test (reproduceTest, validateTestMode)
 import Echidna.Types.Campaign
 import Echidna.Types.Config
 import Echidna.Types.Solidity
 import Echidna.Types.Test (TestMode, EchidnaTest(..))
 import Echidna.UI
+import Echidna.UI.Report (ppFailWithTraces, ppTestName)
 import Echidna.Utility (measureIO)
 
 main :: IO ()
@@ -76,6 +80,20 @@ main = withUtf8 $ withCP65001 $ do
     Just dir -> do
       measureIO cfg.solConf.quiet "Saving test reproducers" $
         saveTxs (dir </> "reproducers") (filter (not . null) $ (.reproducer) <$> tests)
+
+      saveTracesEnabled <- lookupEnv "ECHIDNA_SAVE_TRACES"
+      when (isJust saveTracesEnabled) $ do
+        measureIO cfg.solConf.quiet "Saving test reproducers-traces" $ do
+          flip runReaderT env $ do
+            forM_ tests $ \test ->
+              unless (null test.reproducer) $ do
+                (results, finalVM) <- reproduceTest vm test
+                let subdir = dir </> "reproducers-traces"
+                liftIO $ createDirectoryIfMissing True subdir
+                let file = subdir </> (show . abs . hash . show) test.reproducer <.> "txt"
+                txsPrinted <- ppFailWithTraces Nothing finalVM results
+                liftIO $ writeFile file (ppTestName test <> ": " <> txsPrinted)
+
       measureIO cfg.solConf.quiet "Saving corpus" $ do
         corpus <- readIORef env.corpusRef
         saveTxs (dir </> "coverage") (snd <$> Set.toList corpus)