mirror of https://github.com/crytic/echidna
JP Smith
6 years ago
parent
d183c3a483
commit
468def9b81
@ -1,238 +1,182 @@ |
||||
{-# LANGUAGE ConstraintKinds, FlexibleContexts, LambdaCase, RankNTypes, TupleSections, TypeFamilies #-} |
||||
|
||||
module Echidna.ABI ( |
||||
SolCall |
||||
, SolSignature |
||||
, encodeAbiCall |
||||
, encodeSig |
||||
, displayAbiCall |
||||
, genAbiAddress |
||||
, genAbiArray |
||||
, genAbiArrayDynamic |
||||
, genAbiBool |
||||
, genAbiBytes |
||||
, genAbiBytesDynamic |
||||
, genAbiCall |
||||
, genAbiInt |
||||
, genInteractions |
||||
, genAbiString |
||||
, genAbiType |
||||
, genAbiUInt |
||||
, genAbiValue |
||||
, mutateCall |
||||
, mutateCallSeq |
||||
, mutateValue |
||||
, prettyPrint |
||||
) where |
||||
|
||||
import Control.Lens ((<&>), (&), view) |
||||
import Control.Monad (join, liftM2, replicateM) |
||||
import Control.Monad.Reader (MonadReader) |
||||
import Data.Bool (bool) |
||||
import Data.DoubleWord (Word128(..), Word160(..)) |
||||
import Data.Monoid ((<>)) |
||||
import Data.ByteString (ByteString) |
||||
import Data.Text (Text, unpack) |
||||
import Data.Vector (Vector, generateM) |
||||
import Hedgehog.Internal.Gen (MonadGen) |
||||
import GHC.Exts (IsList(..), Item) |
||||
import Hedgehog.Range (exponential, exponentialFrom, constant, singleton, Range) |
||||
import Numeric (showHex) |
||||
{-# LANGUAGE DeriveAnyClass #-} |
||||
{-# LANGUAGE FlexibleContexts #-} |
||||
{-# LANGUAGE ScopedTypeVariables #-} |
||||
{-# LANGUAGE StandaloneDeriving #-} |
||||
|
||||
module Echidna.ABI where |
||||
|
||||
import Control.Applicative ((<**>)) |
||||
import Control.Monad.Catch (Exception, MonadThrow(..)) |
||||
import Control.Monad.Reader.Class (MonadReader, asks) |
||||
import Control.Monad.Random.Strict |
||||
import Data.Bits (Bits(..)) |
||||
import Data.Bool (bool) |
||||
import Data.ByteString (ByteString) |
||||
import Data.Has (Has(..)) |
||||
import Data.Hashable (Hashable) |
||||
import Data.HashMap.Strict (HashMap) |
||||
import Data.List (group, sort) |
||||
import Data.Maybe (listToMaybe, mapMaybe) |
||||
import Data.Text (Text) |
||||
import Data.Vector (Vector) |
||||
import Data.Word8 (Word8) |
||||
import EVM.ABI (AbiType(..), AbiValue(..), abiValueType) |
||||
|
||||
import qualified Data.ByteString as BS |
||||
import qualified Data.List as L |
||||
import qualified Data.Text as T |
||||
import qualified Hedgehog.Gen as Gen |
||||
import qualified Data.HashMap.Strict as M |
||||
import qualified Data.Vector as V |
||||
|
||||
import Echidna.Config (Config, addrList) |
||||
-- Quick helper |
||||
|
||||
import EVM.ABI |
||||
import EVM.Types (Addr(..)) |
||||
newtype ElemException = ElemException String |
||||
|
||||
type SolCall = (Text, [AbiValue]) |
||||
instance Show ElemException where |
||||
show (ElemException s) = "Exception: tried to get element of " ++ s ++ ", but it was empty!" |
||||
|
||||
instance Exception ElemException |
||||
|
||||
rElem :: (MonadThrow m, MonadRandom m) => String -> [a] -> m a |
||||
rElem s [] = throwM $ ElemException s |
||||
rElem _ l = (l !!) <$> getRandomR (0, length l - 1) |
||||
|
||||
-- Types |
||||
|
||||
-- Don't construct this directly! Use mkConf |
||||
|
||||
type SolCall = (Text, [AbiValue]) |
||||
type SolSignature = (Text, [AbiType]) |
||||
|
||||
prettyPrint :: AbiValue -> String |
||||
prettyPrint (AbiUInt _ n) = show n |
||||
prettyPrint (AbiInt _ n) = show n |
||||
prettyPrint (AbiAddress n) = showHex n "" |
||||
prettyPrint (AbiBool b) = bool "true" "false" b |
||||
prettyPrint (AbiBytes _ b) = show b |
||||
prettyPrint (AbiBytesDynamic b) = show b |
||||
prettyPrint (AbiString s) = show s |
||||
prettyPrint (AbiArrayDynamic _ v) = |
||||
"[" ++ L.intercalate ", " (prettyPrint <$> toList v) ++ "]" |
||||
prettyPrint (AbiArray _ _ v) = |
||||
"[" ++ L.intercalate ", " (prettyPrint <$> toList v) ++ "]" |
||||
|
||||
encodeSig :: Text -> [AbiType] -> Text |
||||
encodeSig n ts = n <> "(" <> T.intercalate "," (map abiTypeSolidity ts) <> ")" |
||||
|
||||
genSize :: MonadGen m => m Int |
||||
genSize = (8 *) <$> Gen.enum 1 32 |
||||
|
||||
genAbiAddress :: (MonadGen m, MonadReader Config m) => m AbiValue |
||||
genAbiAddress = view addrList >>= \case (Just xs) -> fmap (AbiAddress . addressWord160) (Gen.element xs) |
||||
Nothing -> let w64 = Gen.word64 $ constant minBound maxBound in |
||||
fmap AbiAddress . liftM2 Word160 Gen.enumBounded |
||||
$ liftM2 Word128 w64 w64 |
||||
|
||||
genAbiUInt :: MonadGen m => Int -> m AbiValue |
||||
genAbiUInt n = AbiUInt n . fromInteger <$> genUInt |
||||
where genUInt = Gen.integral $ exponential 0 $ 2 ^ toInteger n - 1 |
||||
|
||||
genAbiInt :: MonadGen m => Int -> m AbiValue |
||||
genAbiInt n = AbiInt n . fromInteger <$> genInt |
||||
where genInt = Gen.integral $ exponentialFrom 0 (-1 * 2 ^ toInteger n) (2 ^ (toInteger n - 1)) |
||||
|
||||
genAbiBool :: MonadGen m => m AbiValue |
||||
genAbiBool = AbiBool <$> Gen.bool |
||||
|
||||
genAbiBytes :: MonadGen m => Int -> m AbiValue |
||||
genAbiBytes = liftM2 fmap AbiBytes $ Gen.bytes . singleton |
||||
|
||||
genAbiBytesDynamic :: MonadGen m => m AbiValue |
||||
genAbiBytesDynamic = AbiBytesDynamic <$> Gen.bytes (constant 1 256) |
||||
|
||||
genAbiString :: MonadGen m => m AbiValue |
||||
genAbiString = let fromRange = fmap AbiString . Gen.utf8 (constant 1 256) in |
||||
Gen.choice $ fromRange <$> [Gen.ascii, Gen.digit, Gen.alpha, Gen.element ['a','b','c'], Gen.unicode] |
||||
|
||||
genStaticAbiType :: MonadGen m => m AbiType |
||||
genStaticAbiType = go (16 :: Int) where |
||||
go n = Gen.choice $ [ AbiUIntType <$> genSize |
||||
, AbiIntType <$> genSize |
||||
, pure AbiAddressType |
||||
, pure AbiBoolType |
||||
, AbiBytesType <$> Gen.enum 1 32 |
||||
] ++ [AbiArrayType <$> Gen.enum 0 256 <*> go (n - 1) | n > 0] |
||||
|
||||
genAbiType :: MonadGen m => m AbiType |
||||
genAbiType = Gen.choice [ pure AbiBytesDynamicType |
||||
, pure AbiStringType |
||||
, AbiArrayDynamicType <$> genStaticAbiType |
||||
, genStaticAbiType |
||||
] |
||||
|
||||
genVecOfType :: (MonadReader Config m, MonadGen m) => AbiType -> Range Int -> m (Vector AbiValue) |
||||
genVecOfType t r = do |
||||
s <- Gen.integral r |
||||
generateM s $ \_ -> case t of |
||||
AbiUIntType n -> genAbiUInt n |
||||
AbiIntType n -> genAbiInt n |
||||
AbiAddressType -> genAbiAddress |
||||
AbiBoolType -> genAbiBool |
||||
AbiBytesType n -> genAbiBytes n |
||||
AbiArrayType n t' -> genAbiArray n t' |
||||
_ -> error "Arrays must only contain statically sized types" |
||||
|
||||
genAbiArrayDynamic :: (MonadReader Config m, MonadGen m) => AbiType -> m AbiValue |
||||
genAbiArrayDynamic t = AbiArrayDynamic t <$> genVecOfType t (constant 0 256) |
||||
|
||||
genAbiArray :: (MonadReader Config m, MonadGen m) => Int -> AbiType -> m AbiValue |
||||
genAbiArray n t = AbiArray n t <$> genVecOfType t (singleton n) |
||||
|
||||
genAbiValue :: (MonadReader Config m, MonadGen m) => m AbiValue |
||||
genAbiValue = Gen.choice [ genAbiUInt =<< genSize |
||||
, genAbiInt =<< genSize |
||||
, genAbiAddress |
||||
, genAbiBool |
||||
, genAbiBytes =<< Gen.enum 1 32 |
||||
, genAbiBytesDynamic |
||||
, genAbiString |
||||
, genAbiArrayDynamic =<< genAbiType |
||||
, join $ liftM2 genAbiArray (Gen.enum 0 256) genAbiType |
||||
] |
||||
|
||||
genAbiValueOfType :: (MonadReader Config m, MonadGen m) => AbiType -> m AbiValue |
||||
genAbiValueOfType t = case t of |
||||
AbiUIntType n -> genAbiUInt n |
||||
AbiIntType n -> genAbiInt n |
||||
AbiAddressType -> genAbiAddress |
||||
AbiBoolType -> genAbiBool |
||||
AbiBytesType n -> genAbiBytes n |
||||
AbiBytesDynamicType -> genAbiBytesDynamic |
||||
AbiStringType -> genAbiString |
||||
AbiArrayDynamicType t' -> genAbiArrayDynamic t' |
||||
AbiArrayType n t' -> genAbiArray n t' |
||||
|
||||
genAbiCall :: (MonadReader Config m, MonadGen m) => SolSignature -> m SolCall |
||||
genAbiCall (s,ts) = (s,) <$> mapM genAbiValueOfType ts |
||||
|
||||
encodeAbiCall :: SolCall -> ByteString |
||||
encodeAbiCall (t, vs) = abiCalldata t $ fromList vs |
||||
|
||||
displayAbiCall :: SolCall -> String |
||||
displayAbiCall (t, vs) = unpack t ++ "(" ++ L.intercalate "," (map prettyPrint vs) ++ ")" |
||||
|
||||
-- genInteractions generates a function call from a list of type signatures of |
||||
-- the form (Function name, [arg0 type, arg1 type...]) |
||||
genInteractions :: (MonadReader Config m, MonadGen m) => [SolSignature] -> m SolCall |
||||
genInteractions ls = genAbiCall =<< Gen.element ls |
||||
|
||||
type Listy t a = (IsList (t a), Item (t a) ~ a) |
||||
|
||||
switchElem :: (Listy t a, MonadGen m) => m a -> t a -> m (t a) |
||||
switchElem g t = let l = toList t; n = length l in do |
||||
i <- Gen.element [0..n] |
||||
x <- g |
||||
return . fromList $ take i l <> [x] <> drop (i+1) l |
||||
|
||||
changeChar :: MonadGen m => ByteString -> m ByteString |
||||
changeChar = fmap BS.pack . switchElem Gen.enumBounded . BS.unpack |
||||
|
||||
addBS :: MonadGen m => ByteString -> m ByteString |
||||
addBS b = Gen.element [(<> b), (b <>)] <*> Gen.utf8 (constant 0 (256 - BS.length b)) Gen.unicode |
||||
|
||||
dropBS :: MonadGen m => ByteString -> m ByteString |
||||
dropBS b = Gen.choice [ BS.drop <$> Gen.element [1..BS.length b] <*> pure b |
||||
, BS.take <$> Gen.element [0..BS.length b-1] <*> pure b |
||||
] |
||||
|
||||
changeDynamicBS :: MonadGen m => ByteString -> m ByteString |
||||
changeDynamicBS b = Gen.choice $ [changeChar, addBS, dropBS] <&> ($ b) |
||||
|
||||
changeNumber :: (Enum a, Integral a, MonadGen m) => a -> m a |
||||
changeNumber n = let x = fromIntegral n :: Integer in fromIntegral . (+ x) <$> Gen.element [-10..10] |
||||
|
||||
changeList :: (Listy t a, MonadGen m) => m (t a) -> m a -> t a -> m (t a) |
||||
changeList g0 g1 x = case toList x of |
||||
[] -> g0 |
||||
l -> Gen.choice [ Gen.element [(<> l), (l <>)] <*> fmap toList g0 |
||||
, drop <$> Gen.element [1..length l] <*> pure l |
||||
, take <$> Gen.element [0..length l-1] <*> pure l |
||||
, switchElem g1 l |
||||
] <&> fromList |
||||
|
||||
newOrMod :: MonadGen m => m AbiValue -> (a -> AbiValue) -> m a -> m AbiValue |
||||
newOrMod m f n = Gen.choice [m, f <$> n] |
||||
|
||||
mutateValue :: (MonadReader Config m, MonadGen m) => AbiValue -> m AbiValue |
||||
mutateValue (AbiUInt s n) = |
||||
newOrMod (genAbiUInt s) (AbiUInt s) (changeNumber n) |
||||
mutateValue (AbiInt s n) = |
||||
newOrMod (genAbiInt s) (AbiInt s) (changeNumber n) |
||||
mutateValue (AbiAddress a) = |
||||
newOrMod genAbiAddress AbiAddress (changeNumber a) |
||||
mutateValue (AbiBool _) = genAbiBool |
||||
mutateValue (AbiBytes s b) = |
||||
newOrMod (genAbiBytes s) (AbiBytes s) (changeChar b) |
||||
mutateValue (AbiBytesDynamic b) = |
||||
newOrMod genAbiBytesDynamic AbiBytesDynamic (changeDynamicBS b) |
||||
mutateValue (AbiString b) = |
||||
newOrMod genAbiString AbiString (changeDynamicBS b) |
||||
mutateValue (AbiArrayDynamic t a) = let g0 = genVecOfType t (constant 0 (256 - length a)); g1 = genAbiValueOfType t in |
||||
newOrMod (genAbiArrayDynamic t) (AbiArrayDynamic t) (changeList g0 g1 a) |
||||
mutateValue (AbiArray s t a) = |
||||
newOrMod (genAbiArray s t) (AbiArray s t) (switchElem (genAbiValueOfType t) a) |
||||
|
||||
changeOrId :: (Traversable t, MonadGen m) => (a -> m a) -> t a -> m (t a) |
||||
changeOrId f = mapM $ (Gen.element [f, pure] >>=) . (&) |
||||
|
||||
mutateCall :: (MonadReader Config m, MonadGen m) => SolCall -> m SolCall |
||||
mutateCall (t, vs) = (t,) <$> changeOrId mutateValue vs |
||||
|
||||
mutateCallSeq :: (MonadReader Config m, MonadGen m) => [SolSignature] -> [SolCall] -> m [SolCall] |
||||
mutateCallSeq s cs = let g = genInteractions s in |
||||
changeOrId mutateCall cs >>= changeList (Gen.element [1..10] >>= flip replicateM g) g |
||||
data GenConf = GenConf { pSynthA :: Float -- Fraction of time to use dictionary vs. synthesize |
||||
, constants :: HashMap AbiType [AbiValue] -- Constants to use, sorted by type |
||||
, wholeCalls :: HashMap SolSignature [SolCall] -- Whole calls to use, sorted by type |
||||
} |
||||
|
||||
-- This instance is the only way for mkConf to work nicely, and is well-formed. |
||||
{-# ANN module ("HLint: ignore Unused LANGUAGE pragma" :: String) #-} |
||||
-- We need the above since hlint doesn't notice DeriveAnyClass in StandaloneDeriving. |
||||
deriving instance Hashable AbiType |
||||
|
||||
mkConf :: Float -> [AbiValue] -> [SolCall] -> GenConf |
||||
mkConf p vs cs = GenConf p (tsOf id vs) (tsOf (fmap . fmap) cs) where |
||||
tsOf f = M.fromList . mapMaybe (liftM2 fmap (\l x -> (f abiValueType x, l)) listToMaybe) . group . sort |
||||
|
||||
-- Generation (synthesis) |
||||
|
||||
genAbiValue :: MonadRandom m => AbiType -> m AbiValue |
||||
genAbiValue (AbiUIntType n) = AbiUInt n . fromInteger <$> getRandomR (0, 2 ^ n - 1) |
||||
genAbiValue (AbiIntType n) = AbiInt n . fromInteger <$> getRandomR (-1 * 2 ^ n, 2 ^ (n - 1)) |
||||
genAbiValue AbiAddressType = AbiAddress . fromInteger <$> getRandomR (0, 2 ^ (160 :: Integer) - 1) |
||||
genAbiValue AbiBoolType = AbiBool <$> getRandom |
||||
genAbiValue (AbiBytesType n) = AbiBytes n . BS.pack . take n <$> getRandoms |
||||
genAbiValue AbiBytesDynamicType = liftM2 (\n -> AbiBytesDynamic . BS.pack . take n) (getRandomR (1, 32)) getRandoms |
||||
genAbiValue AbiStringType = liftM2 (\n -> AbiString . BS.pack . take n) (getRandomR (1, 32)) getRandoms |
||||
genAbiValue (AbiArrayType n t) = AbiArray n t <$> V.replicateM n (genAbiValue t) |
||||
genAbiValue (AbiArrayDynamicType t) = fmap (AbiArrayDynamic t) $ getRandomR (1, 32) >>= flip V.replicateM (genAbiValue t) |
||||
|
||||
genAbiCall :: MonadRandom m => SolSignature -> m SolCall |
||||
genAbiCall = traverse $ mapM genAbiValue |
||||
|
||||
genInteractions :: (MonadThrow m, MonadRandom m) => [SolSignature] -> m SolCall |
||||
genInteractions l = genAbiCall =<< rElem "ABI" l |
||||
|
||||
-- Mutation helper functions |
||||
|
||||
mutateNum :: (Integral a, Num a, MonadRandom m) => a -> m a |
||||
mutateNum x = bool (+) (-) <$> getRandom <*> pure x <*> (fromIntegral <$> getRandomR (0 :: Integer, fromIntegral x)) |
||||
|
||||
addChars :: MonadRandom m => m Word8 -> ByteString -> m ByteString |
||||
addChars c b = foldM withR b . enumFromTo 0 =<< rand where |
||||
rand = getRandomR (0, BS.length b) |
||||
withR b' n = (\x -> BS.take n b' <> BS.singleton x <> BS.drop (n + 1) b') <$> c |
||||
|
||||
addNulls :: MonadRandom m => ByteString -> m ByteString |
||||
addNulls = addChars $ pure 0 |
||||
|
||||
shrinkWith :: MonadRandom m => (Int -> a -> a) -> (Int -> a -> a) -> (a -> Int) -> a -> m a |
||||
shrinkWith f g l t = let rand = getRandomR (0, l t) in liftM2 (\x y -> f x $ g y t) rand rand |
||||
|
||||
shrinkBS :: MonadRandom m => ByteString -> m ByteString |
||||
shrinkBS = shrinkWith BS.take BS.drop BS.length |
||||
|
||||
shrinkL :: MonadRandom m => [a] -> m [a] |
||||
shrinkL = shrinkWith take drop length |
||||
|
||||
shrinkV :: MonadRandom m => Vector a -> m (Vector a) |
||||
shrinkV = shrinkWith V.take V.drop V.length |
||||
|
||||
growWith :: MonadRandom m => m b -> (b -> a -> a) -> (a -> b -> a) -> (a -> Int) -> a -> m a |
||||
growWith m f g l t = foldM withR t =<< flip replicateM m =<< rand where |
||||
rand = getRandomR (0, l t) |
||||
withR t' x = bool (f x t') (g t' x) <$> getRandom |
||||
|
||||
mutateBS :: MonadRandom m => ByteString -> m ByteString |
||||
mutateBS b = addChars getRandom =<< changeSize where |
||||
changeSize = bool (shrinkBS b) (growWith getRandom BS.cons BS.snoc BS.length b) =<< getRandom |
||||
|
||||
mutateV :: MonadRandom m => AbiType -> Vector AbiValue -> m (Vector AbiValue) |
||||
mutateV t v = mapM mutateAbiValue =<< changeSize where |
||||
changeSize = bool (shrinkV v) (growWith (genAbiValue t) V.cons V.snoc V.length v) =<< getRandom |
||||
|
||||
-- Mutation |
||||
|
||||
canShrinkAbiValue :: AbiValue -> Bool |
||||
canShrinkAbiValue (AbiUInt _ 0) = False |
||||
canShrinkAbiValue (AbiInt _ 0) = False |
||||
canShrinkAbiValue (AbiBool b) = b |
||||
canShrinkAbiValue (AbiBytes _ b) = BS.any (/= 0) b |
||||
canShrinkAbiValue (AbiBytesDynamic "") = True |
||||
canShrinkAbiValue (AbiString "") = True |
||||
canShrinkAbiValue (AbiArray _ _ l) = any canShrinkAbiValue l |
||||
canShrinkAbiValue (AbiArrayDynamic _ l) = l == mempty |
||||
canShrinkAbiValue _ = True |
||||
|
||||
dropBits :: forall a m. (Bits a, Bounded a, Integral a, MonadRandom m) => a -> m a |
||||
dropBits x = (x .&.) . fromIntegral <$> getRandomR bounds where |
||||
bounds :: (Integer, Integer) |
||||
bounds = (fromIntegral (minBound :: a), fromIntegral (maxBound :: a)) |
||||
|
||||
shrinkAbiValue :: MonadRandom m => AbiValue -> m AbiValue |
||||
shrinkAbiValue (AbiUInt n m) = AbiUInt n <$> dropBits m |
||||
shrinkAbiValue (AbiInt n m) = AbiInt n <$> dropBits m |
||||
shrinkAbiValue x@AbiAddress{} = pure x |
||||
shrinkAbiValue (AbiBool _) = pure $ AbiBool False |
||||
shrinkAbiValue (AbiBytes n b) = AbiBytes n <$> addNulls b |
||||
shrinkAbiValue (AbiBytesDynamic b) = fmap AbiBytesDynamic $ addNulls =<< shrinkBS b |
||||
shrinkAbiValue (AbiString b) = fmap AbiString $ addNulls =<< shrinkBS b |
||||
shrinkAbiValue (AbiArray n t l) = AbiArray n t <$> mapM shrinkAbiValue l |
||||
shrinkAbiValue (AbiArrayDynamic t l) = fmap (AbiArrayDynamic t) $ mapM shrinkAbiValue =<< shrinkV l |
||||
|
||||
shrinkAbiCall :: MonadRandom m => SolCall -> m SolCall |
||||
shrinkAbiCall = traverse $ mapM shrinkAbiValue |
||||
|
||||
mutateAbiValue :: MonadRandom m => AbiValue -> m AbiValue |
||||
mutateAbiValue (AbiUInt n x) = AbiUInt n <$> mutateNum x |
||||
mutateAbiValue (AbiInt n x) = AbiInt n <$> mutateNum x |
||||
mutateAbiValue (AbiAddress _) = genAbiValue AbiAddressType |
||||
mutateAbiValue (AbiBool _) = genAbiValue AbiBoolType |
||||
mutateAbiValue (AbiBytes n b) = AbiBytes n <$> addChars getRandom b |
||||
mutateAbiValue (AbiBytesDynamic b) = AbiBytesDynamic <$> mutateBS b |
||||
mutateAbiValue (AbiString b) = AbiString <$> mutateBS b |
||||
mutateAbiValue (AbiArray n t l) = AbiArray n t <$> mapM mutateAbiValue l |
||||
mutateAbiValue (AbiArrayDynamic t l) = AbiArrayDynamic t <$> mutateV t l |
||||
|
||||
mutateAbiCall :: MonadRandom m => SolCall -> m SolCall |
||||
mutateAbiCall = traverse $ mapM mutateAbiValue |
||||
|
||||
-- Generation, with dictionary |
||||
|
||||
genWithDict :: (Eq a, Hashable a, MonadReader x m, Has GenConf x, MonadRandom m, MonadThrow m) |
||||
=> (GenConf -> HashMap a [b]) -> (a -> m b) -> a -> m b |
||||
genWithDict f g t = asks getter >>= \c -> do |
||||
useD <- (pSynthA c <) <$> getRandom |
||||
g t <**> case (M.lookup t (f c), useD) of (Just l@(_:_), True) -> const <$> rElem "" l |
||||
_ -> pure id |
||||
|
||||
genAbiValueM :: (MonadReader x m, Has GenConf x, MonadRandom m, MonadThrow m) => AbiType -> m AbiValue |
||||
genAbiValueM = genWithDict constants genAbiValue |
||||
|
||||
genAbiCallM :: (MonadReader x m, Has GenConf x, MonadRandom m, MonadThrow m) => SolSignature -> m SolCall |
||||
genAbiCallM = genWithDict wholeCalls genAbiCall |
||||
|
||||
genInteractionsM :: (MonadReader x m, Has GenConf x, MonadRandom m, MonadThrow m) => [SolSignature] -> m SolCall |
||||
genInteractionsM l = genAbiCallM =<< rElem "ABI" l |
||||
|
||||
@ -0,0 +1,90 @@ |
||||
{-# LANGUAGE FlexibleContexts #-} |
||||
{-# LANGUAGE LambdaCase #-} |
||||
{-# LANGUAGE MultiWayIf #-} |
||||
{-# LANGUAGE PatternSynonyms #-} |
||||
{-# LANGUAGE RankNTypes #-} |
||||
{-# LANGUAGE ScopedTypeVariables #-} |
||||
{-# LANGUAGE TemplateHaskell #-} |
||||
{-# LANGUAGE TupleSections #-} |
||||
{-# LANGUAGE ViewPatterns #-} |
||||
|
||||
module Echidna.Campaign where |
||||
|
||||
import Control.Lens |
||||
import Control.Monad (liftM2, replicateM) |
||||
import Control.Monad.Catch (MonadCatch(..)) |
||||
import Control.Monad.Random.Strict (MonadRandom) |
||||
import Control.Monad.Reader.Class (MonadReader) |
||||
import Control.Monad.State.Strict (MonadState(..), StateT, evalStateT, execStateT) |
||||
import Data.Bool (bool) |
||||
import Data.Map (Map) |
||||
import Data.Has (Has(..)) |
||||
import Data.Set (Set) |
||||
import EVM |
||||
import EVM.Types (W256) |
||||
|
||||
import Echidna.ABI |
||||
import Echidna.Exec |
||||
import Echidna.Test |
||||
import Echidna.Transaction |
||||
|
||||
data CampaignConf = CampaignConf { testLimit :: Int |
||||
, seqLen :: Int |
||||
, shrinkLimit :: Int |
||||
, knownCoverage :: Maybe (Map W256 (Set Int)) |
||||
} |
||||
|
||||
data TestState = Open Int | Large Int [Tx] | Passed | Solved [Tx] | Failed ExecException deriving Show |
||||
|
||||
data Campaign = Campaign { _tests :: [(SolTest, TestState)] |
||||
, _coverage :: Maybe (Map W256 (Set Int)) |
||||
} |
||||
makeLenses ''Campaign |
||||
|
||||
isDone :: (MonadReader x m, Has CampaignConf x) => Campaign -> m Bool |
||||
isDone (Campaign ts _) = view (hasLens . to (liftM2 (,) testLimit shrinkLimit)) <&> \(tl, sl) -> |
||||
all (\case Open i -> i >= tl; Large i _ -> i >= sl; _ -> True) $ snd <$> ts |
||||
|
||||
updateTest :: ( MonadCatch m, MonadRandom m, MonadReader x m, Has TestConf x, Has CampaignConf x) |
||||
=> VM -> Maybe (VM, [Tx]) -> (SolTest, TestState) -> m (SolTest, TestState) |
||||
updateTest v (Just (v', xs)) (n, t) = view (hasLens . to testLimit) >>= \tl -> (n,) <$> case t of |
||||
Open i | i >= tl -> pure Passed |
||||
Open i -> catch (evalStateT (checkETest n) v' <&> bool (Large (-1) xs) (Open (i + 1))) |
||||
(pure . Failed) |
||||
_ -> snd <$> updateTest v Nothing (n,t) |
||||
updateTest v Nothing (n, t) = view (hasLens . to shrinkLimit) >>= \sl -> (n,) <$> case t of |
||||
Large i x | i >= sl -> pure $ Solved x |
||||
Large i x -> if any canShrinkTx x then Large (i + 1) <$> evalStateT (shrinkSeq n x) v |
||||
else pure $ Solved x |
||||
_ -> pure t |
||||
|
||||
callseq :: ( MonadCatch m, MonadRandom m, MonadReader x m, MonadState y m |
||||
, Has GenConf x, Has TestConf x, Has CampaignConf x, Has Campaign y) |
||||
=> VM -> World -> Int -> m (Set Tx) |
||||
callseq v w ql = replicateM ql (evalStateT genTxM w) >>= \is -> use hasLens >>= \ca -> case ca ^. coverage of |
||||
Nothing -> execStateT (evalSeq v execTx is) (v, ca) >>= assign hasLens . view _2 >> return mempty |
||||
(Just co) -> do (_, co', ca', s) <- execStateT (evalSeq v execTxRecC is) (v, co, ca, mempty :: Set Tx) |
||||
hasLens .= (ca' & coverage ?~ co') |
||||
return s |
||||
|
||||
campaign :: ( MonadCatch m, MonadRandom m, MonadReader x m, Has GenConf x, Has TestConf x, Has CampaignConf x) |
||||
=> StateT Campaign m a -> VM -> World -> [SolTest] -> m Campaign |
||||
campaign u v w ts = view (hasLens . to knownCoverage) >>= \c -> |
||||
execStateT runCampaign (Campaign ((,Open (-1)) <$> ts) c) where |
||||
step = runUpdate (updateTest v Nothing) >> u >> runCampaign |
||||
runCampaign = use (hasLens . tests . to (fmap snd)) >>= update |
||||
update c = view hasLens >>= \(CampaignConf tl q sl _) -> |
||||
if | any (\case Open n -> n < tl; _ -> False) c -> callseq v w q >> step |
||||
| any (\case Large n _ -> n < sl; _ -> False) c -> step |
||||
| otherwise -> u |
||||
|
||||
evalSeq :: ( MonadCatch m, MonadRandom m, MonadReader x m, MonadState y m |
||||
, Has TestConf x, Has CampaignConf x, Has Campaign y, Has VM y) |
||||
=> VM -> (Tx -> m a) -> [Tx] -> m () |
||||
evalSeq v e l = go [] l where |
||||
go r xs = use hasLens >>= \v' -> runUpdate (updateTest v $ Just (v',reverse r)) >> |
||||
case xs of [] -> pure () |
||||
(y:ys) -> e y >> go (y:r) ys |
||||
|
||||
runUpdate :: (MonadState x m, Has Campaign x) => ((SolTest, TestState) -> m (SolTest, TestState)) -> m () |
||||
runUpdate f = use (hasLens . tests) >>= mapM f >>= (hasLens . tests .=) |
||||
@ -1,72 +1,74 @@ |
||||
{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} |
||||
{-# LANGUAGE FlexibleInstances #-} |
||||
{-# LANGUAGE MultiParamTypeClasses #-} |
||||
{-# LANGUAGE TemplateHaskell #-} |
||||
|
||||
module Echidna.Config where |
||||
|
||||
import Control.Monad.Catch (MonadThrow(..)) |
||||
import Control.Monad.IO.Class (MonadIO(..)) |
||||
import Control.Monad.Reader (ReaderT, runReaderT) |
||||
import Control.Lens |
||||
import Control.Exception (Exception) |
||||
import Control.Monad.Catch (MonadThrow) |
||||
import Control.Monad.IO.Class (MonadIO(..)) |
||||
import Control.Monad.Reader (ReaderT(..)) |
||||
import Data.Has (Has(..)) |
||||
import Data.Aeson |
||||
import Data.Text (Text) |
||||
import Hedgehog (ShrinkLimit, TestLimit) |
||||
import Data.Maybe (fromMaybe) |
||||
import EVM (result) |
||||
|
||||
import qualified Data.ByteString.Char8 as BS |
||||
import qualified Data.ByteString as BS |
||||
import qualified Data.Yaml as Y |
||||
|
||||
import Echidna.Property (PropertyType(..)) |
||||
import Echidna.Campaign |
||||
import Echidna.ABI |
||||
import Echidna.Solidity |
||||
import Echidna.Test |
||||
import Echidna.UI |
||||
|
||||
import EVM.Types (Addr, W256) |
||||
data EConfig = EConfig { _cConf :: CampaignConf |
||||
, _gConf :: GenConf |
||||
, _nConf :: Names |
||||
, _sConf :: SolConf |
||||
, _tConf :: TestConf |
||||
} |
||||
makeLenses ''EConfig |
||||
|
||||
data Config = Config |
||||
{ _solcArgs :: Maybe String |
||||
, _epochs :: Int |
||||
, _range :: Int |
||||
, _contractAddr :: Addr |
||||
, _sender :: Addr |
||||
, _addrList :: Maybe [Addr] |
||||
, _gasLimit :: W256 |
||||
, _testLimit :: TestLimit |
||||
, _shrinkLimit :: ShrinkLimit |
||||
, _returnType :: PropertyType |
||||
, _prefix :: Text |
||||
, _printCoverage :: Bool |
||||
, _outputJson :: Bool |
||||
} |
||||
deriving Show |
||||
instance Has CampaignConf EConfig where |
||||
hasLens = cConf |
||||
|
||||
makeLenses ''Config |
||||
instance Has GenConf EConfig where |
||||
hasLens = gConf |
||||
|
||||
instance FromJSON Config where |
||||
parseJSON (Object v) = |
||||
let fromInt s n = ((v .:? s :: Y.Parser (Maybe Int)) <&> fmap fromIntegral) .!= n in |
||||
Config <$> v .:? "solcArgs" .!= Nothing |
||||
<*> v .:? "epochs" .!= 2 |
||||
<*> v .:? "range" .!= 10 |
||||
<*> v .:? "contractAddr" .!= 0x00a329c0648769a73afac7f9381e08fb43dbea72 |
||||
<*> v .:? "sender" .!= 0x00a329c0648769a73afac7f9381e08fb43dbea70 |
||||
<*> v .:? "addrList" .!= Nothing |
||||
<*> v .:? "gasLimit" .!= 0xffffffffffffffff |
||||
<*> fromInt "testLimit" 10000 |
||||
<*> fromInt "shrinkLimit" 1000 |
||||
<*> v .:? "returnType" .!= ShouldReturnTrue |
||||
<*> v .:? "prefix" .!= "echidna_" |
||||
<*> v .:? "printCoverage" .!= False |
||||
<*> v .:? "outputJson" .!= False |
||||
parseJSON _ = parseJSON (Object mempty) |
||||
instance Has Names EConfig where |
||||
hasLens = nConf |
||||
|
||||
newtype ParseException = ParseException FilePath |
||||
instance Has SolConf EConfig where |
||||
hasLens = sConf |
||||
|
||||
defaultConfig :: Config |
||||
defaultConfig = either (error "Config parser got messed up :(") id $ Y.decodeEither' "" |
||||
instance Has TestConf EConfig where |
||||
hasLens = tConf |
||||
|
||||
instance Show ParseException where |
||||
show (ParseException f) = "Could not parse config file " ++ show f |
||||
instance FromJSON EConfig where |
||||
parseJSON (Object v) = |
||||
let tc = do reverts <- v .:? "reverts" .!= True |
||||
sender <- v .:? "sender" .!= 0x00a329c0648769a73afac7f9381e08fb43dbea70 |
||||
let good = if reverts then (`elem` [ResTrue, ResRevert]) else (== ResTrue) |
||||
return $ TestConf (good . fromMaybe ResOther . fmap classifyRes . view result) (const sender) in |
||||
EConfig <$> (CampaignConf <$> v .:? "testLimit" .!= 10000 |
||||
<*> v .:? "seqLen" .!= 10 |
||||
<*> v .:? "shrinkLimit" .!= 5000 |
||||
<*> pure Nothing) |
||||
<*> pure (GenConf 0 mempty mempty) |
||||
<*> pure (const $ const mempty) |
||||
<*> (SolConf <$> v .:? "contractAddr" .!= 0x00a329c0648769a73afac7f9381e08fb43dbea72 |
||||
<*> v .:? "deployer" .!= 0x00a329c0648769a73afac7f9381e08fb43dbea70 |
||||
<*> v .:? "prefix " .!= "echidna_" |
||||
<*> v .:? "solcArgs " .!= "") |
||||
<*> tc |
||||
parseJSON _ = parseJSON (Object mempty) |
||||
|
||||
instance Exception ParseException |
||||
defaultConfig :: EConfig |
||||
defaultConfig = either (error "Config parser got messed up :(") id $ Y.decodeEither' "" |
||||
|
||||
parseConfig :: (MonadThrow m, MonadIO m) => FilePath -> m Config |
||||
parseConfig :: (MonadThrow m, MonadIO m) => FilePath -> m EConfig |
||||
parseConfig f = liftIO (BS.readFile f) >>= Y.decodeThrow |
||||
|
||||
withDefaultConfig :: ReaderT Config m a -> m a |
||||
withDefaultConfig :: ReaderT EConfig m a -> m a |
||||
withDefaultConfig = (`runReaderT` defaultConfig) |
||||
|
||||
@ -1,106 +0,0 @@ |
||||
{-# LANGUAGE BangPatterns, DeriveGeneric, FlexibleContexts, KindSignatures, LambdaCase, StrictData #-} |
||||
|
||||
module Echidna.Coverage ( |
||||
CoverageInfo |
||||
, CoverageRef |
||||
, CoverageReport(..) |
||||
, eCommandCoverage |
||||
, ePropertySeqCoverage |
||||
, execCallCoverage |
||||
, getCover |
||||
, getCoverageReport |
||||
, module Echidna.Internal.Runner |
||||
, module Echidna.Internal.JsonRunner |
||||
) where |
||||
|
||||
import Control.DeepSeq (force) |
||||
import Control.Concurrent.MVar (MVar, modifyMVar_) |
||||
import Control.Lens ((&), use) |
||||
import Control.Monad.IO.Class (MonadIO, liftIO) |
||||
import Control.Monad.State.Strict (MonadState, StateT, evalStateT, runState) |
||||
import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask) |
||||
import Data.Aeson (ToJSON(..), encode) |
||||
import Data.ByteString.Lazy.Char8 (unpack) |
||||
import Data.Foldable (Foldable(..), foldl') |
||||
import Data.IORef (IORef, modifyIORef', newIORef, readIORef) |
||||
import Data.Ord (comparing) |
||||
import Data.Set (Set, insert, size) |
||||
import Data.Vector (Vector, fromList) |
||||
import Data.Vector.Generic (maximumBy) |
||||
import GHC.Generics |
||||
|
||||
import qualified Control.Monad.State.Strict as S |
||||
|
||||
import Hedgehog |
||||
import Hedgehog.Gen (choice) |
||||
|
||||
import EVM |
||||
|
||||
import Echidna.ABI (SolCall, SolSignature, genInteractions, mutateCall) |
||||
import Echidna.Config (Config(..)) |
||||
import Echidna.Internal.Runner |
||||
import Echidna.Internal.JsonRunner |
||||
import Echidna.Exec |
||||
|
||||
----------------------------------------- |
||||
-- Coverage data types and printing |
||||
|
||||
type CoverageInfo = (SolCall, Set Int) |
||||
type CoverageRef = IORef CoverageInfo |
||||
|
||||
data CoverageReport = CoverageReport {coverage :: Int} deriving (Show,Generic) |
||||
|
||||
instance ToJSON CoverageReport |
||||
|
||||
getCoverageReport :: Set Int -> String |
||||
getCoverageReport = unpack . encode . toJSON . CoverageReport . size |
||||
|
||||
----------------------------------------- |
||||
-- Set cover algo |
||||
|
||||
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 |
||||
|
||||
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 |
||||
|
||||
----------------------------------------- |
||||
-- Echidna exec with coverage |
||||
|
||||
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 |
||||
S.state (runState exec1) |
||||
go . force $ insert current c |
||||
|
||||
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 |
||||
|
||||
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 |
||||
@ -1,146 +1,95 @@ |
||||
{-# LANGUAGE BangPatterns, DeriveGeneric, FlexibleContexts, KindSignatures, LambdaCase, StrictData #-} |
||||
|
||||
module Echidna.Exec ( |
||||
VMState(..) |
||||
, VMAction(..) |
||||
, checkTest |
||||
, checkBoolExpTest |
||||
, checkRevertTest |
||||
, checkTrueOrRevertTest |
||||
, checkFalseOrRevertTest |
||||
, eCommand |
||||
, eCommandUsing |
||||
, ePropertySeq |
||||
, ePropertyUsing |
||||
, execCall |
||||
, execCallUsing |
||||
, module Echidna.Internal.Runner |
||||
, module Echidna.Internal.JsonRunner |
||||
) where |
||||
|
||||
import Control.Lens ((&), (^.), (.=), (?~)) |
||||
import Control.Monad.Catch (MonadCatch) |
||||
import Control.Monad.State.Strict (MonadState, evalState, execState, get, put) |
||||
import Control.Monad.Reader (MonadReader, runReaderT, ask) |
||||
import Data.List (intercalate) |
||||
import Data.Text (Text) |
||||
import Data.Typeable (Typeable) |
||||
import Data.Vector (fromList) |
||||
|
||||
import Hedgehog |
||||
import Hedgehog.Gen (sequential) |
||||
import Hedgehog.Internal.State (Action(..)) |
||||
import Hedgehog.Internal.Property (PropertyConfig(..), mapConfig) |
||||
import Hedgehog.Range (linear) |
||||
|
||||
{-# LANGUAGE DataKinds #-} |
||||
{-# LANGUAGE FlexibleContexts #-} |
||||
{-# LANGUAGE PatternSynonyms #-} |
||||
{-# LANGUAGE ScopedTypeVariables #-} |
||||
{-# LANGUAGE ViewPatterns #-} |
||||
|
||||
module Echidna.Exec where |
||||
|
||||
import Control.Lens |
||||
import Control.Monad.Catch (Exception, MonadThrow(..)) |
||||
import Control.Monad.State.Strict (MonadState, execState, get, put) |
||||
import Data.Either (isRight) |
||||
import Data.Has (Has(..)) |
||||
import Data.Map.Strict (Map) |
||||
import Data.Maybe (fromMaybe) |
||||
import Data.Ord (comparing) |
||||
import Data.Set (Set) |
||||
import EVM |
||||
import EVM.ABI (AbiValue(..), abiCalldata, abiValueType, encodeAbiValue) |
||||
import EVM.Concrete (Blob(..)) |
||||
import EVM.Exec (exec) |
||||
|
||||
import Echidna.ABI (SolCall, SolSignature, displayAbiCall, encodeSig, genInteractions) |
||||
import Echidna.Config (Config(..), testLimit, range, shrinkLimit) |
||||
import Echidna.Internal.Runner |
||||
import Echidna.Internal.JsonRunner |
||||
import Echidna.Property (PropertyType(..)) |
||||
|
||||
------------------------------------------------------------------- |
||||
-- Fuzzing and Hedgehog Init |
||||
|
||||
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 |
||||
cleanUp |
||||
state . calldata .= cd |
||||
m >>= \case x@VMFailure{} -> put (og & result ?~ x) >> return x |
||||
x@VMSuccess{} -> return x |
||||
where cd = B . abiCalldata (encodeSig t $ abiValueType <$> vs) $ fromList vs |
||||
cleanUp = sequence_ [result .= Nothing, state . pc .= 0, state . stack .= mempty] |
||||
|
||||
checkTest :: PropertyType -> VM -> Text -> Bool |
||||
checkTest ShouldReturnTrue = checkBoolExpTest True |
||||
checkTest ShouldReturnFalse = checkBoolExpTest False |
||||
checkTest ShouldRevert = checkRevertTest |
||||
checkTest ShouldReturnFalseRevert = checkFalseOrRevertTest |
||||
|
||||
checkBoolExpTest :: Bool -> VM -> Text -> Bool |
||||
checkBoolExpTest b v t = case evalState (execCall (t, [])) v of |
||||
VMSuccess (B s) -> s == encodeAbiValue (AbiBool b) |
||||
_ -> False |
||||
|
||||
checkRevertTest :: VM -> Text -> Bool |
||||
checkRevertTest v t = case evalState (execCall (t, [])) v of |
||||
(VMFailure Revert) -> True |
||||
_ -> False |
||||
|
||||
checkTrueOrRevertTest :: VM -> Text -> Bool |
||||
checkTrueOrRevertTest v t = case evalState (execCall (t, [])) v of |
||||
(VMSuccess (B s)) -> s == encodeAbiValue (AbiBool True) |
||||
(VMFailure Revert) -> True |
||||
_ -> False |
||||
|
||||
checkFalseOrRevertTest :: VM -> Text -> Bool |
||||
checkFalseOrRevertTest v t = case evalState (execCall (t, [])) v of |
||||
(VMSuccess (B s)) -> s == encodeAbiValue (AbiBool False) |
||||
(VMFailure Revert) -> True |
||||
_ -> False |
||||
|
||||
|
||||
newtype VMState (v :: * -> *) = |
||||
VMState VM |
||||
|
||||
instance Show (VMState v) where |
||||
show (VMState v) = "EVM state, current result: " ++ show (v ^. result) |
||||
|
||||
newtype VMAction (v :: * -> *) = |
||||
Call SolCall |
||||
|
||||
instance Show (VMAction v) where |
||||
show (Call c) = displayAbiCall c |
||||
|
||||
instance HTraversable VMAction where |
||||
htraverse _ (Call b) = pure $ Call b |
||||
|
||||
|
||||
eCommandUsing :: (MonadGen n, MonadTest m, Typeable a) |
||||
=> n SolCall |
||||
-> (VMAction Concrete -> m a) |
||||
-> (VM -> Bool) |
||||
-> Command n m VMState |
||||
eCommandUsing gen ex p = Command (\_ -> pure $ Call <$> gen) ex |
||||
[ Ensure $ \_ (VMState v) _ _ -> assert $ p v |
||||
, Update $ \(VMState v) (Call c) _ -> VMState $ execState (execCall c) v |
||||
] |
||||
|
||||
|
||||
eCommand :: (MonadGen n, MonadTest m) => n SolCall -> (VM -> Bool) -> Command n m VMState |
||||
eCommand = flip eCommandUsing (\ _ -> pure ()) |
||||
|
||||
configProperty :: Config -> PropertyConfig -> PropertyConfig |
||||
configProperty config x = x { propertyTestLimit = config ^. testLimit |
||||
, propertyShrinkLimit = config ^. shrinkLimit |
||||
} |
||||
|
||||
ePropertyUsing :: (MonadCatch m, MonadTest m, MonadReader Config n) |
||||
=> [Command Gen m VMState] |
||||
-> (m () -> PropertyT IO ()) |
||||
-> VM |
||||
-> n Property |
||||
ePropertyUsing cs f v = do |
||||
config <- ask |
||||
return $ mapConfig (configProperty config) . property $ |
||||
f . executeSequential (VMState v) =<< forAllWith printCallSeq |
||||
(sequential (linear 1 (config ^. range)) (VMState v) cs) |
||||
where printCallSeq = ("Call sequence: " ++) . intercalate "\n " . |
||||
map showCall . sequentialActions |
||||
showCall (Action i _ _ _ _ _) = show i ++ ";" |
||||
|
||||
|
||||
ePropertySeq :: (MonadReader Config m) |
||||
=> (VM -> Bool) -- Predicate to fuzz for violations of |
||||
-> [SolSignature] -- Type signatures to fuzz |
||||
-> VM -- Initial state |
||||
-> m Property |
||||
ePropertySeq p ts vm = ask >>= \c -> ePropertyUsing [eCommand (runReaderT (genInteractions ts) c) p] id vm |
||||
import EVM.Exec (exec) |
||||
import EVM.Types (W256(..)) |
||||
|
||||
import qualified Data.Map as M |
||||
import qualified Data.Set as S |
||||
|
||||
import Echidna.Transaction |
||||
|
||||
data ErrorClass = RevertE | IllegalE | UnknownE |
||||
|
||||
classifyError :: Error -> ErrorClass |
||||
classifyError Revert = RevertE |
||||
classifyError (UnrecognizedOpcode _) = RevertE |
||||
classifyError StackUnderrun = IllegalE |
||||
classifyError BadJumpDestination = IllegalE |
||||
classifyError StackLimitExceeded = IllegalE |
||||
classifyError IllegalOverflow = IllegalE |
||||
classifyError _ = UnknownE |
||||
|
||||
pattern Reversion :: VMResult |
||||
pattern Reversion <- VMFailure (classifyError -> RevertE) |
||||
|
||||
pattern Illegal :: VMResult |
||||
pattern Illegal <- VMFailure (classifyError -> IllegalE) |
||||
|
||||
data ExecException = IllegalExec Error | UnknownFailure Error |
||||
|
||||
instance Show ExecException where |
||||
show (IllegalExec e) = "VM attempted an illegal operation: " ++ show e |
||||
show (UnknownFailure e) = "VM failed for unhandled reason, " ++ show e |
||||
++ ". This shouldn't happen. Please file a ticket with this error message and steps to reproduce!" |
||||
|
||||
instance Exception ExecException |
||||
|
||||
vmExcept :: MonadThrow m => Error -> m () |
||||
vmExcept e = throwM $ case VMFailure e of {Illegal -> IllegalExec e; _ -> UnknownFailure e} |
||||
|
||||
execTxWith :: (MonadState x m, Has VM x) => (Error -> m ()) -> m VMResult -> Tx -> m VMResult |
||||
execTxWith h m t = do og <- get |
||||
setupTx t |
||||
res <- m |
||||
case (res, isRight $ t ^. call) of |
||||
(Reversion, _) -> put og |
||||
(VMFailure x, _) -> h x |
||||
(VMSuccess (B bc), True) -> hasLens %= execState ( replaceCodeOfSelf bc |
||||
>> loadContract (t ^. dst)) |
||||
_ -> pure () |
||||
return res |
||||
|
||||
execTx :: (MonadState x m, Has VM x, MonadThrow m) => Tx -> m VMResult |
||||
execTx = execTxWith vmExcept $ liftSH exec |
||||
|
||||
pointCoverage :: (MonadState x m, Has (Map W256 (Set Int)) x, Has VM x) => m () |
||||
pointCoverage = use hasLens >>= \v -> |
||||
hasLens %= M.insertWith (const . S.insert $ v ^. state . pc) (h v) mempty where |
||||
h v = fromMaybe (W256 maxBound) $ v ^? env . contracts . at (v ^. state . contract) . _Just . codehash |
||||
|
||||
fastCoverage :: (MonadState x m, Has (Set Int) x, Has VM x) => m () |
||||
fastCoverage = use hasLens >>= \v -> hasLens %= S.insert (v ^. state . pc) |
||||
|
||||
usingCoverage :: (MonadState x m, Has VM x) => m () -> m VMResult |
||||
usingCoverage cov = maybe (cov >> liftSH exec1 >> usingCoverage cov) pure =<< use (hasLens . result) |
||||
|
||||
execTxRecC :: (MonadState x m, Has VM x, Has (Map W256 (Set Int)) x, MonadThrow m) => Tx -> m VMResult |
||||
execTxRecC = execTxWith vmExcept (usingCoverage pointCoverage) |
||||
|
||||
coveragePoints :: Map W256 (Set Int) -> Int |
||||
coveragePoints = sum . M.map S.size |
||||
|
||||
execTxOptC :: (MonadState x m, Has VM x, Has (Map W256 (Set Int)) x, Has (Set Tx) x, MonadThrow m) => Tx -> m VMResult |
||||
execTxOptC t = let hint = id :: Map W256 (Set Int) -> Map W256 (Set Int) in do |
||||
og <- hasLens <<.= mempty |
||||
res <- execTxRecC t |
||||
new <- M.unionWith S.union og . hint <$> use hasLens |
||||
if comparing coveragePoints new og == GT then hasLens %= S.insert t else pure () |
||||
return res |
||||
|
||||
@ -1,219 +0,0 @@ |
||||
{-# 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.IO.Class (MonadIO, liftIO) |
||||
import Data.Aeson (ToJSON, encode) |
||||
import Data.ByteString.Lazy.Char8 (unpack) |
||||
import Data.Maybe (mapMaybe) |
||||
import GHC.Generics |
||||
import System.IO (hFlush, stdout) |
||||
|
||||
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) |
||||
|
||||
_ <- runTasks n props st noop noop $ \(name, prop) -> do |
||||
result <- checkProp 0 prop |
||||
putStrLn $ unpack $ encode (format name result) |
||||
hFlush stdout |
||||
pure () |
||||
|
||||
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 |
||||
@ -1,925 +0,0 @@ |
||||
{-# LANGUAGE BangPatterns #-} |
||||
{-# LANGUAGE DeriveFoldable #-} |
||||
{-# LANGUAGE DeriveFunctor #-} |
||||
{-# LANGUAGE DeriveTraversable #-} |
||||
{-# LANGUAGE DoAndIfThenElse #-} |
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-} |
||||
{-# LANGUAGE LambdaCase #-} |
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
{-# LANGUAGE RankNTypes #-} |
||||
{-# LANGUAGE TupleSections #-} |
||||
module Echidna.Internal.Runner ( |
||||
checkParallel |
||||
) where |
||||
|
||||
import Control.Concurrent.STM (TVar, atomically) |
||||
import qualified Control.Concurrent.STM.TVar as TVar |
||||
import Control.DeepSeq (NFData) |
||||
import Control.Monad (zipWithM) |
||||
import Control.Monad.Catch |
||||
import Control.Monad.IO.Class (MonadIO(..)) |
||||
import Control.Monad.Trans.Maybe (MaybeT(..)) |
||||
|
||||
import Data.Bifunctor (first, second) |
||||
import Data.DoubleWord(Word128,Word256) |
||||
import Data.Either (partitionEithers) |
||||
import qualified Data.List as List |
||||
import Data.Map (Map) |
||||
import qualified Data.Map as Map |
||||
import Data.Maybe (mapMaybe, catMaybes) |
||||
import Data.Semigroup (Semigroup(..)) |
||||
|
||||
import Hedgehog.Internal.Config |
||||
import Hedgehog.Internal.Gen (runDiscardEffect, runGenT) |
||||
import Hedgehog.Internal.Property |
||||
(Failure(..), Group(..), GroupName(..), Property(..), PropertyT(..), |
||||
PropertyConfig(..), PropertyName(..), ShrinkLimit(..), ShrinkRetries(..), |
||||
Log(..), Diff(..), runTestT) |
||||
import Hedgehog.Internal.Queue |
||||
import Hedgehog.Internal.Region |
||||
import Hedgehog.Internal.Report |
||||
(DiscardCount(..), FailedAnnotation(..), FailureReport(..), PropertyCount(..), |
||||
Progress(..), Report(..), Result(..), ShrinkCount(..), TestCount(..)) |
||||
import Hedgehog.Internal.Runner (RunnerConfig(..)) |
||||
import Hedgehog.Internal.Seed (Seed) |
||||
import qualified Hedgehog.Internal.Seed as Seed |
||||
import Hedgehog.Internal.Show |
||||
import Hedgehog.Internal.Source |
||||
import Hedgehog.Internal.Tree (Node(..), Tree(..), runTree) |
||||
import Hedgehog.Range (Size) |
||||
|
||||
import System.Console.ANSI (ColorIntensity(..), Color(..)) |
||||
import System.Console.ANSI (ConsoleLayer(..), ConsoleIntensity(..)) |
||||
import System.Console.ANSI (SGR(..), setSGRCode) |
||||
|
||||
import Text.PrettyPrint.Annotated.WL (Doc, (<+>)) |
||||
import qualified Text.PrettyPrint.Annotated.WL as WL |
||||
|
||||
import EVM.Types (W256) |
||||
|
||||
instance NFData Word128 |
||||
instance NFData Word256 |
||||
instance NFData W256 |
||||
|
||||
checkParallel :: MonadIO m => Group -> m Bool |
||||
checkParallel = |
||||
checkGroup |
||||
RunnerConfig { |
||||
runnerWorkers = |
||||
Nothing |
||||
, runnerColor = |
||||
Nothing |
||||
, runnerVerbosity = |
||||
Nothing |
||||
} |
||||
|
||||
checkGroup :: MonadIO m => RunnerConfig -> Group -> m Bool |
||||
checkGroup config (Group group props) = |
||||
liftIO $ do |
||||
n <- resolveWorkers (runnerWorkers config) |
||||
|
||||
-- ensure few spare capabilities for concurrent-output, it's likely that |
||||
-- our tests will saturate all the capabilities they're given. |
||||
updateNumCapabilities (n + 2) |
||||
|
||||
putStrLn $ "━━━ " ++ unGroupName group ++ " ━━━" |
||||
|
||||
verbosity <- resolveVerbosity (runnerVerbosity config) |
||||
summary <- checkGroupWith n verbosity (runnerColor config) props |
||||
|
||||
pure $ |
||||
summaryFailed summary == 0 && |
||||
summaryGaveUp summary == 0 |
||||
|
||||
checkGroupWith :: |
||||
WorkerCount |
||||
-> Verbosity |
||||
-> Maybe UseColor |
||||
-> [(PropertyName, Property)] |
||||
-> IO Summary |
||||
checkGroupWith n verbosity mcolor props = |
||||
displayRegion $ \sregion -> do |
||||
svar <- atomically . TVar.newTVar $ mempty { summaryWaiting = PropertyCount (length props) } |
||||
|
||||
let |
||||
start (TasksRemaining tasks) _ix (name, prop) = |
||||
liftIO $ do |
||||
updateSummary sregion svar mcolor $ \x -> x { |
||||
summaryWaiting = |
||||
PropertyCount tasks |
||||
, summaryRunning = |
||||
summaryRunning x + 1 |
||||
} |
||||
|
||||
atomically $ do |
||||
region <- |
||||
case verbosity of |
||||
Quiet -> |
||||
newEmptyRegion |
||||
Normal -> |
||||
newOpenRegion |
||||
|
||||
moveToBottom sregion |
||||
|
||||
pure (name, prop, region) |
||||
|
||||
finish (_name, _prop, _region) = |
||||
updateSummary sregion svar mcolor $ \x -> x { |
||||
summaryRunning = |
||||
summaryRunning x - 1 |
||||
} |
||||
|
||||
finalize (_name, _prop, region) = |
||||
finishRegion region |
||||
|
||||
summary <- |
||||
fmap (mconcat . fmap (fromResult . reportStatus)) $ |
||||
runTasks n props start finish finalize $ \(name, prop, region) -> do |
||||
result <- checkNamed region mcolor (Just name) prop |
||||
updateSummary sregion svar mcolor |
||||
(<> fromResult (reportStatus result)) |
||||
pure result |
||||
|
||||
updateSummary sregion svar mcolor (const summary) |
||||
pure summary |
||||
|
||||
checkNamed :: |
||||
MonadIO m |
||||
=> Region |
||||
-> Maybe UseColor |
||||
-> Maybe PropertyName |
||||
-> Property |
||||
-> m (Report Result) |
||||
checkNamed region mcolor name prop = do |
||||
seed <- liftIO Seed.random |
||||
checkRegion region mcolor name 0 seed prop |
||||
|
||||
checkRegion :: |
||||
MonadIO m |
||||
=> Region |
||||
-> Maybe UseColor |
||||
-> Maybe PropertyName |
||||
-> Size |
||||
-> Seed |
||||
-> Property |
||||
-> m (Report Result) |
||||
checkRegion region mcolor name size seed prop = |
||||
liftIO $ do |
||||
result <- |
||||
checkReport (propertyConfig prop) size seed (propertyTest prop) $ \progress -> do |
||||
ppprogress <- renderProgress mcolor name progress |
||||
case reportStatus progress of |
||||
Running -> |
||||
setRegion region ppprogress |
||||
Shrinking _ -> |
||||
openRegion region ppprogress |
||||
|
||||
ppresult <- renderResult mcolor name result |
||||
case reportStatus result of |
||||
Failed _ -> |
||||
openRegion region ppresult |
||||
GaveUp -> |
||||
openRegion region ppresult |
||||
OK -> |
||||
setRegion region ppresult |
||||
|
||||
pure result |
||||
|
||||
checkReport :: |
||||
forall m. |
||||
MonadIO m |
||||
=> MonadCatch m |
||||
=> PropertyConfig |
||||
-> Size |
||||
-> Seed |
||||
-> PropertyT m () |
||||
-> (Report Progress -> m ()) |
||||
-> m (Report Result) |
||||
checkReport cfg size0 seed0 test0 updateUI = |
||||
let |
||||
test = |
||||
catchAll test0 (fail . show) |
||||
|
||||
loop !tests !discards !size !seed = do |
||||
updateUI $ Report tests discards Running |
||||
|
||||
if size > 99 then |
||||
-- size has reached limit, reset to 0 |
||||
loop tests discards 0 seed |
||||
|
||||
else if tests >= fromIntegral (propertyTestLimit cfg) then |
||||
-- we've hit the test limit, test was successful |
||||
pure $ Report tests discards OK |
||||
|
||||
else if discards >= fromIntegral (propertyDiscardLimit cfg) then |
||||
-- we've hit the discard limit, give up |
||||
pure $ Report tests discards 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 _, _) -> |
||||
let |
||||
mkReport = |
||||
Report (tests + 1) discards |
||||
in |
||||
fmap mkReport $ |
||||
takeSmallest |
||||
size |
||||
seed |
||||
0 |
||||
(propertyShrinkLimit cfg) |
||||
(propertyShrinkRetries cfg) |
||||
(updateUI . mkReport) |
||||
node |
||||
|
||||
Just (Right (), _) -> |
||||
loop (tests + 1) discards (size + 1) s1 |
||||
in |
||||
loop 0 0 size0 seed0 |
||||
|
||||
takeSmallest :: |
||||
MonadIO m |
||||
=> Size |
||||
-> Seed |
||||
-> ShrinkCount |
||||
-> ShrinkLimit |
||||
-> ShrinkRetries |
||||
-> (Progress -> m ()) |
||||
-> Node m (Maybe (Either Failure (), [Log])) |
||||
-> m Result |
||||
takeSmallest size seed shrinks slimit retries updateUI = \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) |
||||
|
||||
updateUI $ Shrinking failure |
||||
|
||||
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 updateUI o |
||||
else |
||||
return Nothing |
||||
|
||||
Right () -> |
||||
return OK |
||||
|
||||
|
||||
updateSummary :: Region -> TVar Summary -> Maybe UseColor -> (Summary -> Summary) -> IO () |
||||
updateSummary sregion svar mcolor f = do |
||||
summary <- atomically (TVar.modifyTVar' svar f >> TVar.readTVar svar) |
||||
setRegion sregion =<< renderSummary mcolor summary |
||||
|
||||
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 |
||||
|
||||
-- liftIO . displayRegion $ \region -> |
||||
-- (== OK) . reportStatus <$> checkNamed region Nothing Nothing prop |
||||
|
||||
------------------------------------------------------------------------ |
||||
-- Data |
||||
|
||||
-- | A summary of all the properties executed. |
||||
-- |
||||
data Summary = |
||||
Summary { |
||||
summaryWaiting :: !PropertyCount |
||||
, summaryRunning :: !PropertyCount |
||||
, summaryFailed :: !PropertyCount |
||||
, summaryGaveUp :: !PropertyCount |
||||
, summaryOK :: !PropertyCount |
||||
} deriving (Show) |
||||
|
||||
instance Monoid Summary where |
||||
mempty = |
||||
Summary 0 0 0 0 0 |
||||
mappend (Summary x1 x2 x3 x4 x5) (Summary y1 y2 y3 y4 y5) = |
||||
Summary |
||||
(x1 + y1) |
||||
(x2 + y2) |
||||
(x3 + y3) |
||||
(x4 + y4) |
||||
(x5 + y5) |
||||
|
||||
instance Semigroup Summary where |
||||
(<>) = mappend |
||||
|
||||
-- | Construct a summary from a single result. |
||||
-- |
||||
fromResult :: Result -> Summary |
||||
fromResult = \case |
||||
Failed _ -> |
||||
mempty { summaryFailed = 1 } |
||||
GaveUp -> |
||||
mempty { summaryGaveUp = 1 } |
||||
OK -> |
||||
mempty { summaryOK = 1 } |
||||
|
||||
summaryCompleted :: Summary -> PropertyCount |
||||
summaryCompleted (Summary _ _ x3 x4 x5) = |
||||
x3 + x4 + x5 |
||||
|
||||
summaryTotal :: Summary -> PropertyCount |
||||
summaryTotal (Summary x1 x2 x3 x4 x5) = |
||||
x1 + x2 + x3 + x4 + x5 |
||||
|
||||
------------------------------------------------------------------------ |
||||
-- Pretty Printing Helpers |
||||
|
||||
data Line a = |
||||
Line a LineNo String |
||||
deriving (Eq, Ord, Show, Functor) |
||||
|
||||
data Declaration a = |
||||
Declaration { |
||||
declarationFile :: !FilePath |
||||
, declarationLine :: !LineNo |
||||
, _declarationName :: !String |
||||
, declarationSource :: !(Map LineNo (Line a)) |
||||
} deriving (Eq, Ord, Show, Functor) |
||||
|
||||
data Style = |
||||
StyleDefault |
||||
| StyleAnnotation |
||||
| StyleFailure |
||||
deriving (Eq, Ord, Show) |
||||
|
||||
data Markup = |
||||
WaitingIcon |
||||
| WaitingHeader |
||||
| RunningIcon |
||||
| RunningHeader |
||||
| ShrinkingIcon |
||||
| ShrinkingHeader |
||||
| FailedIcon |
||||
| FailedHeader |
||||
| GaveUpIcon |
||||
| GaveUpHeader |
||||
| SuccessIcon |
||||
| SuccessHeader |
||||
| DeclarationLocation |
||||
| StyledLineNo !Style |
||||
| StyledBorder !Style |
||||
| StyledSource !Style |
||||
| AnnotationGutter |
||||
| AnnotationValue |
||||
| FailureArrows |
||||
| FailureGutter |
||||
| FailureMessage |
||||
| DiffPrefix |
||||
| DiffInfix |
||||
| DiffSuffix |
||||
| DiffSame |
||||
| DiffRemoved |
||||
| DiffAdded |
||||
| ReproduceHeader |
||||
| ReproduceGutter |
||||
| ReproduceSource |
||||
deriving (Eq, Ord, Show) |
||||
|
||||
instance Semigroup Style where |
||||
(<>) x y = |
||||
case (x, y) of |
||||
(StyleFailure, _) -> |
||||
StyleFailure |
||||
(_, StyleFailure) -> |
||||
StyleFailure |
||||
(StyleAnnotation, _) -> |
||||
StyleAnnotation |
||||
(_, StyleAnnotation) -> |
||||
StyleAnnotation |
||||
(StyleDefault, _) -> |
||||
StyleDefault |
||||
|
||||
------------------------------------------------------------------------ |
||||
|
||||
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 |
||||
|
||||
------------------------------------------------------------------------ |
||||
-- Pretty Printing |
||||
|
||||
ppShow :: Show x => x -> Doc a |
||||
ppShow = -- unfortunate naming clash |
||||
WL.text . show |
||||
|
||||
markup :: Markup -> Doc Markup -> Doc Markup |
||||
markup = |
||||
WL.annotate |
||||
|
||||
icon :: Markup -> Char -> Doc Markup -> Doc Markup |
||||
icon m i x = |
||||
markup m (WL.char i) <+> x |
||||
|
||||
ppTestCount :: TestCount -> Doc a |
||||
ppTestCount = \case |
||||
TestCount 1 -> |
||||
"1 test" |
||||
TestCount n -> |
||||
ppShow n <+> "tests" |
||||
|
||||
ppDiscardCount :: DiscardCount -> Doc a |
||||
ppDiscardCount = \case |
||||
DiscardCount 1 -> |
||||
"1 discard" |
||||
DiscardCount n -> |
||||
ppShow n <+> "discards" |
||||
|
||||
ppShrinkCount :: ShrinkCount -> Doc a |
||||
ppShrinkCount = \case |
||||
ShrinkCount 1 -> |
||||
"1 shrink" |
||||
ShrinkCount n -> |
||||
ppShow n <+> "shrinks" |
||||
|
||||
ppRawPropertyCount :: PropertyCount -> Doc a |
||||
ppRawPropertyCount (PropertyCount n) = |
||||
ppShow n |
||||
|
||||
ppWithDiscardCount :: DiscardCount -> Doc Markup |
||||
ppWithDiscardCount = \case |
||||
DiscardCount 0 -> |
||||
mempty |
||||
n -> |
||||
" with" <+> ppDiscardCount n |
||||
|
||||
ppShrinkDiscard :: ShrinkCount -> DiscardCount -> Doc Markup |
||||
ppShrinkDiscard s d = |
||||
case (s, d) of |
||||
(0, 0) -> |
||||
"" |
||||
(0, _) -> |
||||
" and" <+> ppDiscardCount d |
||||
(_, 0) -> |
||||
" and" <+> ppShrinkCount s |
||||
(_, _) -> |
||||
"," <+> ppShrinkCount s <+> "and" <+> ppDiscardCount d |
||||
|
||||
mapSource :: (Map LineNo (Line a) -> Map LineNo (Line a)) -> Declaration a -> Declaration a |
||||
mapSource f decl = |
||||
decl { |
||||
declarationSource = |
||||
f (declarationSource decl) |
||||
} |
||||
|
||||
ppFailedInputTypedArgument :: Int -> FailedAnnotation -> Doc Markup |
||||
ppFailedInputTypedArgument ix (FailedAnnotation _ val) = |
||||
WL.vsep [ |
||||
WL.text "forAll" <> ppShow ix <+> "=" |
||||
, WL.indent 2 . WL.vsep . fmap (markup AnnotationValue . WL.text) $ lines val |
||||
] |
||||
|
||||
fixedDecl :: Declaration (Style, [t]) |
||||
fixedDecl = Declaration { |
||||
declarationFile = "", |
||||
declarationLine = LineNo 1, |
||||
_declarationName = "", |
||||
declarationSource = Map.fromList [ (LineNo 1, Line (StyleDefault,[]) (LineNo 1) "") ] |
||||
} |
||||
|
||||
ppFailedInputDeclaration :: |
||||
MonadIO m |
||||
=> FailedAnnotation |
||||
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)]))) |
||||
ppFailedInputDeclaration (FailedAnnotation _ val) = |
||||
runMaybeT $ do |
||||
let |
||||
ppValLine = |
||||
WL.indent 0 . |
||||
(markup AnnotationGutter (WL.text "│ ") <>) . |
||||
markup AnnotationValue . |
||||
WL.text |
||||
|
||||
valDocs = |
||||
fmap ((StyleAnnotation, ) . ppValLine) $ |
||||
List.lines val |
||||
|
||||
styleInput kvs = |
||||
foldr (Map.adjust . fmap . first $ const StyleAnnotation) kvs [0,1] |
||||
|
||||
insertDoc = |
||||
Map.adjust (fmap . second $ const valDocs) 1 |
||||
|
||||
pure $ |
||||
mapSource (styleInput . insertDoc) fixedDecl |
||||
|
||||
ppFailedInput :: |
||||
MonadIO m |
||||
=> Int |
||||
-> FailedAnnotation |
||||
-> m (Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))) |
||||
ppFailedInput ix input = do |
||||
mdecl <- ppFailedInputDeclaration input |
||||
case mdecl of |
||||
Nothing -> |
||||
pure . Left $ ppFailedInputTypedArgument ix input |
||||
Just decl -> |
||||
pure $ Right decl |
||||
|
||||
ppLineDiff :: LineDiff -> Doc Markup |
||||
ppLineDiff = \case |
||||
LineSame x -> |
||||
markup DiffSame $ |
||||
" " <> WL.text x |
||||
|
||||
LineRemoved x -> |
||||
markup DiffRemoved $ |
||||
"- " <> WL.text x |
||||
|
||||
LineAdded x -> |
||||
markup DiffAdded $ |
||||
"+ " <> WL.text x |
||||
|
||||
ppDiff :: Diff -> [Doc Markup] |
||||
ppDiff (Diff prefix removed infix_ added suffix diff) = [ |
||||
markup DiffPrefix (WL.text prefix) <> |
||||
markup DiffRemoved (WL.text removed) <+> |
||||
markup DiffInfix (WL.text infix_) <+> |
||||
markup DiffAdded (WL.text added) <> |
||||
markup DiffSuffix (WL.text suffix) |
||||
] ++ fmap ppLineDiff (toLineDiff diff) |
||||
|
||||
ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup |
||||
ppDeclaration decl = |
||||
case Map.maxView $ declarationSource decl of |
||||
Nothing -> |
||||
mempty |
||||
Just _ -> |
||||
let |
||||
ppLines = do |
||||
Line (_, xs) _ _ <- Map.elems $ declarationSource decl |
||||
fmap snd xs |
||||
in |
||||
WL.vsep (ppLines) |
||||
|
||||
mergeLine :: Semigroup a => Line a -> Line a -> Line a |
||||
mergeLine (Line x no src) (Line y _ _) = |
||||
Line (x <> y) no src |
||||
|
||||
mergeDeclaration :: Semigroup a => Declaration a -> Declaration a -> Declaration a |
||||
mergeDeclaration (Declaration file line name src0) (Declaration _ _ _ src1) = |
||||
Declaration file line name $ |
||||
Map.unionWith mergeLine src0 src1 |
||||
|
||||
mergeDeclarations :: Semigroup a => [Declaration a] -> [Declaration a] |
||||
mergeDeclarations = |
||||
Map.elems . |
||||
Map.fromListWith mergeDeclaration . |
||||
fmap (\d -> ((declarationFile d, declarationLine d), d)) |
||||
|
||||
ppTextLines :: String -> [Doc Markup] |
||||
ppTextLines = |
||||
fmap WL.text . List.lines |
||||
|
||||
ppFailureReport :: MonadIO m => Maybe PropertyName -> FailureReport -> m (Doc Markup) |
||||
ppFailureReport _ (FailureReport _ _ _ inputs0 _ msg mdiff msgs0) = do |
||||
_ <- let |
||||
msgs1 = |
||||
msgs0 ++ |
||||
(if null msg then [] else [msg]) |
||||
|
||||
docs = |
||||
concatMap ppTextLines msgs1 ++ |
||||
maybe [] ppDiff mdiff |
||||
in |
||||
pure (docs, Nothing) |
||||
|
||||
(_, idecls) <- partitionEithers <$> zipWithM ppFailedInput [0..] inputs0 |
||||
|
||||
let |
||||
decls = |
||||
mergeDeclarations . |
||||
catMaybes $ |
||||
fmap pure idecls |
||||
|
||||
with xs f = |
||||
if null xs then |
||||
[] |
||||
else |
||||
[f xs] |
||||
|
||||
pure . WL.indent 2 . WL.vsep . WL.punctuate WL.line $ concat [ |
||||
with decls $ |
||||
WL.vsep . WL.punctuate WL.line . fmap ppDeclaration |
||||
] |
||||
|
||||
ppName :: Maybe PropertyName -> Doc a |
||||
ppName = \case |
||||
Nothing -> |
||||
"<interactive>" |
||||
Just (PropertyName name) -> |
||||
WL.text name |
||||
|
||||
ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup) |
||||
ppProgress name (Report tests discards status) = |
||||
case status of |
||||
Running -> |
||||
pure . icon RunningIcon '●' . WL.annotate RunningHeader $ |
||||
ppName name <+> |
||||
"passed" <+> |
||||
ppTestCount tests <> |
||||
ppWithDiscardCount discards <+> |
||||
"(running)" |
||||
|
||||
Shrinking failure -> |
||||
pure . icon ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $ |
||||
ppName name <+> |
||||
"failed after" <+> |
||||
ppTestCount tests <> |
||||
ppShrinkDiscard (failureShrinks failure) discards <+> |
||||
"(shrinking)" |
||||
|
||||
ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup) |
||||
ppResult name (Report tests discards result) = |
||||
case result of |
||||
Failed failure -> do |
||||
pfailure <- ppFailureReport name failure |
||||
pure . WL.vsep $ [ |
||||
icon FailedIcon '✗' . WL.annotate FailedHeader $ |
||||
ppName name <+> |
||||
"failed after" <+> |
||||
ppTestCount tests <> |
||||
ppShrinkDiscard (failureShrinks failure) discards <> |
||||
"." |
||||
, mempty |
||||
, pfailure |
||||
, mempty |
||||
] |
||||
|
||||
GaveUp -> |
||||
pure . icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader $ |
||||
ppName name <+> |
||||
"gave up after" <+> |
||||
ppDiscardCount discards <> |
||||
", passed" <+> |
||||
ppTestCount tests <> |
||||
"." |
||||
|
||||
OK -> |
||||
pure . icon SuccessIcon '✓' . WL.annotate SuccessHeader $ |
||||
ppName name <+> |
||||
"passed" <+> |
||||
ppTestCount tests <> |
||||
"." |
||||
|
||||
ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a) |
||||
ppWhenNonZero suffix n = |
||||
if n <= 0 then |
||||
Nothing |
||||
else |
||||
Just $ ppRawPropertyCount n <+> suffix |
||||
|
||||
annotateSummary :: Summary -> Doc Markup -> Doc Markup |
||||
annotateSummary summary = |
||||
if summaryFailed summary > 0 then |
||||
icon FailedIcon '✗' . WL.annotate FailedHeader |
||||
else if summaryGaveUp summary > 0 then |
||||
icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader |
||||
else if summaryWaiting summary > 0 || summaryRunning summary > 0 then |
||||
icon WaitingIcon '○' . WL.annotate WaitingHeader |
||||
else |
||||
icon SuccessIcon '✓' . WL.annotate SuccessHeader |
||||
|
||||
ppSummary :: MonadIO m => Summary -> m (Doc Markup) |
||||
ppSummary summary = |
||||
let |
||||
complete = |
||||
summaryCompleted summary == summaryTotal summary |
||||
|
||||
prefix end = |
||||
if complete then |
||||
mempty |
||||
else |
||||
ppRawPropertyCount (summaryCompleted summary) <> |
||||
"/" <> |
||||
ppRawPropertyCount (summaryTotal summary) <+> |
||||
"complete" <> end |
||||
|
||||
addPrefix xs = |
||||
if null xs then |
||||
prefix mempty : [] |
||||
else |
||||
prefix ": " : xs |
||||
|
||||
suffix = |
||||
if complete then |
||||
"." |
||||
else |
||||
" (running)" |
||||
in |
||||
pure . |
||||
annotateSummary summary . |
||||
(<> suffix) . |
||||
WL.hcat . |
||||
addPrefix . |
||||
WL.punctuate ", " $ |
||||
catMaybes [ |
||||
ppWhenNonZero "failed" (summaryFailed summary) |
||||
, ppWhenNonZero "gave up" (summaryGaveUp summary) |
||||
, if complete then |
||||
ppWhenNonZero "succeeded" (summaryOK summary) |
||||
else |
||||
Nothing |
||||
] |
||||
|
||||
renderDoc :: MonadIO m => Maybe UseColor -> Doc Markup -> m String |
||||
renderDoc mcolor doc = do |
||||
let |
||||
dull = |
||||
SetColor Foreground Dull |
||||
|
||||
vivid = |
||||
SetColor Foreground Vivid |
||||
|
||||
bold = |
||||
SetConsoleIntensity BoldIntensity |
||||
|
||||
start = \case |
||||
WaitingIcon -> |
||||
setSGRCode [] |
||||
WaitingHeader -> |
||||
setSGRCode [] |
||||
RunningIcon -> |
||||
setSGRCode [] |
||||
RunningHeader -> |
||||
setSGRCode [] |
||||
ShrinkingIcon -> |
||||
setSGRCode [vivid Red] |
||||
ShrinkingHeader -> |
||||
setSGRCode [vivid Red] |
||||
FailedIcon -> |
||||
setSGRCode [vivid Red] |
||||
FailedHeader -> |
||||
setSGRCode [vivid Red] |
||||
GaveUpIcon -> |
||||
setSGRCode [dull Yellow] |
||||
GaveUpHeader -> |
||||
setSGRCode [dull Yellow] |
||||
SuccessIcon -> |
||||
setSGRCode [dull Green] |
||||
SuccessHeader -> |
||||
setSGRCode [dull Green] |
||||
|
||||
DeclarationLocation -> |
||||
setSGRCode [] |
||||
|
||||
StyledLineNo StyleDefault -> |
||||
setSGRCode [] |
||||
StyledSource StyleDefault -> |
||||
setSGRCode [] |
||||
StyledBorder StyleDefault -> |
||||
setSGRCode [] |
||||
|
||||
StyledLineNo StyleAnnotation -> |
||||
setSGRCode [dull Magenta] |
||||
StyledSource StyleAnnotation -> |
||||
setSGRCode [] |
||||
StyledBorder StyleAnnotation -> |
||||
setSGRCode [] |
||||
AnnotationGutter -> |
||||
setSGRCode [dull Magenta] |
||||
AnnotationValue -> |
||||
setSGRCode [dull Magenta] |
||||
|
||||
StyledLineNo StyleFailure -> |
||||
setSGRCode [vivid Red] |
||||
StyledSource StyleFailure -> |
||||
setSGRCode [vivid Red, bold] |
||||
StyledBorder StyleFailure -> |
||||
setSGRCode [] |
||||
FailureArrows -> |
||||
setSGRCode [vivid Red] |
||||
FailureMessage -> |
||||
setSGRCode [] |
||||
FailureGutter -> |
||||
setSGRCode [] |
||||
|
||||
DiffPrefix -> |
||||
setSGRCode [] |
||||
DiffInfix -> |
||||
setSGRCode [] |
||||
DiffSuffix -> |
||||
setSGRCode [] |
||||
DiffSame -> |
||||
setSGRCode [] |
||||
DiffRemoved -> |
||||
setSGRCode [dull Red] |
||||
DiffAdded -> |
||||
setSGRCode [dull Green] |
||||
|
||||
ReproduceHeader -> |
||||
setSGRCode [] |
||||
ReproduceGutter -> |
||||
setSGRCode [] |
||||
ReproduceSource -> |
||||
setSGRCode [] |
||||
|
||||
end _ = |
||||
setSGRCode [Reset] |
||||
|
||||
color <- resolveColor mcolor |
||||
|
||||
let |
||||
display = |
||||
case color of |
||||
EnableColor -> |
||||
WL.displayDecorated start end id |
||||
DisableColor -> |
||||
WL.display |
||||
|
||||
pure . |
||||
display . |
||||
WL.renderSmart 100 $ |
||||
WL.indent 2 doc |
||||
|
||||
renderProgress :: MonadIO m => Maybe UseColor -> Maybe PropertyName -> Report Progress -> m String |
||||
renderProgress mcolor name x = |
||||
renderDoc mcolor =<< ppProgress name x |
||||
|
||||
renderResult :: MonadIO m => Maybe UseColor -> Maybe PropertyName -> Report Result -> m String |
||||
renderResult mcolor name x = |
||||
renderDoc mcolor =<< ppResult name x |
||||
|
||||
renderSummary :: MonadIO m => Maybe UseColor -> Summary -> m String |
||||
renderSummary mcolor x = |
||||
renderDoc mcolor =<< ppSummary x |
||||
@ -1,15 +0,0 @@ |
||||
module Echidna.Property where |
||||
|
||||
import Data.Text ( unpack ) |
||||
import Data.Yaml ( Value(..), FromJSON, parseJSON ) |
||||
|
||||
data PropertyType = ShouldReturnTrue | ShouldReturnFalse | ShouldRevert | ShouldReturnFalseRevert |
||||
deriving (Show) |
||||
|
||||
instance FromJSON PropertyType where |
||||
parseJSON (String "Success") = pure ShouldReturnTrue |
||||
parseJSON (String "Fail") = pure ShouldReturnFalse |
||||
parseJSON (String "Throw") = pure ShouldRevert |
||||
parseJSON (String "Fail or Throw") = pure ShouldReturnFalseRevert |
||||
parseJSON (String s) = fail $ "Expected return type, not " ++ unpack s |
||||
parseJSON _ = fail "Expected return type, should be a string" |
||||
@ -0,0 +1,46 @@ |
||||
{-# LANGUAGE FlexibleContexts #-} |
||||
|
||||
module Echidna.Test where |
||||
|
||||
import Control.Monad (ap) |
||||
import Control.Monad.Catch (MonadThrow) |
||||
import Control.Monad.Random.Strict (MonadRandom, getRandomR) |
||||
import Control.Monad.Reader.Class (MonadReader, asks) |
||||
import Control.Monad.State.Strict (MonadState(..), gets) |
||||
import Data.Bool (bool) |
||||
import Data.Has (Has(..)) |
||||
import Data.Text (Text) |
||||
import EVM |
||||
import EVM.ABI (AbiValue(..), encodeAbiValue) |
||||
import EVM.Concrete (Blob(..)) |
||||
import EVM.Types (Addr) |
||||
|
||||
import Echidna.Exec |
||||
import Echidna.Transaction |
||||
|
||||
type SolTest = (Text, Addr) |
||||
|
||||
data TestConf = TestConf { classifier :: VM -> Bool |
||||
, testSender :: Addr -> Addr |
||||
} |
||||
|
||||
data CallRes = ResFalse | ResTrue | ResRevert | ResOther deriving (Eq, Show) |
||||
|
||||
classifyRes :: VMResult -> CallRes |
||||
classifyRes (VMSuccess (B b)) | b == encodeAbiValue (AbiBool True) = ResTrue |
||||
| b == encodeAbiValue (AbiBool False) = ResFalse |
||||
classifyRes Reversion = ResRevert |
||||
classifyRes _ = ResOther |
||||
|
||||
checkETest :: (MonadReader x m, Has TestConf x, MonadState y m, Has VM y, MonadThrow m) => SolTest -> m Bool |
||||
checkETest (f, a) = asks getter >>= \(TestConf p s) -> do |
||||
og <- get |
||||
res <- execTx (Tx (Left (f, [])) (s a) a 0) >> gets (p . getter) |
||||
put og |
||||
pure res |
||||
|
||||
shrinkSeq :: (MonadRandom m, MonadReader x m, Has TestConf x, MonadState y m, Has VM y, MonadThrow m) |
||||
=> SolTest -> [Tx] -> m [Tx] |
||||
shrinkSeq t xs = shorten >>= mapM shrinkTx >>= ap (fmap . flip bool xs) check where |
||||
check xs' = do {og <- get; res <- traverse execTx xs' >> checkETest t; put og; pure res} |
||||
shorten = (\i -> take i xs ++ drop (i + 1) xs) <$> getRandomR (0, length xs) |
||||
@ -0,0 +1,94 @@ |
||||
{-# LANGUAGE LambdaCase #-} |
||||
{-# LANGUAGE MultiParamTypeClasses #-} |
||||
{-# LANGUAGE FlexibleContexts #-} |
||||
{-# LANGUAGE FlexibleInstances #-} |
||||
{-# LANGUAGE TemplateHaskell #-} |
||||
|
||||
module Echidna.Transaction where |
||||
|
||||
import Prelude hiding (Word) |
||||
|
||||
import Control.Lens |
||||
import Control.Monad (liftM4) |
||||
import Control.Monad.Catch (MonadThrow) |
||||
import Control.Monad.Random.Strict (MonadRandom, getRandomR) |
||||
import Control.Monad.Reader.Class (MonadReader) |
||||
import Control.Monad.State.Strict (MonadState, State, runState) |
||||
import Data.ByteString (ByteString) |
||||
import Data.Either (either, lefts) |
||||
import Data.Has (Has(..)) |
||||
import Data.Set (Set) |
||||
import EVM |
||||
import EVM.ABI (abiCalldata, abiTypeSolidity, abiValueType) |
||||
import EVM.Concrete (Blob(..), Word(..), w256) |
||||
import EVM.Types (Addr) |
||||
|
||||
import qualified Control.Monad.State.Strict as S (state) |
||||
import qualified Data.Set as S |
||||
import qualified Data.Text as T |
||||
import qualified Data.Vector as V |
||||
|
||||
import Echidna.ABI |
||||
|
||||
-- Note: I currently don't model gas cost, nonces, or signatures here |
||||
data Tx = Tx { _call :: Either SolCall ByteString |
||||
, _src :: Addr |
||||
, _dst :: Addr |
||||
, _value :: Word |
||||
} deriving (Eq, Ord, Show) |
||||
|
||||
makeLenses ''Tx |
||||
|
||||
type ContractA = (Addr, [SolSignature]) |
||||
|
||||
data World = World { _senders :: [Addr] |
||||
, _receivers :: [ContractA] |
||||
} |
||||
|
||||
makeLenses ''World |
||||
|
||||
genTxWith :: (MonadRandom m, MonadState x m, Has World x, MonadThrow m) |
||||
=> ([Addr] -> m Addr) -- Sender generator |
||||
-> ([ContractA] -> m ContractA) -- Receiver generator |
||||
-> (Addr -> ContractA -> m SolCall) -- Call generator |
||||
-> (Addr -> ContractA -> SolCall -> m Word) -- Value generator |
||||
-> m Tx |
||||
genTxWith s r c v = use hasLens >>= \case(World ss rs) -> do s' <- s ss |
||||
r' <- r rs |
||||
c' <- c s' r' |
||||
Tx (Left c') s' (fst r') <$> v s' r' c' |
||||
|
||||
genTx :: (MonadRandom m, MonadState x m, Has World x, MonadThrow m) => m Tx |
||||
genTx = genTxWith (rElem "sender list") (rElem "recipient list") (const $ genInteractions . snd) (\_ _ _ -> pure 0) |
||||
|
||||
genTxM :: (MonadRandom m, MonadState x m, Has World x, MonadThrow m, MonadReader y m, Has GenConf y) => m Tx |
||||
genTxM = genTxWith (rElem "sender list") (rElem "recipient list") (const $ genInteractionsM . snd) (\_ _ _ -> pure 0) |
||||
|
||||
canShrinkTx :: Tx -> Bool |
||||
canShrinkTx (Tx (Right _) _ _ 0) = False |
||||
canShrinkTx (Tx (Left (_,l)) _ _ 0) = any canShrinkAbiValue l |
||||
canShrinkTx _ = True |
||||
|
||||
shrinkTx :: MonadRandom m => Tx -> m Tx |
||||
shrinkTx (Tx c s d (C _ v)) = let c' = either (fmap Left . shrinkAbiCall) (fmap Right . pure) c in |
||||
liftM4 Tx c' (pure s) (pure d) $ w256 . fromIntegral <$> getRandomR (0 :: Integer, fromIntegral v) |
||||
|
||||
spliceTxs :: (MonadRandom m, MonadState x m, Has World x, MonadThrow m) => Set Tx -> m Tx |
||||
spliceTxs ts = let l = S.toList ts; (cs, ss) = unzip $ (\(Tx c s _ _) -> (c,s)) <$> l in |
||||
genTxWith (const . rElem "sender list" $ ss) (rElem "recipient list") |
||||
(\_ _ -> mutateAbiCall =<< rElem "past calls" (lefts cs)) |
||||
(\ _ _ (n,_) -> let valOf (Tx c _ _ v) = if elem n $ c ^? _Left . _1 then v else 0 |
||||
in rElem "values" $ valOf <$> l) |
||||
|
||||
liftSH :: (MonadState a m, Has b a) => State b x -> m x |
||||
liftSH = S.state . runState . zoom hasLens |
||||
|
||||
setupTx :: (MonadState x m, Has VM x) => Tx -> m () |
||||
setupTx (Tx c s r v) = liftSH . sequence_ $ |
||||
[ result .= Nothing, state . pc .= 0, state . stack .= mempty, state . gas .= 0xffffffff |
||||
, env . origin .= s, state . caller .= s, state . callvalue .= v, setup] where |
||||
setup = case c of |
||||
Left cd -> loadContract r >> state . calldata .= encode cd |
||||
Right bc -> assign (env . contracts . ix r) (initialContract bc) >> loadContract r |
||||
encode (n, vs) = B . abiCalldata |
||||
(n <> "(" <> T.intercalate "," (abiTypeSolidity . abiValueType <$> vs) <> ")") $ V.fromList vs |
||||
Loading…
Reference in new issue