From bab2f7f1ca81a5f677d7a9818f9f4d600a6b046c Mon Sep 17 00:00:00 2001 From: Artur Cygan Date: Tue, 10 Jan 2023 10:42:28 +0100 Subject: [PATCH] Multicore WIP --- lib/Echidna/Campaign.hs | 40 +++- lib/Echidna/Config.hs | 1 + lib/Echidna/Exec.hs | 4 +- lib/Echidna/Output/JSON.hs | 4 +- lib/Echidna/Output/Source.hs | 7 +- lib/Echidna/Test.hs | 7 +- lib/Echidna/Types/Campaign.hs | 55 ++++- lib/Echidna/Types/Test.hs | 8 + lib/Echidna/UI.hs | 361 ++++++++++++++++++++++-------- lib/Echidna/UI/Report.hs | 28 ++- lib/Echidna/UI/Widgets.hs | 93 ++++++-- lib/Echidna/Utility.hs | 18 +- package.yaml | 28 +-- src/Main.hs | 10 +- src/test/Tests/Seed.hs | 1 + tests/solidity/basic/default.yaml | 2 + 16 files changed, 502 insertions(+), 165 deletions(-) diff --git a/lib/Echidna/Campaign.hs b/lib/Echidna/Campaign.hs index eef4ef969..7a8167946 100644 --- a/lib/Echidna/Campaign.hs +++ b/lib/Echidna/Campaign.hs @@ -3,7 +3,7 @@ module Echidna.Campaign where import Control.DeepSeq (force) -import Control.Lens +import Control.Lens hiding ((|>)) import Control.Monad (foldM, replicateM, when, unless, void) import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) import Control.Monad.Random.Strict (MonadRandom, RandT, evalRandT) @@ -18,6 +18,7 @@ import Data.IORef (readIORef, writeIORef) import Data.Map qualified as Map import Data.Map (Map, (\\)) import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Sequence ((|>)) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) @@ -37,13 +38,15 @@ import Echidna.Test import Echidna.Transaction import Echidna.Types (Gas) import Echidna.Types.Buffer (forceBuf) -import Echidna.Types.Corpus (Corpus) import Echidna.Types.Campaign +import Echidna.Types.Corpus (Corpus) +import Echidna.Types.Coverage (scoveragePoints) import Echidna.Types.Config import Echidna.Types.Signature (makeBytecodeCache, FunctionName) import Echidna.Types.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 @@ -72,7 +75,7 @@ isDone c = do -- | Given a 'Campaign', check if the test results should be reported as a -- success or a failure. -isSuccessful :: Campaign -> Bool +isSuccessful :: GenericCampaign a -> Bool isSuccessful Campaign{tests} = all (\case { Passed -> True; Open _ -> True; _ -> False; }) ((.state) <$> tests) @@ -117,6 +120,7 @@ runCampaign callback vm world tests dict initialCorpus = do , newCoverage = False , corpus = Set.empty , ncallseqs = 0 + , events = mempty } flip execStateT campaign $ do @@ -249,6 +253,10 @@ callseq vm txSeq = do , ncallseqs = camp'.ncallseqs + 1 } + when camp'.newCoverage $ do + points <- liftIO (scoveragePoints camp'.coverage) + pushEvent (NewCoverage points) + pure vm' where -- Given a list of transactions and a return typing rule, checks whether we @@ -351,25 +359,33 @@ runUpdate f = do -- (3): The test is unshrunk, and we can shrink it -- Then update accordingly, keeping track of how many times we've tried to solve or shrink. updateTest - :: (MonadIO m, MonadCatch m, MonadRandom m, MonadReader Env m) + :: (MonadIO m, MonadCatch m, MonadRandom m, MonadReader Env m, MonadState Campaign m) => VM -> (VM, [Tx]) -> EchidnaTest -> m EchidnaTest updateTest vmForShrink (vm, xs) test = do - limit <- asks (.cfg.campaignConf.testLimit) dappInfo <- asks (.dapp) case test.state of - Open i | i > limit -> case test.testType of - OptimizationTest _ _ -> pure $ test { state = Large (-1) } - _ -> pure $ test { state = Passed } Open i -> do (testValue, vm') <- evalStateT (checkETest test) vm - let events = extractEvents False dappInfo vm' - let results = getResultFromVM vm' - pure $ updateOpenTest test xs i (testValue, events, results) - _ -> + let + events = extractEvents False dappInfo vm' + results = getResultFromVM vm' + let test' = updateOpenTest test xs i (testValue, events, results) + case test'.state of + Large _ -> do + pushEvent (TestFalsified test.testType) >> pure test' + _ -> pure test' + Large _ -> -- TODO: We shrink already in `step`, but we shrink here too. It makes -- shrink go faster when some tests are still fuzzed. It's not incorrect -- but requires passing `vmForShrink` and feels a bit wrong. shrinkTest vmForShrink test + _ -> pure test + +pushEvent :: (MonadIO m, MonadState Campaign m) => CampaignEvent -> m () +pushEvent event = do + time <- liftIO getTimestamp + modify' $ \campaign -> + campaign { Echidna.Types.Campaign.events = campaign.events |> (time, event) } diff --git a/lib/Echidna/Config.hs b/lib/Echidna/Config.hs index 32a9f0a8e..c42a1eda3 100644 --- a/lib/Echidna/Config.hs +++ b/lib/Echidna/Config.hs @@ -95,6 +95,7 @@ instance FromJSON EConfigWithUsage where <*> v ..:? "corpusDir" ..!= Nothing <*> v ..:? "mutConsts" ..!= defaultMutationConsts <*> v ..:? "coverageReport" ..!= True + <*> v ..:? "jobs" solConfParser = SolConf <$> v ..:? "contractAddr" ..!= defaultContractAddr diff --git a/lib/Echidna/Exec.hs b/lib/Echidna/Exec.hs index 1219e7951..0880904b4 100644 --- a/lib/Echidna/Exec.hs +++ b/lib/Echidna/Exec.hs @@ -35,7 +35,7 @@ import Echidna.Types.Signature (MetadataCache, getBytecodeMetadata, lookupByteco import Echidna.Types.Tx (TxCall(..), Tx, TxResult(..), call, dst, initialTimestamp, initialBlockNumber, getResult) import Echidna.Types.Config (Env(..), EConfig(..), UIConf(..), OperationMode(..), OutputFormat(Text)) import Echidna.Types.Solidity (SolConf(..)) -import Echidna.Utility (timePrefix) +import Echidna.Utility (getTimestamp, timePrefix) -- | Broad categories of execution failures: reversions, illegal operations, and ???. data ErrorClass = RevertE | IllegalE | UnknownE @@ -216,7 +216,7 @@ logMsg msg = do cfg <- asks (.cfg) operationMode <- asks (.cfg.uiConf.operationMode) when (operationMode == NonInteractive Text && not cfg.solConf.quiet) $ liftIO $ do - time <- timePrefix + time <- timePrefix <$> getTimestamp putStrLn $ time <> msg -- | Execute a transaction "as normal". diff --git a/lib/Echidna/Output/JSON.hs b/lib/Echidna/Output/JSON.hs index 1493d9985..e338bf8b0 100644 --- a/lib/Echidna/Output/JSON.hs +++ b/lib/Echidna/Output/JSON.hs @@ -93,9 +93,9 @@ instance ToJSON Transaction where , "gasprice" .= gasprice ] -encodeCampaign :: C.Campaign -> IO ByteString +encodeCampaign :: C.FrozenCampaign -> IO ByteString encodeCampaign C.Campaign{..} = do - frozenCov <- mapM VU.freeze coverage + let frozenCov = coverage pure $ encode Campaign { _success = True , _error = Nothing diff --git a/lib/Echidna/Output/Source.hs b/lib/Echidna/Output/Source.hs index 391469ca2..167bc272f 100644 --- a/lib/Echidna/Output/Source.hs +++ b/lib/Echidna/Output/Source.hs @@ -23,15 +23,14 @@ import Text.Printf (printf) import EVM.Debug (srcMapCodePos) import EVM.Solidity (SourceCache(..), SrcMap, SolcContract(..)) -import Echidna.Types.Coverage (CoverageMap, FrozenCoverageMap, OpIx, unpackTxResults) +import Echidna.Types.Coverage (FrozenCoverageMap, OpIx, unpackTxResults) import Echidna.Types.Tx (TxResult(..)) import Echidna.Types.Signature (getBytecodeMetadata) type FilePathText = Text -saveCoverage :: Bool -> Int -> FilePath -> SourceCache -> [SolcContract] -> CoverageMap -> IO () -saveCoverage isHtml seed d sc cs covMap = do - frozenCovMap <- mapM VU.freeze covMap +saveCoverage :: Bool -> Int -> FilePath -> SourceCache -> [SolcContract] -> FrozenCoverageMap -> IO () +saveCoverage isHtml seed d sc cs frozenCovMap = do let extension = if isHtml then ".html" else ".txt" fn = d "covered." <> show seed <> extension cc = ppCoveredCode isHtml sc cs frozenCovMap diff --git a/lib/Echidna/Test.hs b/lib/Echidna/Test.hs index 9891a6983..bc96457cd 100644 --- a/lib/Echidna/Test.hs +++ b/lib/Echidna/Test.hs @@ -189,8 +189,11 @@ getIntFromResult (Just (VMSuccess b)) = getIntFromResult _ = IntValue minBound -- | Given a property test, evaluate it and see if it currently passes. -checkOptimization :: (MonadIO m, MonadReader Env m, MonadState VM m, MonadThrow m) - => Text -> Addr -> m (TestValue, VM) +checkOptimization + :: (MonadIO m, MonadReader Env m, MonadState VM m, MonadThrow m) + => Text + -> Addr + -> m (TestValue, VM) checkOptimization f a = do TestConf _ s <- asks (.cfg.testConf) (vm, vm') <- runTx f s a diff --git a/lib/Echidna/Types/Campaign.hs b/lib/Echidna/Types/Campaign.hs index c0118d24d..5331d794d 100644 --- a/lib/Echidna/Types/Campaign.hs +++ b/lib/Echidna/Types/Campaign.hs @@ -1,14 +1,20 @@ module Echidna.Types.Campaign where +import Data.List (transpose) import Data.Map (Map) +import Data.Sequence (Seq) import Data.Text (Text) +import Data.Time (LocalTime) +import Data.Word (Word8) import Echidna.ABI (GenDict, emptyDict) import Echidna.Types import Echidna.Types.Corpus import Echidna.Types.Coverage (CoverageMap, FrozenCoverageMap) -import Echidna.Types.Test (EchidnaTest) +import Echidna.Types.Test (EchidnaTest(..), TestType, TestState (..)) import Echidna.Types.Tx (Tx) +import qualified Data.Vector.Unboxed as VU +import qualified Data.Map as Map -- | Configuration for running an Echidna 'Campaign'. data CampaignConf = CampaignConf @@ -36,11 +42,19 @@ data CampaignConf = CampaignConf -- ^ Directory to load and save lists of transactions , coverageReport :: Bool -- ^ Whether or not to generate a coverage report + , jobs :: Maybe Word8 } +data CampaignEvent where + TestFalsified :: TestType -> CampaignEvent -- TestType uniquely identifies the test + NewCoverage :: Int -> CampaignEvent + TestLimit :: CampaignEvent + deriving Show + type FrozenCampaign = GenericCampaign FrozenCoverageMap type Campaign = GenericCampaign CoverageMap + -- | The state of a fuzzing campaign. data GenericCampaign a = Campaign { tests :: ![EchidnaTest] @@ -57,10 +71,12 @@ data GenericCampaign a = Campaign -- ^ List of transactions with maximum coverage , ncallseqs :: !Int -- ^ Number of times the callseq is called + , events :: !(Seq (LocalTime, CampaignEvent)) } + deriving Functor defaultCampaign :: Monoid a => GenericCampaign a -defaultCampaign = Campaign mempty mempty mempty emptyDict False mempty 0 +defaultCampaign = Campaign mempty mempty mempty emptyDict False mempty 0 mempty defaultTestLimit :: Int defaultTestLimit = 50000 @@ -70,3 +86,38 @@ defaultSequenceLength = 100 defaultShrinkLimit :: Int defaultShrinkLimit = 5000 + +-- Summarize all campaigns from workers as a single campaign +-- TODO: this should return a richer data structure, good enough for now +mergeCampaigns :: [FrozenCampaign] -> FrozenCampaign +mergeCampaigns [] = error "won't happen, fix me with NonEmpty" +mergeCampaigns [c] = c -- don't even try +mergeCampaigns campaigns = + (defaultCampaign :: FrozenCampaign) + { tests = mergeTests <$> transpose ((.tests) <$> campaigns) + , coverage = Map.empty -- Map.unionsWith Set.union ((.coverage) <$> campaigns) + , gasInfo = mempty -- TODO + , genDict = emptyDict -- TODO + , corpus = mempty -- TODO + , ncallseqs = sum ((.ncallseqs) <$> campaigns) + } + where + mergeTests :: [EchidnaTest] -> EchidnaTest + mergeTests [] = error "won't happen, fix me with NonEmpty" + mergeTests (f:ts) = + foldl (\t acc -> + case (t.state, acc.state) of + -- update if better what we have so far + (Solved, _) -> t + (Large i, Large j) -> t { state = Large (i+j) } + (Large _, Open _) -> t + (Large _, Passed) -> t -- shoudn't happen but just in case + (Open i, Open j) -> t { state = Open (i+j) } + -- skip otherwise + _ -> acc + ) f ts + +freezeCampaign :: Campaign -> IO FrozenCampaign +freezeCampaign camp = do + frozenCov <- mapM VU.freeze camp.coverage + pure camp { coverage = frozenCov } diff --git a/lib/Echidna/Types/Test.hs b/lib/Echidna/Types/Test.hs index 5064ecc12..f373957a2 100644 --- a/lib/Echidna/Types/Test.hs +++ b/lib/Echidna/Types/Test.hs @@ -63,6 +63,14 @@ instance Eq TestType where Exploration == Exploration = True _ == _ = False +instance Show TestType where + show = \case + PropertyTest t _ -> show t + AssertionTest _ s _ -> show s + OptimizationTest s _ -> show s + CallTest t _ -> show t + Exploration -> "Exploration" + instance Eq TestState where Open i == Open j = i == j Large i == Large j = i == j diff --git a/lib/Echidna/UI.hs b/lib/Echidna/UI.hs index b4c9f5166..d2837cd21 100644 --- a/lib/Echidna/UI.hs +++ b/lib/Echidna/UI.hs @@ -6,31 +6,27 @@ module Echidna.UI where import Brick import Brick.BChan import Brick.Widgets.Dialog qualified as B -import Control.Monad.Catch (MonadCatch(..), catchAll) -import Control.Monad.Reader (MonadReader (ask), runReader, asks) -import Control.Monad.State (modify') import Graphics.Vty (Config, Event(..), Key(..), Modifier(..), defaultConfig, inputMap, mkVty) import Graphics.Vty qualified as Vty import System.Posix - import Echidna.UI.Widgets -#else /* !INTERACTIVE_UI */ -import Control.Monad.Catch (MonadCatch(..)) -import Control.Monad.Reader (MonadReader, asks) -import Control.Monad.State.Strict (get) #endif -import Control.Monad import Control.Concurrent (killThread, threadDelay) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Random.Strict (MonadRandom) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Random.Strict (MonadRandom, getRandomR) +import Control.Monad.Reader +import Control.Monad.State.Strict hiding (state) import Data.ByteString.Lazy qualified as BS -import Data.IORef +import Data.Foldable (foldl', toList) import Data.Map (Map) import Data.Maybe (fromMaybe, isJust) -import Data.Vector.Unboxed qualified as VU -import UnliftIO (MonadUnliftIO, hFlush, stdout) -import UnliftIO.Timeout (timeout) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Time +import Data.Vector.Storable.Mutable qualified as V +import UnliftIO (MonadUnliftIO, newIORef, readIORef, atomicWriteIORef, hFlush, stdout, IORef, writeIORef) import UnliftIO.Concurrent hiding (killThread, threadDelay) import EVM (VM, Contract) @@ -42,18 +38,26 @@ import Echidna.Output.JSON qualified import Echidna.Types.Campaign import Echidna.Types.Config import Echidna.Types.Corpus (corpusSize) -import Echidna.Types.Coverage (scoveragePoints) -import Echidna.Types.Test (EchidnaTest(..), TestState(..), didFail, isOpen) +import Echidna.Types.Coverage (scoveragePoints, scoveragePointsFrozen) +import Echidna.Types.Test (EchidnaTest(..), TestState(..), didFail, isOpen, isOptimizationTest) import Echidna.Types.Tx (Tx) import Echidna.Types.World (World) import Echidna.UI.Report -import Echidna.Utility (timePrefix) +import Echidna.Utility (timePrefix, getTimestamp) data UIEvent = - CampaignUpdated FrozenCampaign - | CampaignTimedout FrozenCampaign + CampaignUpdated UTCTime [FrozenCampaign] + | CampaignTimedout [FrozenCampaign] | CampaignCrashed String - | FetchCacheUpdated (Map Addr (Maybe Contract)) (Map Addr (Map W256 (Maybe W256))) + | FetchCacheUpdated (Map Addr (Maybe Contract)) + (Map Addr (Map W256 (Maybe W256))) + +-- TODO: sync corpus from time to time? +data WorkerSyncMessage + = CampaignEvents (Seq CampaignEvent) + | TestLimitReached + +type Worker = (IORef Campaign, MVar WorkerSyncMessage, MVar (), MVar ()) -- | Set up and run an Echidna 'Campaign' and display interactive UI or -- print non-interactive output in desired format at the end @@ -64,67 +68,120 @@ ui -> [EchidnaTest] -- ^ Tests to evaluate -> GenDict -> [[Tx]] - -> m Campaign + -> m FrozenCampaign ui vm world ts dict initialCorpus = do + env <- ask conf <- asks (.cfg) - ref <- liftIO $ newIORef defaultCampaign - stop <- newEmptyMVar - let - updateRef = do - shouldStop <- liftIO $ isJust <$> tryReadMVar stop - get >>= liftIO . atomicWriteIORef ref - pure shouldStop - - secToUsec = (* 1000000) - timeoutUsec = secToUsec $ fromMaybe (-1) conf.uiConf.maxTime - runCampaign' = timeout timeoutUsec (runCampaign updateRef vm world ts dict initialCorpus) -#ifdef INTERACTIVE_UI terminalPresent <- liftIO isTerminal -#else - let terminalPresent = False -#endif - let effectiveMode = case conf.uiConf.operationMode of - Interactive | not terminalPresent -> NonInteractive Text - other -> other + + let + -- default to one worker if not configured + jobs = fromIntegral $ fromMaybe 1 conf.campaignConf.jobs + + runWorker = do + -- TODO: change to worker state + stateRef <- newIORef defaultCampaign + eventChannel <- newEmptyMVar + workerStopped <- newEmptyMVar + stopWorker <- newEmptyMVar + + -- Is thread id useful for anything? + _threadId <- forkIO $ void $ do + -- Generate a new seed for each worker + seed <- getRandomR (0, maxBound) + let dict' = dict { defSeed = seed } + -- TODO: catch exceptions + {- + (void $ do + catchAll + (runCampaign >>= \case + Nothing -> liftIO $ updateUI CampaignTimedout + Just _ -> liftIO $ updateUI CampaignUpdated) + (liftIO . writeBChan bc . CampaignCrashed . show) + ) + (const $ liftIO $ killThread ticker) + -} + camp <- runCampaign (workerCallback stateRef eventChannel stopWorker) + vm world ts dict' initialCorpus + putMVar workerStopped () + pure camp + + pure (stateRef, eventChannel, workerStopped, stopWorker) + + workers :: [Worker] <- replicateM jobs runWorker + syncer <- liftIO $ runWorkerSyncer env workers + + let + -- Timeouter thread, sleep for the timeout then order all workers to exit + -- and update the UI + runTimeouter ticker after = + case conf.uiConf.maxTime of + Just seconds -> void . liftIO . forkIO $ do + threadDelay (seconds * 1_000_000) + -- ticker should be killed for the brick UI, but it is not necessary + killThread ticker + killThread syncer + stopWorkers workers + after + Nothing -> pure () + + effectiveMode = case conf.uiConf.operationMode of + Interactive | not terminalPresent -> NonInteractive Text + other -> other + case effectiveMode of #ifdef INTERACTIVE_UI Interactive -> do - bc <- liftIO $ newBChan 100 - let updateUI e = readIORef ref >>= freezeCampaign >>= writeBChan bc . e - env <- ask + -- Channel to push events to update UI + uiChannel <- liftIO $ newBChan 100 + + let updateUI e = do + campaigns <- campaignState workers + -- TODO: take events from campaigns + -- TODO: push MVar messages + writeBChan uiChannel $ e campaigns + ticker <- liftIO $ forkIO $ -- run UI update every 100ms forever $ do - threadDelay 100000 - updateUI CampaignUpdated + threadDelay 100_000 + now <- getCurrentTime + updateUI (CampaignUpdated now) c <- readIORef env.fetchContractCache s <- readIORef env.fetchSlotCache - writeBChan bc (FetchCacheUpdated c s) - _ <- forkFinally -- run worker - (void $ do - catchAll - (runCampaign' >>= \case - Nothing -> liftIO $ updateUI CampaignTimedout - Just _ -> liftIO $ updateUI CampaignUpdated) - (liftIO . writeBChan bc . CampaignCrashed . show) - ) - (const $ liftIO $ killThread ticker) + writeBChan uiChannel (FetchCacheUpdated c s) + + runTimeouter ticker (updateUI CampaignTimedout) + + -- UI initialization let buildVty = do v <- mkVty =<< vtyConfig Vty.setMode (Vty.outputIface v) Vty.Mouse True pure v initialVty <- liftIO buildVty - app <- customMain initialVty buildVty (Just bc) <$> monitor - liftIO $ void $ app UIState - { campaign = defaultCampaign - , status = Uninitialized - , fetchedContracts = mempty - , fetchedSlots = mempty - , fetchedDialog = B.dialog (Just "Fetched contracts/slots") Nothing 80 - , displayFetchedDialog = False - } - final <- liftIO $ readIORef ref - liftIO . putStrLn =<< ppCampaign final + + app <- customMain initialVty buildVty (Just uiChannel) <$> monitor + + liftIO $ do + now <- getCurrentTime + void $ app UIState + { campaigns = [defaultCampaign] + , status = Uninitialized + , timeStarted = now + , now = now + , fetchedContracts = mempty + , fetchedSlots = mempty + , fetchedDialog = B.dialog (Just "Fetched contracts/slots") Nothing 80 + , displayFetchedDialog = False + } + + -- Exited from the UI, stop the workers, not needed anymore + stopWorkers workers + joinWorkers workers -- TODO: do we need this? + + final <- liftIO $ mergeCampaigns <$> campaignState workers + + --liftIO . putStrLn =<< runReader (ppCampaign final) env pure final #else Interactive -> error "Interactive UI is not available" @@ -132,43 +189,147 @@ ui vm world ts dict initialCorpus = do NonInteractive outputFormat -> do #ifdef INTERACTIVE_UI - liftIO $ forM_ [sigINT, sigTERM] (\sig -> installHandler sig (Catch $ putMVar stop ()) Nothing) + -- Handles ctrl-c, TODO: this doesn't work on Windows + liftIO $ forM_ [sigINT, sigTERM] $ \sig -> + installHandler sig (Catch $ stopWorkers workers) Nothing #endif ticker <- liftIO $ forkIO $ -- print out status update every 3s forever $ do - threadDelay $ 3*1000000 - camp <- readIORef ref - time <- timePrefix + threadDelay $ 3*1_000_000 + camp <- liftIO $ mergeCampaigns <$> campaignState workers + time <- timePrefix <$> getTimestamp line <- statusLine conf.campaignConf camp putStrLn $ time <> "[status] " <> line hFlush stdout - result <- runCampaign' + + didTimeout <- newIORef False + runTimeouter ticker (atomicWriteIORef didTimeout True) + + -- block and wait for all workers to finish + joinWorkers workers + liftIO $ killThread ticker - (final, timedout) <- case result of - Nothing -> do - final <- liftIO $ readIORef ref - pure (final, True) - Just final -> - pure (final, False) + + campaigns <- liftIO $ campaignState workers + let final = mergeCampaigns campaigns + case outputFormat of JSON -> liftIO $ BS.putStr =<< Echidna.Output.JSON.encodeCampaign final Text -> do liftIO . putStrLn =<< ppCampaign final + timedout <- readIORef didTimeout when timedout $ liftIO $ putStrLn "TIMEOUT!" None -> pure () pure final + where + -- | This function should be idempotent even if some workers were already + -- stopped, for example due to a timeout, calling this won't throw errors + stopWorkers workers = + forM_ workers $ \(_, _, _, stopWorker) -> tryPutMVar stopWorker () -freezeCampaign :: Campaign -> IO FrozenCampaign -freezeCampaign camp = do - frozenCov <- mapM VU.freeze camp.coverage - pure camp { coverage = frozenCov } + -- | Block and wait for all workers to stop running + joinWorkers workers = + forM_ workers $ \(_, _, workerStopped, _) -> takeMVar workerStopped -#ifdef INTERACTIVE_UI + -- | Get a snapshot of the campaign state + campaignState workers = + forM workers $ \(stateRef, _, _, _) -> readIORef stateRef >>= freezeCampaign + + -- | This blocks since channel has a single slot, this is okay because we + -- call it from a dedicated thread. In fact, it acts as a backpressure, + -- when workers are slower, the events will propagate at a slower rate. + putMessage workers message = + forM_ workers $ \(_,channel,_,_) -> putMVar channel message + + -- | Propagates campaign events periodically to the other workers + -- TODO: should this be moved inside runCampaign? + runWorkerSyncer :: Env -> [Worker] -> IO ThreadId + runWorkerSyncer env workers = do + -- pointers to the last event we processed at each worker + cursors <- V.new (length workers) + + forkIO . forever $ do + campaigns <- campaignState workers + -- collect new events since the last time per campaign + events <- forM (Seq.fromList (zip [0..] campaigns)) $ \(i, campaign) -> do + cursor <- V.read cursors i + let tip = length campaign.events + if tip > cursor then do + -- new events! + V.write cursors i tip + pure $ Seq.drop i campaign.events + else + pure mempty + + -- fan out all the new events to all workers, skip sending back to the + -- worker the events originated from + forM_ (zip [0..] workers) $ \(i,(_,channel,_,_)) -> + let events'= snd <$> mconcat (toList (Seq.drop i events)) + in putMVar channel (CampaignEvents events') + + -- TODO: should this be moved to another thread? + let campaignConf = env.cfg.campaignConf + -- sum runs from all workers + totalFuzzRuns = sum (fuzzRuns campaignConf <$> campaigns) + when (totalFuzzRuns >= campaignConf.testLimit) $ + -- TODO: only if campaign has open tests + + -- NOTE: there is a race here and workers might do a few more iterations + -- until they receive the notification; this is ok + putMessage workers TestLimitReached + + threadDelay 100_000 -- next sync in 100 ms + + workerCallback stateRef channel stopWorker = do + campaign <- get + + -- push campaign update, TODO: should this happen later? + writeIORef stateRef campaign + + -- if something interesting happened on another worker(s), it will be put + -- as a message in this channel + tryTakeMVar channel >>= \case + Nothing -> pure () + Just message -> do + put $ updateCampaign campaign message + + isJust <$> tryTakeMVar stopWorker + where + updateCampaign campaign = \case + CampaignEvents events -> + let + processEvent campaign' event = + case event of + TestFalsified testType -> + let + solveTest test = case test.state of + -- Mark test as Solved, there will be no reproducer, this means + -- the test was solved on another worker + Open _ | test.testType == testType -> + test { state = Solved } + -- TODO: what if there is a race and there is another state? + -- this is not that much of a problem as all the states move forward + _ -> test + in campaign' { tests = solveTest <$> campaign.tests } + _ -> campaign + in foldl' processEvent campaign events + TestLimitReached -> + -- We stop fuzzing by simply passing all Open tests. If there + -- is shrinking going on, it will continue on individual workers. + let passTest test = case test.state of + Open _ -> test { state = Passed } + _ -> test + in campaign { tests = passTest <$> campaign.tests } + -- TODO: Add this only when any was open + -- , events = campaign.events |> TestLimit } + + +#ifdef INTERACTIVE_UI vtyConfig :: IO Config vtyConfig = do config <- Vty.standardIOConfig @@ -187,10 +348,10 @@ monitor = do else emptyWidget , runReader (campaignStatus uiState) conf ] - onEvent (AppEvent (CampaignUpdated c')) = - modify' $ \state -> state { campaign = c', status = Running } + onEvent (AppEvent (CampaignUpdated now c')) = + modify' $ \state -> state { campaigns = c', status = Running, now = now } onEvent (AppEvent (CampaignTimedout c')) = - modify' $ \state -> state { campaign = c', status = Timedout } + modify' $ \state -> state { campaigns = c', status = Timedout } onEvent (AppEvent (CampaignCrashed e)) = do modify' $ \state -> state { status = Crashed e } onEvent (AppEvent (FetchCacheUpdated contracts slots)) = @@ -210,6 +371,14 @@ monitor = do SBTroughBefore -> vScrollBy vp (-10) SBTroughAfter -> vScrollBy vp 10 SBBar -> pure () + LogViewPort -> do + let vp = viewportScroll LogViewPort + case el of + SBHandleBefore -> vScrollBy vp (-1) + SBHandleAfter -> vScrollBy vp 1 + SBTroughBefore -> vScrollBy vp (-10) + SBTroughAfter -> vScrollBy vp 10 + SBBar -> pure () _ -> pure () onEvent _ = pure () @@ -220,23 +389,31 @@ monitor = do , appAttrMap = const attrs , appChooseCursor = neverShowCursor } +#endif -- | Heuristic check that we're in a sensible terminal (not a pipe) isTerminal :: IO Bool -isTerminal = (&&) <$> queryTerminal (Fd 0) <*> queryTerminal (Fd 1) - +isTerminal = +#ifdef INTERACTIVE_UI + (&&) <$> queryTerminal (Fd 0) <*> queryTerminal (Fd 1) +#else + pure False #endif -- | Composes a compact text status line of the campaign -statusLine :: CampaignConf -> Campaign -> IO String +statusLine :: CampaignConf -> FrozenCampaign -> IO String statusLine campaignConf camp = do - points <- scoveragePoints camp.coverage + let points = scoveragePointsFrozen camp.coverage pure $ "tests: " <> show (length $ filter didFail camp.tests) <> "/" <> show (length camp.tests) - <> ", fuzzing: " <> show fuzzRuns <> "/" <> show campaignConf.testLimit + <> ", values: " <> show (map (.value) $ filter (\t -> isOptimizationTest t.testType) camp.tests) + <> ", fuzzing: " <> show (fuzzRuns campaignConf camp) <> "/" <> show campaignConf.testLimit <> ", cov: " <> show points <> ", corpus: " <> show (corpusSize camp.corpus) - where - fuzzRuns = case filter isOpen camp.tests of + +fuzzRuns :: CampaignConf -> GenericCampaign a -> Int +fuzzRuns _ campaign | null campaign.tests = 0 -- TODO: ugly hack, fix UI campaign initialization +fuzzRuns campaignConf campaign = + case filter isOpen campaign.tests of -- fuzzing progress is the same for all Open tests, grab the first one EchidnaTest { state = Open t }:_ -> t _ -> campaignConf.testLimit diff --git a/lib/Echidna/UI/Report.hs b/lib/Echidna/UI/Report.hs index 3ff9afdf9..48b32cfed 100644 --- a/lib/Echidna/UI/Report.hs +++ b/lib/Echidna/UI/Report.hs @@ -1,18 +1,19 @@ module Echidna.UI.Report where -import Control.Monad.Reader (MonadReader, asks, MonadIO (liftIO)) +import Control.Monad.Reader (MonadReader, MonadIO, asks) import Data.List (intercalate, nub, sortOn) import Data.Map (toList) import Data.Maybe (catMaybes) import Data.Text (Text, unpack) import Data.Text qualified as T +import Text.Printf (printf) import Echidna.ABI (GenDict(..), encodeSig) import Echidna.Events (Events) import Echidna.Pretty (ppTxCall) import Echidna.Types (Gas) import Echidna.Types.Campaign -import Echidna.Types.Corpus (Corpus, corpusSize) +import Echidna.Types.Corpus (corpusSize) import Echidna.Types.Coverage (CoverageMap, FrozenCoverageMap, scoveragePoints, scoveragePointsFrozen) import Echidna.Types.Test (EchidnaTest(..), TestState(..), TestType(..)) import Echidna.Types.Tx (Tx(..), TxCall(..), TxConf(..)) @@ -20,12 +21,12 @@ import Echidna.Types.Config import EVM.Types (W256) -ppCampaign :: (MonadIO m, MonadReader Env m) => Campaign -> m String +ppCampaign :: (MonadIO m, MonadReader Env m) => FrozenCampaign -> m String ppCampaign campaign = do testsPrinted <- ppTests campaign gasInfoPrinted <- ppGasInfo campaign - coveragePrinted <- liftIO $ ppCoverage campaign.coverage - let corpusPrinted = "\n" <> ppCorpus campaign.corpus + let coveragePrinted = ppFrozenCoverage campaign.coverage + let corpusPrinted = "\n" <> ppCorpus [campaign] seedPrinted = "\nSeed: " <> show campaign.genDict.defSeed pure $ testsPrinted @@ -69,11 +70,20 @@ ppCoverageCommon points ncodehashes = <> "\nUnique codehashes: " <> show ncodehashes -- | Pretty-print the corpus a 'Campaign' has obtained. -ppCorpus :: Corpus -> String -ppCorpus c = "Corpus size: " <> show (corpusSize c) +ppCorpus :: [GenericCampaign a] -> String +ppCorpus [c] = -- only one worker + "Corpus size: " <> show (corpusSize c.corpus) +ppCorpus c = + "Corpus size (min/avg/max): " + <> show (minimum sizes) <> "/" + <> printf "%.2f" avgSize <> "/" + <> show (maximum sizes) + where + avgSize = fromIntegral (sum sizes) / fromIntegral (length sizes) :: Double + sizes = corpusSize . (.corpus) <$> c -- | Pretty-print the gas usage information a 'Campaign' has obtained. -ppGasInfo :: MonadReader Env m => Campaign -> m String +ppGasInfo :: MonadReader Env m => GenericCampaign a -> m String ppGasInfo Campaign { gasInfo } | gasInfo == mempty = pure "" ppGasInfo Campaign { gasInfo } = do items <- mapM ppGasOne $ sortOn (\(_, (n, _)) -> n) $ toList gasInfo @@ -139,7 +149,7 @@ ppOptimized b es xs = do <> ppEvents es -- | Pretty-print the status of all 'SolTest's in a 'Campaign'. -ppTests :: MonadReader Env m => Campaign -> m String +ppTests :: MonadReader Env m => GenericCampaign a -> m String ppTests Campaign { tests } = unlines . catMaybes <$> mapM pp tests where pp t = diff --git a/lib/Echidna/UI/Widgets.hs b/lib/Echidna/UI/Widgets.hs index 60ea900ad..f1a0c0457 100644 --- a/lib/Echidna/UI/Widgets.hs +++ b/lib/Echidna/UI/Widgets.hs @@ -9,7 +9,7 @@ import Brick.AttrMap qualified as A import Brick.Widgets.Border import Brick.Widgets.Center import Control.Monad.Reader (MonadReader, asks) -import Data.List (nub, intersperse, sortBy) +import Data.List (nub, intersperse, sortBy, sortOn) import Data.Text qualified as T import Data.Version (showVersion) import Graphics.Vty qualified as V @@ -31,10 +31,16 @@ import EVM (Contract) import qualified Brick.Widgets.Dialog as B import qualified Data.Map as Map import Data.Maybe (fromMaybe, isJust) +import Data.Time (UTCTime, diffUTCTime, NominalDiffTime, formatTime, defaultTimeLocale, LocalTime) +import Echidna.Utility (timePrefix) +import Data.Functor ((<&>)) +import Data.Foldable (toList) data UIState = UIState { status :: UIStateStatus - , campaign :: FrozenCampaign + , campaigns :: [FrozenCampaign] + , timeStarted :: UTCTime + , now :: UTCTime , fetchedContracts :: Map Addr (Maybe Contract) , fetchedSlots :: Map Addr (Map W256 (Maybe W256)) , fetchedDialog :: B.Dialog () @@ -51,6 +57,8 @@ attrs = A.attrMap (V.white `on` V.black) , (attrName "tx", fg V.brightWhite) , (attrName "working", fg V.brightBlue) , (attrName "success", fg V.brightGreen) + , (attrName "title", fg V.brightCyan) + , (attrName "time", fg (V.rgbColor (0x70 :: Int) 0x70 0x70)) ] bold :: Widget n -> Widget n @@ -62,15 +70,17 @@ failure = withAttr (attrName "failure") success :: Widget n -> Widget n success = withAttr (attrName "success") -data Name = - TestsViewPort +data Name + = LogViewPort + | TestsViewPort | SBClick ClickableScrollbarElement Name deriving (Ord, Show, Eq) -- | Render 'Campaign' progress as a 'Widget'. campaignStatus :: MonadReader Env m => UIState -> m (Widget Name) campaignStatus uiState = do - done <- isDone uiState.campaign + let campaign = mergeCampaigns uiState.campaigns + done <- isDone campaign case (uiState.status, done) of (Uninitialized, _) -> pure $ mainbox (padLeft (Pad 1) $ str "Starting up, please wait...") emptyWidget @@ -78,13 +88,13 @@ campaignStatus uiState = do pure $ mainbox (padLeft (Pad 1) $ withAttr (attrName "failure") $ strBreak $ formatCrashReport e) emptyWidget (Timedout, _) -> - mainbox <$> testsWidget uiState.campaign.tests + mainbox <$> testsWidget campaign.tests <*> pure (finalStatus "Timed out, C-c or esc to exit") (_, True) -> - mainbox <$> testsWidget uiState.campaign.tests + mainbox <$> testsWidget campaign.tests <*> pure (finalStatus "Campaign complete, C-c or esc to exit") _ -> - mainbox <$> testsWidget uiState.campaign.tests + mainbox <$> testsWidget campaign.tests <*> pure emptyWidget where mainbox :: Widget Name -> Widget Name -> Widget Name @@ -95,14 +105,38 @@ campaignStatus uiState = do joinBorders $ borderWithLabel (bold $ str title) $ summaryWidget uiState <=> - hBorderWithLabel (str "Tests") + hBorderWithLabel (withAttr (attrName "title") $ str " Tests ") <=> inner <=> + hBorderWithLabel (withAttr (attrName "title") $ str $ + "Log (" <> show (sum ((length . (.events) <$> uiState.campaigns))) <> ")") + <=> + logPane uiState.campaigns + <=> underneath title = "Echidna " ++ showVersion Paths_echidna.version finalStatus s = hBorder <=> hCenter (bold $ str s) +logPane :: [GenericCampaign a] -> Widget Name +logPane campaigns = + vLimitPercent 25 . + padLeft (Pad 1) $ + withClickableVScrollBars SBClick . + withVScrollBars OnRight . + withVScrollBarHandles . + viewport LogViewPort Vertical $ + foldl (<=>) emptyWidget (showLogLine <$> logLines) + where + -- TODO: this is ugly + logLines = reverse $ sortOn (\(_, (time, _)) -> time) $ toList $ mconcat $ + (\(n, s) -> (\e -> (n, e)) <$> s) <$> zip [0..] (campaigns <&> (.events)) + +showLogLine :: (Int, (LocalTime, CampaignEvent)) -> Widget Name +showLogLine (n, (time, event)) = + (withAttr (attrName "time") $ str $ (timePrefix time)) + <+> str ("Worker " <> show n <> ": " <> show event) + formatCrashReport :: String -> String formatCrashReport e = "Echidna crashed with an error:\n\n" <> @@ -111,27 +145,50 @@ formatCrashReport e = summaryWidget :: UIState -> Widget Name summaryWidget uiState = - vLimit 5 (hLimitPercent 50 leftSide <+> vBorder <+> hLimitPercent 50 rightSide) + vLimit 6 (hLimitPercent 50 leftSide <+> vBorder <+> rightSide) where leftSide = - let c = uiState.campaign in + let c = mergeCampaigns uiState.campaigns in padLeft (Pad 1) $ vLimit 1 (str "Tests found: " <+> str (show (length c.tests)) <+> fill ' ') <=> - str ("Seed: " ++ show c.genDict.defSeed) + str ("Workers: " ++ show (length uiState.campaigns)) + <=> + str ("Seed: " ++ ppSeed uiState.campaigns) <=> str (ppFrozenCoverage c.coverage) <=> - str (ppCorpus c.corpus) - rightSide = fetchCacheWidget uiState.fetchedContracts uiState.fetchedSlots + str (ppCorpus uiState.campaigns) + rightSide = + padLeft (Pad 1) $ + (fetchCacheWidget uiState.fetchedContracts uiState.fetchedSlots) + <=> + (str "Time elapsed: " <+> str ((formatNominalDiffTime . diffUTCTime uiState.now) uiState.timeStarted)) + <=> + (str "Tx/s: " <+> str ((show . div fuzzRuns . (+1) . floor . diffUTCTime uiState.now) uiState.timeStarted)) + fuzzRuns = case filter isOpen (mergeCampaigns uiState.campaigns).tests of + -- fuzzing progress is the same for all Open tests, grab the first one + EchidnaTest { state = Open t }:_ -> t + _ -> 0 + +ppSeed :: [GenericCampaign a] -> String +ppSeed [campaign] = show campaign.genDict.defSeed +ppSeed _ = "" + +formatNominalDiffTime :: NominalDiffTime -> String +formatNominalDiffTime diff = + let fmt = if | diff < 60 -> "%Ss" + | diff < 60*60 -> "%Mm %Ss" + | diff < 24*60*60 -> "%Hh %Mm %Ss" + | otherwise -> "%dd %Hh %Mm %Ss" + in formatTime defaultTimeLocale fmt diff fetchCacheWidget :: Map Addr (Maybe Contract) -> Map Addr (Map W256 (Maybe W256)) -> Widget Name fetchCacheWidget contracts slots = - padLeft (Pad 1) $ - (str "Fetched contracts: " <+> countWidget (Map.elems contracts)) - <=> - (str "Fetched slots: " <+> countWidget (concat $ Map.elems (Map.elems <$> slots))) + (str "Fetched contracts: " <+> countWidget (Map.elems contracts)) + <=> + (str "Fetched slots: " <+> countWidget (concat $ Map.elems (Map.elems <$> slots))) where countWidget fetches = let successful = filter isJust fetches diff --git a/lib/Echidna/Utility.hs b/lib/Echidna/Utility.hs index a93487810..c73d855a8 100644 --- a/lib/Echidna/Utility.hs +++ b/lib/Echidna/Utility.hs @@ -2,27 +2,29 @@ module Echidna.Utility where import Control.Monad (unless) import Control.Monad.Catch (bracket) -import Data.Time (diffUTCTime, getCurrentTime) +import Data.Time (diffUTCTime, getCurrentTime, zonedTimeToLocalTime, LocalTime, getZonedTime) import Data.Time.Format (defaultTimeLocale, formatTime) -import Data.Time.LocalTime (utcToLocalZonedTime) import System.Directory (getDirectoryContents, getCurrentDirectory, setCurrentDirectory) import System.IO (hFlush, stdout) measureIO :: Bool -> String -> IO b -> IO b measureIO quiet message action = do unless quiet $ do - time <- timePrefix - putStr (time <> message <> "... ") >> hFlush stdout + prefix <- timePrefix <$> getTimestamp + putStr (prefix <> message <> "... ") >> hFlush stdout t0 <- getCurrentTime ret <- action t1 <- getCurrentTime unless quiet $ putStrLn $ "Done! (" <> show (diffUTCTime t1 t0) <> ")" pure ret -timePrefix :: IO String -timePrefix = do - time <- utcToLocalZonedTime =<< getCurrentTime - pure $ "[" <> formatTime defaultTimeLocale "%F %T.%2q" time <> "] " +getTimestamp :: IO LocalTime +getTimestamp = + zonedTimeToLocalTime <$> getZonedTime + +timePrefix :: LocalTime -> String +timePrefix time = + "[" <> formatTime defaultTimeLocale "%F %T.%2q" time <> "] " listDirectory :: FilePath -> IO [FilePath] listDirectory path = filter f <$> getDirectoryContents path diff --git a/package.yaml b/package.yaml index 09e89a169..49b3074e8 100644 --- a/package.yaml +++ b/package.yaml @@ -6,7 +6,7 @@ maintainer: Trail of Bits version: 2.1.1 # https://github.com/haskell/cabal/issues/4739 -ghc-options: -Wall -fno-warn-orphans -O2 -threaded +RTS -N -RTS -optP-Wno-nonportable-include-path +ghc-options: -Wall -fno-warn-orphans -O2 -optP-Wno-nonportable-include-path dependencies: - base @@ -57,6 +57,7 @@ default-extensions: - LambdaCase - MultiWayIf - NoFieldSelectors + - MultiWayIf - OverloadedRecordDot - OverloadedStrings @@ -76,19 +77,20 @@ executables: main: Main.hs source-dirs: src/ dependencies: echidna + ghc-options: -threaded -with-rtsopts=-N when: - - condition: (os(linux) || os(windows)) && flag(static) - ghc-options: - - -optl-static - - condition: os(linux) || os(windows) - ghc-options: - - -O2 - - -optl-pthread - - condition: os(darwin) - extra-libraries: c++ - ld-options: -Wl,-keep_dwarf_unwind - - condition: os(windows) - extra-libraries: stdc++ + - condition: (os(linux) || os(windows)) && flag(static) + ghc-options: + - -optl-static + - condition: os(linux) || os(windows) + ghc-options: + - -O2 + - -optl-pthread + - condition: os(darwin) + extra-libraries: c++ + ld-options: -Wl,-keep_dwarf_unwind + - condition: os(windows) + extra-libraries: stdc++ tests: echidna-testsuite: diff --git a/src/Main.hs b/src/Main.hs index 87b0ce04a..50e45b1ee 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -23,6 +23,7 @@ import Data.Text qualified as Text import Data.Time.Clock.System (getSystemTime, systemSeconds) import Data.Vector qualified as Vector import Data.Version (showVersion) +import Data.Word (Word8) import Main.Utf8 (withUtf8) import Options.Applicative import Paths_echidna (version) @@ -207,6 +208,7 @@ readFileIfExists path = do data Options = Options { cliFilePath :: NE.NonEmpty FilePath + , cliJobs :: Maybe Word8 , cliSelectedContract :: Maybe Text , cliConfigFilepath :: Maybe FilePath , cliOutputFormat :: Maybe OutputFormat @@ -233,6 +235,9 @@ options :: Parser Options options = Options <$> (NE.fromList <$> some (argument str (metavar "FILES" <> help "Solidity files to analyze"))) + <*> optional (option auto $ long "jobs" + <> metavar "N" + <> help "Number of workers to run") <*> optional (option str $ long "contract" <> metavar "CONTRACT" <> help "Contract to analyze") @@ -307,8 +312,11 @@ overrideConfig config Options{..} = do , testLimit = fromMaybe campaignConf.testLimit cliTestLimit , shrinkLimit = fromMaybe campaignConf.shrinkLimit cliShrinkLimit , seqLen = fromMaybe campaignConf.seqLen cliSeqLen - , seed = cliSeed <|> campaignConf.seed + , seed = seed + -- if user specified a seed, we override the jobs to run just one worker + , jobs = if isJust seed then Just 1 else cliJobs <|> campaignConf.jobs } + where seed = cliSeed <|> campaignConf.seed overrideSolConf solConf = solConf { solcArgs = fromMaybe solConf.solcArgs cliSolcArgs diff --git a/src/test/Tests/Seed.hs b/src/test/Tests/Seed.hs index bbb9a518a..28a5cb6ae 100644 --- a/src/test/Tests/Seed.hs +++ b/src/test/Tests/Seed.hs @@ -30,6 +30,7 @@ seedTests = , corpusDir = Nothing , mutConsts = defaultMutationConsts , coverageReport = False + , jobs = Nothing } } & overrideQuiet diff --git a/tests/solidity/basic/default.yaml b/tests/solidity/basic/default.yaml index a87dfb868..7d9ebab5a 100644 --- a/tests/solidity/basic/default.yaml +++ b/tests/solidity/basic/default.yaml @@ -87,3 +87,5 @@ rpcUrl: null rpcBlock: null # whether or not to generate a coverage report coverageReport: false +# number of workers +jobs: 1