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
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)
class (Typeable a, PackedValScope a) => PackedValScope' a
instance (Typeable a, PackedValScope a) => PackedValScope' a
data UStoreElemRef
= UrField MText
| UrSubmap MText (SomeConstrainedValue PackedValScope')
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)
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"