OnlyRPC.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | An alternative implementation of @morley-client@ that does not require
-- @tezos-client@ and has some limitations because of that (not all methods
-- are implemented).

module Morley.Client.OnlyRPC
  ( MorleyOnlyRpcEnv (..)
  , mkMorleyOnlyRpcEnv

  , MorleyOnlyRpcM (..)
  , runMorleyOnlyRpcM
  ) where

import Colog (HasLog(..), Message)
import Control.Lens (at)
import Data.Map.Strict qualified as Map
import Fmt ((+|), (|+))
import Servant.Client (BaseUrl, ClientEnv)
import Servant.Client.Core (RunClient(..))
import UnliftIO (MonadUnliftIO)

import Morley.Client.App
import Morley.Client.Init
import Morley.Client.Logging (ClientLogAction)
import Morley.Client.RPC.Class (HasTezosRpc(..))
import Morley.Client.RPC.HttpClient (newClientEnv)
import Morley.Client.TezosClient.Class (HasTezosClient(..))
import Morley.Tezos.Address
import Morley.Tezos.Address.Alias
import Morley.Tezos.Crypto (SecretKey, sign, toPublic)

----------------
-- Environment
----------------

-- | Environment used by 'MorleyOnlyRpcM'.
data MorleyOnlyRpcEnv = MorleyOnlyRpcEnv
  { moreLogAction :: ClientLogAction MorleyOnlyRpcM
  -- ^ Action used to log messages.
  , moreClientEnv :: ClientEnv
  -- ^ Environment necessary to make HTTP calls.
  , moreSecretKeys :: Map ImplicitAddress SecretKey
  -- ^ In-memory secret keys that can be used for signing.
  }

-- | Construct 'MorleyOnlyRpcEnv'.
--
-- * Full 'MorleyClientConfig' is not passed because we need just 2 things from it.
-- * Log action is built the same way as for t'Morley.Client.MorleyClientEnv'.
-- * All secret keys are passed as an argument.
mkMorleyOnlyRpcEnv ::
  [SecretKey] -> BaseUrl -> Word -> IO MorleyOnlyRpcEnv
mkMorleyOnlyRpcEnv secretKeys endpoint verbosity = do
  clientEnv <- newClientEnv endpoint
  pure MorleyOnlyRpcEnv
    { moreLogAction = mkLogAction verbosity
    , moreClientEnv = clientEnv
    , moreSecretKeys =
      Map.fromList $ map (\sk -> (mkKeyAddress (toPublic sk), sk)) secretKeys
    }

----------------
-- Monad
----------------

-- | Monad that implements 'HasTezosClient' and 'HasTezosRpc' classes and
-- can be used for high-level actions as an alternative to t'Morley.Client.MorleyClientM'.
newtype MorleyOnlyRpcM a = MorleyOnlyRpcM
  { unMorleyOnlyRpcM :: ReaderT MorleyOnlyRpcEnv IO a }
  deriving newtype
    ( Functor, Applicative, Monad, MonadReader MorleyOnlyRpcEnv
    , MonadIO, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO
    )

-- | Run 'MorleyOnlyRpcM' action within given 'MorleyOnlyRpcEnv'. Retry action
-- in case of invalid counter error.
runMorleyOnlyRpcM :: MorleyOnlyRpcEnv -> MorleyOnlyRpcM a -> IO a
runMorleyOnlyRpcM env action = runReaderT (unMorleyOnlyRpcM action) env

----------------
-- Exceptions
----------------

-- | This exception is thrown in methods that are completely unsupported.
data UnsupportedByOnlyRPC = UnsupportedByOnlyRPC Text
  deriving stock (Show, Eq)

instance Exception UnsupportedByOnlyRPC where
  displayException (UnsupportedByOnlyRPC method) =
    toString $ "Method '" <> method <> "' is not supported in only-RPC mode"

-- | This exception is thrown when something goes wrong in supported methods.
data MorleyOnlyRpcException = UnknownSecretKeyFor ImplicitAddress
  deriving stock (Show, Eq)

instance Exception MorleyOnlyRpcException where
  displayException = \case
    UnknownSecretKeyFor addr -> "Secret key is unknown for " +| addr |+ ""

----------------
-- Instances (implementation)
----------------

instance HasLog MorleyOnlyRpcEnv Message MorleyOnlyRpcM where
  getLogAction = moreLogAction
  setLogAction action mce = mce { moreLogAction = action }

-- [#652] We may implement more methods here if the need arises.
instance HasTezosClient MorleyOnlyRpcM where
  signBytes sender _password opHash = case sender of
    AddressAlias {} -> throwM $ UnsupportedByOnlyRPC "signBytes (AddressAlias _)"
    AddressResolved address -> do
      env <- ask
      case moreSecretKeys env ^. at address of
        Nothing -> throwM $ UnknownSecretKeyFor address
        Just secretKey -> liftIO $ sign secretKey opHash

  -- In RPC-only mode we only use unencrypted in-memory passwords.
  getKeyPassword _ = pure Nothing

  -- Stateful actions that simply do nothing because there is no persistent state.
  rememberContract = \_ _ _ -> pass

  -- We return a dummy value here, because this function is used in a lot of
  -- places and with an exception here it's not possible to send transactions.
  -- So be aware of this and do not rely on this value!
  -- TODO [#652]: consider using a `Map` instead
  getAlias = \case
    AddressResolved x -> case x of
      ContractAddress{} -> pure $ ContractAlias "MorleyOnlyRpc"
      ImplicitAddress{} -> pure $ ImplicitAlias "MorleyOnlyRpc"
    AddressAlias a -> pure a

  -- Actions that are not supported and simply throw exceptions.
  genKey _ = throwM $ UnsupportedByOnlyRPC "genKey"
  genFreshKey _ = throwM $ UnsupportedByOnlyRPC "genFreshKey"
  revealKey _ _ = throwM $ UnsupportedByOnlyRPC "revealKey"
  resolveAddressMaybe _ = throwM $ UnsupportedByOnlyRPC "resolveAddressMaybe"
  registerDelegate _ _ = throwM $ UnsupportedByOnlyRPC "registerDelegate"

instance RunClient MorleyOnlyRpcM where
  runRequestAcceptStatus statuses req = do
    env <- moreClientEnv <$> ask
    runRequestAcceptStatusImpl env statuses req
  throwClientError = throwClientErrorImpl

instance HasTezosRpc MorleyOnlyRpcM where
  getBlockHash = getBlockHashImpl
  getCounterAtBlock = getCounterImpl
  getBlockHeader = getBlockHeaderImpl
  getBlockConstants = getBlockConstantsImpl
  getBlockOperations = getBlockOperationsImpl
  getBlockOperationHashes = getBlockOperationHashesImpl
  getProtocolParametersAtBlock = getProtocolParametersImpl
  runOperationAtBlock = runOperationImpl
  preApplyOperationsAtBlock = preApplyOperationsImpl
  forgeOperationAtBlock = forgeOperationImpl
  getScriptSizeAtBlock = getScriptSizeAtBlockImpl
  injectOperation = injectOperationImpl
  getContractScriptAtBlock = getContractScriptImpl
  getContractStorageAtBlock = getContractStorageAtBlockImpl
  getContractBigMapAtBlock = getContractBigMapImpl
  getBigMapValueAtBlock = getBigMapValueAtBlockImpl
  getBigMapValuesAtBlock = getBigMapValuesAtBlockImpl
  getBalanceAtBlock = getBalanceImpl
  getDelegateAtBlock = getDelegateImpl
  runCodeAtBlock = runCodeImpl
  getChainId = getChainIdImpl
  getManagerKeyAtBlock = getManagerKeyImpl
  waitForOperation = (asks moreClientEnv >>=) . waitForOperationImpl