# LANGUAGE ScopedTypeVariables #
# LANGUAGE FlexibleContexts #
# LANGUAGE FlexibleInstances #
# LANGUAGE DeriveGeneric #
  | Supports the go - ethereum and cpp - ethereum json test cases , either as an HSpec or a report in IO .
module JSONSpec where

import qualified Data.Map.Strict as M
import Masala.Word
import Masala.Instruction hiding (Spec,spec)
import Masala.Ext.Simple
import Masala.VM
import Masala.VM.Types
import Masala.RPC
import Data.Aeson hiding ((.=),Success)
import Data.Aeson.Types hiding (parse,Success)
import GHC.Generics
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Vector as V
import Data.Maybe
import Prelude hiding (words)
import qualified Data.Set as S
import Control.Exception
import Control.Monad
import Test.Hspec
import System.Directory



data TestResult =
          Success { tname :: String }
        | Failure { tname :: String,
                    ttest :: VMTest,
                    tout :: (VMResult,VMState,ExtData),
                    terr :: String }
        | Err { tname :: String, terr :: String }
instance Show TestResult where
    show (Success n) = "SUCCESS: " ++ n
    show (Err n e) = "ERROR: " ++ n ++ ": " ++ e
    show (Failure n _t _o e) = "FAILURE: " ++ n ++ ": " ++ e

-- | Runs all files in "testfiles" dir.
spec :: Spec
spec = do
  tfs <- runIO (filter ((".json" ==).reverse.take 5.reverse) <$> getDirectoryContents "testfiles")
  mapM_ (parallel.fileSpec) tfs


  | Run a json file in HSpec .
fileSpec :: FilePath -> Spec
fileSpec tf =
    describe tf $ do
      vts <- runIO $ readVMTests tf
      forM_ (M.toList vts) $ \(n,vt) ->
                  do
                    tr <- runIO $ runTest False n vt
                    let success = return () :: Expectation
                    case tr of
                      (Success sn) -> it sn success
                      r -> case vskip vt of
                             Just reason -> it (n ++ " [UNSUPPORTED, " ++ reason ++ "]: " ++ show r) success
                             Nothing -> it n $ expectationFailure (show r)

-- | run test file with optional debug out
runFile :: Bool -> FilePath -> IO [TestResult]
runFile d f = readVMTests f >>= mapM (uncurry (runTest d)) . M.toList


  | run one test with debug output
runOne :: FilePath -> String -> IO TestResult
runOne f t = do
  m <- readVMTests f
  case M.lookup t m of
    Nothing -> return $ Err t $ "Unknown test, file " ++ f
    Just tc -> do
               r <- runTest True t tc
               case r of
                 Failure{} -> putStrLn $ "Failure, testcase: " ++ show tc
                 _ -> return ()
               return r



-- | parse JSON
readVMTests :: FilePath -> IO (M.Map String VMTest)
readVMTests f = LBS.readFile ("testfiles/" ++ f) >>= either bad return . eitherDecode
    where bad err = throwIO $ userError $ "ERROR: decode failed: " ++ f ++ ": " ++ err

-- | execute VM test
runTest :: Bool -> String -> VMTest -> IO TestResult
runTest dbg t tc = do
  when dbg $ do
    putStrLn "-----------------"
    putStrLn t
    putStrLn "-----------------"
  let catcher :: SomeException -> IO (Either String (VMResult,VMState,ExtData))
      catcher e = return $ Left $ "Runtime exception: " ++ show e
  r <- catch (runVMTest dbg t tc) catcher
  case r of
    Left e -> if isNothing (vpost tc) && isNothing (vout tc)
              then return $ Success (t ++ " [with failure: " ++ e ++ "]")
              else return $ Err t $ "Runtime failure: " ++ e
    Right o -> do
           let tr = validateRun t tc o
           when dbg $ print tr
           return tr

  : :    ExtData 
 actionSuicides ed = over edAccts ( M.filterWithKey isSuicide ) ed 
     where isSuicide a _ = not $ a ` S.member ` ( view edSuicides ed ) 

actionSuicides :: ExtData -> ExtData
actionSuicides ed = over edAccts (M.filterWithKey isSuicide) ed
    where isSuicide a _ = not $ a `S.member` (view edSuicides ed)
-}

validateRun :: String -> VMTest -> (VMResult,VMState,ExtData) -> TestResult
validateRun n t o@(vr,_vs,ed) = either (Failure n t o) (const (Success n)) check
    where check = checkPost (vpost t) >> checkOutput (vout t)
          checkPost Nothing = Right ()
          checkPost (Just ts) = assertPostAcctsMatch (M.mapWithKey toEacct (testAccts ts)) (_edAccts ed)
          checkOutput Nothing = Right ()
          checkOutput (Just ws) =
              case vr of
                Final os -> assertEqual "output matches" (getWords ws) os
                r -> Left $ "FAILED: non-final result expected " ++ show ws ++ ", result: " ++ show r

assertPostAcctsMatch :: M.Map Address ExtAccount -> M.Map Address ExtAccount -> Either String ()
assertPostAcctsMatch i a | i == a = return ()
                         | M.keys i /= M.keys a = assertEqual "post accts match" i a
                         | otherwise = either Left (const $ Right ()) $
                                       mapM testEach (M.toList $ M.intersectionWith (,) i a)

testEach :: (Address, (ExtAccount, ExtAccount)) -> Either String ()
testEach (k, (i, a)) = do
  let msg m = "Account '" ++ show k ++ "' " ++ m ++ " equal"
  assertEqual (msg "code") (_acctCode i) (_acctCode a)
  assertEqual (msg "balance") (_acctBalance i) (_acctBalance a)
  assertEqual (msg "store") (_acctStore i) (_acctStore a)

assertEqual :: (Eq a, Show a) => String -> a -> a -> Either String ()
assertEqual msg a b | a == b = return ()
                 | otherwise = Left $ "FAILED: " ++ msg ++ ", intended=" ++
                               show a ++ ", actual=" ++ show b

runVMTest :: Bool -> String -> VMTest -> IO (Either String (VMResult, VMState, ExtData))
runVMTest dbg testname test = do
  when dbg $ do
    putStrLn ("Test: " ++ show test)
    putStrLn ("Prog: " ++ show tbc)
  if null tbc then return $ Right (Final [],vmstate,exdata)
  else fixup <$> runMExt (launchVM vmstate env Nothing) exdata
    where vmstate = emptyState gas'
          fixup ((Left err,_),_) = Left $ "Test failed: " ++ testname ++ ": " ++ err
          fixup ((Right r,vs),e) = Right (r,vs,e)
          env = Env {
               _gasModel = EthGasModel
             , _callData = V.fromList (getWords (edata ex))
             , _prog = toProg tbc
             , _address = eaddress ex
             , _origin = eorigin ex
             , _caller = ecaller ex
             , _envGas = fromMaybe 0 (vgas test)
             , _gasPrice = egasPrice ex
             , _callValue = evalue ex
             , _prevHash = fromMaybe 0 $ previousHash tenv
             , _coinbase = currentCoinbase tenv
             , _timestamp = currentTimestamp tenv
             , _number = currentNumber tenv
             , _difficulty = currentDifficulty tenv
             , _gaslimit = maybe 0 fromIntegral $ currentGasLimit tenv
             }
          ex = vexec test
          tenv = venv test
          tbc = concatMap toByteCode (parse (getWords (ecode ex)))
          gas' = fromIntegral $ egas ex
          exdata = ExtData (M.mapWithKey toEacct (testAccts (vpre test)))  S.empty S.empty M.empty [] dbg


toEacct :: Address -> TestAcct -> ExtAccount
toEacct k acct = ExtAccount {
                   _acctCode = getWords (acode acct)
                 , _acctBalance = fromIntegral $ abalance acct
                 , _acctAddress = k
                 , _acctStore = testStore $ astorage acct
                 }

newtype TestAccts = TestAccts { testAccts :: M.Map Address TestAcct } deriving (Eq,Show)

data VMTest = VMTest {
      vexec :: TestExec
    , vskip :: Maybe String
    , vgas :: Maybe U256
    , vlogs :: Maybe [TestLog]
    , vout :: Maybe WordArray
    , vpost :: Maybe TestAccts
    , vpre :: TestAccts
    , vpostStateRoot :: Maybe String
    , venv :: TestEnv
    , vcallcreates :: Maybe [CallCreate] -- apparently unused in vmtests
} deriving (Eq,Show,Generic)
instance FromJSON VMTest where parseJSON = parseDropPfxJSON 1

data CallCreate = CallCreate {
      ccdata :: WordArray
, ccdestination : : Maybe U256 TODO empty strings ? ? ? ? ?
    , ccgasLimit :: U256
    , ccvalue :: U256
} deriving (Eq,Show,Generic)
instance FromJSON CallCreate where parseJSON = parseDropPfxJSON 2

data TestEnv = TestEnv {
      currentCoinbase :: U256
    , currentDifficulty :: U256
    , currentGasLimit :: Maybe U256
    , currentNumber :: U256
    , currentTimestamp :: U256
    , previousHash :: Maybe U256
} deriving (Eq,Show,Generic)
instance FromJSON TestEnv

data TestExec = TestExec {
      eaddress :: Address
    , ecaller :: Address
    , ecode :: WordArray
    , edata :: WordArray
    , egas :: U256
    , egasPrice :: U256
    , eorigin :: Address
    , evalue :: U256
} deriving (Eq,Show,Generic)
instance FromJSON TestExec where parseJSON = parseDropPfxJSON 1

data TestLog = TestLog {
      laddress :: Address
    , lbloom :: String
    , ldata :: String
    , topics :: [U256]
} deriving (Eq,Show,Generic)
instance FromJSON TestLog where parseJSON = parseDropPfxJSON 1


newtype TestStore = TestStore { testStore :: M.Map U256 U256 } deriving (Eq,Show)


data TestAcct = TestAcct {
      abalance :: U256
    , acode :: WordArray
    , anonce :: U256
    , astorage :: TestStore
} deriving (Eq,Show,Generic)
instance FromJSON TestAcct where parseJSON = parseDropPfxJSON 1

instance FromJSON TestAccts where
    parseJSON = fmap TestAccts . parseMap (either error id . readHex)
instance FromJSON TestStore where
    parseJSON = fmap TestStore . parseMap (either error id . readHex)

parseMap :: (FromJSON (M.Map k' v), Ord k) =>
            (k' -> k) -> Value -> Parser (M.Map k v)
parseMap keyFun = fmap (hashMapKey keyFun) . parseJSON
    where hashMapKey kv = M.foldrWithKey (M.insert . kv) M.empty

 | Runs all files in "testfiles" dir.
 | run test file with optional debug out
 | parse JSON
 | execute VM test
 apparently unused in vmtests
# LANGUAGE ScopedTypeVariables #
# LANGUAGE FlexibleContexts #
# LANGUAGE FlexibleInstances #
# LANGUAGE DeriveGeneric #
  | Supports the go - ethereum and cpp - ethereum json test cases , either as an HSpec or a report in IO .
module JSONSpec where

import qualified Data.Map.Strict as M
import Masala.Word
import Masala.Instruction hiding (Spec,spec)
import Masala.Ext.Simple
import Masala.VM
import Masala.VM.Types
import Masala.RPC
import Data.Aeson hiding ((.=),Success)
import Data.Aeson.Types hiding (parse,Success)
import GHC.Generics
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Vector as V
import Data.Maybe
import Prelude hiding (words)
import qualified Data.Set as S
import Control.Exception
import Control.Monad
import Test.Hspec
import System.Directory



data TestResult =
          Success { tname :: String }
        | Failure { tname :: String,
                    ttest :: VMTest,
                    tout :: (VMResult,VMState,ExtData),
                    terr :: String }
        | Err { tname :: String, terr :: String }
instance Show TestResult where
    show (Success n) = "SUCCESS: " ++ n
    show (Err n e) = "ERROR: " ++ n ++ ": " ++ e
    show (Failure n _t _o e) = "FAILURE: " ++ n ++ ": " ++ e

spec :: Spec
spec = do
  tfs <- runIO (filter ((".json" ==).reverse.take 5.reverse) <$> getDirectoryContents "testfiles")
  mapM_ (parallel.fileSpec) tfs


  | Run a json file in HSpec .
fileSpec :: FilePath -> Spec
fileSpec tf =
    describe tf $ do
      vts <- runIO $ readVMTests tf
      forM_ (M.toList vts) $ \(n,vt) ->
                  do
                    tr <- runIO $ runTest False n vt
                    let success = return () :: Expectation
                    case tr of
                      (Success sn) -> it sn success
                      r -> case vskip vt of
                             Just reason -> it (n ++ " [UNSUPPORTED, " ++ reason ++ "]: " ++ show r) success
                             Nothing -> it n $ expectationFailure (show r)

runFile :: Bool -> FilePath -> IO [TestResult]
runFile d f = readVMTests f >>= mapM (uncurry (runTest d)) . M.toList


  | run one test with debug output
runOne :: FilePath -> String -> IO TestResult
runOne f t = do
  m <- readVMTests f
  case M.lookup t m of
    Nothing -> return $ Err t $ "Unknown test, file " ++ f
    Just tc -> do
               r <- runTest True t tc
               case r of
                 Failure{} -> putStrLn $ "Failure, testcase: " ++ show tc
                 _ -> return ()
               return r



readVMTests :: FilePath -> IO (M.Map String VMTest)
readVMTests f = LBS.readFile ("testfiles/" ++ f) >>= either bad return . eitherDecode
    where bad err = throwIO $ userError $ "ERROR: decode failed: " ++ f ++ ": " ++ err

runTest :: Bool -> String -> VMTest -> IO TestResult
runTest dbg t tc = do
  when dbg $ do
    putStrLn "-----------------"
    putStrLn t
    putStrLn "-----------------"
  let catcher :: SomeException -> IO (Either String (VMResult,VMState,ExtData))
      catcher e = return $ Left $ "Runtime exception: " ++ show e
  r <- catch (runVMTest dbg t tc) catcher
  case r of
    Left e -> if isNothing (vpost tc) && isNothing (vout tc)
              then return $ Success (t ++ " [with failure: " ++ e ++ "]")
              else return $ Err t $ "Runtime failure: " ++ e
    Right o -> do
           let tr = validateRun t tc o
           when dbg $ print tr
           return tr

  : :    ExtData 
 actionSuicides ed = over edAccts ( M.filterWithKey isSuicide ) ed 
     where isSuicide a _ = not $ a ` S.member ` ( view edSuicides ed ) 

actionSuicides :: ExtData -> ExtData
actionSuicides ed = over edAccts (M.filterWithKey isSuicide) ed
    where isSuicide a _ = not $ a `S.member` (view edSuicides ed)
-}

validateRun :: String -> VMTest -> (VMResult,VMState,ExtData) -> TestResult
validateRun n t o@(vr,_vs,ed) = either (Failure n t o) (const (Success n)) check
    where check = checkPost (vpost t) >> checkOutput (vout t)
          checkPost Nothing = Right ()
          checkPost (Just ts) = assertPostAcctsMatch (M.mapWithKey toEacct (testAccts ts)) (_edAccts ed)
          checkOutput Nothing = Right ()
          checkOutput (Just ws) =
              case vr of
                Final os -> assertEqual "output matches" (getWords ws) os
                r -> Left $ "FAILED: non-final result expected " ++ show ws ++ ", result: " ++ show r

assertPostAcctsMatch :: M.Map Address ExtAccount -> M.Map Address ExtAccount -> Either String ()
assertPostAcctsMatch i a | i == a = return ()
                         | M.keys i /= M.keys a = assertEqual "post accts match" i a
                         | otherwise = either Left (const $ Right ()) $
                                       mapM testEach (M.toList $ M.intersectionWith (,) i a)

testEach :: (Address, (ExtAccount, ExtAccount)) -> Either String ()
testEach (k, (i, a)) = do
  let msg m = "Account '" ++ show k ++ "' " ++ m ++ " equal"
  assertEqual (msg "code") (_acctCode i) (_acctCode a)
  assertEqual (msg "balance") (_acctBalance i) (_acctBalance a)
  assertEqual (msg "store") (_acctStore i) (_acctStore a)

assertEqual :: (Eq a, Show a) => String -> a -> a -> Either String ()
assertEqual msg a b | a == b = return ()
                 | otherwise = Left $ "FAILED: " ++ msg ++ ", intended=" ++
                               show a ++ ", actual=" ++ show b

runVMTest :: Bool -> String -> VMTest -> IO (Either String (VMResult, VMState, ExtData))
runVMTest dbg testname test = do
  when dbg $ do
    putStrLn ("Test: " ++ show test)
    putStrLn ("Prog: " ++ show tbc)
  if null tbc then return $ Right (Final [],vmstate,exdata)
  else fixup <$> runMExt (launchVM vmstate env Nothing) exdata
    where vmstate = emptyState gas'
          fixup ((Left err,_),_) = Left $ "Test failed: " ++ testname ++ ": " ++ err
          fixup ((Right r,vs),e) = Right (r,vs,e)
          env = Env {
               _gasModel = EthGasModel
             , _callData = V.fromList (getWords (edata ex))
             , _prog = toProg tbc
             , _address = eaddress ex
             , _origin = eorigin ex
             , _caller = ecaller ex
             , _envGas = fromMaybe 0 (vgas test)
             , _gasPrice = egasPrice ex
             , _callValue = evalue ex
             , _prevHash = fromMaybe 0 $ previousHash tenv
             , _coinbase = currentCoinbase tenv
             , _timestamp = currentTimestamp tenv
             , _number = currentNumber tenv
             , _difficulty = currentDifficulty tenv
             , _gaslimit = maybe 0 fromIntegral $ currentGasLimit tenv
             }
          ex = vexec test
          tenv = venv test
          tbc = concatMap toByteCode (parse (getWords (ecode ex)))
          gas' = fromIntegral $ egas ex
          exdata = ExtData (M.mapWithKey toEacct (testAccts (vpre test)))  S.empty S.empty M.empty [] dbg


toEacct :: Address -> TestAcct -> ExtAccount
toEacct k acct = ExtAccount {
                   _acctCode = getWords (acode acct)
                 , _acctBalance = fromIntegral $ abalance acct
                 , _acctAddress = k
                 , _acctStore = testStore $ astorage acct
                 }

newtype TestAccts = TestAccts { testAccts :: M.Map Address TestAcct } deriving (Eq,Show)

data VMTest = VMTest {
      vexec :: TestExec
    , vskip :: Maybe String
    , vgas :: Maybe U256
    , vlogs :: Maybe [TestLog]
    , vout :: Maybe WordArray
    , vpost :: Maybe TestAccts
    , vpre :: TestAccts
    , vpostStateRoot :: Maybe String
    , venv :: TestEnv
} deriving (Eq,Show,Generic)
instance FromJSON VMTest where parseJSON = parseDropPfxJSON 1

data CallCreate = CallCreate {
      ccdata :: WordArray
, ccdestination : : Maybe U256 TODO empty strings ? ? ? ? ?
    , ccgasLimit :: U256
    , ccvalue :: U256
} deriving (Eq,Show,Generic)
instance FromJSON CallCreate where parseJSON = parseDropPfxJSON 2

data TestEnv = TestEnv {
      currentCoinbase :: U256
    , currentDifficulty :: U256
    , currentGasLimit :: Maybe U256
    , currentNumber :: U256
    , currentTimestamp :: U256
    , previousHash :: Maybe U256
} deriving (Eq,Show,Generic)
instance FromJSON TestEnv

data TestExec = TestExec {
      eaddress :: Address
    , ecaller :: Address
    , ecode :: WordArray
    , edata :: WordArray
    , egas :: U256
    , egasPrice :: U256
    , eorigin :: Address
    , evalue :: U256
} deriving (Eq,Show,Generic)
instance FromJSON TestExec where parseJSON = parseDropPfxJSON 1

data TestLog = TestLog {
      laddress :: Address
    , lbloom :: String
    , ldata :: String
    , topics :: [U256]
} deriving (Eq,Show,Generic)
instance FromJSON TestLog where parseJSON = parseDropPfxJSON 1


newtype TestStore = TestStore { testStore :: M.Map U256 U256 } deriving (Eq,Show)


data TestAcct = TestAcct {
      abalance :: U256
    , acode :: WordArray
    , anonce :: U256
    , astorage :: TestStore
} deriving (Eq,Show,Generic)
instance FromJSON TestAcct where parseJSON = parseDropPfxJSON 1

instance FromJSON TestAccts where
    parseJSON = fmap TestAccts . parseMap (either error id . readHex)
instance FromJSON TestStore where
    parseJSON = fmap TestStore . parseMap (either error id . readHex)

parseMap :: (FromJSON (M.Map k' v), Ord k) =>
            (k' -> k) -> Value -> Parser (M.Map k v)
parseMap keyFun = fmap (hashMapKey keyFun) . parseJSON
    where hashMapKey kv = M.foldrWithKey (M.insert . kv) M.empty
