{-# 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 "  "
    /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.Monoid     ((<>))
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  allows this kind of union of records .
-- It's convenient here, but typically avoided.
data Fact
  = BalanceFact { addr :: Addr, what :: Word }
  | NonceFact   { addr :: Addr, what :: Word }
  | StorageFact { addr :: Addr, what :: Word, which :: Word }
  | CodeFact    { addr :: Addr, blob :: ByteString }
  deriving (Eq, Show)

  A fact path means something like " /0123 ... abc / storage/0x1 " ,
-- or alternatively "contracts['0123...abc'].storage['0x1']".
data Path = Path [ASCII] ASCII
  deriving (Eq, Ord, 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 { dataASCII :: ASCII }
  deriving (Eq, Ord, Show)

-- We use the word "file" to denote a serialized value at a path.
data File = File { filePath :: Path, fileData :: Data }
  deriving (Eq, Ord, Show)

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

instance AsASCII Addr where
  dump = Char8.pack . show
  load = readMaybe . Char8.unpack

instance AsASCII Word where
  dump = Char8.pack . show
  load = readMaybe . Char8.unpack

instance AsASCII ByteString where
  dump x = BS16.encode x <> "\n"
  load x =
    case BS16.decode . mconcat . BS.split 10 $ x of
      Right y -> Just y
      _       -> Nothing

contractFacts :: Addr -> Contract -> [Fact]
contractFacts a x = case view bytecode x of
  ConcreteBuffer b ->
    storageFacts a x ++
    [ BalanceFact a (view balance x)
    , NonceFact   a (view nonce x)
    , CodeFact    a b
    ]
  SymbolicBuffer b ->
    -- here simply ignore storing the bytecode
    storageFacts a x ++
    [ BalanceFact a (view balance x)
    , NonceFact   a (view nonce x)
    ]


storageFacts :: Addr -> Contract -> [Fact]
storageFacts a x = case view storage x of
  EVM.Symbolic _ _ -> []
  EVM.Concrete s -> map f (Map.toList s)
  where
    f :: (Word, SymWord) -> Fact
    f (k, v) = StorageFact
      { addr  = a
      , what  = fromIntegral (forceLit v)
      , which = fromIntegral k
      }

cacheFacts :: Cache -> Set Fact
cacheFacts c = Set.fromList $ do
  (k, v) <- Map.toList (view EVM.fetched c)
  contractFacts k v

vmFacts :: VM -> Set Fact
vmFacts vm = Set.fromList $ do
  (k, v) <- Map.toList (view (env . contracts) vm)
  contractFacts k 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 =
  case fact of
    CodeFact    {..} -> flip execState vm $ do
      assign (env . contracts . at addr) (Just (EVM.initialContract (EVM.RuntimeCode (ConcreteBuffer blob))))
      when (view (state . contract) vm == addr) $ EVM.loadContract addr
    StorageFact {..} ->
      vm & over (env . contracts . ix addr . storage) (EVM.writeStorage (litWord which) (litWord what))
    BalanceFact {..} ->
      vm & set (env . contracts . ix addr . balance) what
    NonceFact   {..} ->
      vm & set (env . contracts . ix addr . nonce) what

apply2 :: VM -> Fact -> VM
apply2 vm fact =
  case fact of
    CodeFact    {..} -> flip execState vm $ do
      assign (cache . fetched . at addr) (Just (EVM.initialContract (EVM.RuntimeCode (ConcreteBuffer blob))))
      when (view (state . contract) vm == addr) $ EVM.loadContract addr
    StorageFact {..} ->
      vm & over (cache . fetched . ix addr . storage) (EVM.writeStorage (litWord which) (litWord what))
    BalanceFact {..} ->
      vm & set (cache . fetched . ix addr . balance) what
    NonceFact   {..} ->
      vm & set (cache . fetched . ix addr . nonce) what

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

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

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

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

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

# Language PartialTypeSignatures #
# Language FlexibleInstances #
# Language ExtendedDefaultRules #
# Language PatternSynonyms #
# Language ScopedTypeVariables #
# Language ViewPatterns #
 texts.  Dumps and loads such trees as Git repositories (the state
 gets serialized as commits with folders and files).

 Example state file hierarchy:


 This format could easily be serialized into any nested record
 syntax, e.g. JSON.
 We treat everything as ASCII byte strings because
 we only use hex digits (and the letter 'x').
 When using string literals, default to infer the ASCII type.
 information about the state.

 It's convenient here, but typically avoided.
 or alternatively "contracts['0123...abc'].storage['0x1']".
 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).
 We use the word "file" to denote a serialized value at a path.
 here simply ignore storing the bytecode
 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.
 Applies a set of facts to a VM.

 Applies a set of facts to a VM.
 This lets us easier pattern match on serialized things.
# Language RecordWildCards #

  Converts between Ethereum contract states and simple trees of
    /0123 ... abc / balance       says " 0x500 "
    /0123 ... abc / code          says " 60023429 ... "
    /0123 ... abc / nonce         says " 0x3 "
    /0123 ... abc / storage/0x1   says "  "
    /0123 ... abc / storage/0x2   says " 0x0 "

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.Monoid     ((<>))
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

type ASCII = ByteString

default (ASCII)

  We use the word " fact " to mean one piece of serializable
  Note that  allows this kind of union of records .
data Fact
  = BalanceFact { addr :: Addr, what :: Word }
  | NonceFact   { addr :: Addr, what :: Word }
  | StorageFact { addr :: Addr, what :: Word, which :: Word }
  | CodeFact    { addr :: Addr, blob :: ByteString }
  deriving (Eq, Show)

  A fact path means something like " /0123 ... abc / storage/0x1 " ,
data Path = Path [ASCII] ASCII
  deriving (Eq, Ord, Show)

newtype Data = Data { dataASCII :: ASCII }
  deriving (Eq, Ord, Show)

data File = File { filePath :: Path, fileData :: Data }
  deriving (Eq, Ord, Show)

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

instance AsASCII Addr where
  dump = Char8.pack . show
  load = readMaybe . Char8.unpack

instance AsASCII Word where
  dump = Char8.pack . show
  load = readMaybe . Char8.unpack

instance AsASCII ByteString where
  dump x = BS16.encode x <> "\n"
  load x =
    case BS16.decode . mconcat . BS.split 10 $ x of
      Right y -> Just y
      _       -> Nothing

contractFacts :: Addr -> Contract -> [Fact]
contractFacts a x = case view bytecode x of
  ConcreteBuffer b ->
    storageFacts a x ++
    [ BalanceFact a (view balance x)
    , NonceFact   a (view nonce x)
    , CodeFact    a b
    ]
  SymbolicBuffer b ->
    storageFacts a x ++
    [ BalanceFact a (view balance x)
    , NonceFact   a (view nonce x)
    ]


storageFacts :: Addr -> Contract -> [Fact]
storageFacts a x = case view storage x of
  EVM.Symbolic _ _ -> []
  EVM.Concrete s -> map f (Map.toList s)
  where
    f :: (Word, SymWord) -> Fact
    f (k, v) = StorageFact
      { addr  = a
      , what  = fromIntegral (forceLit v)
      , which = fromIntegral k
      }

cacheFacts :: Cache -> Set Fact
cacheFacts c = Set.fromList $ do
  (k, v) <- Map.toList (view EVM.fetched c)
  contractFacts k v

vmFacts :: VM -> Set Fact
vmFacts vm = Set.fromList $ do
  (k, v) <- Map.toList (view (env . contracts) vm)
  contractFacts k v

apply1 :: VM -> Fact -> VM
apply1 vm fact =
  case fact of
    CodeFact    {..} -> flip execState vm $ do
      assign (env . contracts . at addr) (Just (EVM.initialContract (EVM.RuntimeCode (ConcreteBuffer blob))))
      when (view (state . contract) vm == addr) $ EVM.loadContract addr
    StorageFact {..} ->
      vm & over (env . contracts . ix addr . storage) (EVM.writeStorage (litWord which) (litWord what))
    BalanceFact {..} ->
      vm & set (env . contracts . ix addr . balance) what
    NonceFact   {..} ->
      vm & set (env . contracts . ix addr . nonce) what

apply2 :: VM -> Fact -> VM
apply2 vm fact =
  case fact of
    CodeFact    {..} -> flip execState vm $ do
      assign (cache . fetched . at addr) (Just (EVM.initialContract (EVM.RuntimeCode (ConcreteBuffer blob))))
      when (view (state . contract) vm == addr) $ EVM.loadContract addr
    StorageFact {..} ->
      vm & over (cache . fetched . ix addr . storage) (EVM.writeStorage (litWord which) (litWord what))
    BalanceFact {..} ->
      vm & set (cache . fetched . ix addr . balance) what
    NonceFact   {..} ->
      vm & set (cache . fetched . ix addr . nonce) what

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

apply :: VM -> Set Fact -> VM
apply =
  The set 's ordering is relevant ; see ` apply1 ` .
  foldl apply1
applyCache :: VM -> Set Fact -> VM
applyCache =
  The set 's ordering is relevant ; see ` apply1 ` .
  foldl apply2

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

  Uses language extensions : ` PatternSynonyms ` and ` ViewPatterns ` .
pattern Load :: AsASCII a => a -> ASCII
pattern Load x <- (load -> Just x)

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