Getters.hs

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

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

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

  , readAllBigMapValues
  , readAllBigMapValuesMaybe
  , readContractBigMapValue
  , readBigMapValueMaybe
  , readBigMapValue
  , getContract
  , getImplicitContractCounter
  , getContractsParameterTypes
  , getContractStorage
  , 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 qualified Text.Show

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 qualified Morley.Michelson.Untyped 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
instance Exception ContractGetCounterAttempt
instance Show ContractGetCounterAttempt where
  show = pretty
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
instance Exception ValueDecodeFailure
instance Show ValueDecodeFailure where
  show = pretty
instance Buildable ValueDecodeFailure where
  build (ValueDecodeFailure desc ty) =
    "Failed to decode value with expected type " <> build ty <> " \
    \for '" <> build desc <> "'"

data ValueNotFound = ValueNotFound
instance Exception ValueNotFound
instance Show ValueNotFound where
  show = pretty
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

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
      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 Text
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

-- | '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