|
|
|
|
@ -2,7 +2,10 @@ |
|
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-} |
|
|
|
|
{-# LANGUAGE FlexibleContexts #-} |
|
|
|
|
{-# LANGUAGE FlexibleInstances #-} |
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-} |
|
|
|
|
{-# LANGUAGE TemplateHaskell #-} |
|
|
|
|
{-# LANGUAGE TupleSections #-} |
|
|
|
|
{-# LANGUAGE ViewPatterns #-} |
|
|
|
|
|
|
|
|
|
module Echidna.Transaction where |
|
|
|
|
|
|
|
|
|
@ -13,7 +16,7 @@ import Control.Monad (join, liftM2, liftM3, liftM5) |
|
|
|
|
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 Control.Monad.State.Strict (MonadState, State, evalStateT, runState) |
|
|
|
|
import Data.Aeson (ToJSON(..), object) |
|
|
|
|
import Data.ByteString (ByteString) |
|
|
|
|
import Data.Either (either, lefts) |
|
|
|
|
@ -39,14 +42,19 @@ data Tx2 = Tx2 { _call2 :: Either SolCall2 ByteString -- | Either a call or cod |
|
|
|
|
, _dst2 :: Addr -- | Destination |
|
|
|
|
, _gas2' :: Word -- | Gas |
|
|
|
|
, _value2 :: Word -- | Value |
|
|
|
|
, _delay2 :: (Word, Word) -- | (Time, # of blocks since last call) |
|
|
|
|
} deriving (Eq, Ord, Show) |
|
|
|
|
|
|
|
|
|
makeLenses ''Tx2 |
|
|
|
|
|
|
|
|
|
data TxConf = TxConf { _propGas :: Word |
|
|
|
|
data TxConf = TxConf { _propGas :: Word |
|
|
|
|
-- ^ Gas to use evaluating echidna properties |
|
|
|
|
, _txGas :: Word |
|
|
|
|
, _txGas :: Word |
|
|
|
|
-- ^ Gas to use in generated transactions |
|
|
|
|
, _maxTimeDelay :: Word |
|
|
|
|
-- ^ Maximum time delay between transactions (seconds) |
|
|
|
|
, _maxBlockDelay :: Word |
|
|
|
|
-- ^ Maximum block delay between transactions |
|
|
|
|
} |
|
|
|
|
|
|
|
|
|
makeLenses 'TxConf |
|
|
|
|
@ -56,13 +64,21 @@ ppSolCall2 :: SolCall2 -> String |
|
|
|
|
ppSolCall2 (t, vs) = (if t == "" then T.unpack "*fallback*" else T.unpack t) ++ "(" ++ intercalate "," (ppAbiValue2 <$> vs) ++ ")" |
|
|
|
|
|
|
|
|
|
instance ToJSON Tx2 where |
|
|
|
|
toJSON (Tx2 c s d g v) = object [ ("call", toJSON $ either ppSolCall2 (const "<CREATE>") c) |
|
|
|
|
-- from/to are Strings, since JSON doesn't support hexadecimal notation |
|
|
|
|
, ("from", toJSON $ show s) |
|
|
|
|
, ("to", toJSON $ show d) |
|
|
|
|
, ("value", toJSON $ show v) |
|
|
|
|
, ("gas", toJSON $ show g) |
|
|
|
|
] |
|
|
|
|
toJSON (Tx2 c s d g v (t, b)) = object [ ("call", toJSON $ either ppSolCall2 (const "<CREATE>") c) |
|
|
|
|
-- from/to are Strings, since JSON doesn't support hexadecimal notation |
|
|
|
|
, ("from", toJSON $ show s) |
|
|
|
|
, ("to", toJSON $ show d) |
|
|
|
|
, ("value", toJSON $ show v) |
|
|
|
|
, ("gas", toJSON $ show g) |
|
|
|
|
, ("time delay", toJSON $ show t) |
|
|
|
|
, ("block delay", toJSON $ show b) |
|
|
|
|
] |
|
|
|
|
|
|
|
|
|
-- | If half a tuple is zero, make both halves zero. Useful for generating delays, since block number |
|
|
|
|
-- only goes up with timestamp |
|
|
|
|
level :: (Num a, Eq a) => (a, a) -> (a, a) |
|
|
|
|
level (elemOf each 0 -> True) = (0,0) |
|
|
|
|
level x = x |
|
|
|
|
|
|
|
|
|
-- | A contract is just an address with an ABI (for our purposes). |
|
|
|
|
type ContractA2 = (Addr, [SolSignature2]) |
|
|
|
|
@ -82,41 +98,49 @@ genTxWith2 :: (MonadRandom m, MonadState x m, Has World2 x, MonadThrow m) |
|
|
|
|
-> (Addr -> ContractA2 -> m SolCall2) -- ^ Call generator |
|
|
|
|
-> m Word -- ^ Gas generator |
|
|
|
|
-> (Addr -> ContractA2 -> SolCall2 -> m Word) -- ^ Value generator |
|
|
|
|
-> m (Word, Word) -- ^ Delay generator |
|
|
|
|
-> m Tx2 |
|
|
|
|
genTxWith2 s r c g v = use hasLens >>= |
|
|
|
|
\case (World2 ss rs) -> let s' = s ss; r' = r rs; c' = join $ liftM2 c s' r' in |
|
|
|
|
liftM5 Tx2 (Left <$> c') s' (fst <$> r') g =<< liftM3 v s' r' c' |
|
|
|
|
genTxWith2 s r c g v t = use hasLens >>= \(World2 ss rs) -> |
|
|
|
|
let s' = s ss; r' = r rs; c' = join $ liftM2 c s' r' in |
|
|
|
|
(liftM5 Tx2 (Left <$> c') s' (fst <$> r') g =<< liftM3 v s' r' c') <*> t |
|
|
|
|
|
|
|
|
|
-- | Synthesize a random 'Transaction', not using a dictionary. |
|
|
|
|
genTx2 :: (MonadRandom m, MonadReader x m, Has TxConf x, MonadState y m, Has World2 y, MonadThrow m) => m Tx2 |
|
|
|
|
genTx2 = view (hasLens . txGas) >>= \g -> genTxWith2 (rElem "sender list") (rElem "recipient list") |
|
|
|
|
(const $ genInteractions2 . snd) (pure g) (\_ _ _ -> pure 0) |
|
|
|
|
genTx2 :: forall m x y. (MonadRandom m, MonadReader x m, Has TxConf x, MonadState y m, Has World2 y, MonadThrow m) => m Tx2 |
|
|
|
|
genTx2 = use (hasLens :: Lens' y World2) >>= evalStateT genTxM2 . (defaultDict2,) |
|
|
|
|
--genTx2 = view (hasLens . txGas) >>= \g -> genTxWith2 (rElem "sender list") (rElem "recipient list") |
|
|
|
|
-- (const $ genInteractions2 . snd) (pure g) (\_ _ _ -> pure 0) |
|
|
|
|
|
|
|
|
|
-- | Generate a random 'Transaction' with either synthesis or mutation of dictionary entries. |
|
|
|
|
genTxM2 :: (MonadRandom m, MonadReader x m, Has TxConf x, MonadState y m, Has GenDict2 y, Has World2 y, MonadThrow m) => m Tx2 |
|
|
|
|
genTxM2 = view (hasLens . txGas) >>= \g -> genTxWith2 (rElem "sender list") (rElem "recipient list") |
|
|
|
|
(const $ genInteractionsM2 . snd) (pure g) (\_ _ _ -> pure 0) |
|
|
|
|
genTxM2 = view hasLens >>= \(TxConf _ g t b) -> genTxWith2 |
|
|
|
|
(rElem "sender list") (rElem "recipient list") -- src and dst |
|
|
|
|
(const $ genInteractionsM2 . snd) -- call itself |
|
|
|
|
(pure g) (\_ _ _ -> pure 0) (level <$> liftM2 (,) (inRange t) (inRange b)) -- gas, value, delay |
|
|
|
|
where inRange hi = w256 . fromIntegral <$> getRandomR (0 :: Integer, fromIntegral hi) |
|
|
|
|
|
|
|
|
|
-- | Check if a 'Transaction' is as \"small\" (simple) as possible (using ad-hoc heuristics). |
|
|
|
|
canShrinkTx2 :: Tx2 -> Bool |
|
|
|
|
canShrinkTx2 (Tx2 (Right _) _ _ _ 0) = False |
|
|
|
|
canShrinkTx2 (Tx2 (Left (_,l)) _ _ _ 0) = any canShrinkAbiValue2 l |
|
|
|
|
canShrinkTx2 _ = True |
|
|
|
|
canShrinkTx2 (Tx2 (Right _) _ _ _ 0 (0, 0)) = False |
|
|
|
|
canShrinkTx2 (Tx2 (Left (_,l)) _ _ _ 0 (0, 0)) = any canShrinkAbiValue2 l |
|
|
|
|
canShrinkTx2 _ = True |
|
|
|
|
|
|
|
|
|
-- | Given a 'Transaction', generate a random \"smaller\" 'Transaction', preserving origin, |
|
|
|
|
-- destination, value, and call signature. |
|
|
|
|
shrinkTx2 :: MonadRandom m => Tx2 -> m Tx2 |
|
|
|
|
shrinkTx2 (Tx2 c s d g (C _ v)) = let c' = either (fmap Left . shrinkAbiCall2) (fmap Right . pure) c in |
|
|
|
|
liftM5 Tx2 c' (pure s) (pure d) (pure g) $ w256 . fromIntegral <$> getRandomR (0 :: Integer, fromIntegral v) |
|
|
|
|
shrinkTx2 (Tx2 c s d g (C _ v) (C _ t, C _ b)) = let |
|
|
|
|
c' = either (fmap Left . shrinkAbiCall2) (fmap Right . pure) c |
|
|
|
|
lower x = w256 . fromIntegral <$> getRandomR (0 :: Integer, fromIntegral x) in |
|
|
|
|
liftM5 Tx2 c' (pure s) (pure d) (pure g) (lower v) <*> fmap level (liftM2 (,) (lower t) (lower b)) |
|
|
|
|
|
|
|
|
|
-- | Given a 'Set' of 'Transaction's, generate a similar 'Transaction' at random. |
|
|
|
|
spliceTxs2 :: (MonadRandom m, MonadReader x m, Has TxConf x, MonadState y m, Has World2 y, MonadThrow m) => Set Tx2 -> m Tx2 |
|
|
|
|
spliceTxs2 ts = let l = S.toList ts; (cs, ss) = unzip $ (\(Tx2 c s _ _ _) -> (c,s)) <$> l in |
|
|
|
|
spliceTxs2 ts = let l = S.toList ts; (cs, ss) = unzip $ (\(Tx2 c s _ _ _ _) -> (c,s)) <$> l in |
|
|
|
|
view (hasLens . txGas) >>= \g -> |
|
|
|
|
genTxWith2 (const . rElem "sender list" $ ss) (rElem "recipient list") |
|
|
|
|
(\_ _ -> mutateAbiCall2 =<< rElem "past calls" (lefts cs)) (pure g) |
|
|
|
|
(\ _ _ (n,_) -> let valOf (Tx2 c _ _ _ v) = if elem n $ c ^? _Left . _1 then v else 0 |
|
|
|
|
(\ _ _ (n,_) -> let valOf (Tx2 c _ _ _ v _) = if elem n $ c ^? _Left . _1 then v else 0 |
|
|
|
|
in rElem "values" $ valOf <$> l) |
|
|
|
|
(pure (0, 0)) |
|
|
|
|
|
|
|
|
|
-- | Lift an action in the context of a component of some 'MonadState' to an action in the |
|
|
|
|
-- 'MonadState' itself. |
|
|
|
|
@ -126,9 +150,10 @@ liftSH = S.state . runState . zoom hasLens |
|
|
|
|
-- | Given a 'Transaction', set up some 'VM' so it can be executed. Effectively, this just brings |
|
|
|
|
-- 'Transaction's \"on-chain\". |
|
|
|
|
setupTx2 :: (MonadState x m, Has VM x) => Tx2 -> m () |
|
|
|
|
setupTx2 (Tx2 c s r g v) = liftSH . sequence_ $ |
|
|
|
|
setupTx2 (Tx2 c s r g v (t, b)) = liftSH . sequence_ $ |
|
|
|
|
[ result .= Nothing, state . pc .= 0, state . stack .= mempty, state . memory .= mempty, state . gas .= g |
|
|
|
|
, tx . origin .= s, state . caller .= s, state . callvalue .= v, setup] where |
|
|
|
|
, tx . origin .= s, state . caller .= s, state . callvalue .= v |
|
|
|
|
, block . timestamp += t, block . number += b, setup] where |
|
|
|
|
setup = case c of |
|
|
|
|
Left cd -> loadContract r >> state . calldata .= encode cd |
|
|
|
|
Right bc -> assign (env . contracts . at r) (Just $ initialContract (RuntimeCode bc) & set balance v) >> loadContract r |
|
|
|
|
|
Will Song
5 years ago