-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

module Morley.Michelson.Typed.Operation
  ( OperationHash (..)
  , OriginationOperation (..)
  , TransferOperation (..)
  , SetDelegateOperation (..)
  , EmitOperation (..)
  , mkContractAddress
  , mkOriginationOperationHash
  , mkTransferOperationHash
  , mkTransferTicketOperationHash
  , mkDelegationOperationHash
  ) where

import Data.Binary.Builder qualified as Bi
import Data.Binary.Put (putWord64be, runPut)
import Data.ByteString.Lazy qualified as BSL
import Fmt (Buildable(..), Doc, quoteF, quoteOrIndentF, (++|), (|++), (|++^))

import Morley.Micheline.Binary.Internal (buildInteger)
import Morley.Michelson.Interpret.Pack (toBinary, toBinary')
import Morley.Michelson.Runtime.GState (TicketKey(..))
import Morley.Michelson.Runtime.TxData (TxData(..))
import Morley.Michelson.Typed (Emit(..), EpName(..), Instr, cCode, convertContractCodeOptimized)
import Morley.Michelson.Typed.Aliases (Contract, Value)
import Morley.Michelson.Typed.Entrypoints (EpAddress(..))
import Morley.Michelson.Typed.Haskell.Value (IsoValue(..))
import Morley.Michelson.Typed.Scope (PackedValScope, ParameterScope, StorageScope)
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Address.Alias
import Morley.Tezos.Core (Mutez(..))
import Morley.Tezos.Crypto (Hash(..), HashTag(..), KeyHash, blake2b, blake2b160)

{- $setup
>>> import Morley.Tezos.Core
>>> import Morley.Tezos.Address
>>> import Morley.Tezos.Address.Alias
>>> import Morley.Michelson.Typed
>>> import Morley.Michelson.Parser
>>> import Morley.Michelson.Typed.Operation
>>> import Morley.Michelson.Runtime.TxData
>>> import Fmt (pretty)
-}

newtype OperationHash = OperationHash
  { OperationHash -> ByteString
unOperationHash :: ByteString
  }
  deriving stock (Int -> OperationHash -> ShowS
[OperationHash] -> ShowS
OperationHash -> String
(Int -> OperationHash -> ShowS)
-> (OperationHash -> String)
-> ([OperationHash] -> ShowS)
-> Show OperationHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OperationHash -> ShowS
showsPrec :: Int -> OperationHash -> ShowS
$cshow :: OperationHash -> String
show :: OperationHash -> String
$cshowList :: [OperationHash] -> ShowS
showList :: [OperationHash] -> ShowS
Show, OperationHash -> OperationHash -> Bool
(OperationHash -> OperationHash -> Bool)
-> (OperationHash -> OperationHash -> Bool) -> Eq OperationHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OperationHash -> OperationHash -> Bool
== :: OperationHash -> OperationHash -> Bool
$c/= :: OperationHash -> OperationHash -> Bool
/= :: OperationHash -> OperationHash -> Bool
Eq, Eq OperationHash
Eq OperationHash
-> (OperationHash -> OperationHash -> Ordering)
-> (OperationHash -> OperationHash -> Bool)
-> (OperationHash -> OperationHash -> Bool)
-> (OperationHash -> OperationHash -> Bool)
-> (OperationHash -> OperationHash -> Bool)
-> (OperationHash -> OperationHash -> OperationHash)
-> (OperationHash -> OperationHash -> OperationHash)
-> Ord OperationHash
OperationHash -> OperationHash -> Bool
OperationHash -> OperationHash -> Ordering
OperationHash -> OperationHash -> OperationHash
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: OperationHash -> OperationHash -> Ordering
compare :: OperationHash -> OperationHash -> Ordering
$c< :: OperationHash -> OperationHash -> Bool
< :: OperationHash -> OperationHash -> Bool
$c<= :: OperationHash -> OperationHash -> Bool
<= :: OperationHash -> OperationHash -> Bool
$c> :: OperationHash -> OperationHash -> Bool
> :: OperationHash -> OperationHash -> Bool
$c>= :: OperationHash -> OperationHash -> Bool
>= :: OperationHash -> OperationHash -> Bool
$cmax :: OperationHash -> OperationHash -> OperationHash
max :: OperationHash -> OperationHash -> OperationHash
$cmin :: OperationHash -> OperationHash -> OperationHash
min :: OperationHash -> OperationHash -> OperationHash
Ord, (forall x. OperationHash -> Rep OperationHash x)
-> (forall x. Rep OperationHash x -> OperationHash)
-> Generic OperationHash
forall x. Rep OperationHash x -> OperationHash
forall x. OperationHash -> Rep OperationHash x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. OperationHash -> Rep OperationHash x
from :: forall x. OperationHash -> Rep OperationHash x
$cto :: forall x. Rep OperationHash x -> OperationHash
to :: forall x. Rep OperationHash x -> OperationHash
Generic)
  deriving anyclass (OperationHash -> ()
(OperationHash -> ()) -> NFData OperationHash
forall a. (a -> ()) -> NFData a
$crnf :: OperationHash -> ()
rnf :: OperationHash -> ()
NFData)

-- | "optional" encoding in Tezos.
--
-- See https://gitlab.com/nomadic-labs/data-encoding/-/blob/2c2b795a37e7d76e3eaa861da9855f2098edc9b9/src/binary_writer.ml#L278-283
packMaybe :: (a -> ByteString) -> Maybe a -> ByteString
packMaybe :: forall a. (a -> ByteString) -> Maybe a -> ByteString
packMaybe a -> ByteString
_ Maybe a
Nothing = ByteString
"\255"
packMaybe a -> ByteString
f (Just a
a) = ByteString
"\0" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> a -> ByteString
f a
a

----------------------------------------------------------------------------
-- Origination
----------------------------------------------------------------------------

-- | Data necessary to originate a contract.
data OriginationOperation =
  forall cp st kind.
  (StorageScope st, ParameterScope cp, L1AddressKind kind) =>
  OriginationOperation
  { ()
ooOriginator :: KindedAddress kind
  -- ^ Originator of the contract.
  , OriginationOperation -> Maybe KeyHash
ooDelegate :: Maybe KeyHash
  -- ^ Optional delegate.
  , OriginationOperation -> Mutez
ooBalance :: Mutez
  -- ^ Initial balance of the contract.
  , ()
ooStorage :: Value st
  -- ^ Initial storage value of the contract.
  , ()
ooContract :: Contract cp st
  -- ^ The contract itself.
  , OriginationOperation -> GlobalCounter
ooCounter :: GlobalCounter
  -- ^ The value of the global counter at the time the operation was created.
  -- We store it here so that the resulting addresses of @CREATE_CONTRACT@ and
  -- performing of origination operation are the same.
  , OriginationOperation -> Maybe ContractAlias
ooAlias :: Maybe ContractAlias
  -- ^ An alias to be associated with the originated contract's address.

  -- In Tezos each operation also has a special field called @counter@, see here:
  -- https://gitlab.com/tezos/tezos/-/blob/397dd233a10cc6df0df959e2a624c7947997dd0c/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L113-120

  -- This counter seems to be a part of global state of Tezos network. In fact, it may be observed
  -- in raw JSON representation of the operation in the network explorer.
  }

deriving stock instance Show OriginationOperation

{- | Prettyprinter for 'OriginationOperation'

>>> :{
contract
  :: (StorageScope storage, ConstantScope storage)
  => Contract TUnit storage
contract = defaultContract FAILWITH
:}

>>> let ia = [ta|tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH|]
>>> pretty $ OriginationOperation ia Nothing [tz|123u|] VUnit contract 1 Nothing
Originate a contract with delegate <nobody> initial storage 'Unit' and balance
123 μꜩ

>>> :{
pretty $ OriginationOperation ia (Just $ unImplicitAddress ia)
  [tz|123u|] VUnit contract 1 Nothing
:}
Originate a contract with delegate tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH initial
storage 'Unit' and balance 123 μꜩ

>>> :{
pretty $ OriginationOperation ia Nothing
  [tz|123u|] VUnit contract 1 (Just $ mkAlias "some_alias")
:}
Originate contract some_alias with delegate <nobody> initial storage 'Unit' and
balance 123 μꜩ

>>> let storage = toVal (((), ()), ((), ()))
>>> :{
pretty $ OriginationOperation ia Nothing [tz|123u|] storage contract 1 Nothing
:}
Originate a contract with delegate <nobody> initial storage
  Pair (Pair Unit Unit) (Pair Unit Unit)
and balance 123 μꜩ
-}
instance Buildable OriginationOperation where
  build :: OriginationOperation -> Doc
build OriginationOperation{Maybe KeyHash
Maybe ContractAlias
Mutez
KindedAddress kind
GlobalCounter
Contract cp st
Value st
ooOriginator :: ()
ooDelegate :: OriginationOperation -> Maybe KeyHash
ooBalance :: OriginationOperation -> Mutez
ooStorage :: ()
ooContract :: ()
ooCounter :: OriginationOperation -> GlobalCounter
ooAlias :: OriginationOperation -> Maybe ContractAlias
ooOriginator :: KindedAddress kind
ooDelegate :: Maybe KeyHash
ooBalance :: Mutez
ooStorage :: Value st
ooContract :: Contract cp st
ooCounter :: GlobalCounter
ooAlias :: Maybe ContractAlias
..} =
    Text
"Originate" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| Doc
alias Doc -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Text
"with delegate" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| Doc
delegate
      Doc -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Text
"initial storage" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| Value st -> Doc
forall a. Buildable a => a -> Doc
quoteOrIndentF Value st
ooStorage
      Doc -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++^ Text
"and balance" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| Mutez
ooBalance Mutez -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Doc
""
    where
      alias :: Doc
alias = Doc -> (ContractAlias -> Doc) -> Maybe ContractAlias -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Doc
"a contract" :: Doc) ((Text
"contract" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++|) (ReflowingDoc -> Doc)
-> (ContractAlias -> ReflowingDoc) -> ContractAlias -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContractAlias -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Doc
"")) Maybe ContractAlias
ooAlias
      delegate :: Doc
delegate = Doc -> (KeyHash -> Doc) -> Maybe KeyHash -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
"<nobody>" KeyHash -> Doc
forall a. Buildable a => a -> Doc
build Maybe KeyHash
ooDelegate

-- | Construct 'OperationHash' for an 'OriginationOperation'.
mkOriginationOperationHash :: OriginationOperation -> OperationHash
mkOriginationOperationHash :: OriginationOperation -> OperationHash
mkOriginationOperationHash OriginationOperation{Maybe KeyHash
Maybe ContractAlias
Mutez
KindedAddress kind
GlobalCounter
Contract cp st
Value st
ooOriginator :: ()
ooDelegate :: OriginationOperation -> Maybe KeyHash
ooBalance :: OriginationOperation -> Mutez
ooStorage :: ()
ooContract :: ()
ooCounter :: OriginationOperation -> GlobalCounter
ooAlias :: OriginationOperation -> Maybe ContractAlias
ooOriginator :: KindedAddress kind
ooDelegate :: Maybe KeyHash
ooBalance :: Mutez
ooStorage :: Value st
ooContract :: Contract cp st
ooCounter :: GlobalCounter
ooAlias :: Maybe ContractAlias
..} =
  ByteString -> OperationHash
OperationHash (ByteString -> OperationHash) -> ByteString -> OperationHash
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
blake2b ByteString
packedOperation
  where
    -- In Tezos OriginationOperation is encoded as 4-tuple of
    -- (balance, optional delegate, code, storage)
    --
    -- See https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L314
    -- and https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/script_repr.ml#L68
    packedOperation :: ByteString
packedOperation =
      ByteString -> ByteString
BSL.toStrict (Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> Put
putWord64be (Word64 -> Put) -> Word64 -> Put
forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral @Word63 @Word64 (Word63 -> Word64) -> Word63 -> Word64
forall a b. (a -> b) -> a -> b
$ Mutez -> Word63
unMutez Mutez
ooBalance)
      ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (KeyHash -> ByteString) -> Maybe KeyHash -> ByteString
forall a. (a -> ByteString) -> Maybe a -> ByteString
packMaybe (Value 'TKeyHash -> ByteString
forall a. ToExpression a => a -> ByteString
toBinary' (Value 'TKeyHash -> ByteString)
-> (KeyHash -> Value 'TKeyHash) -> KeyHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash -> Value 'TKeyHash
KeyHash -> Value (ToT KeyHash)
forall a. IsoValue a => a -> Value (ToT a)
toVal) Maybe KeyHash
ooDelegate
      -- NB: we don't use typed code directly because there is some mismatch on
      -- when it's a sequence vs a single instruction.
      ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ExpandedOp -> ByteString
forall a. ToExpression a => a -> ByteString
toBinary' (Contract' ExpandedOp -> ExpandedOp
forall op. Contract' op -> op
U.contractCode (Contract' ExpandedOp -> ExpandedOp)
-> Contract' ExpandedOp -> ExpandedOp
forall a b. (a -> b) -> a -> b
$ ContractCode cp st -> Contract' ExpandedOp
forall (param :: T) (store :: T).
(SingI param, SingI store) =>
ContractCode param store -> Contract' ExpandedOp
convertContractCodeOptimized (ContractCode cp st -> Contract' ExpandedOp)
-> ContractCode cp st -> Contract' ExpandedOp
forall a b. (a -> b) -> a -> b
$ Contract cp st -> ContractCode cp st
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> ContractCode' instr cp st
cCode Contract cp st
ooContract)
      ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Value st -> ByteString
forall a. ToExpression a => a -> ByteString
toBinary' Value st
ooStorage

-- | Compute address of a contract from its origination operation and global counter.
--
-- However, in real Tezos encoding of the operation is more than just 'OriginationOperation'.
-- There an Operation has several more meta-fields plus a big sum-type of all possible operations.
--
-- See here: https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L78
--
-- In other words, contract hash is calculated as the blake2b160 (20-byte) hash of
-- origination operation hash + word64 global counter.
--
-- In Morley we do not yet support full encoding of Tezos Operations, therefore we choose
-- to generate contract addresses in a simplified manner.
--
-- Namely, we encode 'OriginationOperation' as we can and concat it with the global counter.
--
-- Then we take 'blake2b160' hash of the resulting bytes and consider it to be the contract's
-- address.
mkContractAddress
  :: OperationHash
  -> GlobalCounter
  -> ContractAddress
mkContractAddress :: OperationHash -> GlobalCounter -> ContractAddress
mkContractAddress (OperationHash ByteString
opHash) (GlobalCounter Word64
counter) =
  ContractHash -> ContractAddress
ContractAddress
  (ContractHash -> ContractAddress)
-> ContractHash -> ContractAddress
forall a b. (a -> b) -> a -> b
$ HashTag 'HashKindContract -> ByteString -> ContractHash
forall (kind :: HashKind). HashTag kind -> ByteString -> Hash kind
Hash HashTag 'HashKindContract
HashContract
  (ByteString -> ContractHash) -> ByteString -> ContractHash
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
blake2b160
  (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
opHash ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BSL.toStrict (Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> Put
putWord64be Word64
counter)

----------------------------------------------------------------------------
-- Transfer
----------------------------------------------------------------------------

-- | Data necessary to send a transaction to given address which is assumed to be the
-- address of an originated contract.
data TransferOperation = TransferOperation
  { TransferOperation -> Address
toDestination :: Address
  , TransferOperation -> TxData
toTxData :: TxData
  , TransferOperation -> GlobalCounter
toCounter :: GlobalCounter
  } deriving stock (Int -> TransferOperation -> ShowS
[TransferOperation] -> ShowS
TransferOperation -> String
(Int -> TransferOperation -> ShowS)
-> (TransferOperation -> String)
-> ([TransferOperation] -> ShowS)
-> Show TransferOperation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransferOperation -> ShowS
showsPrec :: Int -> TransferOperation -> ShowS
$cshow :: TransferOperation -> String
show :: TransferOperation -> String
$cshowList :: [TransferOperation] -> ShowS
showList :: [TransferOperation] -> ShowS
Show)

{- | Prettyprinter for 'TransferOperation'

>>> let ia = [ta|tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH|]
>>> let ca = [ta|KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz|]
>>> :{
transfer
  :: (IsoValue p, ParameterScope (ToT p))
  => KindedAddress kind -> p -> TransferOperation
transfer dest param =
  TransferOperation (Constrained dest) (TxData (Constrained ia)
    (TxTypedParam $ toVal param) DefEpName [tz|123u|]) 1
:}

>>> pretty $ transfer ia ()
Transfer 123 μꜩ tokens from tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH to
tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH

>>> pretty $ transfer ca ()
Transfer to KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz entrypoint <default> from
tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH with parameter 'Unit' and amount 123 μꜩ

>>> pretty $ transfer ca (MkAddress ca, MkAddress ia)
Transfer to KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz entrypoint <default> from
tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH with parameter
  Pair
    "KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz"
    "tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH"
and amount 123 μꜩ
-}
instance Buildable TransferOperation where
  build :: TransferOperation -> Doc
build (TransferOperation (Constrained KindedAddress a
dest) TxData{L1Address
EpName
Mutez
TxParam
tdSenderAddress :: L1Address
tdParameter :: TxParam
tdEntrypoint :: EpName
tdAmount :: Mutez
tdSenderAddress :: TxData -> L1Address
tdParameter :: TxData -> TxParam
tdEntrypoint :: TxData -> EpName
tdAmount :: TxData -> Mutez
..} GlobalCounter
_) = case KindedAddress a
dest of
    ImplicitAddress{} ->
      -- Implicit address' entrypoint and parameter are fixed, so omit them.
      Text
"Transfer" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| Mutez
tdAmount Mutez -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Text
"tokens from" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| L1Address
tdSenderAddress L1Address -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Text
"to" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| KindedAddress a
dest KindedAddress a -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Doc
""
    KindedAddress a
_ -> Text
"Transfer to" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| KindedAddress a
dest KindedAddress a -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Text
"entrypoint" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| EpName
tdEntrypoint
      EpName -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Text
"from" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| L1Address
tdSenderAddress L1Address -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Text
"with parameter" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| TxParam -> Doc
forall a. Buildable a => a -> Doc
quoteOrIndentF TxParam
tdParameter
      Doc -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++^ Text
"and amount" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| Mutez
tdAmount Mutez -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Doc
""

mkTransferOperationHash
  :: ParameterScope t
  => KindedAddress kind
  -> Value t
  -> EpName
  -> Mutez
  -> OperationHash
mkTransferOperationHash :: forall (t :: T) (kind :: AddressKind).
ParameterScope t =>
KindedAddress kind -> Value t -> EpName -> Mutez -> OperationHash
mkTransferOperationHash KindedAddress kind
to Value t
param EpName
epName Mutez
amount =
  ByteString -> OperationHash
OperationHash (ByteString -> OperationHash) -> ByteString -> OperationHash
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
blake2b ByteString
packedOperation
  where
    -- In Tezos, transfer operations are encoded as 4-tuple of
    -- (amount, destination, entrypoint, value)
    --
    -- See https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L275-282
    packedOperation :: ByteString
packedOperation =
      ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
        (Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> Put
putWord64be (Word64 -> Put) -> Word64 -> Put
forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral @Word63 @Word64 (Word63 -> Word64) -> Word63 -> Word64
forall a b. (a -> b) -> a -> b
$ Mutez -> Word63
unMutez Mutez
amount)
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (Value 'TAddress -> ByteString
forall a. ToExpression a => a -> ByteString
toBinary (Value 'TAddress -> ByteString) -> Value 'TAddress -> ByteString
forall a b. (a -> b) -> a -> b
$ EpAddress -> Value (ToT EpAddress)
forall a. IsoValue a => a -> Value (ToT a)
toVal (KindedAddress kind -> EpName -> EpAddress
forall (kind :: AddressKind).
KindedAddress kind -> EpName -> EpAddress
EpAddress KindedAddress kind
to EpName
epName))
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Value t -> ByteString
forall a. ToExpression a => a -> ByteString
toBinary Value t
param

mkTransferTicketOperationHash
  :: TicketKey
  -> Natural
  -> Address
  -> EpName
  -> OperationHash
mkTransferTicketOperationHash :: TicketKey -> Natural -> Address -> EpName -> OperationHash
mkTransferTicketOperationHash (TicketKey (Address
ticketer, Value
contents, Ty
ty)) Natural
amount Address
dest EpName
epName =
  ByteString -> OperationHash
OperationHash (ByteString -> OperationHash) -> ByteString -> OperationHash
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
blake2b ByteString
packedOperation
  where
    -- In Tezos, ticket transfer operations are encoded as 6-tuple of
    -- (contents, type, ticketer, ticket amount, dest, epName)
    --
    -- See https://gitlab.com/tezos/tezos/-/blob/f7f6047237974ef85d94c87368f2a82615bcc8ca/src/proto_016_PtMumbai/lib_protocol/operation_repr.ml#L1044-1051
    packedOperation :: ByteString
packedOperation =
      ByteString -> ByteString
BSL.toStrict
        (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$  Value -> ByteString
forall a. ToExpression a => a -> ByteString
toBinary Value
contents
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Ty -> ByteString
forall a. ToExpression a => a -> ByteString
toBinary Ty
ty
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Value 'TAddress -> ByteString
forall a. ToExpression a => a -> ByteString
toBinary (Address -> Value (ToT Address)
forall a. IsoValue a => a -> Value (ToT a)
toVal Address
ticketer)
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Builder -> ByteString
Bi.toLazyByteString (Integer -> Builder
buildInteger (Natural -> Integer
forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral Natural
amount))
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Value 'TAddress -> ByteString
forall a. ToExpression a => a -> ByteString
toBinary (EpAddress -> Value (ToT EpAddress)
forall a. IsoValue a => a -> Value (ToT a)
toVal (EpAddress -> Value (ToT EpAddress))
-> EpAddress -> Value (ToT EpAddress)
forall a b. (a -> b) -> a -> b
$ Address -> EpName -> EpAddress
EpAddress' Address
dest EpName
epName)

----------------------------------------------------------------------------
-- Set Delegate
----------------------------------------------------------------------------

-- | Set contract's delegate
data SetDelegateOperation = SetDelegateOperation
  { SetDelegateOperation -> L1Address
sdoContract :: L1Address
  -- ^ The contract we're setting delegate of
  , SetDelegateOperation -> Maybe KeyHash
sdoDelegate :: Maybe KeyHash
  -- ^ The delegate we're setting
  , SetDelegateOperation -> GlobalCounter
sdoCounter :: GlobalCounter
  } deriving stock Int -> SetDelegateOperation -> ShowS
[SetDelegateOperation] -> ShowS
SetDelegateOperation -> String
(Int -> SetDelegateOperation -> ShowS)
-> (SetDelegateOperation -> String)
-> ([SetDelegateOperation] -> ShowS)
-> Show SetDelegateOperation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SetDelegateOperation -> ShowS
showsPrec :: Int -> SetDelegateOperation -> ShowS
$cshow :: SetDelegateOperation -> String
show :: SetDelegateOperation -> String
$cshowList :: [SetDelegateOperation] -> ShowS
showList :: [SetDelegateOperation] -> ShowS
Show

{- | Prettyprinter for 'SetDelegateOperation'

>>> let ia = [ta|tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH|]
>>> pretty $ SetDelegateOperation (Constrained ia) Nothing 1
Set delegate of contract tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH to <nobody>

>>> :{
pretty $ SetDelegateOperation (Constrained ia) (Just $ unImplicitAddress ia) 1
:}
Set delegate of contract tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH to
tz29EDhZ4D3XueHxm5RGZsJLHRtj3qSA2MzH
-}
instance Buildable SetDelegateOperation where
  build :: SetDelegateOperation -> Doc
build SetDelegateOperation{Maybe KeyHash
L1Address
GlobalCounter
sdoContract :: SetDelegateOperation -> L1Address
sdoDelegate :: SetDelegateOperation -> Maybe KeyHash
sdoCounter :: SetDelegateOperation -> GlobalCounter
sdoContract :: L1Address
sdoDelegate :: Maybe KeyHash
sdoCounter :: GlobalCounter
..} =
    Text
"Set delegate of contract" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| L1Address
sdoContract
      L1Address -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Text
"to" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| Doc -> (KeyHash -> Doc) -> Maybe KeyHash -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
"<nobody>" KeyHash -> Doc
forall a. Buildable a => a -> Doc
build Maybe KeyHash
sdoDelegate Doc -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Doc
""

-- | Construct 'OperationHash' for a 'SetDelegateOperation'.
mkDelegationOperationHash :: SetDelegateOperation -> OperationHash
mkDelegationOperationHash :: SetDelegateOperation -> OperationHash
mkDelegationOperationHash SetDelegateOperation{Maybe KeyHash
L1Address
GlobalCounter
sdoContract :: SetDelegateOperation -> L1Address
sdoDelegate :: SetDelegateOperation -> Maybe KeyHash
sdoCounter :: SetDelegateOperation -> GlobalCounter
sdoContract :: L1Address
sdoDelegate :: Maybe KeyHash
sdoCounter :: GlobalCounter
..} =
  ByteString -> OperationHash
OperationHash (ByteString -> OperationHash) -> ByteString -> OperationHash
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
blake2b ByteString
packedOperation
  where
    -- In Tezos DelegationOperation is encoded as simply the delegation key hash
    --
    -- https://gitlab.com/tezos/tezos/-/blob/685227895f48a2564a9de3e1e179e7cd741d52fb/src/proto_010_PtGRANAD/lib_protocol/operation_repr.ml#L354
    packedOperation :: ByteString
packedOperation = (KeyHash -> ByteString) -> Maybe KeyHash -> ByteString
forall a. (a -> ByteString) -> Maybe a -> ByteString
packMaybe (Value 'TKeyHash -> ByteString
forall a. ToExpression a => a -> ByteString
toBinary' (Value 'TKeyHash -> ByteString)
-> (KeyHash -> Value 'TKeyHash) -> KeyHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash -> Value 'TKeyHash
KeyHash -> Value (ToT KeyHash)
forall a. IsoValue a => a -> Value (ToT a)
toVal) Maybe KeyHash
sdoDelegate

data EmitOperation = forall t. PackedValScope t => EmitOperation
  { EmitOperation -> ContractAddress
eoSource :: ContractAddress
  , ()
eoEmit :: Emit Instr t
  }

deriving stock instance Show EmitOperation

{- | Prettyprinter for 'EmitOperation'

>>> let ca = [ta|KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz|]
>>> :{
emit :: (IsoValue a, PackedValScope (ToT a)) => a -> EmitOperation
emit val = EmitOperation ca $ Emit "tag" starNotes (toVal val) 1
:}

>>> pretty $ emit ()
Emit event 'tag' with type 'unit' and value 'Unit' from contract
KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz

>>> let tup = (((), ()), ((), ()))
>>> let largeTup = (tup, tup)
>>> pretty $ emit largeTup
Emit event 'tag' with type
  pair (pair (pair unit unit) unit unit) (pair unit unit) unit unit
and value
  Pair
    (Pair (Pair Unit Unit) (Pair Unit Unit))
    (Pair (Pair Unit Unit) (Pair Unit Unit))
from contract KT19upy4rX95WF5R3aCNgrtYA8926GP6fuJz
-}
instance Buildable EmitOperation where
  build :: EmitOperation -> Doc
build (EmitOperation ContractAddress
source Emit{Text
GlobalCounter
Notes t
Value' Instr t
emTag :: Text
emNotes :: Notes t
emValue :: Value' Instr t
emCounter :: GlobalCounter
emTag :: forall (instr :: [T] -> [T] -> *) (t :: T). Emit instr t -> Text
emNotes :: forall (instr :: [T] -> [T] -> *) (t :: T). Emit instr t -> Notes t
emValue :: forall (instr :: [T] -> [T] -> *) (t :: T).
Emit instr t -> Value' instr t
emCounter :: forall (instr :: [T] -> [T] -> *) (t :: T).
Emit instr t -> GlobalCounter
..}) =
    Text
"Emit event" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| Doc -> Text -> Doc
forall a. Buildable a => Doc -> a -> Doc
quoteF Doc
"'" Text
emTag
      Doc -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Text
"with type" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| Notes t -> Doc
forall a. Buildable a => a -> Doc
quoteOrIndentF Notes t
emNotes
      Doc -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++^ Text
"and value" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| Value' Instr t -> Doc
forall a. Buildable a => a -> Doc
quoteOrIndentF Value' Instr t
emValue
      Doc -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++^ Text
"from contract" Text -> ReflowingDoc -> Doc
forall b. FromDoc b => Text -> ReflowingDoc -> b
++| ContractAddress
source
      ContractAddress -> Doc -> ReflowingDoc
forall a. Buildable a => a -> Doc -> ReflowingDoc
|++ Doc
""