diff --git a/lib/Echidna/Campaign.hs b/lib/Echidna/Campaign.hs index 565b6e698..f9da2ecaf 100644 --- a/lib/Echidna/Campaign.hs +++ b/lib/Echidna/Campaign.hs @@ -3,7 +3,7 @@ module Echidna.Campaign where -import Control.Concurrent (writeChan) +import Control.Concurrent import Control.DeepSeq (force) import Control.Monad (replicateM, when, void, forM_) import Control.Monad.Catch (MonadThrow(..)) @@ -22,6 +22,7 @@ import Data.Maybe (isJust, mapMaybe, fromMaybe) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) +import Data.Time (LocalTime) import System.Random (mkStdGen) import EVM (cheatCode) @@ -67,7 +68,7 @@ replayCorpus replayCorpus vm txSeqs = forM_ (zip [1..] txSeqs) $ \(i, txSeq) -> do _ <- callseq vm txSeq - pushEvent (TxSequenceReplayed i (length txSeqs)) + pushWorkerEvent (TxSequenceReplayed i (length txSeqs)) -- | Run a fuzzing campaign given an initial universe state, some tests, and an -- optional dictionary to generate calls with. Return the 'Campaign' state once @@ -206,7 +207,11 @@ callseq vm txSeq = do cov <- liftIO . readIORef =<< asks (.coverageRef) points <- liftIO $ scoveragePoints cov - pushEvent (NewCoverage points (length cov) newSize) + pushWorkerEvent NewCoverage { points + , numCodehashes = length cov + , corpusSize = newSize + , transactions = fst <$> results + } modify' $ \workerState -> @@ -368,10 +373,10 @@ updateTest vmForShrink (vm, xs) test = do test' = updateOpenTest test xs (testValue, vm', results) case test'.state of Large _ -> do - pushEvent (TestFalsified test') + pushWorkerEvent (TestFalsified test') pure (Just test') _ | test'.value > test.value -> do - pushEvent (TestOptimized test') + pushWorkerEvent (TestOptimized test') pure (Just test') _ -> pure Nothing Large _ -> @@ -381,12 +386,46 @@ updateTest vmForShrink (vm, xs) test = do shrinkTest vmForShrink test _ -> pure Nothing -pushEvent +pushWorkerEvent :: (MonadReader Env m, MonadState WorkerState m, MonadIO m) - => CampaignEvent + => WorkerEvent -> m () -pushEvent event = do +pushWorkerEvent event = do workerId <- gets (.workerId) + env <- ask + liftIO $ pushCampaignEvent env (WorkerEvent workerId event) + +pushCampaignEvent :: Env -> CampaignEvent -> IO () +pushCampaignEvent env event = do time <- liftIO getTimestamp - chan <- asks (.eventQueue) - liftIO $ writeChan chan (workerId, time, event) + writeChan env.eventQueue (time, event) + +-- | Listener reads events and runs the given 'handler' function. It exits after +-- receiving all 'WorkerStopped' events and sets the returned 'MVar' so the +-- parent thread can safely block on listener until all events are processed. +-- +-- NOTE: because the 'Failure' event does not come from a specific fuzzing worker +-- it is possible that a listener won't process it if emitted after all workers +-- are stopped. This is quite unlikely and non-critical but should be addressed +-- in the long term. +spawnListener + :: (MonadReader Env m, MonadIO m) + => ((LocalTime, CampaignEvent) -> IO ()) + -- ^ a function that handles the events + -> m (MVar ()) +spawnListener handler = do + cfg <- asks (.cfg) + let nworkers = fromMaybe 1 cfg.campaignConf.workers + eventQueue <- asks (.eventQueue) + chan <- liftIO $ dupChan eventQueue + stopVar <- liftIO newEmptyMVar + liftIO $ void $ forkFinally (loop chan nworkers) (const $ putMVar stopVar ()) + pure stopVar + where + loop chan !workersAlive = + when (workersAlive > 0) $ do + event <- readChan chan + handler event + case event of + (_, WorkerEvent _ (WorkerStopped _)) -> loop chan (workersAlive - 1) + _ -> loop chan workersAlive diff --git a/lib/Echidna/Output/Corpus.hs b/lib/Echidna/Output/Corpus.hs index c1df732fc..45563cd28 100644 --- a/lib/Echidna/Output/Corpus.hs +++ b/lib/Echidna/Output/Corpus.hs @@ -1,20 +1,28 @@ module Echidna.Output.Corpus where +import Control.Exception (IOException, handle) +import Control.Monad (unless) import Control.Monad.Extra (unlessM) import Data.Aeson (ToJSON(..), decodeStrict, encodeFile) import Data.ByteString qualified as BS import Data.Hashable (hash) import Data.Maybe (catMaybes) +import Data.Time (LocalTime) import System.Directory (createDirectoryIfMissing, makeRelativeToCurrentDirectory, doesFileExist) import System.FilePath ((), (<.>)) +import Echidna.Campaign (pushCampaignEvent) +import Echidna.Types.Config +import Echidna.Types.Campaign +import Echidna.Types.Test (EchidnaTest(..)) import Echidna.Types.Tx (Tx) import Echidna.Utility (listDirectory, withCurrentDirectory) saveTxs :: FilePath -> [[Tx]] -> IO () saveTxs dir = mapM_ saveTxSeq where saveTxSeq txSeq = do - let file = dir (show . hash . show) txSeq <.> "txt" + createDirectoryIfMissing True dir + let file = dir (show . abs . hash . show) txSeq <.> "txt" unlessM (doesFileExist file) $ encodeFile file (toJSON txSeq) loadTxs :: FilePath -> IO [[Tx]] @@ -26,3 +34,31 @@ loadTxs dir = do putStrLn ("Loaded " ++ show (length txSeqs) ++ " transaction sequences from " ++ dir) pure txSeqs where readCall f = decodeStrict <$> BS.readFile f + +-- Save corpus/reproducers transactions based on an event +saveCorpusEvent :: Env -> (LocalTime, CampaignEvent) -> IO () +saveCorpusEvent env (_time, campaignEvent) = do + case env.cfg.campaignConf.corpusDir of + Just corpusDir -> saveEvent corpusDir campaignEvent + Nothing -> pure () + where + saveEvent dir (WorkerEvent _workerId event) = + maybe (pure ()) (saveFile dir) $ getEventInfo event + saveEvent _ _ = pure () + + getEventInfo = \case + -- TODO: We save intermediate reproducers in separate directories. + -- This is to because there can be a lot of them and we want to skip + -- loading those on startup. Ideally, we should override the same file + -- with a better version of a reproducer, this is smaller or more optimized. + TestFalsified test -> Just ("reproducers-unshrunk", test.reproducer) + TestOptimized test -> Just ("reproducers-optimizations", test.reproducer) + NewCoverage { transactions } -> Just ("coverage", transactions) + _ -> Nothing + + saveFile dir (subdir, txs) = + unless (null txs) $ + handle exceptionHandler $ saveTxs (dir subdir) [txs] + + exceptionHandler (e :: IOException) = + pushCampaignEvent env (Failure $ "Problem while writing to file: " ++ show e) diff --git a/lib/Echidna/Server.hs b/lib/Echidna/Server.hs index b9e0f851c..bfc166d7a 100644 --- a/lib/Echidna/Server.hs +++ b/lib/Echidna/Server.hs @@ -10,17 +10,21 @@ import Data.Word (Word16) import Network.Wai.EventSource (ServerEvent(..), eventSourceAppIO) import Network.Wai.Handler.Warp (run) -import Echidna.Types.Campaign (CampaignEvent (..)) +import Echidna.Types.Campaign import Echidna.Types.Config (Env(..)) -newtype SSE = SSE (Int, LocalTime, CampaignEvent) +newtype SSE = SSE (LocalTime, CampaignEvent) instance ToJSON SSE where - toJSON (SSE (workerId, time, event)) = + toJSON (SSE (time, WorkerEvent workerId event)) = object [ "worker" .= workerId , "timestamp" .= time , "data" .= event ] + toJSON (SSE (time, Failure reason)) = + object [ "timestamp" .= time + , "data" .= reason + ] runSSEServer :: MVar () -> Env -> Word16 -> Int -> IO () runSSEServer serverStopVar env port nworkers = do @@ -32,15 +36,18 @@ runSSEServer serverStopVar env port nworkers = do if aliveNow == 0 then pure CloseEvent else do - event@(_, _, campaignEvent) <- readChan sseChan + event@(_, campaignEvent) <- readChan sseChan let eventName = \case - TestFalsified _ -> "test_falsified" - TestOptimized _ -> "test_optimized" - NewCoverage {} -> "new_coverage" - TxSequenceReplayed _ _ -> "tx_sequence_replayed" - WorkerStopped _ -> "worker_stopped" + WorkerEvent _ workerEvent -> + case workerEvent of + TestFalsified _ -> "test_falsified" + TestOptimized _ -> "test_optimized" + NewCoverage {} -> "new_coverage" + TxSequenceReplayed _ _ -> "tx_sequence_replayed" + WorkerStopped _ -> "worker_stopped" + Failure _err -> "failure" case campaignEvent of - WorkerStopped _ -> do + WorkerEvent _ (WorkerStopped _) -> do aliveAfter <- atomicModifyIORef' aliveRef (\n -> (n-1, n-1)) when (aliveAfter == 0) $ putMVar serverStopVar () _ -> pure () diff --git a/lib/Echidna/Types/Campaign.hs b/lib/Echidna/Types/Campaign.hs index c29f2b48f..7e1e5591c 100644 --- a/lib/Echidna/Types/Campaign.hs +++ b/lib/Echidna/Types/Campaign.hs @@ -45,22 +45,28 @@ data CampaignConf = CampaignConf -- ^ Server-Sent Events HTTP port number, if missing server is not ran } +type WorkerId = Int + data CampaignEvent + = WorkerEvent WorkerId WorkerEvent + | Failure String + +data WorkerEvent = TestFalsified !EchidnaTest | TestOptimized !EchidnaTest - | NewCoverage !Int !Int !Int + | NewCoverage { points :: !Int, numCodehashes :: !Int, corpusSize :: !Int, transactions :: [Tx] } | TxSequenceReplayed !Int !Int | WorkerStopped WorkerStopReason -- ^ This is a terminal event. Worker exits and won't push any events after -- this one deriving Show -instance ToJSON CampaignEvent where +instance ToJSON WorkerEvent where toJSON = \case TestFalsified test -> toJSON test TestOptimized test -> toJSON test - NewCoverage coverage numContracts corpusSize -> - object [ "coverage" .= coverage, "contracts" .= numContracts, "corpus_size" .= corpusSize] + NewCoverage { points, numCodehashes, corpusSize } -> + object [ "coverage" .= points, "contracts" .= numCodehashes, "corpus_size" .= corpusSize] TxSequenceReplayed current total -> object [ "current" .= current, "total" .= total ] WorkerStopped reason -> object [ "reason" .= show reason ] @@ -74,20 +80,20 @@ data WorkerStopReason ppCampaignEvent :: CampaignEvent -> String ppCampaignEvent = \case + WorkerEvent _ e -> ppWorkerEvent e + Failure err -> err + +ppWorkerEvent :: WorkerEvent -> String +ppWorkerEvent = \case TestFalsified test -> - let name = case test.testType of - PropertyTest n _ -> n - AssertionTest _ n _ -> encodeSig n - CallTest n _ -> n - _ -> error "impossible" - in "Test " <> T.unpack name <> " falsified!" + "Test " <> T.unpack (showTest test) <> " falsified!" TestOptimized test -> let name = case test.testType of OptimizationTest n _ -> n; _ -> error "fixme" in "New maximum value of " <> T.unpack name <> ": " <> show test.value - NewCoverage points codehashes corpus -> + NewCoverage { points, numCodehashes, corpusSize } -> "New coverage: " <> show points <> " instr, " - <> show codehashes <> " contracts, " - <> show corpus <> " seqs in corpus" + <> show numCodehashes <> " contracts, " + <> show corpusSize <> " seqs in corpus" TxSequenceReplayed current total -> "Sequence replayed from corpus (" <> show current <> "/" <> show total <> ")" WorkerStopped TestLimitReached -> @@ -102,6 +108,12 @@ ppCampaignEvent = \case "Crashed:\n\n" <> e <> "\n\nPlease report it to https://github.com/crytic/echidna/issues" + where + showTest test = case test.testType of + PropertyTest n _ -> n + AssertionTest _ n _ -> encodeSig n + CallTest n _ -> n + _ -> error "impossible" -- | The state of a fuzzing campaign. data WorkerState = WorkerState diff --git a/lib/Echidna/Types/Config.hs b/lib/Echidna/Types/Config.hs index 0f2dc39d5..84f82fecb 100644 --- a/lib/Echidna/Types/Config.hs +++ b/lib/Echidna/Types/Config.hs @@ -65,7 +65,7 @@ data Env = Env -- | Shared between all workers. Events are fairly rare so contention is -- minimal. - , eventQueue :: Chan (Int, LocalTime, CampaignEvent) + , eventQueue :: Chan (LocalTime, CampaignEvent) , testsRef :: IORef [EchidnaTest] , coverageRef :: IORef CoverageMap diff --git a/lib/Echidna/UI.hs b/lib/Echidna/UI.hs index 4c2bfec5b..ccfbc3ea0 100644 --- a/lib/Echidna/UI.hs +++ b/lib/Echidna/UI.hs @@ -21,7 +21,6 @@ import Control.Monad.Catch import Control.Monad.Reader import Control.Monad.State.Strict hiding (state) import Control.Monad.ST (RealWorld) -import Data.Binary.Builder import Data.ByteString.Lazy qualified as BS import Data.List.Split (chunksOf) import Data.Map (Map) @@ -34,12 +33,13 @@ import UnliftIO.Concurrent hiding (killThread, threadDelay) import EVM.Types (Addr, Contract, VM, W256) import Echidna.ABI -import Echidna.Campaign (runWorker) +import Echidna.Campaign (runWorker, spawnListener) +import Echidna.Output.Corpus (saveCorpusEvent) import Echidna.Output.JSON qualified import Echidna.Server (runSSEServer) import Echidna.Types.Campaign import Echidna.Types.Config -import Echidna.Types.Corpus (corpusSize) +import Echidna.Types.Corpus qualified as Corpus import Echidna.Types.Coverage (scoveragePoints) import Echidna.Types.Test (EchidnaTest(..), didFail, isOptimizationTest) import Echidna.Types.Tx (Tx) @@ -51,7 +51,7 @@ data UIEvent = CampaignUpdated LocalTime [EchidnaTest] [WorkerState] | FetchCacheUpdated (Map Addr (Maybe Contract)) (Map Addr (Map W256 (Maybe W256))) - | WorkerEvent (Int, LocalTime, CampaignEvent) + | EventReceived (LocalTime, CampaignEvent) -- | Set up and run an Echidna 'Campaign' and display interactive UI or -- print non-interactive output in desired format at the end @@ -84,19 +84,18 @@ ui vm world dict initialCorpus = do (fromIntegral (length initialCorpus) / fromIntegral nworkers :: Double) corpusChunks = chunksOf chunkSize initialCorpus ++ repeat [] + corpusSaverStopVar <- spawnListener (saveCorpusEvent env) + workers <- forM (zip corpusChunks [0..(nworkers-1)]) $ uncurry (spawnWorker env perWorkerTestLimit) - -- A var used to block and wait for listener to finish - listenerStopVar <- newEmptyMVar - case effectiveMode of #ifdef INTERACTIVE_UI Interactive -> do -- Channel to push events to update UI uiChannel <- liftIO $ newBChan 1000 - let forwardEvent = writeBChan uiChannel . WorkerEvent - liftIO $ spawnListener env forwardEvent nworkers listenerStopVar + let forwardEvent = writeBChan uiChannel . EventReceived + uiEventsForwarderStopVar <- spawnListener forwardEvent ticker <- liftIO . forkIO . forever $ do threadDelay 200_000 -- 200 ms @@ -133,7 +132,7 @@ ui vm world dict initialCorpus = do , fetchedSlots = mempty , fetchedDialog = B.dialog (Just $ str " Fetched contracts/slots ") Nothing 80 , displayFetchedDialog = False - , workerEvents = mempty + , events = mempty , corpusSize = 0 , coverage = 0 , numCodehashes = 0 @@ -145,7 +144,7 @@ ui vm world dict initialCorpus = do stopWorkers workers -- wait for all events to be processed - takeMVar listenerStopVar + forM_ [uiEventsForwarderStopVar, corpusSaverStopVar] takeMVar liftIO $ killThread ticker @@ -162,10 +161,13 @@ ui vm world dict initialCorpus = do #ifdef INTERACTIVE_UI -- Handles ctrl-c, TODO: this doesn't work on Windows liftIO $ forM_ [sigINT, sigTERM] $ \sig -> - installHandler sig (Catch $ stopWorkers workers >> putMVar serverStopVar ()) Nothing + let handler = Catch $ do + stopWorkers workers + void $ tryPutMVar serverStopVar () + in installHandler sig handler Nothing #endif let forwardEvent = putStrLn . ppLogLine - liftIO $ spawnListener env forwardEvent nworkers listenerStopVar + uiEventsForwarderStopVar <- spawnListener forwardEvent let printStatus = do states <- liftIO $ workerStates workers @@ -183,7 +185,7 @@ ui vm world dict initialCorpus = do printStatus -- wait for all events to be processed - takeMVar listenerStopVar + forM_ [uiEventsForwarderStopVar, corpusSaverStopVar] takeMVar liftIO $ killThread ticker @@ -227,7 +229,7 @@ ui vm world dict initialCorpus = do ] time <- liftIO getTimestamp - writeChan env.eventQueue (workerId, time, WorkerStopped stopReason) + writeChan env.eventQueue (time, WorkerEvent workerId (WorkerStopped stopReason)) pure (threadId, stateRef) @@ -235,28 +237,6 @@ ui vm world dict initialCorpus = do workerStates workers = forM workers $ \(_, stateRef) -> readIORef stateRef --- | Listener reads events and forwards all of them to the UI using the --- 'forwardEvent' function. It exits after receiving all 'WorkerStopped' --- events and sets the passed 'MVar' so the parent thread can block on listener --- until all workers are done. -spawnListener - :: Env - -> ((Int, LocalTime, CampaignEvent) -> IO ()) - -- ^ a function that forwards event to the UI - -> Int -- ^ number of workers - -> MVar () -- ^ use to join this thread - -> IO () -spawnListener env forwardEvent nworkers stopVar = - void $ forkFinally (loop nworkers) (const $ putMVar stopVar ()) - where - loop !workersAlive = - when (workersAlive > 0) $ do - event <- readChan env.eventQueue - forwardEvent event - case event of - (_, _, WorkerStopped _) -> loop (workersAlive - 1) - _ -> loop workersAlive - #ifdef INTERACTIVE_UI -- | Order the workers to stop immediately stopWorkers :: MonadIO m => [(ThreadId, a)] -> m () @@ -288,18 +268,18 @@ monitor = do modify' $ \state -> state { fetchedContracts = contracts , fetchedSlots = slots } - AppEvent (WorkerEvent event@(_,time,campaignEvent)) -> do - modify' $ \state -> state { workerEvents = state.workerEvents |> event } + AppEvent (EventReceived event@(time,campaignEvent)) -> do + modify' $ \state -> state { events = state.events |> event } case campaignEvent of - NewCoverage coverage numCodehashes size -> + WorkerEvent _ (NewCoverage { points, numCodehashes, corpusSize }) -> modify' $ \state -> - state { coverage = max state.coverage coverage -- max not really needed - , corpusSize = size + state { coverage = max state.coverage points -- max not really needed + , corpusSize , numCodehashes , lastNewCov = time } - WorkerStopped _ -> + WorkerEvent _ (WorkerStopped _) -> modify' $ \state -> state { workersAlive = state.workersAlive - 1 , timeStopped = if state.workersAlive == 1 @@ -365,4 +345,5 @@ statusLine env states = do <> ", fuzzing: " <> show totalCalls <> "/" <> show env.cfg.campaignConf.testLimit <> ", values: " <> show ((.value) <$> filter isOptimizationTest tests) <> ", cov: " <> show points - <> ", corpus: " <> show (corpusSize corpus) + <> ", corpus: " <> show (Corpus.corpusSize corpus) + diff --git a/lib/Echidna/UI/Report.hs b/lib/Echidna/UI/Report.hs index eb6956848..ac3dd396e 100644 --- a/lib/Echidna/UI/Report.hs +++ b/lib/Echidna/UI/Report.hs @@ -25,9 +25,11 @@ import Echidna.Utility (timePrefix) import EVM.Format (showTraceTree) import EVM.Types (W256, VM) -ppLogLine :: (Int, LocalTime, CampaignEvent) -> String -ppLogLine (workerId, time, event) = +ppLogLine :: (LocalTime, CampaignEvent) -> String +ppLogLine (time, event@(WorkerEvent workerId _)) = timePrefix time <> "[Worker " <> show workerId <> "] " <> ppCampaignEvent event +ppLogLine (time, event) = + timePrefix time <> " " <> ppCampaignEvent event ppCampaign :: (MonadIO m, MonadReader Env m) => [WorkerState] -> m String ppCampaign workerStates = do diff --git a/lib/Echidna/UI/Widgets.hs b/lib/Echidna/UI/Widgets.hs index 6bbeec60d..c0d1b2f67 100644 --- a/lib/Echidna/UI/Widgets.hs +++ b/lib/Echidna/UI/Widgets.hs @@ -49,7 +49,7 @@ data UIState = UIState , fetchedDialog :: B.Dialog () Name , displayFetchedDialog :: Bool - , workerEvents :: Seq (Int, LocalTime, CampaignEvent) + , events :: Seq (LocalTime, CampaignEvent) , workersAlive :: Int , corpusSize :: Int @@ -117,7 +117,7 @@ campaignStatus uiState = do inner <=> hBorderWithLabel (withAttr (attrName "subtitle") $ str $ - " Log (" <> show (length uiState.workerEvents) <> ") ") + " Log (" <> show (length uiState.events) <> ") ") <=> logPane uiState <=> @@ -137,12 +137,14 @@ logPane uiState = withVScrollBars OnRight . withVScrollBarHandles . viewport LogViewPort Vertical $ - foldl (<=>) emptyWidget (showLogLine <$> Seq.reverse uiState.workerEvents) + foldl (<=>) emptyWidget (showLogLine <$> Seq.reverse uiState.events) -showLogLine :: (Int, LocalTime, CampaignEvent) -> Widget Name -showLogLine (workerId, time, event) = +showLogLine :: (LocalTime, CampaignEvent) -> Widget Name +showLogLine (time, event@(WorkerEvent workerId _)) = (withAttr (attrName "time") $ str $ (timePrefix time) <> "[Worker " <> show workerId <> "] ") <+> strBreak (ppCampaignEvent event) +showLogLine (time, event) = + (withAttr (attrName "time") $ str $ (timePrefix time) <> " ") <+> strBreak (ppCampaignEvent event) summaryWidget :: Env -> UIState -> Widget Name summaryWidget env uiState =