Getters.hs

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

-- | Some read-only actions (wrappers over RPC calls).

module Morley.Client.RPC.Getters
  ( ValueDecodeFailure (..)
  , ValueNotFound (..)

  , readAllBigMapValues
  , readAllBigMapValuesMaybe
  , readContractBigMapValue
  , readBigMapValueMaybe
  , readBigMapValue
  , getContract
  , getImplicitContractCounter
  , getContractsParameterTypes
  , getContractStorage
  , getScriptSize
  , getBigMapValue
  , getBigMapValues
  , getHeadBlock
  , getCounter
  , getProtocolParameters
  , runOperation
  , preApplyOperations
  , forgeOperation
  , getContractScript
  , getContractBigMap
  , getBalance
  , getDelegate
  , runCode
  , getManagerKey
  , contractStateResolver
  , getTicketBalance
  , getAllTicketBalances
  ) where

import Data.Map as Map (fromList)
import Data.Singletons (demote)
import Fmt (Buildable(..), pretty, (+|), (|+))
import Network.HTTP.Types.Status (statusCode)
import Servant.Client (ClientError(..), responseStatusCode)

import Lorentz (NicePackedValue, NiceUnpackedValue, valueToScriptExpr)
import Lorentz.Value
import Morley.Micheline
import Morley.Michelson.Runtime.GState (ContractState(..))
import Morley.Michelson.TypeCheck (typeCheckContract, typeCheckingWith)
import Morley.Michelson.TypeCheck.TypeCheck
  (SomeParamType(..), TcOriginatedContracts, mkSomeParamType)
import Morley.Michelson.Typed
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Crypto (encodeBase58Check)
import Morley.Util.ByteString
import Morley.Util.Exception (throwLeft)

import Morley.Client.RPC.Class
import Morley.Client.RPC.Types

data ContractGetCounterAttempt = ContractGetCounterAttempt ContractAddress
  deriving stock (Show)
instance Exception ContractGetCounterAttempt
instance Buildable ContractGetCounterAttempt where
  build (ContractGetCounterAttempt addr) =
    "Failed to get counter of contract '" <> build addr <> "', " <>
    "this operation is allowed only for implicit contracts"

-- | Failed to decode received value to the given type.
data ValueDecodeFailure = ValueDecodeFailure Text T
  deriving stock (Show)
instance Exception ValueDecodeFailure
instance Buildable ValueDecodeFailure where
  build (ValueDecodeFailure desc ty) =
    "Failed to decode value with expected type " <> build ty <> " \
    \for '" <> build desc <> "'"

data ValueNotFound = ValueNotFound
  deriving stock (Show)
instance Exception ValueNotFound
instance Buildable ValueNotFound where
  build ValueNotFound =
    "Value with such coordinates is not found in contract big maps"

-- | Read big_map value of given contract by key.
--
-- If the contract contains several @big_map@s with given key type, only one
-- of them will be considered.
readContractBigMapValue
  :: forall k v m.
     (PackedValScope k, HasTezosRpc m, SingI v)
  => ContractAddress -> Value k -> m (Value v)
readContractBigMapValue contract key = do
  let
    req = GetBigMap
      { bmKey = toExpression key
      , bmType = toExpression (demote @k)
      }
  res <- getContractBigMap contract req >>= \case
    GetBigMapResult res -> pure res
    GetBigMapNotFound -> throwM ValueNotFound
  fromExpression res
    & either (const $ throwM $ ValueDecodeFailure "big map value" (demote @k)) pure

-- | Read big_map value, given it's ID and a key.
-- If the value is not of the expected type, a 'ValueDecodeFailure' will be thrown.
--
-- Returns 'Nothing' if a big_map with the given ID does not exist,
-- or it does exist but does not contain the given key.
readBigMapValueMaybe
  :: forall v k m.
     (NicePackedValue k, NiceUnpackedValue v, HasTezosRpc m)
  => BigMapId k v -> k -> m (Maybe v)
readBigMapValueMaybe bigMapId key =
  handleStatusCode 404
    (pure Nothing)
    (Just <$> readBigMapValue bigMapId key)

-- | Read big_map value, given it's ID and a key.
-- If the value is not of the expected type, a 'ValueDecodeFailure' will be thrown.
readBigMapValue
  :: forall v k m.
     (NicePackedValue k, NiceUnpackedValue v, HasTezosRpc m)
  => BigMapId k v -> k -> m v
readBigMapValue (BigMapId bigMapId) key =
  getBigMapValue bigMapId scriptExpr >>= \expr ->
    case fromVal <$> fromExpression expr of
      Right v -> pure v
      Left _ -> throwM $ ValueDecodeFailure "big map value" (demote @(ToT k))
  where
    scriptExpr = encodeBase58Check $ valueToScriptExpr key

-- | Read all big_map values, given it's ID.
-- If the values are not of the expected type, a 'ValueDecodeFailure' will be thrown.
--
-- Returns 'Nothing' if a big_map with the given ID does not exist.
readAllBigMapValuesMaybe
  :: forall v k m.
     (NiceUnpackedValue v, HasTezosRpc m)
  => BigMapId k v -> m (Maybe [v])
readAllBigMapValuesMaybe bigMapId =
  handleStatusCode 404
    (pure Nothing)
    (Just <$> readAllBigMapValues bigMapId)

-- | Read all big_map values, given it's ID.
-- If the values are not of the expected type, a 'ValueDecodeFailure' will be thrown.
readAllBigMapValues
  :: forall v k m.
     (NiceUnpackedValue v, HasTezosRpc m)
  => BigMapId k v -> m [v]
readAllBigMapValues (BigMapId bigMapId) =
  getBigMapValues bigMapId Nothing Nothing >>= \expr ->
    case fromVal <$> fromExpression expr of
      Right v -> pure v
      Left _ -> throwM $ ValueDecodeFailure "big map value " (demote @(ToT v))

data ContractNotFound = ContractNotFound ContractAddress
  deriving stock Show

instance Buildable ContractNotFound where
  build (ContractNotFound addr) =
    "Smart contract " +| addr |+ " was not found"

instance Exception ContractNotFound where
  displayException = pretty

-- | Get originated t'U.Contract' for some address.
getContract :: (HasTezosRpc m) => ContractAddress -> m U.Contract
getContract addr =
  handleStatusCode 404 (throwM $ ContractNotFound addr) $
  throwLeft $ fromExpression . osCode <$> getContractScript addr

-- | Get counter value for given implicit address.
getImplicitContractCounter :: (HasTezosRpc m) => ImplicitAddress -> m TezosInt64
getImplicitContractCounter addr = getCounter addr

handleStatusCode :: MonadCatch m => Int -> m a -> m a -> m a
handleStatusCode code onError action = action `catch`
  \case FailureResponse _ resp
          | statusCode (responseStatusCode resp) == code -> onError
        e -> throwM e

-- | Extract parameter types for all smart contracts' addresses and return mapping
-- from their hashes to their parameter types
getContractsParameterTypes
  :: HasTezosRpc m => [ContractAddress] -> m TcOriginatedContracts
getContractsParameterTypes addrs =
  Map.fromList <$> concatMapM (fmap maybeToList . extractParameterType) addrs
  where
    extractParameterType
      :: HasTezosRpc m => ContractAddress
      -> m (Maybe (ContractHash, SomeParamType))
    extractParameterType addr@(ContractAddress ch) =
      handleStatusCode 404 (return Nothing) $ do
        params <- fmap (U.contractParameter) . throwLeft $
            fromExpression @U.Contract . osCode <$> getContractScript addr
        (paramNotes :: SomeParamType) <- throwLeft $ pure $ mkSomeParamType params
        pure $ Just (ch, paramNotes)

-- | 'getContractStorageAtBlock' applied to the head block.
getContractStorage :: HasTezosRpc m => ContractAddress -> m Expression
getContractStorage = getContractStorageAtBlock HeadId

-- | 'getBigMapValueAtBlock' applied to the head block.
getBigMapValue :: HasTezosRpc m => Natural -> Text -> m Expression
getBigMapValue = getBigMapValueAtBlock HeadId

-- | 'getBigMapValuesAtBlock' applied to the head block.
getBigMapValues :: HasTezosRpc m => Natural -> Maybe Natural -> Maybe Natural -> m Expression
getBigMapValues = getBigMapValuesAtBlock HeadId

-- | Get hash of the current head block, this head hash is used in other
-- RPC calls.
getHeadBlock :: HasTezosRpc m => m BlockHash
getHeadBlock = getBlockHash HeadId

-- | 'getCounterAtBlock' applied to the head block.
getCounter :: HasTezosRpc m => ImplicitAddress -> m TezosInt64
getCounter = getCounterAtBlock HeadId

-- | 'getProtocolParametersAtBlock' applied to the head block.
getProtocolParameters :: HasTezosRpc m => m ProtocolParameters
getProtocolParameters = getProtocolParametersAtBlock HeadId

-- | 'runOperationAtBlock' applied to the head block.
runOperation :: HasTezosRpc m => RunOperation -> m RunOperationResult
runOperation = runOperationAtBlock HeadId

-- | 'preApplyOperationsAtBlock' applied to the head block.
preApplyOperations :: HasTezosRpc m => [PreApplyOperation] -> m [RunOperationResult]
preApplyOperations = preApplyOperationsAtBlock HeadId

-- | 'forgeOperationAtBlock' applied to the head block.
forgeOperation :: HasTezosRpc m => ForgeOperation -> m HexJSONByteString
forgeOperation = forgeOperationAtBlock HeadId

-- | 'getContractScriptAtBlock' applied to the head block.
getContractScript :: HasTezosRpc m => ContractAddress -> m OriginationScript
getContractScript = getContractScriptAtBlock HeadId

-- | 'getContractBigMapAtBlock' applied to the head block.
getContractBigMap :: HasTezosRpc m => ContractAddress -> GetBigMap -> m GetBigMapResult
getContractBigMap = getContractBigMapAtBlock HeadId

-- | 'getBalanceAtBlock' applied to the head block.
getBalance
  :: forall kind m. (HasTezosRpc m, L1AddressKind kind)
  => KindedAddress kind
  -> m Mutez
getBalance = usingImplicitOrContractKind @kind $ getBalanceAtBlock HeadId . MkAddress

-- | 'getScriptSizeAtBlock' applied to the head block.
getScriptSize :: HasTezosRpc m => CalcSize -> m ScriptSize
getScriptSize = getScriptSizeAtBlock HeadId

-- | 'getDelegateAtBlock' applied to the head block.
getDelegate :: HasTezosRpc m => L1Address -> m (Maybe KeyHash)
getDelegate = getDelegateAtBlock HeadId

-- | 'runCodeAtBlock' applied to the head block.
runCode :: HasTezosRpc m => RunCode -> m RunCodeResult
runCode = runCodeAtBlock HeadId

getManagerKey :: HasTezosRpc m => ImplicitAddress -> m (Maybe PublicKey)
getManagerKey = getManagerKeyAtBlock HeadId

-- | Get 'ContractState' for a given t'ContractAddress' at a given 'BlockId'.
-- Can be used with the morley interpreter to add some network interoperability.
contractStateResolver :: HasTezosRpc m => BlockId -> ContractAddress -> m (Maybe ContractState)
contractStateResolver blkId addr = handleStatusCode 404 (pure Nothing) $ Just <$> do
  block <- BlockHashId <$> getBlockHash blkId
  uContract <- throwLeft $ fromExpression . osCode <$> getContractScriptAtBlock block addr
  csBalance <- getBalanceAtBlock block $ Constrained addr
  csDelegate <- getDelegateAtBlock block $ Constrained addr
  SomeContract csContract@Contract{} <-
    either throwM pure . typeCheckingWith def $ typeCheckContract uContract
  csStorage <- throwLeft $ fromExpression <$> getContractStorageAtBlock block addr
  pure ContractState{..}

getTicketBalance
  :: HasTezosRpc m
  => L1Address -- ^ Ticket owner
  -> GetTicketBalance -- ^ Ticket description
  -> m Natural
getTicketBalance = getTicketBalanceAtBlock HeadId . toAddress

getAllTicketBalances
  :: HasTezosRpc m
  => ContractAddress -- ^ Ticket owner
  -> m [GetAllTicketBalancesResponse]
getAllTicketBalances = getAllTicketBalancesAtBlock HeadId