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

-- | This module contains various types which are used in @octez-node@ RPC API.
--
-- Documentation for RPC API can be found e. g. [here](http://tezos.gitlab.io/010/rpc.html)
-- (010 is the protocol, change to the desired one).
--
-- Note that errors are reported a bit inconsistently by RPC.
-- For more information see
-- [this question](https://tezos.stackexchange.com/q/2656/342)
-- and [this issue](https://gitlab.com/metastatedev/tezos/-/issues/150).


module Morley.Client.RPC.Types
  ( AppliedResult (..)
  , BlockConstants (..)
  , BlockHash (..)
  , BlockHeaderNoHash (..)
  , BlockHeader (..)
  , FeeConstants (..)
  , BlockId (..)
  , BlockOperation (..)
  , CommonOperationData (..)
  , DelegationOperation (..)
  , ForgeOperation (..)
  , GetBigMap (..)
  , CalcSize(..)
  , ScriptSize(..)
  , GetBigMapResult (..)
  , InternalOperation (..)
  , WithSource (..)
  , OperationContent (..)
  , OperationHash (..)
  , OperationInput
  , OperationResp (..)
  , OperationRespWithMeta (..)
  , OperationMetadata (..)
  , OperationResult (..)
  , OriginationOperation (..)
  , OriginationScript (..)
  , ParametersInternal (..)
  , PreApplyOperation (..)
  , ProtocolParameters (..)
  , RevealOperation (..)
  , RunCode (..)
  , RunCodeResult (..)
  , RunMetadata (..)
  , RunOperation (..)
  , RunOperationInternal (..)
  , RunOperationResult (..)
  , RPCInput
  , TransactionOperation (..)
  , TransferTicketOperation (..)
  , WithCommonOperationData (..)
  , EventOperation (..)
  , MonitorHeadsStep(..)
  , GetTicketBalance (..)
  , GetAllTicketBalancesResponse (..)
  , PackData(..)
  , PackDataResult(..)
  , mkCommonOperationData

  -- * Errors
  , RunError (..)
  , InternalError (..)

  -- * Prisms
  , _RuntimeError
  , _ScriptRejected
  , _BadContractParameter
  , _InvalidConstant
  , _InconsistentTypes
  , _InvalidPrimitive
  , _InvalidSyntacticConstantError
  , _InvalidExpressionKind
  , _InvalidContractNotation
  , _UnexpectedContract
  , _IllFormedType
  , _UnexpectedOperation
  , _REEmptyTransaction
  , _ScriptOverflow
  , _PreviouslyRevealedKey
  , _GasExhaustedOperation
  , _UnregisteredDelegate

  -- * Lenses
  , wcoCommonDataL
  ) where

import Control.Lens (makePrisms)
import Data.Aeson
  (FromJSON(..), Key, Object, ToJSON(..), Value(..), object, omitNothingFields, withObject,
  withText, (.!=), (.:), (.:?), (.=))
import Data.Aeson.Key qualified as Key (toText)
import Data.Aeson.TH (deriveFromJSON, deriveJSON, deriveToJSON)
import Data.Default (Default(..))
import Data.Fixed (Milli)
import Data.List (isSuffixOf)
import Data.Ratio ((%))
import Data.Text qualified as T
import Data.Time (UTCTime)
import Fmt
  (Buildable(..), blockListF, blockMapF, enumerateF', fillSepF', nameF, reflowF, unlinesF, (++|),
  (|++))
import Servant.API (ToHttpApiData(..))

import Data.Aeson.Types (Parser)
import Morley.Client.RPC.Aeson
import Morley.Client.Types
import Morley.Micheline
  (Expression, MichelinePrimAp(..), MichelinePrimitive(..), StringEncode(..), TezosBigNum,
  TezosInt64, TezosMutez(..), TezosNat, expressionPrim)
import Morley.Michelson.Text (MText)
import Morley.Tezos.Address
import Morley.Tezos.Core (Mutez, tz, zeroMutez)
import Morley.Tezos.Crypto
  (KeyHash, PublicKey, Signature, decodeBase58CheckWithPrefix, formatSignature)
import Morley.Util.CLI (HasCLReader(..), eitherReader)
import Morley.Util.MismatchError
import Morley.Util.Named
import Morley.Util.Text (dquotes)

mergeObjects :: HasCallStack => Value -> Value -> Value
mergeObjects (Object a) (Object b) = Object (a <> b)
mergeObjects (Object _) _ = error "Right part is not an Object"
mergeObjects _ _ = error "Left part is not an Object"

-- | Designates an input RPC data that we supply to perform an operation.
data RPCInput
instance OperationInfoDescriptor RPCInput where
  type TransferInfo RPCInput = TransactionOperation
  type TransferTicketInfo RPCInput = TransferTicketOperation
  type OriginationInfo RPCInput = OriginationOperation
  type RevealInfo RPCInput = RevealOperation
  type DelegationInfo RPCInput = DelegationOperation

type OperationInput = WithCommonOperationData (OperationInfo RPCInput)

data ForgeOperation = ForgeOperation
  { foBranch :: BlockHash
  , foContents :: NonEmpty OperationInput
  }

data RunOperationInternal = RunOperationInternal
  { roiBranch :: BlockHash
  , roiContents :: NonEmpty OperationInput
  , roiSignature :: Signature
  }

data RunOperation = RunOperation
  { roOperation :: RunOperationInternal
  , roChainId :: Text
  }

data PreApplyOperation = PreApplyOperation
  { paoProtocol :: Text
  , paoBranch :: BlockHash
  , paoContents :: NonEmpty OperationInput
  , paoSignature :: Signature
  }

data RunOperationResult = RunOperationResult
  { rrOperationContents :: NonEmpty OperationContent
  }

instance FromJSON RunOperationResult where
  parseJSON = withObject "preApplyRes" $ \o ->
    RunOperationResult <$> o .: "contents"

newtype OperationHash = OperationHash
  { unOperationHash :: Text
  }
  deriving stock (Eq, Show)
  deriving newtype (FromJSON, Buildable)

data OperationContent = OperationContent
  { ocOperation :: OperationResp WithSource
  , ocMetadata :: RunMetadata
  }

instance FromJSON OperationContent where
  parseJSON json = json & withObject "operationCostContent" \o ->
    OperationContent <$> parseJSON json <*> o .: "metadata"

data RunMetadata = RunMetadata
  { rmOperationResult :: OperationResult
  , rmInternalOperationResults :: [InternalOperation]
  }

instance FromJSON RunMetadata where
  parseJSON = withObject "metadata" $ \o ->
    RunMetadata <$> o .: "operation_result" <*>
    o .:? "internal_operation_results" .!= []

data InternalOperation = InternalOperation
  { ioData :: OperationResp WithSource
  , ioResult :: OperationResult
  }

instance FromJSON InternalOperation where
  parseJSON json = json & withObject "internal_operation" \o ->
    InternalOperation <$> parseJSON json <*> o .: "result"

data BlockConstants = BlockConstants
  { bcProtocol :: Text
  , bcChainId :: Text
  , bcHeader :: BlockHeaderNoHash
  , bcHash :: BlockHash
  }

data BlockHeaderNoHash = BlockHeaderNoHash
  { bhnhTimestamp :: UTCTime
  , bhnhLevel :: Int64
  , bhnhPredecessor :: BlockHash
  }

-- Consider merging this type with 'BlockHeaderNoHash' if it becomes larger (i. e.
-- if we need more data from it).
-- | The whole block header.
data BlockHeader = BlockHeader
  { bhTimestamp :: UTCTime
  , bhLevel :: Int64
  , bhPredecessor :: BlockHash
  , bhHash :: BlockHash
  }

newtype BlockHash = BlockHash { unBlockHash :: Text }
  deriving newtype (Eq, Ord, Show, Buildable, ToJSON, FromJSON, ToHttpApiData)

data FeeConstants = FeeConstants
  { fcBase :: Mutez
  , fcMutezPerGas :: Milli
  , fcMutezPerOpByte :: Milli
  }

-- | At the moment of writing, Tezos always uses these constants.
instance Default FeeConstants where
  def = FeeConstants
    { fcBase = [tz|100u|]
    , fcMutezPerGas = 0.1
    , fcMutezPerOpByte = 1
    }

-- | A block identifier as submitted to RPC.
--
-- A block can be referenced by @head@, @genesis@, level or block hash
data BlockId
  = HeadId
  -- ^ Identifier referring to the head block.
  | FinalHeadId
  -- ^ Identifier of the most recent block guaranteed to have been finalized.
  -- See: https://web.archive.org/web/20220305165609/https://tezos.gitlab.io/protocols/tenderbake.html#operations
  | GenesisId
  -- ^ Identifier referring to the genesis block.
  | LevelId Natural
  -- ^ Identifier referring to a block by its level.
  | BlockHashId BlockHash
  -- ^ Idenfitier referring to a block by its hash in Base58Check notation.
  | AtDepthId Natural
  -- ^ Identifier of a block at specific depth relative to @head@.
  deriving stock (Show, Eq)

instance ToHttpApiData BlockId where
  toUrlPiece = \case
    HeadId -> "head"
    FinalHeadId -> "head~2"
    GenesisId -> "genesis"
    LevelId x -> toUrlPiece x
    BlockHashId hash -> toUrlPiece hash
    AtDepthId depth -> "head~" <> toUrlPiece depth

instance Buildable BlockId where
  build = \case
    HeadId -> "head"
    FinalHeadId -> "head~2"
    GenesisId -> "genesis"
    LevelId x -> "block at level " <> build x
    BlockHashId hash -> "block with hash " <> build hash
    AtDepthId depth -> "block at depth " <> build depth

-- | Parse 'BlockId' in its textual representation in the same format as
-- submitted via RPC.
parseBlockId :: Text -> Maybe BlockId
parseBlockId t
  | t == "head" = Just HeadId
  | t == "head~2" = Just FinalHeadId
  | t == "genesis" = Just GenesisId
  | Right lvl <- readEither t = Just (LevelId lvl)
  | Just depthTxt <- "head~" `T.stripPrefix` t
  , Right depth <- readEither depthTxt = Just (AtDepthId depth)
  | Right _ <- decodeBase58CheckWithPrefix blockPrefix t = Just (BlockHashId (BlockHash t))
  | otherwise = Nothing

-- A magic prefix used by Tezos for block hashes
-- see https://gitlab.com/tezos/tezos/-/blob/v11-release/src/lib_crypto/base58.ml#L341
blockPrefix :: ByteString
blockPrefix = "\001\052"

instance HasCLReader BlockId where
  getReader = eitherReader parseBlockId'
    where
      parseBlockId' :: String -> Either String BlockId
      parseBlockId' =
        maybeToRight ("failed to parse block ID, try passing block's hash, level or 'head'") .
        parseBlockId . toText
  getMetavar = "BLOCK_ID"

-- | Protocol-wide constants.
--
-- There are more constants, but currently, we are using only these
-- in our code.
data ProtocolParameters = ProtocolParameters
  { ppOriginationSize :: Int
  -- ^ Byte size cost for originating new contract.
  , ppHardGasLimitPerOperation :: TezosInt64
  -- ^ Gas limit for a single operation.
  , ppHardStorageLimitPerOperation :: TezosInt64
  -- ^ Storage limit for a single operation.
  , ppMinimalBlockDelay :: TezosNat
  -- ^ Minimal delay between two blocks, this constant is new in V010.
  , ppCostPerByte :: TezosMutez
  -- ^ Burn cost per storage byte
  , ppHardGasLimitPerBlock :: TezosInt64
  -- ^ Gas limit for a single block.
  }

-- | Details of a @BadStack@ error.
data BadStackInformation = BadStackInformation
  { bsiLocation :: Int
  , bsiStackPortion :: Int
  , bsiPrim :: Text
  , bsiStack :: Expression
  } deriving stock (Eq, Show)

instance FromJSON BadStackInformation where
  parseJSON = withObject "BadStack" $ \o -> BadStackInformation
    <$> o .: "location"
    <*> o .: "relevant_stack_portion"
    <*> o .: "primitive_name"
    <*> o .: "wrong_stack_type"

instance Buildable BadStackInformation where
  build (BadStackInformation loc stack_portion prim stack_type) =
    "Bad Stack in location" ++| loc |++ "stack portion" ++| stack_portion |++
    "on primitive" ++| prim |++ "with (wrong) stack type" ++| stack_type |++ ""

-- | Errors that are sent as part of operation result in an OK
-- response (status 200). They are semi-formally defined as errors
-- that can happen when a contract is executed and something goes
-- wrong.
data RunError
  = RuntimeError ContractAddress
  | ScriptRejected Expression
  | BadContractParameter Address
  | InvalidConstant Expression Expression
  | InvalidContract Address
  | InconsistentTypes Expression Expression
  | InvalidPrimitive [Text] Text
  | InvalidSyntacticConstantError Expression Expression
  | InvalidExpressionKind [Text] Text
  | InvalidContractNotation Text
  | UnexpectedContract
  | IllFormedType Expression
  | UnexpectedOperation
  | REEmptyTransaction
    -- ^ Transfer of 0 to an implicit account.
      ImplicitAddress -- ^ Receiver address.
  | ScriptOverflow
    -- ^ A contract failed due to the detection of an overflow.
    -- It seems to happen if a too big value is passed to shift instructions
    -- (as second argument).
  | GasExhaustedOperation
  | MutezAdditionOverflow [TezosInt64]
  | MutezSubtractionUnderflow [TezosInt64]
  | MutezMultiplicationOverflow TezosInt64 TezosInt64
  | CantPayStorageFee
  | BalanceTooLow ("balance" :! Mutez) ("required" :! Mutez)
  | PreviouslyRevealedKey ImplicitAddress
  | NonExistingContract Address
  | InvalidB58Check Text
  | UnregisteredDelegate ImplicitAddress
  | FailedUnDelegation ImplicitAddress
  | DelegateAlreadyActive
  | IllTypedContract Expression
  | IllTypedData Expression Expression
  | BadStack BadStackInformation
  | ForbiddenZeroAmountTicket
  | REEmptyImplicitContract ImplicitAddress
  deriving stock Show

instance FromJSON RunError where
  parseJSON = withObject "preapply error" $ \o -> do
    id' <- o .: "id"
    decode id'
      [ "runtime_error" ~> RuntimeError <$> o .: "contract_handle"
      , "script_rejected" ~> ScriptRejected <$> o .: "with"
      , "bad_contract_parameter" ~> BadContractParameter <$> o .: "contract"
      , "invalid_constant" ~> InvalidConstant <$> o .: "expected_type" <*> o .: "wrong_expression"
      , "invalid_contract" ~> InvalidContract <$> o .: "contract"
      , "inconsistent_types" ~> InconsistentTypes <$> o .: "first_type" <*> o .: "other_type"
      , "invalid_primitive" ~>
          InvalidPrimitive <$> o .: "expected_primitive_names" <*> o .: "wrong_primitive_name"
      , "invalidSyntacticConstantError" ~>
          InvalidSyntacticConstantError <$> o .: "expectedForm" <*> o .: "wrongExpression"
      , "invalid_expression_kind" ~>
          InvalidExpressionKind <$> o .: "expected_kinds" <*> o .: "wrong_kind"
      , "invalid_contract_notation" ~> InvalidContractNotation <$> o .: "notation"
      , "unexpected_contract" ~> pure UnexpectedContract
      , "ill_formed_type" ~> IllFormedType <$> o .: "ill_formed_expression"
      , "unexpected_operation" ~> pure UnexpectedOperation
      , "empty_transaction" ~> REEmptyTransaction <$> o .: "contract"
      , "script_overflow" ~> pure ScriptOverflow
      , "gas_exhausted.operation" ~> pure GasExhaustedOperation
      , "tez.addition_overflow" ~> MutezAdditionOverflow <$> o .: "amounts"
      , "tez.subtraction_underflow" ~> MutezSubtractionUnderflow <$> o .: "amounts"
      , "tez.multiplication_overflow" ~>
          MutezMultiplicationOverflow <$> o .: "amount" <*> o .: "multiplicator"
      , "cannot_pay_storage_fee" ~> pure CantPayStorageFee
      , "balance_too_low" ~> do
          balance <- unTezosMutez <$> o .: "balance"
          amount  <- unTezosMutez <$> o .: "amount"
          return $ BalanceTooLow (#balance :! balance) (#required :! amount)
      , "previously_revealed_key" ~> PreviouslyRevealedKey <$> o .: "contract"
      , "non_existing_contract" ~> NonExistingContract <$> o .: "contract"
      , "invalid_b58check" ~> InvalidB58Check <$> o .: "input"
      , "unregistered_delegate" ~> UnregisteredDelegate <$> o .: "hash"
      , "no_deletion" ~> FailedUnDelegation <$> o .: "delegate"
      , "delegate.already_active" ~> pure DelegateAlreadyActive
      , "empty_implicit_contract" ~> REEmptyImplicitContract <$> o .: "implicit"
      , "ill_typed_contract" ~> IllTypedContract <$> o .: "ill_typed_code"
      , "ill_typed_data" ~> IllTypedData <$> o .: "expected_type" <*> o .: "ill_typed_expression"
      , "bad_stack" ~> BadStack <$> parseJSON (Object o)
      , "forbidden_zero_amount_ticket" ~> pure ForbiddenZeroAmountTicket
      ]
    where
      infix 0 ~>
      (~>) = (,)
      decode x xs = fromMaybe (fail $ "unknown id: " <> x) $
        snd <$> find (\(k, _) -> ('.' : k) `isSuffixOf` x) xs

instance Buildable RunError where
  build = \case
    RuntimeError addr -> nameF "Runtime error for contract" addr
    ScriptRejected expr -> nameF "Script rejected with:" expr
    BadContractParameter addr -> nameF "Bad contract parameter for" addr
    InvalidConstant expectedType expr -> unlinesF
      [ nameF "Invalid type" expectedType
      , nameF "For" expr
      ]
    InvalidContract addr -> nameF "Invalid contract" addr
    InconsistentTypes type1 type2 ->
      nameF "Inconsistent types" $ MkMismatchError type1 type2
    InvalidPrimitive expectedPrimitives wrongPrimitive -> unlinesF
      [ nameF "Invalid primitive" wrongPrimitive
      , nameF "Expecting one of" $ fillSepF' "," expectedPrimitives
      ]
    InvalidSyntacticConstantError expectedForm wrongExpression ->
      nameF "Invalid syntatic constant error" $ MkMismatchError
        { meExpected = expectedForm, meActual = wrongExpression }
    InvalidExpressionKind expectedKinds wrongKind ->
      nameF "Invalid expression kind" $ MkMismatchError
        { meExpected = fillSepF' "," expectedKinds, meActual = build wrongKind }
    InvalidContractNotation notation -> nameF "Invalid contract notation" notation
    UnexpectedContract -> reflowF
      "When parsing script, a contract type was found in \
      \the storage or parameter field."
    IllFormedType expr -> nameF "Ill formed type" expr
    UnexpectedOperation -> reflowF
      "When parsing script, an operation type was found in \
      \the storage or parameter field"
    REEmptyTransaction addr ->
      "It's forbidden to send 0ꜩ to " ++| addr |++ " that has no code"
    ScriptOverflow -> reflowF
      "A contract failed due to the detection of an overflow"
    GasExhaustedOperation -> reflowF
      "Contract failed due to gas exhaustion"
    MutezAdditionOverflow amounts -> nameF
      (reflowF "A contract failed due to mutez addition overflow when adding following values")
      $ fillSepF' "," amounts
    MutezSubtractionUnderflow amounts -> nameF
      (reflowF "A contract failed due to mutez subtraction underflow when subtracting following values")
      $ fillSepF' "," amounts
    MutezMultiplicationOverflow amount multiplicator ->
      "A contract failed due to mutez multiplication overflow when multiplying" ++|
      amount |++ "by" ++| multiplicator |++ ""
    CantPayStorageFee -> reflowF
      "Balance is too low to pay storage fee"
    BalanceTooLow (arg #balance -> balance) (arg #required -> required) ->
      nameF "Balance is too low" $ blockMapF @Text
        [ ("current balance:", balance)
        , ("required balance:", required)
        ]
    PreviouslyRevealedKey addr -> "Key for " ++| addr |++ " has already been revealed"
    NonExistingContract addr -> nameF "Contract is not registered" addr
    InvalidB58Check input ->
      "Failed to read a valid b58check_encoding data from" ++| dquotes input |++ ""
    UnregisteredDelegate addr ->
      "" ++| addr |++ " is not registered as delegate"
    FailedUnDelegation addr ->
      "Failed to withdraw delegation for" ++| addr |++ ""
    DelegateAlreadyActive -> reflowF "Delegate already active"
    REEmptyImplicitContract addr -> nameF "Empty implicit contract" addr
    IllTypedContract expr -> nameF "Ill typed contract" expr
    IllTypedData expected ill_typed ->
      nameF "Ill typed data" $ blockMapF @Text
        [ ("Expected type", build expected)
        , ("Ill typed expression", build ill_typed)
        ]
    BadStack info -> build info
    ForbiddenZeroAmountTicket -> "Forbidden zero amount ticket"

-- | Errors that are sent as part of an "Internal Server Error"
-- response (HTTP code 500).
--
-- We call them internal because of the HTTP code, but we shouldn't
-- treat them as internal. They can be easily triggered by making a
-- failing operation.
data InternalError
  = CounterInThePast
    -- ^ An operation assumed a contract counter in the past.
      ImplicitAddress -- ^ Address whose counter is invalid.
      ("expected" :! Word) -- ^ Expected counter.
      ("found" :! Word) -- ^ Found counter.
  | UnrevealedKey
    -- ^ One tried to apply a manager operation without revealing
    -- the manager public key.
      ImplicitAddress -- ^ Manager address.
  | Failure Text
    -- ^ Failure reported without specific id
  deriving stock Show

instance Buildable InternalError where
  build = \case
    CounterInThePast addr (arg #expected -> expected) (arg #found -> found) ->
      "Expected counter" ++| expected |++ "for" ++| addr |++ "but got:" ++| found |++ ""
    UnrevealedKey addr ->
      "One tried to apply a manager operation without revealing " <>
      "the manager public key of " ++| addr |++ ""
    Failure msg -> nameF (reflowF "Contract failed with the following message") msg

instance FromJSON InternalError where
  parseJSON = withObject "internal error" $ \o ->
    o .: "id" >>= \case
      x | ".counter_in_the_past" `isSuffixOf` x ->
          CounterInThePast <$> o .: "contract" <*>
            (#expected <:!> parseCounter o "expected") <*>
            (#found <:!> parseCounter o "found")
      x | ".unrevealed_key" `isSuffixOf` x ->
          UnrevealedKey <$> o .: "contract"
      "failure" -> Failure <$> o .: "msg"
      x -> fail ("unknown id: " <> x)
    where
      parseCounter :: Object -> Key -> Parser Word
      parseCounter o fieldName = do
        fieldValue <- o .: fieldName
        let mCounter = fromIntegralMaybe fieldValue
        maybe (fail $ mkErrorMsg (Key.toText fieldName) fieldValue) pure mCounter

      mkErrorMsg :: Text -> TezosInt64 -> String
      mkErrorMsg fieldName fieldValue = toString $ unwords
        ["Invalid", dquotes fieldName, "counter:", show $ unStringEncode fieldValue]

data OperationResult
  = OperationApplied AppliedResult
  | OperationFailed [RunError]

data AppliedResult = AppliedResult
  { arConsumedMilliGas :: TezosInt64
  , arStorageSize :: TezosInt64
  , arPaidStorageDiff :: TezosInt64
  , arOriginatedContracts :: [ContractAddress]
  , arAllocatedDestinationContracts :: TezosInt64
  -- ^ We need to count number of destination contracts that are new
  -- to the chain in order to calculate proper storage_limit
  }
  deriving stock Show

instance Semigroup AppliedResult where
  (<>) ar1 ar2 = AppliedResult
    { arConsumedMilliGas = arConsumedMilliGas ar1 + arConsumedMilliGas ar2
    , arStorageSize = arStorageSize ar1 + arStorageSize ar2
    , arPaidStorageDiff = arPaidStorageDiff ar1 + arPaidStorageDiff ar2
    , arOriginatedContracts = arOriginatedContracts ar1 <> arOriginatedContracts ar2
    , arAllocatedDestinationContracts =
      arAllocatedDestinationContracts ar1 + arAllocatedDestinationContracts ar2
    }

instance Monoid AppliedResult where
  mempty = AppliedResult 0 0 0 [] 0

instance FromJSON OperationResult where
  parseJSON = withObject "operation_costs" $ \o -> do
    status <- o .: "status"
    case status of
      "applied" -> OperationApplied <$> do
        arConsumedMilliGas <- o .: "consumed_milligas"
        arStorageSize <- o .:? "storage_size" .!= 0
        arPaidStorageDiff <- o .:? "paid_storage_size_diff" .!= 0
        arOriginatedContracts <- o .:? "originated_contracts" .!= []
        allocatedFlag <- o .:? "allocated_destination_contract" .!= False
        let arAllocatedDestinationContracts = if allocatedFlag then 1 else 0
        return AppliedResult{..}
      "failed" -> OperationFailed <$> o .: "errors"
      "backtracked" ->
        OperationFailed <$> o .:? "errors" .!= []
      "skipped" ->
        OperationFailed <$> o .:? "errors" .!= []
      _ -> fail ("unexpected status " ++ status)

data ParametersInternal = ParametersInternal
  { piEntrypoint :: Text
  , piValue :: Expression
  } deriving stock (Generic, Show)
    deriving (FromJSON, ToJSON) via ClientJSON ParametersInternal

instance Buildable ParametersInternal where
  build ParametersInternal{..} =
    "entrypoint:" ++| (build piEntrypoint <> ",") |++ "value:" ++| piValue |++ ""

-- | 'ParametersInternal' can be missing when default entrypoint is called with
-- Unit value. Usually it happens when destination is an implicit account.
-- In our structures 'ParametersInternal' is not optional because missing
-- case is equivalent to explicit calling of @default@ with @Unit@.
defaultParametersInternal :: ParametersInternal
defaultParametersInternal = ParametersInternal
  { piEntrypoint = "default"
  , piValue = expressionPrim MichelinePrimAp
    { mpaPrim = Prim_Unit
    , mpaArgs = []
    , mpaAnnots = []
    }
  }

-- | Data that is common for transaction and origination
-- operations.
data CommonOperationData = CommonOperationData
  { codSource :: ImplicitAddress
  , codFee :: TezosMutez
  , codCounter :: TezosInt64
  , codGasLimit :: TezosInt64
  , codStorageLimit :: TezosInt64
  }

-- | Create 'CommonOperationData' based on current blockchain protocol parameters
-- and sender info. This data is used for operation simulation.
--
-- @num_operations@ parameter can be used for smarter gas limit estimation. If
-- 'Nothing', the gas limit is set to 'ppHardGasLimitPerOperation', but that
-- puts a hard low limit on the number of operations that will fit into one
-- batch. If @num_operations@ is set, then gas limit is estimated as
--
-- \[
-- \mathrm{min}\left(\mathbf{hard\_gas\_limit\_per\_operation},
-- \left\lfloor \frac{\mathbf{hard\_gas\_limit\_per\_block}}
-- {num\_operations}\right\rfloor\right)
-- \]
--
-- This works well enough for the case of many small operations, but will break
-- when there is one big one and a lot of small ones. That said, specifying
-- @num_operations@ will work in all cases where not specifying it would, and
-- then some, so it's recommended to specify it whenever possible.
--
-- @num_operations@ is assumed to be greater than @0@, otherwise it'll be
-- silently ignored.
--
-- Fee isn't accounted during operation simulation, so it's safe to use zero amount.
-- Real operation fee is calculated later using @octez-client@.
mkCommonOperationData
  :: ProtocolParameters
  -> "sender" :! ImplicitAddress
  -> "counter" :! TezosInt64
  -> "num_operations" :? Int64
  -> CommonOperationData
mkCommonOperationData ProtocolParameters{..} source counter mNumOp =
  CommonOperationData
    { codSource = arg #sender source
    , codFee = TezosMutez zeroMutez
    , codCounter = arg #counter counter
    , codGasLimit = estGasLimitPerOperation
    , codStorageLimit = ppHardStorageLimitPerOperation
    }
  where
    estGasLimitPerOperation
      | Just numOp <- argF #num_operations mNumOp
      , numOp > 0
      = StringEncode $
          min (unStringEncode ppHardGasLimitPerOperation) $ floor $
            unStringEncode ppHardGasLimitPerBlock % numOp
      | otherwise = ppHardGasLimitPerOperation

instance ToJSON CommonOperationData where
  toJSON CommonOperationData{..} = object
    [ "source" .= codSource
    , "fee" .= codFee
    , "counter" .= codCounter
    , "gas_limit" .= codGasLimit
    , "storage_limit" .= codStorageLimit
    ]

instance FromJSON CommonOperationData where
  parseJSON = withObject "common operation data" $ \o -> do
    codSource <- o .: "source"
    codFee <- o .: "fee"
    codCounter <- o .: "counter"
    codGasLimit <- o .: "gas_limit"
    codStorageLimit <- o .: "storage_limit"
    pure CommonOperationData {..}

-- | Some operation data accompanied with common data.
data WithCommonOperationData a = WithCommonOperationData
  { wcoCommon :: CommonOperationData
  , wcoCustom :: a
  }

instance ToJSONObject a => ToJSON (WithCommonOperationData a) where
  toJSON (WithCommonOperationData common custom) =
    toJSON common `mergeObjects` toJSON custom

instance FromJSON a => FromJSON (WithCommonOperationData a) where
  parseJSON v = WithCommonOperationData <$> parseJSON v <*> parseJSON v

data WithSource a = WithSource
  { wsSource :: Address
  , wsOtherData :: a
  } deriving stock (Show, Functor)

instance FromJSON a => FromJSON (WithSource a) where
  parseJSON v = v & withObject "WithSource" \o ->
    WithSource <$> (o .: "source") <*> parseJSON v

instance Buildable a => Buildable (WithSource a) where
  build WithSource{..} = "" ++| (build wsOtherData <> ",") |++ "and source" ++| wsSource |++ ""

-- | All the data needed to perform a transaction through
-- Tezos RPC interface.
-- For additional information, please refer to RPC documentation
-- http://tezos.gitlab.io/api/rpc.html
data TransactionOperation = TransactionOperation
  { toAmount :: TezosMutez
  , toDestination :: Address
  , toParameters :: ParametersInternal
  } deriving stock Show

instance Buildable TransactionOperation where
  build TransactionOperation{..} = enumerateF' ","
    [ ("Transaction with amount:", build $ unTezosMutez toAmount)
    , ("destination:", build toDestination)
    , ("and parameter:", build toParameters)
    ]

data TransferTicketOperation = TransferTicketOperation
  { ttoTicketContents :: Expression
  , ttoTicketTy :: Expression
  , ttoTicketTicketer :: Address
  , ttoTicketAmount :: TezosNat
  , ttoDestination :: Address
  , ttoEntrypoint :: Text
  } deriving stock (Show)

instance Buildable TransferTicketOperation where
  build TransferTicketOperation{..} =
    nameF "Transfer ticket with" $ blockListF
      [ nameF "Contents" $ build ttoTicketContents
      , nameF "Type" $ build ttoTicketTy
      , nameF "Ticketer" $ build ttoTicketTicketer
      , nameF "Amount" $ build ttoTicketAmount
      , nameF "Destination" $ build ttoDestination
      , nameF "Entrypoint" $ build ttoEntrypoint
      ]

data OriginationScript = OriginationScript
  { osCode :: Expression
  , osStorage :: Expression
  } deriving stock (Generic, Show)
    deriving (FromJSON, ToJSON) via ClientJSON OriginationScript

-- | All the data needed to perform contract origination
-- through Tezos RPC interface
data OriginationOperation = OriginationOperation
  { ooBalance :: TezosMutez
  , ooDelegate :: Maybe KeyHash
  , ooScript :: OriginationScript
  } deriving stock (Generic, Show)
    deriving (FromJSON) via ClientJSON OriginationOperation
    deriving anyclass ToJSONObject

instance Buildable OriginationOperation where
  build OriginationOperation{..} =
    "Origination operation with balance " ++| (build (unTezosMutez ooBalance) <> ",")
      |++ "delegate" ++| ooDelegate |++ ""

instance ToJSON OriginationOperation where
  toJSON OriginationOperation{..} = object $
    [ "kind" .= String "origination"
    , "balance" .= ooBalance
    , "script" .= ooScript
    ] <> maybeToList (("delegate" .=) <$> ooDelegate)

-- | All the data needed to perform key revealing
-- through Tezos RPC interface
data RevealOperation = RevealOperation
  { roPublicKey :: PublicKey
  } deriving stock (Generic, Show)
    deriving anyclass ToJSONObject
    deriving FromJSON via ClientJSON RevealOperation

instance ToJSON RevealOperation where
  toJSON RevealOperation{..} = object $
    [ "kind" .= String "reveal"
    , "public_key" .= roPublicKey
    ]

instance Buildable RevealOperation where
  build (RevealOperation pk) = "Reveal operation for public key" ++| pk |++ ""

data DelegationOperation = DelegationOperation
  { doDelegate :: Maybe KeyHash
    -- ^ 'Nothing' removes delegate, 'Just' sets it
  } deriving stock (Generic, Show)
    deriving FromJSON via ClientJSON DelegationOperation
    deriving anyclass ToJSONObject

instance ToJSON DelegationOperation where
  toJSON DelegationOperation{..} = object $
    [ "kind" .= String "delegation" ]
    <> maybeToList (("delegate" .=) <$> doDelegate)

instance Buildable DelegationOperation where
  build DelegationOperation{..} = case doDelegate of
    Nothing -> reflowF "Delegation operation removing delegate"
    Just kh -> "Delegation operation setting delegate to" ++| kh |++ ""

data EventOperation = EventOperation
  { eoType :: Expression
  , eoTag :: Maybe MText
  , eoPayload :: Maybe Expression
  } deriving stock (Generic, Show)
    deriving anyclass ToJSONObject
    deriving (ToJSON, FromJSON) via ClientJSON EventOperation

instance Buildable EventOperation where
  build EventOperation{..} = enumerateF' ","
    [ ("Contract event with tag:", build eoTag)
    , ("type:", build eoType)
    , ("and payload:", build eoPayload)
    ]

-- | @$operation@ in Tezos docs.
data BlockOperation = BlockOperation
  { boHash :: Text
  , boContents :: [OperationRespWithMeta]
  }

-- | Contents of an operation that can appear in RPC responses.
data OperationResp f
  = TransactionOpResp (f TransactionOperation)
  -- ^ Operation with kind @transaction@.
  | TransferTicketOpResp (f TransferTicketOperation)
  -- ^ Operation with kind @transfer_ticket@.
  | OriginationOpResp (f OriginationOperation)
  -- ^ Operation with kind @origination@.
  | DelegationOpResp (f DelegationOperation)
  -- ^ Operation with kind @delegation@.
  | RevealOpResp (f RevealOperation)
  -- ^ Operation with kind @reveal@.
  | EventOpResp (f EventOperation)
  -- ^ Operation with kind @event@.
  | OtherOpResp Text
  -- ^ Response we don't handle yet.

deriving stock instance (forall a. Show a => Show (f a)) => Show (OperationResp f)

instance (forall a. Buildable a => Buildable (f a)) => Buildable (OperationResp f) where
  build = \case
    TransactionOpResp x -> build x
    TransferTicketOpResp x -> build x
    OriginationOpResp x -> build x
    DelegationOpResp x -> build x
    RevealOpResp x -> build x
    EventOpResp x -> build x
    OtherOpResp x -> "Unsupported operation kind: " <> build x

data OperationRespWithMeta = OperationRespWithMeta
  { orwmResponse :: OperationResp WithCommonOperationData
  , orwmMetadata :: Maybe OperationMetadata
  }

newtype OperationMetadata = OperationMetadata { unOperationMetadata :: Maybe OperationResult }

instance FromJSON OperationMetadata where
  parseJSON = withObject "operationMetadata" $ \o ->
    OperationMetadata <$> o .:? "operation_result"

data GetBigMap = GetBigMap
  { bmKey :: Expression
  , bmType :: Expression
  }

data GetBigMapResult
  = GetBigMapResult Expression
  | GetBigMapNotFound

-- | Data required for calling @run_code@ RPC endpoint.
data RunCode = RunCode
  { rcScript :: Expression
  , rcStorage :: Expression
  , rcInput :: Expression
  , rcAmount :: TezosMutez
  , rcBalance :: TezosMutez
  , rcChainId :: Text
  , rcNow :: Maybe TezosNat
  , rcLevel :: Maybe TezosNat
  , rcSource :: Maybe ImplicitAddress
  , rcPayer :: Maybe ImplicitAddress
  }

data GetTicketBalance = GetTicketBalance
  { gtbTicketer :: ContractAddress
  , gtbContentType :: Expression
  , gtbContent :: Expression
  }

data GetAllTicketBalancesResponse = GetAllTicketBalancesResponse
  { gatbrTicketer :: ContractAddress
  , gatbrContentType :: Expression
  , gatbrContent :: Expression
  , gatbrAmount :: TezosNat
  }

-- | Result storage of @run_code@ RPC endpoint call.
--
-- Actual resulting JSON has more contents, but currently we're interested
-- only in resulting storage.
data RunCodeResult = RunCodeResult
  { rcrStorage :: Expression
  }

newtype ScriptSize = ScriptSize { ssScriptSize :: Natural }

data CalcSize = CalcSize
  { csProgram :: Expression
  , csStorage :: Expression
  , csGas     :: TezosInt64
  , csLegacy  :: Bool
  }

data MonitorHeadsStep a = MonitorHeadsStop a | MonitorHeadsContinue

instance ToJSON TransactionOperation where
  toJSON TransactionOperation{..} = object $
    [ "kind" .= String "transaction"
    , "amount" .= toAmount
    , "destination" .= toDestination
    , "parameters" .= toParameters
    ]
instance ToJSONObject TransactionOperation

instance ToJSON TransferTicketOperation where
  toJSON TransferTicketOperation{..} = object $
    [ "kind" .= String "transfer_ticket"
    , "ticket_contents" .= ttoTicketContents
    , "ticket_ty"       .= ttoTicketTy
    , "ticket_ticketer" .= ttoTicketTicketer
    , "ticket_amount"   .= ttoTicketAmount
    , "destination"     .= ttoDestination
    , "entrypoint"      .= ttoEntrypoint
    ]
instance ToJSONObject TransferTicketOperation

instance FromJSON TransactionOperation where
  parseJSON = withObject "TransactionOperation" $ \obj -> do
    toAmount <- obj .: "amount"
    toDestination <- obj .: "destination"
    toParameters <- fromMaybe defaultParametersInternal <$> obj .:? "parameters"
    pure TransactionOperation {..}

instance (forall a. FromJSON a => FromJSON (f a)) => FromJSON (OperationResp f) where
  parseJSON json = json & withObject "OperationResp" \obj -> do
    kind :: Text <- obj .: "kind"
    case kind of
      "transaction" -> TransactionOpResp <$> parseJSON json
      "origination" -> OriginationOpResp <$> parseJSON json
      "delegation"  -> DelegationOpResp <$> parseJSON json
      "event"  -> EventOpResp <$> parseJSON json
      x -> pure $ OtherOpResp x

instance FromJSON OperationRespWithMeta where
  parseJSON = withObject "OperationRespWithMeta" $ \obj -> do
    OperationRespWithMeta <$> parseJSON (Object obj) <*> obj .:? "metadata"

instance ToJSON ForgeOperation where
  toJSON ForgeOperation{..} = object
    [ "branch" .= unBlockHash foBranch
    , "contents" .= foContents
    ]

instance ToJSON RunOperationInternal where
  toJSON RunOperationInternal{..} = object
    [ "branch" .= unBlockHash roiBranch
    , "contents" .= roiContents
    , "signature" .= roiSignature
    ]

instance ToJSON PreApplyOperation where
  toJSON PreApplyOperation{..} = object
    [ "branch" .= unBlockHash paoBranch
    , "contents" .= paoContents
    , "protocol" .= paoProtocol
    , "signature" .= formatSignature paoSignature
    ]

data PackData = PackData
  { pdData :: Expression
  , pdType :: Expression
  , pdGas :: Maybe TezosBigNum
  }

instance Buildable PackData where
  build PackData{..} = enumerateF' "," $
    [ ("Pack data request with data:", build pdData)
    , ("type:", build pdType)
    ] <> maybeToList (("gas:",) . build . unStringEncode <$> pdGas)

data PackDataResult = PackDataResult
  { pdrPacked :: Text
  , pdrGas :: PackDataResultGas
  }

newtype PackDataResultGas = PackDataResultGas (Maybe TezosBigNum)

instance FromJSON PackDataResultGas where
  parseJSON o = o & withText "PackDataResultGas" \case
    "unaccounted" -> pure $ PackDataResultGas Nothing
    _ -> PackDataResultGas . Just <$> parseJSON o

instance Buildable PackDataResultGas where
  build (PackDataResultGas x) = maybe "unaccounted" (build . unStringEncode) x

instance Buildable PackDataResult where
  build PackDataResult{..} = enumerateF' ","
    [ ("Pack data response packed data:", build pdrPacked)
    , ("gas:", build pdrGas)
    ]

deriveToJSON morleyClientAesonOptions ''RunOperation
deriveToJSON morleyClientAesonOptions ''GetBigMap
deriveToJSON morleyClientAesonOptions ''GetTicketBalance
deriveToJSON morleyClientAesonOptions ''CalcSize
deriveToJSON morleyClientAesonOptions{omitNothingFields = True} ''RunCode
deriveFromJSON morleyClientAesonOptions ''GetAllTicketBalancesResponse
deriveFromJSON morleyClientAesonOptions ''BlockHeaderNoHash
deriveFromJSON morleyClientAesonOptions ''ScriptSize
deriveFromJSON morleyClientAesonOptions ''BlockConstants
deriveJSON morleyClientAesonOptions ''BlockHeader
deriveFromJSON morleyClientAesonOptions ''ProtocolParameters
deriveFromJSON morleyClientAesonOptions ''BlockOperation
deriveFromJSON morleyClientAesonOptions ''RunCodeResult
deriveToJSON morleyClientAesonOptions{omitNothingFields = True} ''PackData
deriveFromJSON morleyClientAesonOptions ''PackDataResult

instance FromJSON GetBigMapResult where
  parseJSON v = maybe GetBigMapNotFound GetBigMapResult <$> parseJSON v

makePrisms ''RunError

wcoCommonDataL :: Lens' (WithCommonOperationData a) CommonOperationData
wcoCommonDataL = \f (WithCommonOperationData com cust) ->
  (`WithCommonOperationData` cust) <$> f com