From 8a2fca4492cb83b32c1ec185a6a959c4994aec65 Mon Sep 17 00:00:00 2001 From: Sam Alws Date: Thu, 18 May 2023 16:04:54 -0400 Subject: [PATCH] Save corpus while fuzzing; add TestSimplified event; change event system --- lib/Echidna/Async.hs | 39 +++++++++++++++++++++++++++++++++ lib/Echidna/Campaign.hs | 15 ++----------- lib/Echidna/Output/Corpus.hs | 32 ++++++++++++++++++++++++--- lib/Echidna/Shrink.hs | 15 ++++++++----- lib/Echidna/Types/Campaign.hs | 24 +++++++++++++------- lib/Echidna/Types/Config.hs | 10 +++++---- lib/Echidna/UI.hs | 41 +++++------------------------------ package.yaml | 1 + src/Main.hs | 16 +++++++++----- src/test/Common.hs | 14 +++++++----- src/test/Tests/Compile.hs | 8 ++++--- 11 files changed, 132 insertions(+), 83 deletions(-) create mode 100644 lib/Echidna/Async.hs diff --git a/lib/Echidna/Async.hs b/lib/Echidna/Async.hs new file mode 100644 index 000000000..4b9d82151 --- /dev/null +++ b/lib/Echidna/Async.hs @@ -0,0 +1,39 @@ +module Echidna.Async where + +import Control.Concurrent.Thread.Group (forkIO) +import Control.Monad (void) +import Control.Monad.Reader (MonadReader, asks, ask) +import Control.Monad.State.Strict (MonadState, gets) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.IORef (atomicModifyIORef', readIORef) +import Data.Time (LocalTime) + +import Echidna.Types.Campaign (CampaignEvent, WorkerState(..)) +import Echidna.Types.Config (Env(..)) +import Echidna.Utility (getTimestamp) + +spawnThread :: Env -> IO a -> IO () +spawnThread env io = void $ forkIO env.threadGroup io + +addEventHandler + :: (MonadReader Env m, MonadIO m) + => ((Int, LocalTime, CampaignEvent) -> IO ()) + -> m () +addEventHandler f = do + handlersRef <- asks (.eventHandlers) + liftIO $ atomicModifyIORef' handlersRef (\l -> (f:l, ())) + +pushEvent + :: (MonadReader Env m, MonadState WorkerState m, MonadIO m) + => CampaignEvent + -> m () +pushEvent event = do + workerId <- gets (.workerId) + env <- ask + liftIO $ pushEventIO env workerId event + +pushEventIO :: Env -> Int -> CampaignEvent -> IO () +pushEventIO env workerId event = do + time <- liftIO getTimestamp + handlers <- readIORef env.eventHandlers + mapM_ (\f -> spawnThread env $ f (workerId, time, event)) handlers diff --git a/lib/Echidna/Campaign.hs b/lib/Echidna/Campaign.hs index 3beedb00b..19b63af60 100644 --- a/lib/Echidna/Campaign.hs +++ b/lib/Echidna/Campaign.hs @@ -4,7 +4,6 @@ module Echidna.Campaign where import Optics.Core hiding ((|>)) -import Control.Concurrent (writeChan) import Control.DeepSeq (force) import Control.Monad (replicateM, when, void, forM_) import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) @@ -30,6 +29,7 @@ import EVM.ABI (getAbi, AbiType(AbiAddressType), AbiValue(AbiAddress)) import EVM.Types (Addr, Expr(ConcreteBuf)) import Echidna.ABI +import Echidna.Async (pushEvent) import Echidna.Exec import Echidna.Events (extractEvents) import Echidna.Mutator.Corpus @@ -47,7 +47,6 @@ import Echidna.Types.Test import Echidna.Types.Test qualified as Test import Echidna.Types.Tx (TxCall(..), Tx(..), call) import Echidna.Types.World (World) -import Echidna.Utility (getTimestamp) instance MonadThrow m => MonadThrow (RandT g m) where throwM = lift . throwM @@ -242,7 +241,7 @@ callseq vm txSeq = do cov <- liftIO . readIORef =<< asks (.coverageRef) points <- liftIO $ scoveragePoints cov - pushEvent (NewCoverage points (length cov) newSize) + pushEvent (NewCoverage points (length cov) newSize (fst <$> res)) -- Update the campaign state put campaign' @@ -392,13 +391,3 @@ updateTest vmForShrink (vm, xs) test = do -- but requires passing `vmForShrink` and feels a bit wrong. shrinkTest vmForShrink test _ -> pure Nothing - -pushEvent - :: (MonadReader Env m, MonadState WorkerState m, MonadIO m) - => CampaignEvent - -> m () -pushEvent event = do - workerId <- gets (.workerId) - time <- liftIO getTimestamp - chan <- asks (.eventQueue) - liftIO $ writeChan chan (workerId, time, event) diff --git a/lib/Echidna/Output/Corpus.hs b/lib/Echidna/Output/Corpus.hs index c1df732fc..58e4adc28 100644 --- a/lib/Echidna/Output/Corpus.hs +++ b/lib/Echidna/Output/Corpus.hs @@ -1,5 +1,9 @@ module Echidna.Output.Corpus where +import Control.Exception (handle, IOException) +import Control.Monad (unless) +import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.IO.Class (MonadIO) import Control.Monad.Extra (unlessM) import Data.Aeson (ToJSON(..), decodeStrict, encodeFile) import Data.ByteString qualified as BS @@ -8,13 +12,17 @@ import Data.Maybe (catMaybes) import System.Directory (createDirectoryIfMissing, makeRelativeToCurrentDirectory, doesFileExist) import System.FilePath ((), (<.>)) +import Echidna.Async (addEventHandler, pushEventIO) +import Echidna.Types.Campaign (CampaignEvent(..), CampaignConf(..)) +import Echidna.Types.Config (Env(..), EConfig(..)) +import Echidna.Types.Test (EchidnaTest(..)) import Echidna.Types.Tx (Tx) import Echidna.Utility (listDirectory, withCurrentDirectory) -saveTxs :: FilePath -> [[Tx]] -> IO () -saveTxs dir = mapM_ saveTxSeq where +saveTxs :: FilePath -> String -> [[Tx]] -> IO () +saveTxs dir prefix = mapM_ saveTxSeq where saveTxSeq txSeq = do - let file = dir (show . hash . show) txSeq <.> "txt" + let file = dir prefix ++ (show . abs . hash . show) txSeq <.> "txt" unlessM (doesFileExist file) $ encodeFile file (toJSON txSeq) loadTxs :: FilePath -> IO [[Tx]] @@ -26,3 +34,21 @@ loadTxs dir = do putStrLn ("Loaded " ++ show (length txSeqs) ++ " transaction sequences from " ++ dir) pure txSeqs where readCall f = decodeStrict <$> BS.readFile f + +-- setup a handler to save to corpus in the background while tests are running +setupCorpusSaver :: (MonadReader Env m, MonadIO m) => m () +setupCorpusSaver = do + env <- ask + maybe (pure ()) (addEventHandler . saveEvent env) env.cfg.campaignConf.corpusDir + where + saveEvent env dir (workerId, _, event) = maybe (pure ()) (saveFile workerId env dir) $ getEventInfo event + + getEventInfo (TestFalsified test) = Just ("reproducers", "unshrunk-", test.reproducer) + getEventInfo (TestOptimized test) = Just ("reproducers", "", test.reproducer) + getEventInfo (TestShrunk test) = Just ("reproducers", "", test.reproducer) + getEventInfo (NewCoverage _ _ _ txs) = Just ("coverage", "", txs) + getEventInfo _ = Nothing + + saveFile workerId env dir (subdir, prefix, txs) = unless (null txs) $ handle (exceptionHandler workerId env) $ saveTxs (dir subdir) prefix [txs] + + exceptionHandler workerId env (e :: IOException) = pushEventIO env workerId . HandlerFailed $ "Problem while writing to file: " ++ show e diff --git a/lib/Echidna/Shrink.hs b/lib/Echidna/Shrink.hs index 4a16612a9..0f2fbd535 100644 --- a/lib/Echidna/Shrink.hs +++ b/lib/Echidna/Shrink.hs @@ -11,6 +11,7 @@ import Data.List qualified as List import EVM (VM) +import Echidna.Async (pushEvent) import Echidna.Events (extractEvents) import Echidna.Exec import Echidna.Transaction @@ -18,11 +19,11 @@ import Echidna.Types.Solidity (SolConf(..)) import Echidna.Types.Test (TestValue(..), EchidnaTest(..), TestState(..), isOptimizationTest) import Echidna.Types.Tx (Tx(..)) import Echidna.Types.Config -import Echidna.Types.Campaign (CampaignConf(..)) +import Echidna.Types.Campaign (CampaignConf(..), CampaignEvent(..), WorkerState(..)) import Echidna.Test (getResultFromVM, checkETest) shrinkTest - :: (MonadIO m, MonadCatch m, MonadRandom m, MonadReader Env m) + :: (MonadIO m, MonadCatch m, MonadRandom m, MonadReader Env m, MonadState WorkerState m) => VM -> EchidnaTest -> m (Maybe EchidnaTest) @@ -30,7 +31,7 @@ shrinkTest vm test = do env <- ask case test.state of Large i | i >= env.cfg.campaignConf.shrinkLimit && not (isOptimizationTest test) -> - pure $ Just test { state = Solved } + solvedEvent $ test { state = Solved } Large i -> if length test.reproducer > 1 || any canShrinkTx test.reproducer then do maybeShrunk <- evalStateT (shrinkSeq (checkETest test) test.value test.reproducer) vm @@ -44,11 +45,13 @@ shrinkTest vm test = do Nothing -> -- No success with shrinking this time, just bump trials Just test { state = Large (i + 1) } + else if isOptimizationTest test then + pure $ Just test { state = Large (i + 1) } else - pure $ Just test { state = if isOptimizationTest test - then Large (i + 1) - else Solved } + solvedEvent $ test { state = Solved } _ -> pure Nothing + where + solvedEvent test' = pushEvent (TestShrunk test') >> pure (Just test') -- | Given a call sequence that solves some Echidna test, try to randomly -- generate a smaller one that still solves that test. diff --git a/lib/Echidna/Types/Campaign.hs b/lib/Echidna/Types/Campaign.hs index 85f0ca478..38096b30d 100644 --- a/lib/Echidna/Types/Campaign.hs +++ b/lib/Echidna/Types/Campaign.hs @@ -44,8 +44,12 @@ data CampaignConf = CampaignConf data CampaignEvent = TestFalsified !EchidnaTest | TestOptimized !EchidnaTest - | NewCoverage !Int !Int !Int + | TestShrunk !EchidnaTest + | NewCoverage !Int !Int !Int [Tx] | TxSequenceReplayed !Int !Int + | HandlerFailed !String + -- ^ Error occurred while handling another event + -- (e.g. failed to write coverage to a file) | WorkerStopped WorkerStopReason -- ^ This is a terminal event. Worker exits and won't push any events after -- this one @@ -62,21 +66,19 @@ data WorkerStopReason ppCampaignEvent :: CampaignEvent -> String ppCampaignEvent = \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 -> + TestShrunk test -> + "Test " <> T.unpack (showTest test) <> " shrunk." + NewCoverage points codehashes corpus _ -> "New coverage: " <> show points <> " instr, " <> show codehashes <> " contracts, " <> show corpus <> " seqs in corpus" TxSequenceReplayed current total -> "Sequence replayed from corpus (" <> show current <> "/" <> show total <> ")" + HandlerFailed s -> "Error while handling event: " ++ s WorkerStopped TestLimitReached -> "Test limit reached. Stopping." WorkerStopped TimeLimitReached -> @@ -89,6 +91,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 1250129d2..1813b1ba7 100644 --- a/lib/Echidna/Types/Config.hs +++ b/lib/Echidna/Types/Config.hs @@ -1,6 +1,6 @@ module Echidna.Types.Config where -import Control.Concurrent (Chan) +import Control.Concurrent.Thread.Group (ThreadGroup) import Data.Aeson.Key (Key) import Data.IORef (IORef) import Data.Map (Map) @@ -64,9 +64,11 @@ data Env = Env { cfg :: EConfig , dapp :: DappInfo - -- | Shared between all workers. Events are fairly rare so contention is - -- minimal. - , eventQueue :: Chan (Int, LocalTime, CampaignEvent) + , eventHandlers :: IORef [(Int, LocalTime, CampaignEvent) -> IO ()] + + -- mainly for handling events, but can be used for any purpose + -- `wait` is called on this group before echidna closes + , threadGroup :: ThreadGroup , testsRef :: IORef [EchidnaTest] , coverageRef :: IORef CoverageMap diff --git a/lib/Echidna/UI.hs b/lib/Echidna/UI.hs index e8aadcc35..8682a5cd6 100644 --- a/lib/Echidna/UI.hs +++ b/lib/Echidna/UI.hs @@ -36,6 +36,7 @@ import EVM (VM, Contract) import EVM.Types (Addr, W256) import Echidna.ABI +import Echidna.Async (addEventHandler, pushEventIO) import Echidna.Campaign (runWorker) import Echidna.Output.JSON qualified import Echidna.Types.Campaign @@ -88,16 +89,13 @@ ui vm world dict initialCorpus = do 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 + addEventHandler forwardEvent ticker <- liftIO . forkIO . forever $ do threadDelay 200_000 -- 200 ms @@ -145,9 +143,6 @@ ui vm world dict initialCorpus = do -- Exited from the UI, stop the workers, not needed anymore stopWorkers workers - -- wait for all events to be processed - takeMVar listenerStopVar - liftIO $ killThread ticker states <- workerStates workers @@ -165,7 +160,7 @@ ui vm world dict initialCorpus = do installHandler sig (Catch $ stopWorkers workers) Nothing #endif let forwardEvent = putStrLn . ppLogLine - liftIO $ spawnListener env forwardEvent nworkers listenerStopVar + addEventHandler forwardEvent let printStatus = do states <- liftIO $ workerStates workers @@ -178,9 +173,6 @@ ui vm world dict initialCorpus = do threadDelay 3_000_000 -- 3 seconds printStatus - -- wait for all events to be processed - takeMVar listenerStopVar - liftIO $ killThread ticker -- print final status regardless the last scheduled update @@ -217,8 +209,7 @@ ui vm world dict initialCorpus = do , Handler $ \(e :: SomeException) -> pure $ Crashed (show e) ] - time <- liftIO getTimestamp - writeChan env.eventQueue (workerId, time, WorkerStopped stopReason) + liftIO $ pushEventIO env workerId (WorkerStopped stopReason) pure (threadId, stateRef) @@ -226,28 +217,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 () @@ -283,7 +252,7 @@ monitor = do modify' $ \state -> state { workerEvents = state.workerEvents |> event } case campaignEvent of - NewCoverage coverage numCodehashes size -> + NewCoverage coverage numCodehashes size _ -> modify' $ \state -> state { coverage = max state.coverage coverage -- max not really needed , corpusSize = size diff --git a/package.yaml b/package.yaml index 81a33cf6b..9feafbeb2 100644 --- a/package.yaml +++ b/package.yaml @@ -38,6 +38,7 @@ dependencies: - semver - split - text + - threads - transformers - time - unliftio diff --git a/src/Main.hs b/src/Main.hs index 5f4a50887..fb87f1371 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,7 +4,7 @@ module Main where import Optics.Core (view) -import Control.Concurrent (newChan) +import Control.Concurrent.Thread.Group qualified as ThreadGroup import Control.Monad (unless, forM_, when) import Control.Monad.Reader (runReaderT) import Control.Monad.Random (getRandomR) @@ -92,7 +92,8 @@ main = withUtf8 $ withCP65001 $ do cacheSlotsRef <- newIORef $ fromMaybe mempty loadedSlotsCache cacheMetaRef <- newIORef mempty chainId <- RPC.fetchChainId cfg.rpcUrl - eventQueue <- newChan + eventHandlers <- newIORef mempty + threadGroup <- ThreadGroup.new coverageRef <- newIORef mempty corpusRef <- newIORef mempty testsRef <- newIORef mempty @@ -107,7 +108,8 @@ main = withUtf8 $ withCP65001 $ do , fetchContractCache = cacheContractsRef , fetchSlotCache = cacheSlotsRef , chainId = chainId - , eventQueue + , eventHandlers + , threadGroup , coverageRef , corpusRef , testsRef @@ -118,6 +120,8 @@ main = withUtf8 $ withCP65001 $ do (vm, world, dict) <- prepareContract env contracts cliFilePath cliSelectedContract seed + runReaderT setupCorpusSaver env + initialCorpus <- loadInitialCorpus env world -- start ui and run tests _campaign <- runReaderT (ui vm world dict initialCorpus) env @@ -127,6 +131,8 @@ main = withUtf8 $ withCP65001 $ do tests <- readIORef testsRef + ThreadGroup.wait threadGroup + -- save corpus case cfg.campaignConf.corpusDir of Nothing -> pure () @@ -143,10 +149,10 @@ main = withUtf8 $ withCP65001 $ do pure () measureIO cfg.solConf.quiet "Saving test reproducers" $ - saveTxs (dir "reproducers") (filter (not . null) $ (.reproducer) <$> tests) + saveTxs (dir "reproducers") "" (filter (not . null) $ (.reproducer) <$> tests) measureIO cfg.solConf.quiet "Saving corpus" $ do corpus <- readIORef corpusRef - saveTxs (dir "coverage") (snd <$> Set.toList corpus) + saveTxs (dir "coverage") "" (snd <$> Set.toList corpus) -- TODO: We use the corpus dir to save coverage reports which is confusing. -- Add config option to pass dir for saving coverage report and decouple it diff --git a/src/test/Common.hs b/src/test/Common.hs index b02e99045..00ee51e4f 100644 --- a/src/test/Common.hs +++ b/src/test/Common.hs @@ -25,6 +25,7 @@ import Prelude hiding (lookup) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase, assertBool) +import Control.Concurrent.Thread.Group qualified as ThreadGroup import Control.Monad.Reader (runReaderT) import Control.Monad.Random (getRandomR) import Control.Monad.State.Strict (evalStateT) @@ -54,7 +55,6 @@ import Echidna.Types.Tx (Tx(..), TxCall(..), call) import EVM.Dapp (dappInfo, emptyDapp) import EVM.Solidity (SolcContract(..)) -import Control.Concurrent (newChan) import Control.Monad (forM_) testConfig :: EConfig @@ -102,7 +102,8 @@ runContract f selectedContract cfg = do fetchSlotCache <- newIORef mempty coverageRef <- newIORef mempty corpusRef <- newIORef mempty - eventQueue <- newChan + eventHandlers <- newIORef mempty + threadGroup <- ThreadGroup.new testsRef <- newIORef mempty let env = Env { cfg = cfg , dapp = dappInfo "/" solcByName sourceCache @@ -111,7 +112,8 @@ runContract f selectedContract cfg = do , fetchSlotCache , coverageRef , corpusRef - , eventQueue + , eventHandlers + , threadGroup , testsRef , chainId = Nothing } (vm, world, dict) <- prepareContract env contracts (f :| []) selectedContract seed @@ -167,7 +169,8 @@ checkConstructorConditions fp as = testCase fp $ do coverageRef <- newIORef mempty corpusRef <- newIORef mempty testsRef <- newIORef mempty - eventQueue <- newChan + eventHandlers <- newIORef mempty + threadGroup <- ThreadGroup.new let env = Env { cfg = testConfig , dapp = emptyDapp , metadataCache = cacheMeta @@ -175,7 +178,8 @@ checkConstructorConditions fp as = testCase fp $ do , fetchSlotCache = cacheSlots , coverageRef , corpusRef - , eventQueue + , eventHandlers + , threadGroup , testsRef , chainId = Nothing } (v, _, t) <- loadSolTests env (fp :| []) Nothing diff --git a/src/test/Tests/Compile.hs b/src/test/Tests/Compile.hs index 905b956f1..2ed1e7518 100644 --- a/src/test/Tests/Compile.hs +++ b/src/test/Tests/Compile.hs @@ -4,6 +4,7 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, assertBool) import Common (testConfig) +import Control.Concurrent.Thread.Group qualified as ThreadGroup import Control.Monad (void) import Control.Monad.Catch (catch) import Data.List.NonEmpty (NonEmpty(..)) @@ -13,7 +14,6 @@ import Echidna.Solidity (loadSolTests) import Echidna.Types.Config (Env(..)) import EVM.Dapp (emptyDapp) import Data.IORef (newIORef) -import Control.Concurrent (newChan) compilationTests :: TestTree compilationTests = testGroup "Compilation and loading tests" @@ -43,7 +43,8 @@ loadFails fp c e p = testCase fp . catch tryLoad $ assertBool e . p where cacheMeta <- newIORef mempty cacheContracts <- newIORef mempty cacheSlots <- newIORef mempty - eventQueue <- newChan + eventHandlers <- newIORef mempty + threadGroup <- ThreadGroup.new coverageRef <- newIORef mempty corpusRef <- newIORef mempty testsRef <- newIORef mempty @@ -53,7 +54,8 @@ loadFails fp c e p = testCase fp . catch tryLoad $ assertBool e . p where , fetchContractCache = cacheContracts , fetchSlotCache = cacheSlots , chainId = Nothing - , eventQueue + , eventHandlers + , threadGroup , coverageRef , corpusRef , testsRef