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

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

import Data.Binary.Put (putWord64be, runPut)
import Data.ByteString.Lazy qualified as BSL

import Morley.Michelson.Interpret.Pack (toBinary, toBinary')
import Morley.Michelson.Runtime.TxData (TxData)
import Morley.Michelson.Typed (Emit, EpName(..), Instr, unContractCode)
import Morley.Michelson.Typed.Aliases (Contract, Value)
import Morley.Michelson.Typed.Contract (cCode)
import Morley.Michelson.Typed.Entrypoints (EpAddress(..))
import Morley.Michelson.Typed.Haskell.Value (IsoValue(..))
import Morley.Michelson.Typed.Scope (PackedValScope, ParameterScope, StorageScope)
import Morley.Tezos.Address
import Morley.Tezos.Address.Alias
import Morley.Tezos.Core (Mutez(..))
import Morley.Tezos.Crypto (Hash(..), HashTag(..), KeyHash, blake2b, blake2b160)

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
showList :: [OperationHash] -> ShowS
$cshowList :: [OperationHash] -> ShowS
show :: OperationHash -> String
$cshow :: OperationHash -> String
showsPrec :: Int -> OperationHash -> ShowS
$cshowsPrec :: Int -> OperationHash -> ShowS
Show, OperationHash -> OperationHash -> Bool
(OperationHash -> OperationHash -> Bool)
-> (OperationHash -> OperationHash -> Bool) -> Eq OperationHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OperationHash -> OperationHash -> Bool
$c/= :: OperationHash -> OperationHash -> Bool
== :: OperationHash -> OperationHash -> Bool
$c== :: 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
min :: OperationHash -> OperationHash -> OperationHash
$cmin :: OperationHash -> OperationHash -> OperationHash
max :: OperationHash -> OperationHash -> OperationHash
$cmax :: OperationHash -> OperationHash -> OperationHash
>= :: OperationHash -> OperationHash -> Bool
$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
compare :: OperationHash -> OperationHash -> Ordering
$ccompare :: OperationHash -> OperationHash -> Ordering
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
$cto :: forall x. Rep OperationHash x -> OperationHash
$cfrom :: forall x. OperationHash -> Rep OperationHash x
Generic)
  deriving anyclass (OperationHash -> ()
(OperationHash -> ()) -> NFData OperationHash
forall a. (a -> ()) -> NFData a
rnf :: OperationHash -> ()
$crnf :: 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

-- | Construct 'OperationHash' for an 'OriginationOperation'.
mkOriginationOperationHash :: OriginationOperation -> OperationHash
mkOriginationOperationHash :: OriginationOperation -> OperationHash
mkOriginationOperationHash OriginationOperation{Maybe KeyHash
Maybe ContractAlias
Mutez
GlobalCounter
KindedAddress kind
Contract cp st
Value st
ooAlias :: Maybe ContractAlias
ooCounter :: GlobalCounter
ooContract :: Contract cp st
ooStorage :: Value st
ooBalance :: Mutez
ooDelegate :: Maybe KeyHash
ooOriginator :: KindedAddress kind
ooAlias :: OriginationOperation -> Maybe ContractAlias
ooCounter :: OriginationOperation -> GlobalCounter
ooContract :: ()
ooStorage :: ()
ooBalance :: OriginationOperation -> Mutez
ooDelegate :: OriginationOperation -> Maybe KeyHash
ooOriginator :: ()
..} =
  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
forall a. IsoValue a => a -> Value (ToT a)
toVal) Maybe KeyHash
ooDelegate
      ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Instr (ContractInp cp st) (ContractOut st) -> ByteString
forall a. ToExpression a => a -> ByteString
toBinary' (ContractCode' Instr cp st
-> Instr (ContractInp cp st) (ContractOut st)
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
ContractCode' instr cp st
-> instr (ContractInp cp st) (ContractOut st)
unContractCode (ContractCode' Instr cp st
 -> Instr (ContractInp cp st) (ContractOut st))
-> ContractCode' Instr cp st
-> Instr (ContractInp cp st) (ContractOut st)
forall a b. (a -> b) -> a -> b
$ Contract cp st -> ContractCode' Instr 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
showList :: [TransferOperation] -> ShowS
$cshowList :: [TransferOperation] -> ShowS
show :: TransferOperation -> String
$cshow :: TransferOperation -> String
showsPrec :: Int -> TransferOperation -> ShowS
$cshowsPrec :: Int -> TransferOperation -> ShowS
Show)

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

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

-- | Set contract's delegate
data SetDelegateOperation = SetDelegateOperation
  { SetDelegateOperation -> ContractAddress
sdoContract :: ContractAddress
  -- ^ 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
showList :: [SetDelegateOperation] -> ShowS
$cshowList :: [SetDelegateOperation] -> ShowS
show :: SetDelegateOperation -> String
$cshow :: SetDelegateOperation -> String
showsPrec :: Int -> SetDelegateOperation -> ShowS
$cshowsPrec :: Int -> SetDelegateOperation -> ShowS
Show

-- | Construct 'OperationHash' for a 'SetDelegateOperation'.
mkDelegationOperationHash :: SetDelegateOperation -> OperationHash
mkDelegationOperationHash :: SetDelegateOperation -> OperationHash
mkDelegationOperationHash SetDelegateOperation{Maybe KeyHash
GlobalCounter
ContractAddress
sdoCounter :: GlobalCounter
sdoDelegate :: Maybe KeyHash
sdoContract :: ContractAddress
sdoCounter :: SetDelegateOperation -> GlobalCounter
sdoDelegate :: SetDelegateOperation -> Maybe KeyHash
sdoContract :: SetDelegateOperation -> ContractAddress
..} =
  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
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