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
  ) 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, niceUnpackedValueEvi, valueToScriptExpr)
import Lorentz.Value
import Morley.Micheline
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 Address
  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)
  => Address -> 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 ->
    withDict (niceUnpackedValueEvi @v) $
      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 ->
    withDict (niceUnpackedValueEvi @v) $
      case fromVal <$> fromExpression expr of
        Right v -> pure v
        Left _ -> throwM $ ValueDecodeFailure "big map value " (demote @(ToT v))

data ContractNotFound = ContractNotFound Address
  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) => Address -> m U.Contract
getContract addr =
  handleStatusCode 404 (throwM $ ContractNotFound addr) $
  throwLeft $ fromExpression . osCode <$> getContractScript addr

-- | Get counter value for given address.
--
-- Throws an error if given address is a contract address.
getImplicitContractCounter :: (HasTezosRpc m) => Address -> m TezosInt64
getImplicitContractCounter addr = case addr of
  KeyAddress _      -> getCounter addr
  ContractAddress _ -> throwM $ ContractGetCounterAttempt addr
  TransactionRollupAddress _ -> throwM $ ContractGetCounterAttempt 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 => [Address] -> m TcOriginatedContracts
getContractsParameterTypes addrs =
  Map.fromList <$> concatMapM (fmap maybeToList . extractParameterType) addrs
  where
    extractParameterType
      :: HasTezosRpc m => Address
      -> m (Maybe (ContractHash, SomeParamType))
    extractParameterType addr = case addr of
      KeyAddress _ -> return Nothing
      TransactionRollupAddress _ -> return Nothing
      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 => Address -> 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 => Address -> 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 => Address -> m OriginationScript
getContractScript = getContractScriptAtBlock HeadId

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

-- | 'getBalanceAtBlock' applied to the head block.
getBalance :: HasTezosRpc m => Address -> m Mutez
getBalance = getBalanceAtBlock HeadId

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

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

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

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