Client.hs

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

-- | Operations related to upgradeable contracts.
module Lorentz.Contracts.Upgradeable.Client
  ( UStoreValueUnpackFailed (..)
  , UStoreElemRef (..)
  , readContractUStore
  , readContractUStoreEntrypoint
  ) where

import Prelude

import Data.Singletons (demote)
import Fmt (Buildable(..), pretty)
import Text.Hex (encodeHex)
import qualified Text.Show

import Lorentz.Contracts.Upgradeable.StorageDriven (UMarkerEntrypoint)
import Lorentz.UStore.Types (UMarkerPlainField, UStoreSubmapKeyT, mkFieldMarkerUKey)
import Lorentz.Value
import Michelson.Interpret.Pack
import Michelson.Interpret.Unpack
import Michelson.Typed
import Michelson.Untyped (ExpandedOp(..))

import Morley.Client

-- | Failed to code UStore value to given type.
data UStoreValueUnpackFailed = UStoreValueUnpackFailed ByteString Text
instance Exception UStoreValueUnpackFailed
instance Show UStoreValueUnpackFailed where
  show = pretty
instance Buildable UStoreValueUnpackFailed where
  build (UStoreValueUnpackFailed val ty) =
    "Unexpected UStore value of type `" <> build ty <> "`: \
    \0x" <> build (encodeHex val)


-- | Version of 'PackedValScope' which can be partially applied.
class (Typeable a, PackedValScope a) => PackedValScope' a
instance (Typeable a, PackedValScope a) => PackedValScope' a

data UStoreElemRef
  = UrField MText
  | UrSubmap MText (SomeConstrainedValue PackedValScope')

-- | Read 'UStore' value of given contract.
--
-- This essentially requires contract having only one @big_map bytes bytes@
-- in storage.
readContractUStore
  :: forall v m.
     (UnpackedValScope v, HasTezosRpc m)
  => Address -> UStoreElemRef -> m (Value v)
readContractUStore contract ref = do
  let ukey = toVal @ByteString (refToKey ref)
  uval <- readContractBigMapValue contract ukey
  unpackValue' (fromVal @ByteString uval)
    & either (const (throwUnpackFailed uval)) pure
  where
    throwUnpackFailed uval =
      throwM $ UStoreValueUnpackFailed (fromVal uval) (pretty $ demote @v)

    refToKey :: UStoreElemRef -> ByteString
    refToKey = \case
      UrField field ->
        mkFieldMarkerUKey @UMarkerPlainField field
      UrSubmap field (SomeConstrainedValue key) ->
        packValue' @(UStoreSubmapKeyT _) $ VPair (toVal field, key)

-- | Read an 'UStore' entrypoint. For contracts which are filled with
-- storage-driven approach.
--
-- Unlike 'readContractUStore', here we don't need to know exact type of
-- value (lambda) in order to unpack it, thus returning code in untyped
-- representation.
readContractUStoreEntrypoint
  :: HasTezosRpc m
  => Address -> MText -> m [ExpandedOp]
readContractUStoreEntrypoint contract field = do
  let ukey = toVal @ByteString (mkFieldMarkerUKey @UMarkerEntrypoint field)
  uval <- readContractBigMapValue contract ukey
  unpackInstr' (fromVal @ByteString uval)
    & either (const (throwUnpackFailed uval)) pure
  where
    throwUnpackFailed uval =
      throwM $ UStoreValueUnpackFailed (fromVal uval) "code"