-- 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 :: UStoreValueUnpackFailed -> String
show = UStoreValueUnpackFailed -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty
instance Buildable UStoreValueUnpackFailed where
  build :: UStoreValueUnpackFailed -> Builder
build (UStoreValueUnpackFailed ByteString
val Text
ty) =
    Builder
"Unexpected UStore value of type `" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
ty Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"`: \
    \0x" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build (ByteString -> Text
encodeHex ByteString
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 :: Address -> UStoreElemRef -> m (Value v)
readContractUStore Address
contract UStoreElemRef
ref = do
  let ukey :: Value (ToT ByteString)
ukey = ByteString -> Value (ToT ByteString)
forall a. IsoValue a => a -> Value (ToT a)
toVal @ByteString (UStoreElemRef -> ByteString
refToKey UStoreElemRef
ref)
  Value 'TBytes
uval <- Address -> Value 'TBytes -> m (Value 'TBytes)
forall (k :: T) (v :: T) (m :: * -> *).
(PackedValScope k, UnpackedValScope v, HasTezosRpc m) =>
Address -> Value k -> m (Value v)
readContractBigMapValue Address
contract Value (ToT ByteString)
Value 'TBytes
ukey
  ByteString -> Either UnpackError (Value v)
forall (t :: T).
UnpackedValScope t =>
ByteString -> Either UnpackError (Value t)
unpackValue' (Value (ToT ByteString) -> ByteString
forall a. IsoValue a => Value (ToT a) -> a
fromVal @ByteString Value (ToT ByteString)
Value 'TBytes
uval)
    Either UnpackError (Value v)
-> (Either UnpackError (Value v) -> m (Value v)) -> m (Value v)
forall a b. a -> (a -> b) -> b
& (UnpackError -> m (Value v))
-> (Value v -> m (Value v))
-> Either UnpackError (Value v)
-> m (Value v)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Value v) -> UnpackError -> m (Value v)
forall a b. a -> b -> a
const (Value 'TBytes -> m (Value v)
throwUnpackFailed Value 'TBytes
uval)) Value v -> m (Value v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    throwUnpackFailed :: Value 'TBytes -> m (Value v)
throwUnpackFailed Value 'TBytes
uval =
      UStoreValueUnpackFailed -> m (Value v)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UStoreValueUnpackFailed -> m (Value v))
-> UStoreValueUnpackFailed -> m (Value v)
forall a b. (a -> b) -> a -> b
$ ByteString -> Text -> UStoreValueUnpackFailed
UStoreValueUnpackFailed (Value (ToT ByteString) -> ByteString
forall a. IsoValue a => Value (ToT a) -> a
fromVal Value (ToT ByteString)
Value 'TBytes
uval) (T -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (T -> Text) -> T -> Text
forall a b. (a -> b) -> a -> b
$ (SingKind T, SingI v) => Demote T
forall k (a :: k). (SingKind k, SingI a) => Demote k
demote @v)

    refToKey :: UStoreElemRef -> ByteString
    refToKey :: UStoreElemRef -> ByteString
refToKey = \case
      UrField MText
field ->
        MText -> ByteString
forall (marker :: UStoreMarkerType).
KnownUStoreMarker marker =>
MText -> ByteString
mkFieldMarkerUKey @UMarkerPlainField MText
field
      UrSubmap MText
field (SomeConstrainedValue Value' Instr t
key) ->
        PackedValScope (UStoreSubmapKeyT t) =>
Value (UStoreSubmapKeyT t) -> ByteString
forall (t :: T). PackedValScope t => Value t -> ByteString
packValue' @(UStoreSubmapKeyT _) (Value (UStoreSubmapKeyT t) -> ByteString)
-> Value (UStoreSubmapKeyT t) -> ByteString
forall a b. (a -> b) -> a -> b
$ (Value' Instr 'TString, Value' Instr t)
-> Value' Instr ('TPair 'TString t)
forall (l :: T) (r :: T) (instr :: [T] -> [T] -> *).
(Value' instr l, Value' instr r) -> Value' instr ('TPair l r)
VPair (MText -> Value (ToT MText)
forall a. IsoValue a => a -> Value (ToT a)
toVal MText
field, Value' Instr t
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 :: Address -> MText -> m [ExpandedOp]
readContractUStoreEntrypoint Address
contract MText
field = do
  let ukey :: Value (ToT ByteString)
ukey = ByteString -> Value (ToT ByteString)
forall a. IsoValue a => a -> Value (ToT a)
toVal @ByteString (MText -> ByteString
forall (marker :: UStoreMarkerType).
KnownUStoreMarker marker =>
MText -> ByteString
mkFieldMarkerUKey @UMarkerEntrypoint MText
field)
  Value 'TBytes
uval <- Address -> Value 'TBytes -> m (Value 'TBytes)
forall (k :: T) (v :: T) (m :: * -> *).
(PackedValScope k, UnpackedValScope v, HasTezosRpc m) =>
Address -> Value k -> m (Value v)
readContractBigMapValue Address
contract Value (ToT ByteString)
Value 'TBytes
ukey
  ByteString -> Either UnpackError [ExpandedOp]
unpackInstr' (Value (ToT ByteString) -> ByteString
forall a. IsoValue a => Value (ToT a) -> a
fromVal @ByteString Value (ToT ByteString)
Value 'TBytes
uval)
    Either UnpackError [ExpandedOp]
-> (Either UnpackError [ExpandedOp] -> m [ExpandedOp])
-> m [ExpandedOp]
forall a b. a -> (a -> b) -> b
& (UnpackError -> m [ExpandedOp])
-> ([ExpandedOp] -> m [ExpandedOp])
-> Either UnpackError [ExpandedOp]
-> m [ExpandedOp]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m [ExpandedOp] -> UnpackError -> m [ExpandedOp]
forall a b. a -> b -> a
const (Value 'TBytes -> m [ExpandedOp]
forall (m :: * -> *) a. MonadThrow m => Value 'TBytes -> m a
throwUnpackFailed Value 'TBytes
uval)) [ExpandedOp] -> m [ExpandedOp]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    throwUnpackFailed :: Value 'TBytes -> m a
throwUnpackFailed Value 'TBytes
uval =
      UStoreValueUnpackFailed -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UStoreValueUnpackFailed -> m a) -> UStoreValueUnpackFailed -> m a
forall a b. (a -> b) -> a -> b
$ ByteString -> Text -> UStoreValueUnpackFailed
UStoreValueUnpackFailed (Value (ToT ByteString) -> ByteString
forall a. IsoValue a => Value (ToT a) -> a
fromVal Value (ToT ByteString)
Value 'TBytes
uval) Text
"code"