From 6bf931a0109578ef951d8788269f74d33d657ad4 Mon Sep 17 00:00:00 2001 From: Ben Perez Date: Thu, 19 Jul 2018 15:20:03 -0400 Subject: [PATCH 1/5] Can now choose to output only JSON corresponding to test output --- lib/Echidna/Config.hs | 2 + lib/Echidna/Exec.hs | 2 + lib/Echidna/Internal/JsonRunner.hs | 219 +++++++++++++++++++++++++++++ lib/Echidna/Solidity.hs | 11 +- src/Main.hs | 1 + 5 files changed, 231 insertions(+), 4 deletions(-) create mode 100644 lib/Echidna/Internal/JsonRunner.hs diff --git a/lib/Echidna/Config.hs b/lib/Echidna/Config.hs index ccd69fba..2409c15f 100644 --- a/lib/Echidna/Config.hs +++ b/lib/Echidna/Config.hs @@ -31,6 +31,7 @@ data Config = Config , _returnType :: PropertyType , _prefix :: Text , _printCoverage :: Bool + , _outputJson :: Bool } deriving Show @@ -51,6 +52,7 @@ instance FromJSON Config where <*> v .:? "return" .!= ShouldReturnTrue <*> v .:? "prefix" .!= "echidna_" <*> v .:? "printCoverage" .!= False + <*> v .:? "outputJson" .!= False parseJSON _ = parseJSON (Object mempty) newtype ParseException = ParseException FilePath diff --git a/lib/Echidna/Exec.hs b/lib/Echidna/Exec.hs index e003c164..ffee663e 100644 --- a/lib/Echidna/Exec.hs +++ b/lib/Echidna/Exec.hs @@ -21,6 +21,7 @@ module Echidna.Exec ( , getCover , ppHashes , module Echidna.Internal.Runner + , module Echidna.Internal.JsonRunner ) where import Control.Concurrent.MVar (MVar, modifyMVar_) @@ -61,6 +62,7 @@ import EVM.Types (W256) import Echidna.ABI (SolCall, SolSignature, displayAbiCall, encodeSig, genInteractions, mutateCall) import Echidna.Config (Config(..), testLimit, shrinkLimit, range) import Echidna.Internal.Runner +import Echidna.Internal.JsonRunner import Echidna.Property (PropertyType(..)) -------------------------------------------------------------------- diff --git a/lib/Echidna/Internal/JsonRunner.hs b/lib/Echidna/Internal/JsonRunner.hs new file mode 100644 index 00000000..50417d60 --- /dev/null +++ b/lib/Echidna/Internal/JsonRunner.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +module Echidna.Internal.JsonRunner ( + checkParallelJson + ) where + +import Control.Monad (forM_) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (ToJSON, encode) +import Data.ByteString.Lazy.Char8 (unpack) +import Data.Maybe (mapMaybe) +import GHC.Generics + +import Hedgehog.Internal.Config +import Hedgehog.Internal.Gen (runDiscardEffect, runGenT) +import Hedgehog.Internal.Property + (Failure(..), Group(..), Property(..), PropertyT(..), + PropertyConfig(..), ShrinkLimit(..), ShrinkRetries(..), + Log(..), Diff(..), runTestT, unPropertyName) +import Hedgehog.Internal.Queue +import Hedgehog.Internal.Report + (FailedAnnotation(..), FailureReport(..), Result(..), ShrinkCount(..)) +import Hedgehog.Internal.Runner (RunnerConfig(..)) +import Hedgehog.Internal.Seed (Seed) +import qualified Hedgehog.Internal.Seed as Seed +import Hedgehog.Internal.Source +import Hedgehog.Internal.Tree (Node(..), Tree(..), runTree) +import Hedgehog.Range (Size) + + +data JsonOutput = JsonOutput { + propName :: !String + , propTrue :: !Bool + , propCall :: !(Maybe [String]) + } deriving (Generic, Show) + +instance ToJSON JsonOutput + +checkParallelJson :: MonadIO m => Group -> m Bool +checkParallelJson = + checkGroup + RunnerConfig { + runnerWorkers = + Nothing + , runnerColor = + Nothing + , runnerVerbosity = + Nothing + } + +checkGroup :: MonadIO m => RunnerConfig -> Group -> m Bool +checkGroup config (Group _ props) = + liftIO $ do + n <- resolveWorkers (runnerWorkers config) + + updateNumCapabilities (n + 2) + + --verbosity <- resolveVerbosity (runnerVerbosity config) + rs <- runTasks n props st noop noop $ \(name, prop) -> checkProp 0 prop >>= pure . (format name) + + --output JSON here + forM_ rs $ (putStrLn . unpack . encode) + + pure True + + where st _ _ (name,prop) = pure (name,prop) + noop = const $ pure () + failVals (FailureReport _ _ _ xs _ _ _ _) = map (\(FailedAnnotation _ v) -> v) xs + format n r = let name = unPropertyName n in + case r of + OK -> JsonOutput { propName = name, propTrue = True, propCall = Nothing } + GaveUp -> JsonOutput { propName = name, propTrue = False, propCall = Nothing } + Failed s -> JsonOutput { propName = name, propTrue = False, propCall = Just (failVals s) } + +checkProp :: Size -> Property -> IO Result +checkProp size0 (Property conf test) = Seed.random >>= loop (0 :: Integer) (0 :: Integer) size0 + where loop !tests !discards !size !seed = + if size > 99 then + -- size has reached limit, reset to 0 + loop tests discards 0 seed + + else if tests >= fromIntegral (propertyTestLimit conf) then + -- we've hit the test limit, test was successful + pure $ OK + + else if discards >= fromIntegral (propertyDiscardLimit conf) then + -- we've hit the discard limit, give up + pure $ GaveUp + + else + case Seed.split seed of + (s0, s1) -> do + node@(Node x _) <- + runTree . runDiscardEffect $ runGenT size s0 . runTestT $ unPropertyT test + case x of + Nothing -> + loop tests (discards + 1) (size + 1) s1 + + Just (Left _, _) -> + takeSmallest + size + seed + 0 + (propertyShrinkLimit conf) + (propertyShrinkRetries conf) + node + + Just (Right (), _) -> + loop (tests + 1) discards (size + 1) s1 + +takeSmallest :: + Size + -> Seed + -> ShrinkCount + -> ShrinkLimit + -> ShrinkRetries + -> Node IO (Maybe (Either Failure (), [Log])) + -> IO Result +takeSmallest size seed shrinks slimit retries = \case + Node Nothing _ -> + pure GaveUp + + Node (Just (x, w)) xs -> + case x of + Left (Failure loc err mdiff) -> do + let failure = mkFailure size seed shrinks loc err mdiff (reverse w) + + if shrinks >= fromIntegral slimit then + -- if we've hit the shrink limit, don't shrink any further + pure $ Failed failure + + else + findM xs (Failed failure) $ \m -> do + o <- runTreeN retries m + if isFailure o then + Just <$> takeSmallest size seed (shrinks + 1) slimit retries o + else + return Nothing + + Right () -> + return OK + +isFailure :: Node m (Maybe (Either x a, b)) -> Bool +isFailure = \case + Node (Just (Left _, _)) _ -> + True + _ -> + False + +isSuccess :: Node m (Maybe (Either x a, b)) -> Bool +isSuccess = + not . isFailure + +runTreeN :: + Monad m + => ShrinkRetries + -> Tree m (Maybe (Either x a, b)) + -> m (Node m (Maybe (Either x a, b))) +runTreeN n m = do + o <- runTree m + if n > 0 && isSuccess o then + runTreeN (n - 1) m + else + pure o + +findM :: Monad m => [a] -> b -> (a -> m (Maybe b)) -> m b +findM xs0 def p = + case xs0 of + [] -> + return def + x0 : xs -> + p x0 >>= \m -> + case m of + Nothing -> + findM xs def p + Just x -> + return x + +takeAnnotation :: Log -> Maybe FailedAnnotation +takeAnnotation = \case + Annotation loc val -> + Just $ FailedAnnotation loc val + _ -> + Nothing + +takeFootnote :: Log -> Maybe String +takeFootnote = \case + Footnote x -> + Just x + _ -> + Nothing + +mkFailure :: + Size + -> Seed + -> ShrinkCount + -> Maybe Span + -> String + -> Maybe Diff + -> [Log] + -> FailureReport +mkFailure size seed shrinks location message diff logs = + let + inputs = + mapMaybe takeAnnotation logs + + footnotes = + mapMaybe takeFootnote logs + in + FailureReport size seed shrinks inputs location message diff footnotes diff --git a/lib/Echidna/Solidity.hs b/lib/Echidna/Solidity.hs index 1e002302..0140816f 100644 --- a/lib/Echidna/Solidity.hs +++ b/lib/Echidna/Solidity.hs @@ -22,7 +22,7 @@ import System.IO.Temp (writeSystemTempFile) import qualified Data.Map as Map (lookup) import Echidna.ABI (SolSignature) -import Echidna.Config (Config(..), sender, contractAddr, gasLimit, prefix, solcArgs) +import Echidna.Config (Config(..), sender, contractAddr, gasLimit, prefix, solcArgs, outputJson) import EVM @@ -70,11 +70,14 @@ readContracts filePath = do -- | reads either the first contract found or the contract named `selectedContractName` within the solidity file at `filepath` readContract :: (MonadIO m, MonadThrow m, MonadReader Config m) => FilePath -> Maybe Text -> m SolcContract readContract filePath selectedContractName = do + config <- ask cs <- readContracts filePath c <- chooseContract cs selectedContractName - warn (isNothing selectedContractName && 1 < length cs) - "Multiple contracts found in file, only analyzing the first" - liftIO $ print $ "Analyzing contract: " <> c ^. contractName + if config ^. outputJson then pure () + else do + warn (isNothing selectedContractName && 1 < length cs) + "Multiple contracts found in file, only analyzing the first" + liftIO $ print $ "Analyzing contract: " <> c ^. contractName return c where chooseContract :: (MonadThrow m) => [SolcContract] -> Maybe Text -> m SolcContract chooseContract [] _ = throwM NoContracts diff --git a/src/Main.hs b/src/Main.hs index d1e10448..41875f5f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -15,6 +15,7 @@ import Data.Semigroup ((<>)) import Echidna.Config import Echidna.Exec import Echidna.Solidity +--import Echidna.Internal.ZooRunner as Z import Hedgehog hiding (checkParallel) import Hedgehog.Internal.Property (GroupName(..), PropertyName(..)) From d05e9852be34434e67ebf19b3fbc098c836038fa Mon Sep 17 00:00:00 2001 From: Ben Perez Date: Thu, 19 Jul 2018 15:38:38 -0400 Subject: [PATCH 2/5] perprop now defaults to only outputting JSON --- perprop/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/perprop/Main.hs b/perprop/Main.hs index e392ab4a..70fa0ec0 100644 --- a/perprop/Main.hs +++ b/perprop/Main.hs @@ -74,7 +74,7 @@ readConf :: FilePath -> IO (Maybe (Config, [Property])) readConf f = decodeEither <$> BS.readFile f >>= \case Left e -> putStrLn ("couldn't parse config, " ++ e) >> pure Nothing Right (PerPropConf t s p) -> pure . Just . (,p) $ - defaultConfig & addrList .~ Just (view address <$> s) & testLimit .~ t & epochs .~ 1 + defaultConfig & addrList .~ Just (view address <$> s) & testLimit .~ t & epochs .~ 1 & outputJson .~ True group :: String -> Config @@ -106,7 +106,7 @@ main = getArgs >>= \case _ <- swapMVar mvar [] pure (p,lastGen,mvar) - checkParallel $ group sf c a v xs + checkParallelJson $ group sf c a v xs ls <- mapM (readMVar . snd) tests let ci = foldl' (\acc xs -> unions (acc : map snd xs)) mempty ls From d2d8d4f71d748f0b3f7dcc24a6d8f6a8c6ae63ac Mon Sep 17 00:00:00 2001 From: Ben Perez Date: Thu, 19 Jul 2018 16:05:54 -0400 Subject: [PATCH 3/5] Added option to turn on JSON output in Main.hs, removed json logic from Solidity.hs --- lib/Echidna/Solidity.hs | 11 ++++------- src/Main.hs | 7 ++++--- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/lib/Echidna/Solidity.hs b/lib/Echidna/Solidity.hs index 0140816f..1e002302 100644 --- a/lib/Echidna/Solidity.hs +++ b/lib/Echidna/Solidity.hs @@ -22,7 +22,7 @@ import System.IO.Temp (writeSystemTempFile) import qualified Data.Map as Map (lookup) import Echidna.ABI (SolSignature) -import Echidna.Config (Config(..), sender, contractAddr, gasLimit, prefix, solcArgs, outputJson) +import Echidna.Config (Config(..), sender, contractAddr, gasLimit, prefix, solcArgs) import EVM @@ -70,14 +70,11 @@ readContracts filePath = do -- | reads either the first contract found or the contract named `selectedContractName` within the solidity file at `filepath` readContract :: (MonadIO m, MonadThrow m, MonadReader Config m) => FilePath -> Maybe Text -> m SolcContract readContract filePath selectedContractName = do - config <- ask cs <- readContracts filePath c <- chooseContract cs selectedContractName - if config ^. outputJson then pure () - else do - warn (isNothing selectedContractName && 1 < length cs) - "Multiple contracts found in file, only analyzing the first" - liftIO $ print $ "Analyzing contract: " <> c ^. contractName + warn (isNothing selectedContractName && 1 < length cs) + "Multiple contracts found in file, only analyzing the first" + liftIO $ print $ "Analyzing contract: " <> c ^. contractName return c where chooseContract :: (MonadThrow m) => [SolcContract] -> Maybe Text -> m SolcContract chooseContract [] _ = throwM NoContracts diff --git a/src/Main.hs b/src/Main.hs index b5e6f889..93bde2c3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -15,7 +15,6 @@ import Data.Semigroup ((<>)) import Echidna.Config import Echidna.Exec import Echidna.Solidity ---import Echidna.Internal.ZooRunner as Z import Hedgehog hiding (checkParallel) import Hedgehog.Internal.Property (GroupName(..), PropertyName(..)) @@ -56,7 +55,9 @@ main = do -- Read cmd line options and load config (Options file contract usecov configFile) <- execParser opts config <- maybe (pure defaultConfig) parseConfig configFile + let f = checkTest (config ^. returnType) + checkGroup = if config ^. outputJson then checkParallelJson else checkParallel flip runReaderT config $ do -- Load solidity contract and get VM @@ -65,7 +66,7 @@ main = do -- Run without coverage then do let prop t = ePropertySeq (`f` t) a v >>= \x -> return (PropertyName $ show t, x) - _ <- checkParallel . Group (GroupName file) =<< mapM prop ts + _ <- checkGroup . Group (GroupName file) =<< mapM prop ts return () -- Run with coverage @@ -81,7 +82,7 @@ main = do _ <- swapMVar y [] return (lastGen,x,y) - checkParallel . Group (GroupName file) =<< mapM prop xs + checkGroup . Group (GroupName file) =<< mapM prop xs ls <- liftIO $ mapM (readMVar . snd) tests let ci = foldl' (\acc xs -> unions (acc : map snd xs)) mempty ls From 6b157cb754abc23fc68359aad91f79c78e1c4a42 Mon Sep 17 00:00:00 2001 From: Ben Perez Date: Thu, 19 Jul 2018 16:16:00 -0400 Subject: [PATCH 4/5] JSON now outputs as-completed instead of in bulk --- lib/Echidna/Internal/JsonRunner.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/lib/Echidna/Internal/JsonRunner.hs b/lib/Echidna/Internal/JsonRunner.hs index 50417d60..695ea8d6 100644 --- a/lib/Echidna/Internal/JsonRunner.hs +++ b/lib/Echidna/Internal/JsonRunner.hs @@ -13,7 +13,7 @@ module Echidna.Internal.JsonRunner ( checkParallelJson ) where -import Control.Monad (forM_) +--import Control.Monad (forM_) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson (ToJSON, encode) import Data.ByteString.Lazy.Char8 (unpack) @@ -65,10 +65,13 @@ checkGroup config (Group _ props) = updateNumCapabilities (n + 2) --verbosity <- resolveVerbosity (runnerVerbosity config) - rs <- runTasks n props st noop noop $ \(name, prop) -> checkProp 0 prop >>= pure . (format name) + _ <- runTasks n props st noop noop $ \(name, prop) -> do + result <- checkProp 0 prop + putStrLn $ unpack $ encode (format name result) + pure () --output JSON here - forM_ rs $ (putStrLn . unpack . encode) + --forM_ rs $ (putStrLn . unpack . encode) pure True From ac6cb5b60b0fd5a83b3c08242ccfca88fe985161 Mon Sep 17 00:00:00 2001 From: Ben Perez Date: Thu, 19 Jul 2018 16:53:49 -0400 Subject: [PATCH 5/5] Removed commented out code --- lib/Echidna/Internal/JsonRunner.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/lib/Echidna/Internal/JsonRunner.hs b/lib/Echidna/Internal/JsonRunner.hs index 695ea8d6..33d517b3 100644 --- a/lib/Echidna/Internal/JsonRunner.hs +++ b/lib/Echidna/Internal/JsonRunner.hs @@ -13,7 +13,6 @@ module Echidna.Internal.JsonRunner ( checkParallelJson ) where ---import Control.Monad (forM_) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson (ToJSON, encode) import Data.ByteString.Lazy.Char8 (unpack) @@ -64,14 +63,10 @@ checkGroup config (Group _ props) = updateNumCapabilities (n + 2) - --verbosity <- resolveVerbosity (runnerVerbosity config) _ <- runTasks n props st noop noop $ \(name, prop) -> do result <- checkProp 0 prop putStrLn $ unpack $ encode (format name result) pure () - - --output JSON here - --forM_ rs $ (putStrLn . unpack . encode) pure True