Concrete sequence replay with a JSON report

lib/Echidna/Types/InterWorker.hs

@@ -10,10 +10,11 @@ module Echidna.Types.InterWorker
   , Bus
   , FuzzerCmd(..)
   , Message(..)
+  , Reply(..)
   , WrappedMessage(..)
   ) where
 
-import Control.Concurrent.STM (TChan)
+import Control.Concurrent.STM (TChan, TMVar)
 import Data.Text (Text)
 
 import Echidna.Types.Signature (SolCallPrototype)
@@ -24,6 +25,14 @@ import Echidna.Types.Worker (WorkerId)
 data AgentId = FuzzerId WorkerId | SymbolicId
   deriving (Show, Eq, Ord)
 
+-- | The channel a command answers on, filled exactly once by whoever handles
+-- the command. Shown opaquely, so that carrying one does not cost a command
+-- its derived 'Show'.
+newtype Reply a = Reply (TMVar a)
+
+instance Show (Reply a) where
+  show _ = "<reply>"
+
 -- | A command addressed to a single fuzzing worker.
 data FuzzerCmd
   = EnableSampling Text
@@ -36,6 +45,11 @@ data FuzzerCmd
     --   probability in place of a corpus-mutated one.
   | ClearPrioritization
     -- ^ Forget every prioritized sequence.
+  | ExecuteSequence [Tx] Bool (Reply Text)
+    -- ^ Replay a sequence of transactions and report on what it did, without
+    --   perturbing the campaign. The flag asks for the EVM trace to be part of
+    --   the report; the reply is the JSON report itself. See
+    --   'Echidna.Worker.Replay.executeSeq'.
   deriving Show
 
 -- | A message every agent gets to see.

lib/Echidna/Worker/Command.hs

@@ -1,12 +1,19 @@
 -- | Commands a fuzzing worker accepts over the inter-worker bus.
 module Echidna.Worker.Command (checkMessages) where
 
-import Control.Concurrent.STM (TChan, atomically, tryReadTChan)
+import Control.Concurrent.STM (TChan, atomically, putTMVar, tryReadTChan)
+import Control.Monad.Catch (MonadThrow)
+import Control.Monad.Reader (MonadReader)
 import Control.Monad.State.Strict (MonadIO, MonadState, gets, liftIO, modify')
 import Data.Map qualified as Map
 
+import EVM.Types (VM, VMType(Concrete))
+
 import Echidna.Types.Campaign
-import Echidna.Types.InterWorker (FuzzerCmd(..), Message(..), WrappedMessage(..))
+import Echidna.Types.Config (Env)
+import Echidna.Types.InterWorker
+  (FuzzerCmd(..), Message(..), Reply(..), WrappedMessage(..))
+import Echidna.Worker.Replay (executeSeq)
 
 -- | Run every command addressed to this worker that is currently waiting on
 -- the bus, then return.
@@ -16,22 +23,29 @@ import Echidna.Types.InterWorker (FuzzerCmd(..), Message(..), WrappedMessage(..)
 -- behind would let a worker's view of the bus grow without bound while a burst
 -- of coverage is being found. Commands only ever originate outside the
 -- campaign, at the pace of whoever is driving it, so draining cannot starve
--- fuzzing.
+-- fuzzing -- though a command that runs transactions of its own does hold this
+-- worker up while it does.
 checkMessages
-  :: (MonadIO m, MonadState WorkerState m)
-  => TChan WrappedMessage
+  :: (MonadIO m, MonadThrow m, MonadReader Env m, MonadState WorkerState m)
+  => VM Concrete
+  -- ^ The worker's initial VM, for commands that run transactions of their own
+  -> TChan WrappedMessage
   -> m ()
-checkMessages chan = do
+checkMessages vm chan = do
   workerId <- gets (.workerId)
   let loop = liftIO (atomically (tryReadTChan chan)) >>= \case
         Nothing -> pure ()
         Just (WrappedMessage _ (ToFuzzer tid cmd)) | tid == workerId ->
-          handleCmd cmd >> loop
+          handleCmd vm cmd >> loop
         Just _ -> loop
   loop
 
-handleCmd :: MonadState WorkerState m => FuzzerCmd -> m ()
-handleCmd (EnableSampling sig) =
+handleCmd
+  :: (MonadIO m, MonadThrow m, MonadReader Env m, MonadState WorkerState m)
+  => VM Concrete
+  -> FuzzerCmd
+  -> m ()
+handleCmd _ (EnableSampling sig) =
   modify' $ \workerState ->
     if Map.size workerState.sampledFunctions >= maxSampledFunctions
        || Map.member sig workerState.sampledFunctions
@@ -41,13 +55,20 @@ handleCmd (EnableSampling sig) =
           Map.insert sig emptySampleStats workerState.sampledFunctions
       }
 
-handleCmd ClearSampling =
+handleCmd _ ClearSampling =
   modify' $ \workerState -> workerState { sampledFunctions = Map.empty }
 
-handleCmd (FuzzSequence prototypes prob) =
+handleCmd _ (FuzzSequence prototypes prob) =
   modify' $ \workerState -> workerState
     { prioritizedSequences = (prob, prototypes) : workerState.prioritizedSequences
     }
 
-handleCmd ClearPrioritization =
+handleCmd _ ClearPrioritization =
   modify' $ \workerState -> workerState { prioritizedSequences = [] }
+
+-- The command is addressed to a single worker, so this replies exactly once and
+-- 'putTMVar' cannot block. The replay runs on the worker's own thread: the
+-- caller waits for it, and this worker stops fuzzing until it is done.
+handleCmd vm (ExecuteSequence txs includeTrace (Reply replyVar)) = do
+  report <- executeSeq includeTrace vm txs
+  liftIO $ atomically $ putTMVar replyVar report

lib/Echidna/Worker/Fuzz.hs

@@ -67,7 +67,7 @@ runFuzzWorker callback vm dict workerId initialCorpus testLimit = do
 
   where
   run chan = do
-    checkMessages chan
+    checkMessages vm chan
     testRefs <- asks (.testRefs)
     tests <- liftIO $ traverse readIORef testRefs
     CampaignConf{stopOnFail, shrinkLimit} <- asks (.cfg.campaignConf)

lib/Echidna/Worker/Replay.hs

@@ -0,0 +1,126 @@
+-- | Replaying a concrete transaction sequence to report on it, rather than to
+-- fuzz with it.
+module Echidna.Worker.Replay (executeSeq) where
+
+import Control.Applicative ((<|>))
+import Control.Monad.Catch (MonadThrow)
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Reader (MonadReader, asks)
+import Data.Aeson (ToJSON(..), object, (.=))
+import Data.Aeson.Text (encodeToLazyText)
+import Data.List qualified as List
+import Data.String.AnsiEscapeCodes.Strip.Text (stripAnsiEscapeCodes)
+import Data.Text (Text)
+import Data.Text.Lazy qualified as LT
+import Data.Word (Word64)
+
+import EVM.Format (showTraceTree)
+import EVM.Types (Block(..), VM(..), VMType(Concrete), forceLit)
+
+import Echidna.Events (Events, extractEvents)
+import Echidna.Exec (execTx)
+import Echidna.Test (checkAssertionEvent, checkPanicEvent)
+import Echidna.Types.Config (Env(..))
+import Echidna.Types.Tx (Tx, TxResult(..), getResult)
+import Echidna.UI.Report (ppTx)
+
+-- | How a single transaction of the sequence ended. Assertion failures are
+-- kept apart from ordinary reverts because they mean different things: a
+-- revert is usually just an input the contract rejected, an assertion failure
+-- is the contract contradicting itself.
+data TxStatus = Completed | Reverted | AssertionFailed
+  deriving Eq
+
+instance ToJSON TxStatus where
+  toJSON Completed = "completed"
+  toJSON Reverted = "reverted"
+  toJSON AssertionFailed = "assertion_failed"
+
+-- | What replaying one transaction produced.
+data TxOutcome = TxOutcome
+  { index :: Int -- ^ Position in the sequence, counting from one
+  , call :: String
+  , status :: TxStatus
+  , result :: TxResult
+  , gasUsed :: Word64
+  , logs :: Events
+  }
+
+instance ToJSON TxOutcome where
+  toJSON outcome = object
+    [ "index" .= outcome.index
+    , "call" .= outcome.call
+    , "status" .= outcome.status
+    , "result" .= outcome.result
+    , "gas_used" .= outcome.gasUsed
+    , "logs" .= outcome.logs
+    ]
+
+-- | Replay a concrete sequence of transactions and describe what happened as a
+-- JSON report.
+--
+-- The transactions run through 'execTx', which leaves the campaign alone: no
+-- coverage is recorded, nothing reaches the corpus, and no test is falsified.
+-- The point is to answer a question about the contract without changing what
+-- the campaign does next.
+executeSeq
+  :: (MonadIO m, MonadReader Env m, MonadThrow m)
+  => Bool -- ^ Whether to include the EVM trace of the replay
+  -> VM Concrete -- ^ VM to replay from
+  -> [Tx]
+  -> m Text
+executeSeq includeTrace vm0 txs = do
+  dapp <- asks (.dapp)
+  (outcomes, finalVm) <- go dapp vm0 (zip [1..] txs)
+  let
+    -- Summarise the sequence by its worst transaction. An assertion failure
+    -- anywhere is what the caller is looking for, so it outranks a revert even
+    -- when something reverted earlier; reverts are common enough in a random
+    -- sequence that reporting one would bury it.
+    notable =
+      List.find ((== AssertionFailed) . (.status)) outcomes
+        <|> List.find ((/= Completed) . (.status)) outcomes
+    traceFields
+      -- Traces are cleared before each transaction unless `allEvents` is set,
+      -- so this is the trace of the last transaction alone in the usual case.
+      -- 'showTraceTree' colours its output; whoever reads the report is not a
+      -- terminal, so the escape codes are only tokens wasted.
+      | includeTrace && not (null txs) =
+          ["trace" .= stripAnsiEscapeCodes (showTraceTree dapp finalVm)]
+      | otherwise = []
+  pure $ LT.toStrict $ encodeToLazyText $ object $
+    [ "status" .= maybe Completed (.status) notable
+    , "transaction_count" .= length txs
+    , "failed_tx_index" .= ((.index) <$> notable)
+    , "final_block_number" .= show (forceLit finalVm.block.number)
+    , "final_timestamp" .= show (forceLit finalVm.block.timestamp)
+    , "transactions" .= outcomes
+    ] ++ traceFields
+
+  where
+  -- Recursing rather than folding keeps the report in execution order, and
+  -- hands back the final VM for the summary.
+  go _ vm [] = pure ([], vm)
+  go dapp vm ((index, tx):rest) = do
+    (vmResult, vm') <- execTx vm tx
+    call <- ppTx vm' False tx
+    let
+      result = getResult vmResult
+      logs = extractEvents True dapp vm'
+      outcome = TxOutcome { index
+                          , call
+                          , status = txStatus result logs
+                          , result
+                          , gasUsed = fromIntegral (vm'.burned - vm.burned)
+                          , logs
+                          }
+    (outcomes, finalVm) <- go dapp vm' rest
+    pure (outcome : outcomes, finalVm)
+
+-- | Classify how a transaction ended, detecting assertion failures the same
+-- way an assertion test does.
+txStatus :: TxResult -> Events -> TxStatus
+txStatus result logs
+  | checkAssertionEvent logs || checkPanicEvent "1" logs = AssertionFailed
+  | result `elem` [ReturnTrue, ReturnFalse, Stop] = Completed
+  | otherwise = Reverted

src/test/Spec.hs

@@ -12,6 +12,7 @@ import Tests.FoundryTestGen (foundryTestGenTests)
 import Tests.Integration (integrationTests)
 import Tests.Optimization (optimizationTests)
 import Tests.Overflow (overflowTests)
+import Tests.Replay (replayTests)
 import Tests.Research (researchTests)
 import Tests.Sample (sampleTests)
 import Tests.Seed (seedTests)
@@ -35,6 +36,7 @@ main = withCurrentDirectory "./tests/solidity" . defaultMain $
            , foundryTests
            , encodingJSONTests
            , sampleTests
+           , replayTests
            , foundryTestGenTests
            , cheatTests
            , symbolicTests