-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
{-# OPTIONS_GHC -Wno-orphans #-}
-- | Module that defines some basic infrastructure
-- for faking tezos-node RPC interaction.
module TestM
( ContractData (..)
, ContractState (..)
, ContractStateBigMap (..)
, Handlers (..)
, FakeState (..)
, TestError (..)
, TestHandlers (..)
, TestM
, TestT
, defaultHandlers
, defaultFakeState
, runFakeTest
, runFakeTestT
, liftToFakeTest
-- * Lens
, fsContractsL
) where
import Colog.Core.Class (HasLog(..))
import Colog.Message (Message)
import Control.Lens (makeLensesFor)
import Control.Monad.Catch.Pure (CatchT(..))
import Data.ByteArray (ScrubbedBytes)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Fmt (pretty)
import Morley.Client
import Morley.Client.Logging (ClientLogAction)
import Morley.Client.RPC
import Morley.Client.TezosClient (CalcOriginationFeeData, CalcTransferFeeData, TezosClientConfig)
import Morley.Micheline
import Morley.Michelson.Typed.Scope (UntypedValScope)
import Morley.Tezos.Address
import Morley.Tezos.Address.Alias (AddressOrAlias, Alias(..))
import Morley.Tezos.Core
import Morley.Tezos.Crypto (KeyHash, PublicKey, SecretKey, Signature)
import Morley.Util.ByteString
-- | A test-specific orphan.
instance IsString Alias where
fromString = Alias . fromString
-- | Reader environment to interact with the fake state.
data Handlers m = Handlers
{ -- HasTezosRpc
hGetBlockHash :: BlockId -> m BlockHash
, hGetCounter :: BlockId -> Address -> m TezosInt64
, hGetBlockHeader :: BlockId -> m BlockHeader
, hGetBlockConstants :: BlockId -> m BlockConstants
, hGetBlockOperations :: BlockId -> m [[BlockOperation]]
, hGetScriptSizeAtBlock :: BlockId -> CalcSize -> m ScriptSize
, hGetBlockOperationHashes :: BlockId -> m [[OperationHash]]
, hGetProtocolParameters :: BlockId -> m ProtocolParameters
, hRunOperation :: BlockId -> RunOperation -> m RunOperationResult
, hPreApplyOperations :: BlockId -> [PreApplyOperation] -> m [RunOperationResult]
, hForgeOperation :: BlockId -> ForgeOperation -> m HexJSONByteString
, hInjectOperation :: HexJSONByteString -> m OperationHash
, hGetContractScript :: BlockId -> Address -> m OriginationScript
, hGetContractBigMap :: BlockId -> Address -> GetBigMap -> m GetBigMapResult
, hGetBigMapValue :: BlockId -> Natural -> Text -> m Expression
, hGetBigMapValues :: BlockId -> Natural -> Maybe Natural -> Maybe Natural -> m Expression
, hGetBalance :: BlockId -> Address -> m Mutez
, hRunCode :: BlockId -> RunCode -> m RunCodeResult
, hGetChainId :: m ChainId
, hGetManagerKey :: BlockId -> Address -> m (Maybe PublicKey)
, hGetDelegateAtBlock :: BlockId -> Address -> m (Maybe KeyHash)
-- HasTezosClient
, hSignBytes :: AddressOrAlias -> Maybe ScrubbedBytes -> ByteString -> m Signature
, hGenKey :: Alias -> m Address
, hGenFreshKey :: Alias -> m Address
, hRevealKey :: Alias -> Maybe ScrubbedBytes -> m ()
, hWaitForOperation :: m OperationHash -> m OperationHash
, hRememberContract :: Bool -> Address -> Alias -> m ()
, hImportKey :: Bool -> Alias -> SecretKey -> m Alias
, hResolveAddressMaybe :: AddressOrAlias -> m (Maybe Address)
, hGetAlias :: AddressOrAlias -> m Alias
, hGetPublicKey :: AddressOrAlias -> m PublicKey
, hGetSecretKey :: AddressOrAlias -> m SecretKey
, hGetTezosClientConfig :: m TezosClientConfig
, hCalcTransferFee
:: AddressOrAlias -> Maybe ScrubbedBytes -> TezosInt64 -> [CalcTransferFeeData] -> m [TezosMutez]
, hCalcOriginationFee
:: forall cp st. UntypedValScope st => CalcOriginationFeeData cp st -> m TezosMutez
, hGetKeyPassword :: Address -> m (Maybe ScrubbedBytes)
, hRegisterDelegate :: Alias -> Maybe ScrubbedBytes -> m ()
-- HasLog
, hLogAction :: ClientLogAction m
}
defaultHandlers :: Monad m => Handlers (TestT m)
defaultHandlers = Handlers
{ hGetBlockHash = \_ -> throwM $ UnexpectedRpcCall "getHeadBlock"
, hGetCounter = \_ _ -> throwM $ UnexpectedRpcCall "getCounter"
, hGetBlockHeader = \_ -> throwM $ UnexpectedRpcCall "getBlockHeader"
, hGetBlockConstants = \_ -> throwM $ UnexpectedRpcCall "getBlockConstants"
, hGetScriptSizeAtBlock = \_ _ -> throwM $ UnexpectedRpcCall "getScriptSizeAtBlock"
, hGetBlockOperations = \_ -> throwM $ UnexpectedRpcCall "getBlockOperations"
, hGetBlockOperationHashes = \_ -> throwM $ UnexpectedRpcCall "hGetBlockOperationHashes"
, hGetProtocolParameters = \_ -> throwM $ UnexpectedRpcCall "getProtocolParameters"
, hRunOperation = \_ _ -> throwM $ UnexpectedRpcCall "runOperation"
, hPreApplyOperations = \_ _ -> throwM $ UnexpectedRpcCall "preApplyOperations"
, hForgeOperation = \_ _ -> throwM $ UnexpectedRpcCall "forgeOperation"
, hInjectOperation = \_ -> throwM $ UnexpectedRpcCall "injectOperation"
, hGetContractScript = \_ _ -> throwM $ UnexpectedRpcCall "getContractScript"
, hGetContractBigMap = \_ _ _ -> throwM $ UnexpectedRpcCall "getContractBigMap"
, hGetBigMapValue = \_ _ _ -> throwM $ UnexpectedRpcCall "getBigMapValue"
, hGetBigMapValues = \_ _ _ _ -> throwM $ UnexpectedRpcCall "getBigMapValues"
, hGetBalance = \_ _ -> throwM $ UnexpectedRpcCall "getBalance"
, hRunCode = \_ _ -> throwM $ UnexpectedRpcCall "runCode"
, hGetChainId = throwM $ UnexpectedRpcCall "getChainId"
, hGetManagerKey = \_ _ -> throwM $ UnexpectedRpcCall "getManagerKey"
, hGetDelegateAtBlock = \_ _ -> throwM $ UnexpectedRpcCall "getDelegateAtBlock"
, hSignBytes = \_ _ _ -> throwM $ UnexpectedClientCall "signBytes"
, hGenKey = \_ -> throwM $ UnexpectedClientCall "genKey"
, hGenFreshKey = \_ -> throwM $ UnexpectedRpcCall "genFreshKey"
, hRevealKey = \_ _ -> throwM $ UnexpectedClientCall "revealKey"
, hWaitForOperation = \_ -> throwM $ UnexpectedRpcCall "waitForOperation"
, hRememberContract = \_ _ _ -> throwM $ UnexpectedClientCall "hRememberContract"
, hImportKey = \_ _ _ -> throwM $ UnexpectedClientCall "importKey"
, hResolveAddressMaybe = \_ -> throwM $ UnexpectedRpcCall "resolveAddressMaybe"
, hGetAlias = \_ -> throwM $ UnexpectedRpcCall "getAlias"
, hGetPublicKey = \_ -> throwM $ UnexpectedRpcCall "getPublicKey"
, hGetSecretKey = \_ -> throwM $ UnexpectedRpcCall "getSecretKey"
, hGetTezosClientConfig = throwM $ UnexpectedClientCall "getTezosClientConfig"
, hCalcTransferFee = \_ _ _ _ -> throwM $ UnexpectedClientCall "calcTransferFee"
, hCalcOriginationFee = \_ -> throwM $ UnexpectedClientCall "calcOriginationFee"
, hGetKeyPassword = \_ -> throwM $ UnexpectedClientCall "getKeyPassword"
, hRegisterDelegate = \_ _ -> throwM $ UnexpectedClientCall "registerDelegate"
, hLogAction = mempty
}
-- | Type to represent contract state in the @FakeState@.
-- This type can represent both implicit accounts and contracts.
data ContractState = ContractState
{ csCounter :: TezosInt64
, csAlias :: Alias
, csContractData :: ContractData
}
data ContractData
= ContractData OriginationScript (Maybe ContractStateBigMap)
| ImplicitContractData (Maybe PublicKey)
-- | Type to represent big_map in @ContractState@.
data ContractStateBigMap = ContractStateBigMap
{ csbmKeyType :: Expression
, csbmValueType :: Expression
, csbmMap :: Map Text ByteString
-- ^ Real tezos bigmap also has deserialized keys and values
, csbmId :: Natural
-- ^ The big_map's ID
}
newtype TestHandlers m = TestHandlers {unTestHandlers :: Handlers (TestT m)}
-- | Type to represent chain state in mock tests.
data FakeState = FakeState
{ fsContracts :: Map Address ContractState
, fsHeadBlock :: BlockHash
-- ^ Hash of the `head` block
, fsFinalHeadBlock :: BlockHash
-- ^ Hash of the `head~2` block
, fsBlockConstants :: BlockId -> BlockConstants
, fsProtocolParameters :: ProtocolParameters
}
defaultFakeState :: FakeState
defaultFakeState = FakeState
{ fsContracts = mempty
, fsHeadBlock = BlockHash "HEAD"
, fsFinalHeadBlock = BlockHash "HEAD~2"
, fsBlockConstants = \blkId -> BlockConstants
{ bcProtocol = "PROTOCOL"
, bcChainId = "CHAIN_ID"
, bcHeader = BlockHeaderNoHash
{ bhnhTimestamp = posixSecondsToUTCTime 0
, bhnhLevel = 0
, bhnhPredecessor = BlockHash "PREV_HASH"
}
, bcHash = BlockHash $ pretty blkId
}
, fsProtocolParameters = ProtocolParameters 257 1040000 60000 15
(TezosMutez [tz|250u|])
}
type TestT m = StateT FakeState (ReaderT (TestHandlers m) (CatchT m))
type TestM = TestT Identity
runFakeTestT
:: forall a m. Monad m =>
Handlers (TestT m) -> FakeState -> TestT m a -> m (Either SomeException a)
runFakeTestT handlers fakeState action =
runCatchT $ runReaderT (evalStateT action fakeState) (TestHandlers handlers)
runFakeTest
:: forall a. Handlers TestM -> FakeState -> TestM a -> Either SomeException a
runFakeTest =
runIdentity ... runFakeTestT
getHandler :: Monad m => (Handlers (TestT m) -> fn) -> TestT m fn
getHandler fn = fn . unTestHandlers <$> ask
liftToFakeTest :: Monad m => m a -> TestT m a
liftToFakeTest = lift . lift . lift
-- | Various fake test errors.
data TestError
= AlreadyRevealed Address
| UnexpectedRpcCall Text
| UnexpectedClientCall Text
| UnknownContract AddressOrAlias
| UnexpectedImplicitContract Address
| ContractDoesntHaveBigMap Address
| CantRevealContract Address
| InvalidChainId
| InvalidProtocol
| InvalidBranch BlockHash
| CounterMismatch
deriving stock Show
instance Exception TestError
instance HasLog (TestHandlers m) Message (TestT m) where
getLogAction = hLogAction . unTestHandlers
setLogAction action (TestHandlers handlers) =
TestHandlers $ handlers { hLogAction = action }
instance Monad m => HasTezosClient (TestT m) where
signBytes alias mbPassword op = do
h <- getHandler hSignBytes
h alias mbPassword op
genKey alias = do
h <- getHandler hGenKey
h alias
genFreshKey alias = do
h <- getHandler hGenFreshKey
h alias
revealKey alias mbPassword = do
h <- getHandler hRevealKey
h alias mbPassword
rememberContract replaceExisting addr alias = do
h <- getHandler hRememberContract
h replaceExisting addr alias
importKey replaceExisting alias key = do
h <- getHandler hImportKey
h replaceExisting alias key
resolveAddressMaybe addr = do
h <- getHandler hResolveAddressMaybe
h addr
getAlias originator = do
h <- getHandler hGetAlias
h originator
getPublicKey alias = do
h <- getHandler hGetPublicKey
h alias
getSecretKey alias = do
h <- getHandler hGetSecretKey
h alias
getTezosClientConfig =
join $ getHandler hGetTezosClientConfig
calcTransferFee from mbPassword burnCap transferDatas = do
h <- getHandler hCalcTransferFee
h from mbPassword burnCap transferDatas
calcOriginationFee origData = do
h <- getHandler (\hs -> hCalcOriginationFee hs)
h origData
getKeyPassword addr = do
h <- getHandler hGetKeyPassword
h addr
registerDelegate kh pw = do
h <- getHandler hRegisterDelegate
h kh pw
instance Monad m => HasTezosRpc (TestT m) where
getBlockHash block = do
h <- getHandler hGetBlockHash
h block
getCounterAtBlock block addr = do
h <- getHandler hGetCounter
h block addr
getBlockHeader block = do
h <- getHandler hGetBlockHeader
h block
getBlockConstants block = do
h <- getHandler hGetBlockConstants
h block
getBlockOperations block = do
h <- getHandler hGetBlockOperations
h block
getProtocolParametersAtBlock block = do
h <- getHandler hGetProtocolParameters
h block
runOperationAtBlock block op = do
h <- getHandler hRunOperation
h block op
preApplyOperationsAtBlock block ops = do
h <- getHandler hPreApplyOperations
h block ops
getScriptSizeAtBlock block script = do
h <- getHandler hGetScriptSizeAtBlock
h block script
forgeOperationAtBlock block op = do
h <- getHandler hForgeOperation
h block op
injectOperation op = do
h <- getHandler hInjectOperation
h op
getContractScriptAtBlock block addr = do
h <- getHandler hGetContractScript
h block addr
getContractStorageAtBlock blockId addr = do
h <- getHandler hGetContractScript
osStorage <$> h blockId addr
getContractBigMapAtBlock block addr getBigMap = do
h <- getHandler hGetContractBigMap
h block addr getBigMap
getBigMapValueAtBlock blockId bigMapId scriptExpr = do
h <- getHandler hGetBigMapValue
h blockId bigMapId scriptExpr
getBigMapValuesAtBlock blockId bigMapId mbOffset mbLength = do
h <- getHandler hGetBigMapValues
h blockId bigMapId mbOffset mbLength
getBalanceAtBlock block addr = do
h <- getHandler hGetBalance
h block addr
runCodeAtBlock block r = do
h <- getHandler hRunCode
h block r
getChainId = join (getHandler hGetChainId)
getManagerKeyAtBlock block addr = do
h <- getHandler hGetManagerKey
h block addr
getDelegateAtBlock block addr = do
h <- getHandler hGetDelegateAtBlock
h block addr
getBlockOperationHashes block = do
h <- getHandler hGetBlockOperationHashes
h block
waitForOperation opHash = do
h <- getHandler hWaitForOperation
h opHash
makeLensesFor [("fsContracts", "fsContractsL")] ''FakeState