App.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Functions useful for implementing instances of type classes from this package.
-- Monads and actual instances are defined in separate modules.

module Morley.Client.App
  ( -- * RunClient
    runRequestAcceptStatusImpl
  , throwClientErrorImpl

  -- * HasTezosRpc
  , getBlockHashImpl
  , getCounterImpl
  , getBlockHeaderImpl
  , getBlockConstantsImpl
  , getBlockOperationsImpl
  , getProtocolParametersImpl
  , runOperationImpl
  , preApplyOperationsImpl
  , forgeOperationImpl
  , injectOperationImpl
  , getContractScriptImpl
  , getContractStorageAtBlockImpl
  , getContractBigMapImpl
  , getBigMapValueAtBlockImpl
  , getBigMapValuesAtBlockImpl
  , getBalanceImpl
  , getManagerKeyImpl
  , runCodeImpl
  , getChainIdImpl
  , getDelegateImpl

  -- * Timeouts and retries
  , retryOnTimeout
  , failOnTimeout
  , retryOnceOnTimeout
  , waitBeforeRetry
  , handleInvalidCounterRpc
  ) where

import Control.Concurrent (threadDelay)
import qualified Data.Aeson as Aeson
import qualified Data.Binary.Builder as Binary
import Data.List ((!!))
import Data.Text (isInfixOf)
import Fmt (Buildable(..), Builder, build, pretty, (+|), (|+))
import Network.HTTP.Types (Status(..), renderQuery)
import Servant.Client (ClientEnv, runClientM)
import Servant.Client.Core
  (ClientError(..), Request, RequestBody(..), RequestF(..), Response, ResponseF(..), RunClient)
import Servant.Client.Core.RunClient (runRequest)
import System.Random (randomRIO)
import UnliftIO (MonadUnliftIO)
import UnliftIO.Timeout (timeout)
import qualified Unsafe (fromIntegral)

import Morley.Client.Logging (WithClientLog, logDebug)
import Morley.Client.RPC
import qualified Morley.Client.RPC.API as API
import Morley.Micheline (Expression, TezosInt64, TezosNat, unTezosMutez)
import Morley.Tezos.Address (Address)
import Morley.Tezos.Core (ChainId, Mutez, parseChainId)
import Morley.Tezos.Crypto (KeyHash, PublicKey)
import Morley.Util.ByteString (HexJSONByteString)
import Morley.Util.Exception (throwLeft)

----------------
-- RunClient functions
----------------

runRequestAcceptStatusImpl ::
  (WithClientLog env m, MonadIO m, MonadThrow m) =>
  ClientEnv -> Maybe [Status] -> Request -> m Response
runRequestAcceptStatusImpl env _ req = do
  logRequest req
  response <- either throwClientErrorImpl pure =<<
    liftIO (runClientM (runRequest req) env)
  response <$ logResponse response

throwClientErrorImpl :: forall m a . MonadThrow m => ClientError -> m a
throwClientErrorImpl err = case err of
  FailureResponse _ resp
    | 500 <- statusCode (responseStatusCode resp) ->
      handleInternalError (responseBody resp)
  _ -> throwM err
  where
    -- In some cases RPC returns important useful errors as internal ones.
    -- We try to parse the response to a list of 'InternalError'.
    -- If we receive one 'InternalError', we throw it wrapped into
    -- 'ClientInternalError', that's what we observed in most obvious cases.
    -- If we receive more than one, we wrap them into 'UnexpectedInternalErrors'.
    handleInternalError :: LByteString -> m a
    handleInternalError body = case Aeson.decode @[InternalError] body of
      Nothing -> case Aeson.decode @[RunError] body of
        Nothing -> throwM err
        Just runErrs -> throwM $ RunCodeErrors runErrs
      Just [knownErr] -> throwM $ ClientInternalError knownErr
      Just errs -> throwM $ UnexpectedInternalErrors errs

----------------
-- HasTezosRpc functions
----------------

getBlockHashImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m Text
getBlockHashImpl = retryOnceOnTimeout ... API.getBlockHash API.nodeMethods

getCounterImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> Address -> m TezosInt64
getCounterImpl = retryOnceOnTimeout ... API.getCounter API.nodeMethods

getBlockHeaderImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m BlockHeader
getBlockHeaderImpl = retryOnceOnTimeout ... API.getBlockHeader API.nodeMethods

getBlockConstantsImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m BlockConstants
getBlockConstantsImpl = retryOnceOnTimeout ... API.getBlockConstants API.nodeMethods

getBlockOperationsImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m [[BlockOperation]]
getBlockOperationsImpl =
  retryOnceOnTimeout ... API.getBlockOperations API.nodeMethods

getProtocolParametersImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m ProtocolParameters
getProtocolParametersImpl = retryOnceOnTimeout ... API.getProtocolParameters API.nodeMethods

runOperationImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> RunOperation -> m RunOperationResult
runOperationImpl = retryOnceOnTimeout ... API.runOperation API.nodeMethods

preApplyOperationsImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) =>
  BlockId -> [PreApplyOperation] -> m [RunOperationResult]
preApplyOperationsImpl =
  retryOnceOnTimeout ... API.preApplyOperations API.nodeMethods

forgeOperationImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) =>
  BlockId -> ForgeOperation -> m HexJSONByteString
forgeOperationImpl = retryOnceOnTimeout ... API.forgeOperation API.nodeMethods

injectOperationImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) =>
  HexJSONByteString -> m OperationHash
injectOperationImpl =
  failOnTimeout ... API.injectOperation API.nodeMethods

getContractScriptImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) =>
  BlockId -> Address -> m OriginationScript
getContractScriptImpl = retryOnceOnTimeout ... API.getScript API.nodeMethods

getContractStorageAtBlockImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) =>
  BlockId -> Address -> m Expression
getContractStorageAtBlockImpl =
  retryOnceOnTimeout ... API.getStorageAtBlock API.nodeMethods

getContractBigMapImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) =>
  BlockId -> Address -> GetBigMap -> m GetBigMapResult
getContractBigMapImpl = retryOnceOnTimeout ... API.getBigMap API.nodeMethods

getBigMapValueAtBlockImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) =>
  BlockId -> Natural -> Text -> m Expression
getBigMapValueAtBlockImpl =
  retryOnceOnTimeout ... API.getBigMapValueAtBlock API.nodeMethods

getBigMapValuesAtBlockImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) =>
  BlockId -> Natural -> Maybe Natural -> Maybe Natural -> m Expression
getBigMapValuesAtBlockImpl =
  retryOnceOnTimeout ... API.getBigMapValuesAtBlock API.nodeMethods

getBalanceImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> Address -> m Mutez
getBalanceImpl =
  retryOnceOnTimeout ... fmap unTezosMutez ... API.getBalance API.nodeMethods

getDelegateImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> Address -> m (Maybe KeyHash)
getDelegateImpl =
  retryOnceOnTimeout ... API.getDelegate API.nodeMethods

-- | Similar to 'API.getManagerKey', but retries once on timeout.
getManagerKeyImpl ::
  (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> Address -> m (Maybe PublicKey)
getManagerKeyImpl =
  retryOnceOnTimeout ... API.getManagerKey API.nodeMethods

runCodeImpl :: (RunClient m, MonadCatch m) => BlockId -> RunCode -> m RunCodeResult
runCodeImpl = API.runCode API.nodeMethods

getChainIdImpl :: (RunClient m, MonadCatch m) => m ChainId
getChainIdImpl = throwLeft $ parseChainId <$> API.getChainId API.nodeMethods

----------------
-- Logging of requests and responses
----------------

-- | Convert a bytestring to a string assuming this bytestring stores
-- something readable in UTF-8 encoding.
fromBS :: ConvertUtf8 Text bs => bs -> Text
fromBS = decodeUtf8

ppRequestBody :: RequestBody -> Builder
ppRequestBody = build .
  \case
    RequestBodyLBS lbs -> fromBS lbs
    RequestBodyBS bs -> fromBS bs
    RequestBodySource {} -> "<body is not in memory>"

-- | Pretty print a @servant@'s request.
-- Note that we print only some part of t'Request': method, request
-- path and query, request body. We don't print other things that are
-- subjectively less interesting such as HTTP version or media type.
-- But feel free to add them if you want.
ppRequest :: Request -> Builder
ppRequest Request {..} =
  fromBS requestMethod |+ " " +| fromBS (Binary.toLazyByteString requestPath)
  |+ fromBS (renderQuery True $ toList requestQueryString) |+
  maybe mempty (mappend "\n" . ppRequestBody . fst) requestBody

logRequest :: WithClientLog env m => Request -> m ()
logRequest req = logDebug $ "RPC request: " +| ppRequest req |+ ""

-- | Pretty print a @servant@'s response.
-- Note that we print only status and body,
-- the rest looks not so interesting in our case.
--
-- If response is not human-readable text in UTF-8 encoding it will
-- print some garbage.  Apparently we don't make such requests for now.
ppResponse :: Response -> Builder
ppResponse Response {..} =
  statusCode responseStatusCode |+ " " +|
  fromBS (statusMessage responseStatusCode) |+ "\n" +|
  fromBS responseBody  |+ ""

logResponse :: WithClientLog env m => Response -> m ()
logResponse resp = logDebug $ "RPC response: " +| ppResponse resp |+ ""

----------------
-- Timeouts and retries
----------------

data TimeoutError = TimeoutError
  deriving stock Show

instance Buildable TimeoutError where
  build TimeoutError =
    "Timeout for action call was reached. Probably, something is wrong with \
    \testing environment."

instance Exception TimeoutError where
  displayException = pretty

-- | Helper function that retries a monadic action in case action hasn't succeed
-- in 'timeoutInterval'. In case retry didn't help, error that indicates
-- timeout is thrown.
retryOnTimeout :: (MonadUnliftIO m, MonadThrow m) => Bool -> m a -> m a
retryOnTimeout wasRetried action = do
  res <- timeout timeoutInterval action
  maybe (if wasRetried then throwM TimeoutError else retryOnTimeout True action)
    pure res

-- | Helper function that consider action failed in case of timeout,
-- because it's unsafe to perform some of the actions twice. E.g. performing two 'injectOperation'
-- action can lead to a situation when operation is injected twice.
failOnTimeout :: (MonadUnliftIO m, MonadThrow m) => m a -> m a
failOnTimeout = retryOnTimeout True

-- | Helper function that retries action once in case of timeout. If retry ended up with timeout
-- as well, action is considered failed. It's safe to retry read-only actions that don't update chain state
-- or @tezos-client@ config/environment.
retryOnceOnTimeout :: (MonadUnliftIO m, MonadThrow m) => m a -> m a
retryOnceOnTimeout = retryOnTimeout False

-- | Timeout for 'retryOnTimeout', 'retryOnceOnTimeout' and 'failOnTimeout' helpers in microseconds.
timeoutInterval :: Int
timeoutInterval = 120 * 1e6

-- | Wait for a reasonable amount of time before retrying an action that failed
-- due to invalid counter.
-- The waiting time depends on protocol parameters.
waitBeforeRetry :: (MonadIO m, HasTezosRpc m, WithClientLog env m) => m ()
waitBeforeRetry = do
  i <- liftIO $
    (blockAwaitAmounts !!) <$> randomRIO (0, length blockAwaitAmounts - 1)
  logDebug $ "Invalid counter error occurred, retrying the request after " <> show i <> " blocks"
  ProtocolParameters {..} <- getProtocolParameters
  -- Invalid counter error may occur in case we try to perform multiple operations
  -- from the same address. We should try to wait different amount of times before retry
  -- in case there are multiple actions failed with invalid counter error.
  liftIO $ threadDelay $ i * Unsafe.fromIntegral @TezosNat @Int ppMinimalBlockDelay * 1e6
  where
    blockAwaitAmounts :: [Int]
    blockAwaitAmounts = [1..5]

-- | Retry action if it failed due to invalid counter (already used one).
handleInvalidCounterRpc :: MonadThrow m => m a -> ClientRpcError -> m a
handleInvalidCounterRpc retryAction = \case
  ClientInternalError (CounterInThePast {}) -> retryAction
  ClientInternalError (Failure msg)
    | "Counter" `isInfixOf` msg && "already used for contract" `isInfixOf` msg ->
      retryAction
  anotherErr -> throwM anotherErr