{-# Language PartialTypeSignatures #-}
{-# Language FlexibleInstances #-}
{-# Language ExtendedDefaultRules #-}
{-# Language PatternSynonyms #-}
{-# Language RecordWildCards #-}
{-# Language ScopedTypeVariables #-}
{-# Language ViewPatterns #-}

-- Converts between Ethereum contract states and simple trees of
-- texts.  Dumps and loads such trees as Git repositories (the state
-- gets serialized as commits with folders and files).
--
-- Example state file hierarchy:
--
--   /0123...abc/balance      says "0x500"
--   /0123...abc/code         says "60023429..."
--   /0123...abc/nonce        says "0x3"
--   /0123...abc/storage/0x1  says "0x1"
--   /0123...abc/storage/0x2  says "0x0"
--
-- This format could easily be serialized into any nested record
-- syntax, e.g. JSON.

module EVM.Facts
  ( File (..)
  , Fact (..)
  , Data (..)
  , Path (..)
  , apply
  , applyCache
  , cacheFacts
  , contractFacts
  , vmFacts
  , factToFile
  , fileToFact
  ) where

import EVM          (VM, Contract, Cache)
import EVM.Symbolic (litWord, forceLit)
import EVM          (balance, nonce, storage, bytecode, env, contracts, contract, state, cache, fetched)
import EVM.Types    (Addr, Word, SymWord, Buffer(..))

import qualified EVM

import Prelude hiding (Word)

import Control.Lens    (view, set, at, ix, (&), over, assign)
import Control.Monad.State.Strict (execState, when)
import Data.ByteString (ByteString)
import Data.Ord        (comparing)
import Data.Set        (Set)
import Text.Read       (readMaybe)

import qualified Data.ByteString.Base16 as BS16
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as Char8
import qualified Data.Map as Map
import qualified Data.Set as Set

-- We treat everything as ASCII byte strings because
-- we only use hex digits (and the letter 'x').
type ASCII = ByteString

-- When using string literals, default to infer the ASCII type.
default (ASCII)

-- We use the word "fact" to mean one piece of serializable
-- information about the state.
--
-- Note that Haskell allows this kind of union of records.
-- It's convenient here, but typically avoided.
data Fact
  = BalanceFact { Fact -> Addr
addr :: Addr, Fact -> Word
what :: Word }
  | NonceFact   { addr :: Addr, what :: Word }
  | StorageFact { addr :: Addr, what :: Word, Fact -> Word
which :: Word }
  | CodeFact    { addr :: Addr, Fact -> ByteString
blob :: ByteString }
  deriving (Fact -> Fact -> Bool
(Fact -> Fact -> Bool) -> (Fact -> Fact -> Bool) -> Eq Fact
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Fact -> Fact -> Bool
$c/= :: Fact -> Fact -> Bool
== :: Fact -> Fact -> Bool
$c== :: Fact -> Fact -> Bool
Eq, Int -> Fact -> ShowS
[Fact] -> ShowS
Fact -> String
(Int -> Fact -> ShowS)
-> (Fact -> String) -> ([Fact] -> ShowS) -> Show Fact
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Fact] -> ShowS
$cshowList :: [Fact] -> ShowS
show :: Fact -> String
$cshow :: Fact -> String
showsPrec :: Int -> Fact -> ShowS
$cshowsPrec :: Int -> Fact -> ShowS
Show)

-- A fact path means something like "/0123...abc/storage/0x1",
-- or alternatively "contracts['0123...abc'].storage['0x1']".
data Path = Path [ASCII] ASCII
  deriving (Path -> Path -> Bool
(Path -> Path -> Bool) -> (Path -> Path -> Bool) -> Eq Path
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c== :: Path -> Path -> Bool
Eq, Eq Path
Eq Path
-> (Path -> Path -> Ordering)
-> (Path -> Path -> Bool)
-> (Path -> Path -> Bool)
-> (Path -> Path -> Bool)
-> (Path -> Path -> Bool)
-> (Path -> Path -> Path)
-> (Path -> Path -> Path)
-> Ord Path
Path -> Path -> Bool
Path -> Path -> Ordering
Path -> Path -> Path
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Path -> Path -> Path
$cmin :: Path -> Path -> Path
max :: Path -> Path -> Path
$cmax :: Path -> Path -> Path
>= :: Path -> Path -> Bool
$c>= :: Path -> Path -> Bool
> :: Path -> Path -> Bool
$c> :: Path -> Path -> Bool
<= :: Path -> Path -> Bool
$c<= :: Path -> Path -> Bool
< :: Path -> Path -> Bool
$c< :: Path -> Path -> Bool
compare :: Path -> Path -> Ordering
$ccompare :: Path -> Path -> Ordering
$cp1Ord :: Eq Path
Ord, Int -> Path -> ShowS
[Path] -> ShowS
Path -> String
(Int -> Path -> ShowS)
-> (Path -> String) -> ([Path] -> ShowS) -> Show Path
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Path] -> ShowS
$cshowList :: [Path] -> ShowS
show :: Path -> String
$cshow :: Path -> String
showsPrec :: Int -> Path -> ShowS
$cshowsPrec :: Int -> Path -> ShowS
Show)

-- A fact data is the content of a file.  We encapsulate it
-- with a newtype to make it easier to change the representation
-- (to use bytestrings, some sum type, or whatever).
newtype Data = Data { Data -> ByteString
dataASCII :: ASCII }
  deriving (Data -> Data -> Bool
(Data -> Data -> Bool) -> (Data -> Data -> Bool) -> Eq Data
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Data -> Data -> Bool
$c/= :: Data -> Data -> Bool
== :: Data -> Data -> Bool
$c== :: Data -> Data -> Bool
Eq, Eq Data
Eq Data
-> (Data -> Data -> Ordering)
-> (Data -> Data -> Bool)
-> (Data -> Data -> Bool)
-> (Data -> Data -> Bool)
-> (Data -> Data -> Bool)
-> (Data -> Data -> Data)
-> (Data -> Data -> Data)
-> Ord Data
Data -> Data -> Bool
Data -> Data -> Ordering
Data -> Data -> Data
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Data -> Data -> Data
$cmin :: Data -> Data -> Data
max :: Data -> Data -> Data
$cmax :: Data -> Data -> Data
>= :: Data -> Data -> Bool
$c>= :: Data -> Data -> Bool
> :: Data -> Data -> Bool
$c> :: Data -> Data -> Bool
<= :: Data -> Data -> Bool
$c<= :: Data -> Data -> Bool
< :: Data -> Data -> Bool
$c< :: Data -> Data -> Bool
compare :: Data -> Data -> Ordering
$ccompare :: Data -> Data -> Ordering
$cp1Ord :: Eq Data
Ord, Int -> Data -> ShowS
[Data] -> ShowS
Data -> String
(Int -> Data -> ShowS)
-> (Data -> String) -> ([Data] -> ShowS) -> Show Data
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Data] -> ShowS
$cshowList :: [Data] -> ShowS
show :: Data -> String
$cshow :: Data -> String
showsPrec :: Int -> Data -> ShowS
$cshowsPrec :: Int -> Data -> ShowS
Show)

-- We use the word "file" to denote a serialized value at a path.
data File = File { File -> Path
filePath :: Path, File -> Data
fileData :: Data }
  deriving (File -> File -> Bool
(File -> File -> Bool) -> (File -> File -> Bool) -> Eq File
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: File -> File -> Bool
$c/= :: File -> File -> Bool
== :: File -> File -> Bool
$c== :: File -> File -> Bool
Eq, Eq File
Eq File
-> (File -> File -> Ordering)
-> (File -> File -> Bool)
-> (File -> File -> Bool)
-> (File -> File -> Bool)
-> (File -> File -> Bool)
-> (File -> File -> File)
-> (File -> File -> File)
-> Ord File
File -> File -> Bool
File -> File -> Ordering
File -> File -> File
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: File -> File -> File
$cmin :: File -> File -> File
max :: File -> File -> File
$cmax :: File -> File -> File
>= :: File -> File -> Bool
$c>= :: File -> File -> Bool
> :: File -> File -> Bool
$c> :: File -> File -> Bool
<= :: File -> File -> Bool
$c<= :: File -> File -> Bool
< :: File -> File -> Bool
$c< :: File -> File -> Bool
compare :: File -> File -> Ordering
$ccompare :: File -> File -> Ordering
$cp1Ord :: Eq File
Ord, Int -> File -> ShowS
[File] -> ShowS
File -> String
(Int -> File -> ShowS)
-> (File -> String) -> ([File] -> ShowS) -> Show File
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [File] -> ShowS
$cshowList :: [File] -> ShowS
show :: File -> String
$cshow :: File -> String
showsPrec :: Int -> File -> ShowS
$cshowsPrec :: Int -> File -> ShowS
Show)

class AsASCII a where
  dump :: a -> ASCII
  load :: ASCII -> Maybe a

instance AsASCII Addr where
  dump :: Addr -> ByteString
dump = String -> ByteString
Char8.pack (String -> ByteString) -> (Addr -> String) -> Addr -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Addr -> String
forall a. Show a => a -> String
show
  load :: ByteString -> Maybe Addr
load = String -> Maybe Addr
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Addr)
-> (ByteString -> String) -> ByteString -> Maybe Addr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
Char8.unpack

instance AsASCII Word where
  dump :: Word -> ByteString
dump = String -> ByteString
Char8.pack (String -> ByteString) -> (Word -> String) -> Word -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String
forall a. Show a => a -> String
show
  load :: ByteString -> Maybe Word
load = String -> Maybe Word
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Word)
-> (ByteString -> String) -> ByteString -> Maybe Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
Char8.unpack

instance AsASCII ByteString where
  dump :: ByteString -> ByteString
dump ByteString
x = ByteString -> ByteString
BS16.encode ByteString
x ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"
  load :: ByteString -> Maybe ByteString
load ByteString
x =
    case ByteString -> Either String ByteString
BS16.decode (ByteString -> Either String ByteString)
-> (ByteString -> ByteString)
-> ByteString
-> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
BS.split Word8
10 (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
x of
      Right ByteString
y -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
y
      Either String ByteString
_       -> Maybe ByteString
forall a. Maybe a
Nothing

contractFacts :: Addr -> Contract -> [Fact]
contractFacts :: Addr -> Contract -> [Fact]
contractFacts Addr
a Contract
x = case Getting Buffer Contract Buffer -> Contract -> Buffer
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Buffer Contract Buffer
Getter Contract Buffer
bytecode Contract
x of
  ConcreteBuffer ByteString
b ->
    Addr -> Contract -> [Fact]
storageFacts Addr
a Contract
x [Fact] -> [Fact] -> [Fact]
forall a. [a] -> [a] -> [a]
++
    [ Addr -> Word -> Fact
BalanceFact Addr
a (Getting Word Contract Word -> Contract -> Word
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Word Contract Word
Lens' Contract Word
balance Contract
x)
    , Addr -> Word -> Fact
NonceFact   Addr
a (Getting Word Contract Word -> Contract -> Word
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Word Contract Word
Lens' Contract Word
nonce Contract
x)
    , Addr -> ByteString -> Fact
CodeFact    Addr
a ByteString
b
    ]
  SymbolicBuffer [SWord 8]
_ ->
    -- here simply ignore storing the bytecode
    Addr -> Contract -> [Fact]
storageFacts Addr
a Contract
x [Fact] -> [Fact] -> [Fact]
forall a. [a] -> [a] -> [a]
++
    [ Addr -> Word -> Fact
BalanceFact Addr
a (Getting Word Contract Word -> Contract -> Word
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Word Contract Word
Lens' Contract Word
balance Contract
x)
    , Addr -> Word -> Fact
NonceFact   Addr
a (Getting Word Contract Word -> Contract -> Word
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Word Contract Word
Lens' Contract Word
nonce Contract
x)
    ]


storageFacts :: Addr -> Contract -> [Fact]
storageFacts :: Addr -> Contract -> [Fact]
storageFacts Addr
a Contract
x = case Getting Storage Contract Storage -> Contract -> Storage
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Storage Contract Storage
Lens' Contract Storage
storage Contract
x of
  EVM.Symbolic [(SymWord, SymWord)]
_ SArray (WordN 256) (WordN 256)
_ -> []
  EVM.Concrete Map Word SymWord
s -> ((Word, SymWord) -> Fact) -> [(Word, SymWord)] -> [Fact]
forall a b. (a -> b) -> [a] -> [b]
map (Word, SymWord) -> Fact
f (Map Word SymWord -> [(Word, SymWord)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Word SymWord
s)
  where
    f :: (Word, SymWord) -> Fact
    f :: (Word, SymWord) -> Fact
f (Word
k, SymWord
v) = StorageFact :: Addr -> Word -> Word -> Fact
StorageFact
      { addr :: Addr
addr  = Addr
a
      , what :: Word
what  = Word -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SymWord -> Word
forceLit SymWord
v)
      , which :: Word
which = Word -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
k
      }

cacheFacts :: Cache -> Set Fact
cacheFacts :: Cache -> Set Fact
cacheFacts Cache
c = [Fact] -> Set Fact
forall a. Ord a => [a] -> Set a
Set.fromList ([Fact] -> Set Fact) -> [Fact] -> Set Fact
forall a b. (a -> b) -> a -> b
$ do
  (Addr
k, Contract
v) <- Map Addr Contract -> [(Addr, Contract)]
forall k a. Map k a -> [(k, a)]
Map.toList (Getting (Map Addr Contract) Cache (Map Addr Contract)
-> Cache -> Map Addr Contract
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Addr Contract) Cache (Map Addr Contract)
Lens' Cache (Map Addr Contract)
EVM.fetched Cache
c)
  Addr -> Contract -> [Fact]
contractFacts Addr
k Contract
v

vmFacts :: VM -> Set Fact
vmFacts :: VM -> Set Fact
vmFacts VM
vm = [Fact] -> Set Fact
forall a. Ord a => [a] -> Set a
Set.fromList ([Fact] -> Set Fact) -> [Fact] -> Set Fact
forall a b. (a -> b) -> a -> b
$ do
  (Addr
k, Contract
v) <- Map Addr Contract -> [(Addr, Contract)]
forall k a. Map k a -> [(k, a)]
Map.toList (Getting (Map Addr Contract) VM (Map Addr Contract)
-> VM -> Map Addr Contract
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Env -> Const (Map Addr Contract) Env)
-> VM -> Const (Map Addr Contract) VM
Lens' VM Env
env ((Env -> Const (Map Addr Contract) Env)
 -> VM -> Const (Map Addr Contract) VM)
-> ((Map Addr Contract
     -> Const (Map Addr Contract) (Map Addr Contract))
    -> Env -> Const (Map Addr Contract) Env)
-> Getting (Map Addr Contract) VM (Map Addr Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract
 -> Const (Map Addr Contract) (Map Addr Contract))
-> Env -> Const (Map Addr Contract) Env
Lens' Env (Map Addr Contract)
contracts) VM
vm)
  Addr -> Contract -> [Fact]
contractFacts Addr
k Contract
v

-- Somewhat stupidly, this function demands that for each contract,
-- the code fact for that contract comes before the other facts for
-- that contract.  This is an incidental thing because right now we
-- always initialize contracts starting with the code (to calculate
-- the code hash and so on).
--
-- Therefore, we need to make sure to sort the fact set in such a way.
apply1 :: VM -> Fact -> VM
apply1 :: VM -> Fact -> VM
apply1 VM
vm Fact
fact =
  case Fact
fact of
    CodeFact    {ByteString
Addr
blob :: ByteString
addr :: Addr
blob :: Fact -> ByteString
addr :: Fact -> Addr
..} -> (State VM () -> VM -> VM) -> VM -> State VM () -> VM
forall a b c. (a -> b -> c) -> b -> a -> c
flip State VM () -> VM -> VM
forall s a. State s a -> s -> s
execState VM
vm (State VM () -> VM) -> State VM () -> VM
forall a b. (a -> b) -> a -> b
$ do
      ASetter VM VM (Maybe Contract) (Maybe Contract)
-> Maybe Contract -> State VM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ((Env -> Identity Env) -> VM -> Identity VM
Lens' VM Env
env ((Env -> Identity Env) -> VM -> Identity VM)
-> ((Maybe Contract -> Identity (Maybe Contract))
    -> Env -> Identity Env)
-> ASetter VM VM (Maybe Contract) (Maybe Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Identity (Map Addr Contract))
-> Env -> Identity Env
Lens' Env (Map Addr Contract)
contracts ((Map Addr Contract -> Identity (Map Addr Contract))
 -> Env -> Identity Env)
-> ((Maybe Contract -> Identity (Maybe Contract))
    -> Map Addr Contract -> Identity (Map Addr Contract))
-> (Maybe Contract -> Identity (Maybe Contract))
-> Env
-> Identity Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Addr Contract)
-> Lens' (Map Addr Contract) (Maybe (IxValue (Map Addr Contract)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Addr Contract)
Addr
addr) (Contract -> Maybe Contract
forall a. a -> Maybe a
Just (ContractCode -> Contract
EVM.initialContract (Buffer -> ContractCode
EVM.RuntimeCode (ByteString -> Buffer
ConcreteBuffer ByteString
blob))))
      Bool -> State VM () -> State VM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Getting Addr VM Addr -> VM -> Addr
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((FrameState -> Const Addr FrameState) -> VM -> Const Addr VM
Lens' VM FrameState
state ((FrameState -> Const Addr FrameState) -> VM -> Const Addr VM)
-> ((Addr -> Const Addr Addr)
    -> FrameState -> Const Addr FrameState)
-> Getting Addr VM Addr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Addr -> Const Addr Addr) -> FrameState -> Const Addr FrameState
Lens' FrameState Addr
contract) VM
vm Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
addr) (State VM () -> State VM ()) -> State VM () -> State VM ()
forall a b. (a -> b) -> a -> b
$ Addr -> State VM ()
EVM.loadContract Addr
addr
    StorageFact {Addr
Word
which :: Word
what :: Word
addr :: Addr
which :: Fact -> Word
what :: Fact -> Word
addr :: Fact -> Addr
..} ->
      VM
vm VM -> (VM -> VM) -> VM
forall a b. a -> (a -> b) -> b
& ASetter VM VM Storage Storage -> (Storage -> Storage) -> VM -> VM
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Env -> Identity Env) -> VM -> Identity VM
Lens' VM Env
env ((Env -> Identity Env) -> VM -> Identity VM)
-> ((Storage -> Identity Storage) -> Env -> Identity Env)
-> ASetter VM VM Storage Storage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Identity (Map Addr Contract))
-> Env -> Identity Env
Lens' Env (Map Addr Contract)
contracts ((Map Addr Contract -> Identity (Map Addr Contract))
 -> Env -> Identity Env)
-> ((Storage -> Identity Storage)
    -> Map Addr Contract -> Identity (Map Addr Contract))
-> (Storage -> Identity Storage)
-> Env
-> Identity Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Addr Contract)
-> Traversal' (Map Addr Contract) (IxValue (Map Addr Contract))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map Addr Contract)
Addr
addr ((Contract -> Identity Contract)
 -> Map Addr Contract -> Identity (Map Addr Contract))
-> ((Storage -> Identity Storage) -> Contract -> Identity Contract)
-> (Storage -> Identity Storage)
-> Map Addr Contract
-> Identity (Map Addr Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Storage -> Identity Storage) -> Contract -> Identity Contract
Lens' Contract Storage
storage) (SymWord -> SymWord -> Storage -> Storage
EVM.writeStorage (Word -> SymWord
litWord Word
which) (Word -> SymWord
litWord Word
what))
    BalanceFact {Addr
Word
what :: Word
addr :: Addr
what :: Fact -> Word
addr :: Fact -> Addr
..} ->
      VM
vm VM -> (VM -> VM) -> VM
forall a b. a -> (a -> b) -> b
& ASetter VM VM Word Word -> Word -> VM -> VM
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Env -> Identity Env) -> VM -> Identity VM
Lens' VM Env
env ((Env -> Identity Env) -> VM -> Identity VM)
-> ((Word -> Identity Word) -> Env -> Identity Env)
-> ASetter VM VM Word Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Identity (Map Addr Contract))
-> Env -> Identity Env
Lens' Env (Map Addr Contract)
contracts ((Map Addr Contract -> Identity (Map Addr Contract))
 -> Env -> Identity Env)
-> ((Word -> Identity Word)
    -> Map Addr Contract -> Identity (Map Addr Contract))
-> (Word -> Identity Word)
-> Env
-> Identity Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Addr Contract)
-> Traversal' (Map Addr Contract) (IxValue (Map Addr Contract))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map Addr Contract)
Addr
addr ((Contract -> Identity Contract)
 -> Map Addr Contract -> Identity (Map Addr Contract))
-> ((Word -> Identity Word) -> Contract -> Identity Contract)
-> (Word -> Identity Word)
-> Map Addr Contract
-> Identity (Map Addr Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word -> Identity Word) -> Contract -> Identity Contract
Lens' Contract Word
balance) Word
what
    NonceFact   {Addr
Word
what :: Word
addr :: Addr
what :: Fact -> Word
addr :: Fact -> Addr
..} ->
      VM
vm VM -> (VM -> VM) -> VM
forall a b. a -> (a -> b) -> b
& ASetter VM VM Word Word -> Word -> VM -> VM
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Env -> Identity Env) -> VM -> Identity VM
Lens' VM Env
env ((Env -> Identity Env) -> VM -> Identity VM)
-> ((Word -> Identity Word) -> Env -> Identity Env)
-> ASetter VM VM Word Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Identity (Map Addr Contract))
-> Env -> Identity Env
Lens' Env (Map Addr Contract)
contracts ((Map Addr Contract -> Identity (Map Addr Contract))
 -> Env -> Identity Env)
-> ((Word -> Identity Word)
    -> Map Addr Contract -> Identity (Map Addr Contract))
-> (Word -> Identity Word)
-> Env
-> Identity Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Addr Contract)
-> Traversal' (Map Addr Contract) (IxValue (Map Addr Contract))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map Addr Contract)
Addr
addr ((Contract -> Identity Contract)
 -> Map Addr Contract -> Identity (Map Addr Contract))
-> ((Word -> Identity Word) -> Contract -> Identity Contract)
-> (Word -> Identity Word)
-> Map Addr Contract
-> Identity (Map Addr Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word -> Identity Word) -> Contract -> Identity Contract
Lens' Contract Word
nonce) Word
what

apply2 :: VM -> Fact -> VM
apply2 :: VM -> Fact -> VM
apply2 VM
vm Fact
fact =
  case Fact
fact of
    CodeFact    {ByteString
Addr
blob :: ByteString
addr :: Addr
blob :: Fact -> ByteString
addr :: Fact -> Addr
..} -> (State VM () -> VM -> VM) -> VM -> State VM () -> VM
forall a b c. (a -> b -> c) -> b -> a -> c
flip State VM () -> VM -> VM
forall s a. State s a -> s -> s
execState VM
vm (State VM () -> VM) -> State VM () -> VM
forall a b. (a -> b) -> a -> b
$ do
      ASetter VM VM (Maybe Contract) (Maybe Contract)
-> Maybe Contract -> State VM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ((Cache -> Identity Cache) -> VM -> Identity VM
Lens' VM Cache
cache ((Cache -> Identity Cache) -> VM -> Identity VM)
-> ((Maybe Contract -> Identity (Maybe Contract))
    -> Cache -> Identity Cache)
-> ASetter VM VM (Maybe Contract) (Maybe Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Identity (Map Addr Contract))
-> Cache -> Identity Cache
Lens' Cache (Map Addr Contract)
fetched ((Map Addr Contract -> Identity (Map Addr Contract))
 -> Cache -> Identity Cache)
-> ((Maybe Contract -> Identity (Maybe Contract))
    -> Map Addr Contract -> Identity (Map Addr Contract))
-> (Maybe Contract -> Identity (Maybe Contract))
-> Cache
-> Identity Cache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Addr Contract)
-> Lens' (Map Addr Contract) (Maybe (IxValue (Map Addr Contract)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Addr Contract)
Addr
addr) (Contract -> Maybe Contract
forall a. a -> Maybe a
Just (ContractCode -> Contract
EVM.initialContract (Buffer -> ContractCode
EVM.RuntimeCode (ByteString -> Buffer
ConcreteBuffer ByteString
blob))))
      Bool -> State VM () -> State VM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Getting Addr VM Addr -> VM -> Addr
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((FrameState -> Const Addr FrameState) -> VM -> Const Addr VM
Lens' VM FrameState
state ((FrameState -> Const Addr FrameState) -> VM -> Const Addr VM)
-> ((Addr -> Const Addr Addr)
    -> FrameState -> Const Addr FrameState)
-> Getting Addr VM Addr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Addr -> Const Addr Addr) -> FrameState -> Const Addr FrameState
Lens' FrameState Addr
contract) VM
vm Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
addr) (State VM () -> State VM ()) -> State VM () -> State VM ()
forall a b. (a -> b) -> a -> b
$ Addr -> State VM ()
EVM.loadContract Addr
addr
    StorageFact {Addr
Word
which :: Word
what :: Word
addr :: Addr
which :: Fact -> Word
what :: Fact -> Word
addr :: Fact -> Addr
..} ->
      VM
vm VM -> (VM -> VM) -> VM
forall a b. a -> (a -> b) -> b
& ASetter VM VM Storage Storage -> (Storage -> Storage) -> VM -> VM
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Cache -> Identity Cache) -> VM -> Identity VM
Lens' VM Cache
cache ((Cache -> Identity Cache) -> VM -> Identity VM)
-> ((Storage -> Identity Storage) -> Cache -> Identity Cache)
-> ASetter VM VM Storage Storage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Identity (Map Addr Contract))
-> Cache -> Identity Cache
Lens' Cache (Map Addr Contract)
fetched ((Map Addr Contract -> Identity (Map Addr Contract))
 -> Cache -> Identity Cache)
-> ((Storage -> Identity Storage)
    -> Map Addr Contract -> Identity (Map Addr Contract))
-> (Storage -> Identity Storage)
-> Cache
-> Identity Cache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Addr Contract)
-> Traversal' (Map Addr Contract) (IxValue (Map Addr Contract))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map Addr Contract)
Addr
addr ((Contract -> Identity Contract)
 -> Map Addr Contract -> Identity (Map Addr Contract))
-> ((Storage -> Identity Storage) -> Contract -> Identity Contract)
-> (Storage -> Identity Storage)
-> Map Addr Contract
-> Identity (Map Addr Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Storage -> Identity Storage) -> Contract -> Identity Contract
Lens' Contract Storage
storage) (SymWord -> SymWord -> Storage -> Storage
EVM.writeStorage (Word -> SymWord
litWord Word
which) (Word -> SymWord
litWord Word
what))
    BalanceFact {Addr
Word
what :: Word
addr :: Addr
what :: Fact -> Word
addr :: Fact -> Addr
..} ->
      VM
vm VM -> (VM -> VM) -> VM
forall a b. a -> (a -> b) -> b
& ASetter VM VM Word Word -> Word -> VM -> VM
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Cache -> Identity Cache) -> VM -> Identity VM
Lens' VM Cache
cache ((Cache -> Identity Cache) -> VM -> Identity VM)
-> ((Word -> Identity Word) -> Cache -> Identity Cache)
-> ASetter VM VM Word Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Identity (Map Addr Contract))
-> Cache -> Identity Cache
Lens' Cache (Map Addr Contract)
fetched ((Map Addr Contract -> Identity (Map Addr Contract))
 -> Cache -> Identity Cache)
-> ((Word -> Identity Word)
    -> Map Addr Contract -> Identity (Map Addr Contract))
-> (Word -> Identity Word)
-> Cache
-> Identity Cache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Addr Contract)
-> Traversal' (Map Addr Contract) (IxValue (Map Addr Contract))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map Addr Contract)
Addr
addr ((Contract -> Identity Contract)
 -> Map Addr Contract -> Identity (Map Addr Contract))
-> ((Word -> Identity Word) -> Contract -> Identity Contract)
-> (Word -> Identity Word)
-> Map Addr Contract
-> Identity (Map Addr Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word -> Identity Word) -> Contract -> Identity Contract
Lens' Contract Word
balance) Word
what
    NonceFact   {Addr
Word
what :: Word
addr :: Addr
what :: Fact -> Word
addr :: Fact -> Addr
..} ->
      VM
vm VM -> (VM -> VM) -> VM
forall a b. a -> (a -> b) -> b
& ASetter VM VM Word Word -> Word -> VM -> VM
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Cache -> Identity Cache) -> VM -> Identity VM
Lens' VM Cache
cache ((Cache -> Identity Cache) -> VM -> Identity VM)
-> ((Word -> Identity Word) -> Cache -> Identity Cache)
-> ASetter VM VM Word Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Identity (Map Addr Contract))
-> Cache -> Identity Cache
Lens' Cache (Map Addr Contract)
fetched ((Map Addr Contract -> Identity (Map Addr Contract))
 -> Cache -> Identity Cache)
-> ((Word -> Identity Word)
    -> Map Addr Contract -> Identity (Map Addr Contract))
-> (Word -> Identity Word)
-> Cache
-> Identity Cache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Addr Contract)
-> Traversal' (Map Addr Contract) (IxValue (Map Addr Contract))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map Addr Contract)
Addr
addr ((Contract -> Identity Contract)
 -> Map Addr Contract -> Identity (Map Addr Contract))
-> ((Word -> Identity Word) -> Contract -> Identity Contract)
-> (Word -> Identity Word)
-> Map Addr Contract
-> Identity (Map Addr Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word -> Identity Word) -> Contract -> Identity Contract
Lens' Contract Word
nonce) Word
what

-- Sort facts in the right order for `apply1` to work.
instance Ord Fact where
  compare :: Fact -> Fact -> Ordering
compare = (Fact -> (Int, Addr, Word)) -> Fact -> Fact -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Fact -> (Int, Addr, Word)
f
    where
    f :: Fact -> (Int, Addr, Word)
    f :: Fact -> (Int, Addr, Word)
f (CodeFact Addr
a ByteString
_)      = (Int
0, Addr
a, Word
0)
    f (BalanceFact Addr
a Word
_)   = (Int
1, Addr
a, Word
0)
    f (NonceFact Addr
a Word
_)     = (Int
2, Addr
a, Word
0)
    f (StorageFact Addr
a Word
_ Word
x) = (Int
3, Addr
a, Word
x)

-- Applies a set of facts to a VM.
apply :: VM -> Set Fact -> VM
apply :: VM -> Set Fact -> VM
apply =
  -- The set's ordering is relevant; see `apply1`.
  (VM -> Fact -> VM) -> VM -> Set Fact -> VM
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl VM -> Fact -> VM
apply1
--
-- Applies a set of facts to a VM.
applyCache :: VM -> Set Fact -> VM
applyCache :: VM -> Set Fact -> VM
applyCache =
  -- The set's ordering is relevant; see `apply1`.
  (VM -> Fact -> VM) -> VM -> Set Fact -> VM
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl VM -> Fact -> VM
apply2

factToFile :: Fact -> File
factToFile :: Fact -> File
factToFile Fact
fact = case Fact
fact of
  StorageFact {Addr
Word
which :: Word
what :: Word
addr :: Addr
which :: Fact -> Word
what :: Fact -> Word
addr :: Fact -> Addr
..} -> [ByteString] -> ByteString -> Word -> File
forall a. AsASCII a => [ByteString] -> ByteString -> a -> File
mk [ByteString
"storage"] (Word -> ByteString
forall a. AsASCII a => a -> ByteString
dump Word
which) Word
what
  BalanceFact {Addr
Word
what :: Word
addr :: Addr
what :: Fact -> Word
addr :: Fact -> Addr
..} -> [ByteString] -> ByteString -> Word -> File
forall a. AsASCII a => [ByteString] -> ByteString -> a -> File
mk []          ByteString
"balance"    Word
what
  NonceFact   {Addr
Word
what :: Word
addr :: Addr
what :: Fact -> Word
addr :: Fact -> Addr
..} -> [ByteString] -> ByteString -> Word -> File
forall a. AsASCII a => [ByteString] -> ByteString -> a -> File
mk []          ByteString
"nonce"      Word
what
  CodeFact    {ByteString
Addr
blob :: ByteString
addr :: Addr
blob :: Fact -> ByteString
addr :: Fact -> Addr
..} -> [ByteString] -> ByteString -> ByteString -> File
forall a. AsASCII a => [ByteString] -> ByteString -> a -> File
mk []          ByteString
"code"       ByteString
blob
  where
    mk :: AsASCII a => [ASCII] -> ASCII -> a -> File
    mk :: [ByteString] -> ByteString -> a -> File
mk [ByteString]
prefix ByteString
base a
a =
      Path -> Data -> File
File ([ByteString] -> ByteString -> Path
Path (Addr -> ByteString
forall a. AsASCII a => a -> ByteString
dump (Fact -> Addr
addr Fact
fact) ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
prefix) ByteString
base)
           (ByteString -> Data
Data (ByteString -> Data) -> ByteString -> Data
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. AsASCII a => a -> ByteString
dump a
a)

-- This lets us easier pattern match on serialized things.
-- Uses language extensions: `PatternSynonyms` and `ViewPatterns`.
pattern Load :: AsASCII a => a -> ASCII
pattern $mLoad :: forall r a.
AsASCII a =>
ByteString -> (a -> r) -> (Void# -> r) -> r
Load x <- (load -> Just x)

fileToFact :: File -> Maybe Fact
fileToFact :: File -> Maybe Fact
fileToFact = \case
  File (Path [Load Addr
a] ByteString
"code")    (Data (Load ByteString
x))
    -> Fact -> Maybe Fact
forall a. a -> Maybe a
Just (Addr -> ByteString -> Fact
CodeFact Addr
a ByteString
x)
  File (Path [Load Addr
a] ByteString
"balance") (Data (Load Word
x))
    -> Fact -> Maybe Fact
forall a. a -> Maybe a
Just (Addr -> Word -> Fact
BalanceFact Addr
a Word
x)
  File (Path [Load Addr
a] ByteString
"nonce")   (Data (Load Word
x))
    -> Fact -> Maybe Fact
forall a. a -> Maybe a
Just (Addr -> Word -> Fact
NonceFact Addr
a Word
x)
  File (Path [Load Addr
a, ByteString
"storage"] (Load Word
x)) (Data (Load Word
y))
    -> Fact -> Maybe Fact
forall a. a -> Maybe a
Just (Addr -> Word -> Word -> Fact
StorageFact Addr
a Word
y Word
x)
  File
_
    -> Maybe Fact
forall a. Maybe a
Nothing