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

-- | Various errors that can happen in the RPC part of @morley-client@.
module Morley.Client.RPC.Error
  ( ClientRpcError (..)
  , ClientRpcErrorWithStack (..)
  , RunCodeErrors (..)
  , UnexpectedErrors (..)
  , IncorrectRpcResponse (..)
  , WaitForOperationError (..)
  ) where

import Data.Typeable (cast)
import Fmt (Buildable(..), blockListF, nameF, pretty, unlinesF, (+|), (|+))

import Morley.Micheline (Expression)
import Morley.Tezos.Address

import Morley.Client.RPC.Types

----------------------------------------------------------------------------
-- Caused by invalid user action
----------------------------------------------------------------------------

data ClientRpcErrorWithStack a = ClientRpcErrorWithStack
  { forall a.
ClientRpcErrorWithStack a -> NonEmpty (OperationResp WithSource)
crewsStack :: NonEmpty (OperationResp WithSource)
  , forall a. ClientRpcErrorWithStack a -> a
crewsError :: a
  } deriving stock Int -> ClientRpcErrorWithStack a -> ShowS
[ClientRpcErrorWithStack a] -> ShowS
ClientRpcErrorWithStack a -> String
(Int -> ClientRpcErrorWithStack a -> ShowS)
-> (ClientRpcErrorWithStack a -> String)
-> ([ClientRpcErrorWithStack a] -> ShowS)
-> Show (ClientRpcErrorWithStack a)
forall a. Show a => Int -> ClientRpcErrorWithStack a -> ShowS
forall a. Show a => [ClientRpcErrorWithStack a] -> ShowS
forall a. Show a => ClientRpcErrorWithStack a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientRpcErrorWithStack a] -> ShowS
$cshowList :: forall a. Show a => [ClientRpcErrorWithStack a] -> ShowS
show :: ClientRpcErrorWithStack a -> String
$cshow :: forall a. Show a => ClientRpcErrorWithStack a -> String
showsPrec :: Int -> ClientRpcErrorWithStack a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ClientRpcErrorWithStack a -> ShowS
Show

instance Buildable a => Buildable (ClientRpcErrorWithStack a) where
  build :: ClientRpcErrorWithStack a -> Doc
build ClientRpcErrorWithStack{a
NonEmpty (OperationResp WithSource)
crewsError :: a
crewsStack :: NonEmpty (OperationResp WithSource)
crewsError :: forall a. ClientRpcErrorWithStack a -> a
crewsStack :: forall a.
ClientRpcErrorWithStack a -> NonEmpty (OperationResp WithSource)
..} = [Doc] -> Doc
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Doc
unlinesF
    [ a -> Doc
forall a. Buildable a => a -> Doc
build a
crewsError
    , Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Call stack" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Doc
unlinesF ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ OperationResp WithSource -> Doc
forall a. Buildable a => a -> Doc
build (OperationResp WithSource -> Doc)
-> [OperationResp WithSource] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (OperationResp WithSource)
-> [Element (NonEmpty (OperationResp WithSource))]
forall t. Container t => t -> [Element t]
toList NonEmpty (OperationResp WithSource)
crewsStack
    ]

instance (Show a, Typeable a, Buildable a) => Exception (ClientRpcErrorWithStack a) where
  displayException :: ClientRpcErrorWithStack a -> String
displayException = ClientRpcErrorWithStack a -> String
forall a b. (Buildable a, FromDoc b) => a -> b
pretty

-- | Errors that can happen in the RPC part when a user tries to make
-- failing actions.
data ClientRpcError
  -- | Smart contract execution has failed.
  = ContractFailed
      ContractAddress -- ^ Smart contract address.
      Expression -- ^ Value the contract has failed with.

  | BadParameter
    -- ^ Parameter passed to a contract does not match its type.
      Address -- ^ Smart or implicit contract address.
      Expression -- ^ Value passed as parameter.
  | EmptyTransaction
    -- ^ Transfer of 0 to an implicit account.
      ImplicitAddress -- ^ Receiver address.
  | ShiftOverflow
    -- ^ A smart contract execution failed due to a shift overflow.
    ContractAddress
    -- ^ Smart contract address.
  | GasExhaustion
    -- ^ A smart contract execution failed due gas exhaustion.
    ContractAddress
    -- ^ Smart contract address.
  | KeyAlreadyRevealed
    -- ^ A key has already been revealed.
    ImplicitAddress
    -- ^ The address corresponding to the key.
  | DelegateNotRegistered
    -- ^ Address not registered as delegate
    ImplicitAddress
    -- ^ The address in question.
  | ClientInternalError
    -- ^ An error that RPC considers internal occurred. These errors
    -- are considered internal by mistake, they are actually quite
    -- realistic and normally indicate bad user action. Currently we
    -- put 'InternalError' here as is, because it's easy for a user of
    -- @morley-client@ to work with this type. In #284 we will
    -- consider more errors and maybe some of them will need to be
    -- mapped into something more user-friendly, then we will
    -- reconsider this approach.
    InternalError
  deriving stock Int -> ClientRpcError -> ShowS
[ClientRpcError] -> ShowS
ClientRpcError -> String
(Int -> ClientRpcError -> ShowS)
-> (ClientRpcError -> String)
-> ([ClientRpcError] -> ShowS)
-> Show ClientRpcError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientRpcError] -> ShowS
$cshowList :: [ClientRpcError] -> ShowS
show :: ClientRpcError -> String
$cshow :: ClientRpcError -> String
showsPrec :: Int -> ClientRpcError -> ShowS
$cshowsPrec :: Int -> ClientRpcError -> ShowS
Show

instance Buildable ClientRpcError where
  build :: ClientRpcError -> Doc
build = \case
    ContractFailed ContractAddress
addr Expression
expr ->
      Doc
"The execution of the smart contract " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ContractAddress
addr ContractAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+
      Doc
" failed with " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Expression
expr Expression -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
    BadParameter Address
addr Expression
expr ->
      Doc
"Parameter " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Expression
expr Expression -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" does not match the type of " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Address
addr Address -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"."
    EmptyTransaction ImplicitAddress
addr -> RunError -> Doc
forall a. Buildable a => a -> Doc
build (ImplicitAddress -> RunError
REEmptyTransaction ImplicitAddress
addr)
    ShiftOverflow ContractAddress
addr -> ContractAddress
addr ContractAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" failed due to shift overflow"
    GasExhaustion ContractAddress
addr -> ContractAddress
addr ContractAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" failed due to gas exhaustion"
    KeyAlreadyRevealed ImplicitAddress
addr -> Doc
"Key for " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ImplicitAddress
addr ImplicitAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" has already been revealed"
    DelegateNotRegistered ImplicitAddress
addr -> ImplicitAddress
addr ImplicitAddress -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" not registered as delegate"
    ClientInternalError InternalError
err -> InternalError -> Doc
forall a. Buildable a => a -> Doc
build InternalError
err

-- | To reduce friction between 'ClientRpcErrorWithStack' and 'ClientRpcError',
-- this instance will try to convert from both in 'fromException'
instance Exception ClientRpcError where
  displayException :: ClientRpcError -> String
displayException = ClientRpcError -> String
forall a b. (Buildable a, FromDoc b) => a -> b
pretty
  fromException :: SomeException -> Maybe ClientRpcError
fromException (SomeException e
e) = e -> Maybe ClientRpcError
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e Maybe ClientRpcError
-> Maybe ClientRpcError -> Maybe ClientRpcError
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ClientRpcErrorWithStack ClientRpcError -> ClientRpcError)
-> Maybe (ClientRpcErrorWithStack ClientRpcError)
-> Maybe ClientRpcError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClientRpcErrorWithStack ClientRpcError -> ClientRpcError
forall a. ClientRpcErrorWithStack a -> a
crewsError (e -> Maybe (ClientRpcErrorWithStack ClientRpcError)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e)

-- | Errors that can happen during @run_code@ endpoint call.
-- These errors returned along with 500 code, so we have to handle
-- them a bit differently in comparison to other run errors that are
-- returned as a part of successful JSON response.
data RunCodeErrors = RunCodeErrors [RunError]
  deriving stock Int -> RunCodeErrors -> ShowS
[RunCodeErrors] -> ShowS
RunCodeErrors -> String
(Int -> RunCodeErrors -> ShowS)
-> (RunCodeErrors -> String)
-> ([RunCodeErrors] -> ShowS)
-> Show RunCodeErrors
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RunCodeErrors] -> ShowS
$cshowList :: [RunCodeErrors] -> ShowS
show :: RunCodeErrors -> String
$cshow :: RunCodeErrors -> String
showsPrec :: Int -> RunCodeErrors -> ShowS
$cshowsPrec :: Int -> RunCodeErrors -> ShowS
Show

instance Buildable RunCodeErrors where
  build :: RunCodeErrors -> Doc
build (RunCodeErrors [RunError]
errs) = Doc
"'run_code' failed with the following errors: " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+|
      [RunError] -> Doc
forall a (f :: * -> *). (Buildable a, Foldable f) => f a -> Doc
blockListF [RunError]
errs Doc -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""

instance Exception RunCodeErrors where
  displayException :: RunCodeErrors -> String
displayException = RunCodeErrors -> String
forall a b. (Buildable a, FromDoc b) => a -> b
pretty

----------------------------------------------------------------------------
-- Caused by unexpected node behavior or incorrect assumption in our code
----------------------------------------------------------------------------

-- | Errors that we don't expect to happen, but they can be reported
-- by the server.
data UnexpectedErrors
  = UnexpectedRunErrors [RunError]
  | UnexpectedInternalErrors [InternalError]
  deriving stock (Int -> UnexpectedErrors -> ShowS
[UnexpectedErrors] -> ShowS
UnexpectedErrors -> String
(Int -> UnexpectedErrors -> ShowS)
-> (UnexpectedErrors -> String)
-> ([UnexpectedErrors] -> ShowS)
-> Show UnexpectedErrors
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnexpectedErrors] -> ShowS
$cshowList :: [UnexpectedErrors] -> ShowS
show :: UnexpectedErrors -> String
$cshow :: UnexpectedErrors -> String
showsPrec :: Int -> UnexpectedErrors -> ShowS
$cshowsPrec :: Int -> UnexpectedErrors -> ShowS
Show)

instance Buildable UnexpectedErrors where
  build :: UnexpectedErrors -> Doc
build = \case
    UnexpectedRunErrors [RunError]
errs ->
      Doc
"Preapply failed due to the following errors:\n" Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+|
      [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ((RunError -> Doc) -> [RunError] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\n\n") (Doc -> Doc) -> (RunError -> Doc) -> RunError -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunError -> Doc
forall a. Buildable a => a -> Doc
build) [RunError]
errs) Doc -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
    UnexpectedInternalErrors [InternalError]
errs ->
      Doc
"RPC failed with unexpected internal errors:\n" Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+|
      [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ((InternalError -> Doc) -> [InternalError] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\n\n") (Doc -> Doc) -> (InternalError -> Doc) -> InternalError -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalError -> Doc
forall a. Buildable a => a -> Doc
build) [InternalError]
errs) Doc -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""

-- | To reduce friction between 'ClientRpcErrorWithStack' and 'UnexpectedErrors',
-- this instance will try to convert from both in 'fromException'
instance Exception UnexpectedErrors where
  displayException :: UnexpectedErrors -> String
displayException = UnexpectedErrors -> String
forall a b. (Buildable a, FromDoc b) => a -> b
pretty
  fromException :: SomeException -> Maybe UnexpectedErrors
fromException (SomeException e
e) = e -> Maybe UnexpectedErrors
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e Maybe UnexpectedErrors
-> Maybe UnexpectedErrors -> Maybe UnexpectedErrors
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ClientRpcErrorWithStack UnexpectedErrors -> UnexpectedErrors)
-> Maybe (ClientRpcErrorWithStack UnexpectedErrors)
-> Maybe UnexpectedErrors
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClientRpcErrorWithStack UnexpectedErrors -> UnexpectedErrors
forall a. ClientRpcErrorWithStack a -> a
crewsError (e -> Maybe (ClientRpcErrorWithStack UnexpectedErrors)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e)

-- | Errors that we can throw when we get a response from a node that
-- doesn't match our expectations. It means that either the node we
-- are talking to misbehaves or our code is incorrect.
data IncorrectRpcResponse
  = RpcUnexpectedSize Int Int
  | RpcOriginatedNoContracts
  | RpcOriginatedMoreContracts [ContractAddress]
  deriving stock Int -> IncorrectRpcResponse -> ShowS
[IncorrectRpcResponse] -> ShowS
IncorrectRpcResponse -> String
(Int -> IncorrectRpcResponse -> ShowS)
-> (IncorrectRpcResponse -> String)
-> ([IncorrectRpcResponse] -> ShowS)
-> Show IncorrectRpcResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IncorrectRpcResponse] -> ShowS
$cshowList :: [IncorrectRpcResponse] -> ShowS
show :: IncorrectRpcResponse -> String
$cshow :: IncorrectRpcResponse -> String
showsPrec :: Int -> IncorrectRpcResponse -> ShowS
$cshowsPrec :: Int -> IncorrectRpcResponse -> ShowS
Show

instance Buildable IncorrectRpcResponse where
  build :: IncorrectRpcResponse -> Doc
build = \case
    RpcUnexpectedSize Int
expected Int
got ->
      Doc
"An RPC call returned a list that has " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Int
got Int -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+
      Doc
" items, but we expected to get " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Int
expected Int -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" results"
    RpcOriginatedMoreContracts [ContractAddress]
addresses ->
      Doc
"Operation expected to originate one contract, but will more:\n" Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+|
      [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ((ContractAddress -> Doc) -> [ContractAddress] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\n") (Doc -> Doc) -> (ContractAddress -> Doc) -> ContractAddress -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractAddress -> Doc
forall a. Buildable a => a -> Doc
build) [ContractAddress]
addresses) Doc -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
    IncorrectRpcResponse
RpcOriginatedNoContracts ->
      Doc
"Operation expected to originate a contract, but produced nothing"

instance Exception IncorrectRpcResponse where
  displayException :: IncorrectRpcResponse -> String
displayException = IncorrectRpcResponse -> String
forall a b. (Buildable a, FromDoc b) => a -> b
pretty

data WaitForOperationError
  = WaitForOperationBlockout Word
  | WaitForOperationStreamingError Text
  deriving stock Int -> WaitForOperationError -> ShowS
[WaitForOperationError] -> ShowS
WaitForOperationError -> String
(Int -> WaitForOperationError -> ShowS)
-> (WaitForOperationError -> String)
-> ([WaitForOperationError] -> ShowS)
-> Show WaitForOperationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WaitForOperationError] -> ShowS
$cshowList :: [WaitForOperationError] -> ShowS
show :: WaitForOperationError -> String
$cshow :: WaitForOperationError -> String
showsPrec :: Int -> WaitForOperationError -> ShowS
$cshowsPrec :: Int -> WaitForOperationError -> ShowS
Show

instance Buildable WaitForOperationError where
  build :: WaitForOperationError -> Doc
build = \case
    WaitForOperationBlockout Word
n -> Doc
"Operation not included after " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Word
n Word -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" blocks"
    WaitForOperationStreamingError Text
s ->
      Doc
"Streaming error received waiting for operation: " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Text
s Text -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""

instance Exception WaitForOperationError where
  displayException :: WaitForOperationError -> String
displayException = WaitForOperationError -> String
forall a b. (Buildable a, FromDoc b) => a -> b
pretty