|
|
|
@ -1,26 +1,19 @@ |
|
|
|
|
{-# LANGUAGE BangPatterns, DeriveGeneric, FlexibleContexts, KindSignatures, LambdaCase, StrictData #-} |
|
|
|
|
|
|
|
|
|
module Echidna.Exec ( |
|
|
|
|
ContractCov(..) |
|
|
|
|
, CoveragePoint(..) |
|
|
|
|
, CoverageReport(..) |
|
|
|
|
, byHashes |
|
|
|
|
VMState |
|
|
|
|
, VMAction(..) |
|
|
|
|
, checkTest |
|
|
|
|
, checkBoolExpTest |
|
|
|
|
, checkRevertTest |
|
|
|
|
, checkTrueOrRevertTest |
|
|
|
|
, checkFalseOrRevertTest |
|
|
|
|
, CoverageInfo |
|
|
|
|
, CoverageRef |
|
|
|
|
, eCommand |
|
|
|
|
, eCommandCoverage |
|
|
|
|
, eCommandUsing |
|
|
|
|
, ePropertySeq |
|
|
|
|
, ePropertySeqCoverage |
|
|
|
|
, ePropertyUsing |
|
|
|
|
, execCall |
|
|
|
|
, execCallCoverage |
|
|
|
|
, getCover |
|
|
|
|
, ppHashes |
|
|
|
|
, printResults |
|
|
|
|
, execCallUsing |
|
|
|
|
, module Echidna.Internal.Runner |
|
|
|
|
, module Echidna.Internal.JsonRunner |
|
|
|
|
) where |
|
|
|
@ -67,48 +60,11 @@ import Echidna.Internal.Runner |
|
|
|
|
import Echidna.Internal.JsonRunner |
|
|
|
|
import Echidna.Property (PropertyType(..)) |
|
|
|
|
|
|
|
|
|
-------------------------------------------------------------------- |
|
|
|
|
-- COVERAGE HANDLING |
|
|
|
|
|
|
|
|
|
data CoveragePoint = C (Int, Int) W256 deriving (Eq, Generic) |
|
|
|
|
|
|
|
|
|
instance NFData CoveragePoint |
|
|
|
|
|
|
|
|
|
instance Ord CoveragePoint where |
|
|
|
|
compare (C (_,i0) w0) (C (_,i1) w1) = case compare w0 w1 of EQ -> compare i0 i1 |
|
|
|
|
x -> x |
|
|
|
|
|
|
|
|
|
type CoverageInfo = (SolCall, Set CoveragePoint) |
|
|
|
|
type CoverageRef = IORef CoverageInfo |
|
|
|
|
|
|
|
|
|
byHashes :: (Foldable t, Monoid (t CoveragePoint)) => t CoveragePoint -> Map W256 (Set (Int, Int)) |
|
|
|
|
byHashes = foldr (\(C i w) -> insertWith mappend w $ singleton i) mempty . toList |
|
|
|
|
|
|
|
|
|
printResults :: (MonadIO m, MonadReader Config m) => Set CoveragePoint -> m () |
|
|
|
|
printResults ci = do liftIO (putStrLn $ "Coverage: " ++ show (size ci) ++ " unique arcs") |
|
|
|
|
view printCoverage >>= \case True -> liftIO . print . ppHashes $ byHashes ci |
|
|
|
|
False -> pure () |
|
|
|
|
|
|
|
|
|
data ContractCov = ContractCov { hash :: String, arcs :: [(Int, Int)] } deriving (Show, Generic) |
|
|
|
|
newtype CoverageReport = CoverageReport { coverage :: [ContractCov] } deriving (Show, Generic) |
|
|
|
|
|
|
|
|
|
instance ToJSON ContractCov |
|
|
|
|
instance ToJSON CoverageReport |
|
|
|
|
|
|
|
|
|
ppHashes :: Map W256 (Set (Int, Int)) -> String |
|
|
|
|
ppHashes = unpack . encode . toJSON . CoverageReport |
|
|
|
|
. map (\(h, is) -> ContractCov (show h) (toList is)) . toAscList |
|
|
|
|
|
|
|
|
|
getCover :: (Foldable t, Monoid (t b)) => [(a, t b)] -> [a] |
|
|
|
|
getCover [] = [] |
|
|
|
|
getCover xs = setCover (fromList xs) mempty totalCoverage [] |
|
|
|
|
where totalCoverage = length $ foldl' (\acc -> mappend acc . snd) mempty xs |
|
|
|
|
------------------------------------------------------------------- |
|
|
|
|
-- Fuzzing and Hedgehog Init |
|
|
|
|
|
|
|
|
|
setCover :: (Foldable t, Monoid (t b)) => Vector (a, t b) -> t b -> Int -> [a] -> [a] |
|
|
|
|
setCover vs cov tot calls = best : calls & if length new == tot then id |
|
|
|
|
else setCover vs new tot where |
|
|
|
|
(best, new) = mappend cov <$> maximumBy (comparing $ length . mappend cov . snd) vs |
|
|
|
|
|
|
|
|
|
execCall :: MonadState VM m => SolCall -> m VMResult |
|
|
|
|
execCall = execCallUsing exec |
|
|
|
|
|
|
|
|
|
execCallUsing :: MonadState VM m => m VMResult -> SolCall -> m VMResult |
|
|
|
|
execCallUsing m (t,vs) = do og <- get |
|
|
|
@ -119,26 +75,6 @@ execCallUsing m (t,vs) = do og <- get |
|
|
|
|
where cd = B . abiCalldata (encodeSig t $ abiValueType <$> vs) $ fromList vs |
|
|
|
|
cleanUp = sequence_ [result .= Nothing, state . pc .= 0, state . stack .= mempty] |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
execCall :: MonadState VM m => SolCall -> m VMResult |
|
|
|
|
execCall = execCallUsing exec |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
execCallCoverage :: (MonadState VM m, MonadReader CoverageRef m, MonadIO m) => SolCall -> m VMResult |
|
|
|
|
execCallCoverage sol = execCallUsing (go mempty) sol where |
|
|
|
|
go !c = use result >>= \case |
|
|
|
|
Just x -> do ref <- ask |
|
|
|
|
liftIO $ modifyIORef' ref (const (sol, c)) |
|
|
|
|
return x |
|
|
|
|
_ -> do current <- use $ state . pc |
|
|
|
|
ch <- view codehash . fromMaybe (error "no current contract??") . currentContract <$> get |
|
|
|
|
S.state (runState exec1) |
|
|
|
|
new <- use $ state . pc |
|
|
|
|
go . force $ insert (C (current, new) ch) c |
|
|
|
|
|
|
|
|
|
------------------------------------------------------------------- |
|
|
|
|
-- Fuzzing and Hedgehog Init |
|
|
|
|
|
|
|
|
|
checkTest :: PropertyType -> VM -> Text -> Bool |
|
|
|
|
checkTest ShouldReturnTrue = checkBoolExpTest True |
|
|
|
|
checkTest ShouldReturnFalse = checkBoolExpTest False |
|
|
|
@ -198,14 +134,6 @@ eCommandUsing gen ex p = Command (\_ -> pure $ Call <$> gen) ex |
|
|
|
|
eCommand :: (MonadGen n, MonadTest m) => n SolCall -> (VM -> Bool) -> Command n m VMState |
|
|
|
|
eCommand = flip eCommandUsing (\ _ -> pure ()) |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
eCommandCoverage :: (MonadGen n, MonadTest m, MonadState VM m, MonadReader CoverageRef m, MonadIO m) |
|
|
|
|
=> [SolCall] -> (VM -> Bool) -> [SolSignature] -> Config -> [Command n m VMState] |
|
|
|
|
eCommandCoverage cov p ts conf = let useConf = flip runReaderT conf in case cov of |
|
|
|
|
[] -> [eCommandUsing (useConf $ genInteractions ts) (\(Call c) -> execCallCoverage c) p] |
|
|
|
|
xs -> map (\x -> eCommandUsing (choice $ useConf <$> [mutateCall x, genInteractions ts]) |
|
|
|
|
(\(Call c) -> execCallCoverage c) p) xs |
|
|
|
|
|
|
|
|
|
configProperty :: Config -> PropertyConfig -> PropertyConfig |
|
|
|
|
configProperty config x = x { propertyTestLimit = config ^. testLimit |
|
|
|
|
, propertyShrinkLimit = config ^. shrinkLimit |
|
|
|
@ -232,21 +160,3 @@ ePropertySeq :: (MonadReader Config m) |
|
|
|
|
-> VM -- Initial state |
|
|
|
|
-> m Property |
|
|
|
|
ePropertySeq p ts vm = ask >>= \c -> ePropertyUsing [eCommand (runReaderT (genInteractions ts) c) p] id vm |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
ePropertySeqCoverage :: (MonadReader Config m) |
|
|
|
|
=> [SolCall] |
|
|
|
|
-> MVar [CoverageInfo] |
|
|
|
|
-> (VM -> Bool) |
|
|
|
|
-> [SolSignature] |
|
|
|
|
-> VM |
|
|
|
|
-> m Property |
|
|
|
|
ePropertySeqCoverage calls cov p ts v = ask >>= \c -> ePropertyUsing (eCommandCoverage calls p ts c) writeCoverage v |
|
|
|
|
where writeCoverage :: MonadIO m => ReaderT CoverageRef (StateT VM m) a -> m a |
|
|
|
|
writeCoverage m = do |
|
|
|
|
threadCovRef <- liftIO $ newIORef mempty |
|
|
|
|
let s = runReaderT m threadCovRef |
|
|
|
|
a <- evalStateT s v |
|
|
|
|
threadCov <- liftIO $ readIORef threadCovRef |
|
|
|
|
liftIO $ modifyMVar_ cov (\xs -> pure $ threadCov:xs) |
|
|
|
|
return a |
|
|
|
|