-- 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
  { unOperationHash :: ByteString
  }
  deriving stock (Show, Eq, Ord, Generic)
  deriving anyclass (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 _ Nothing = "\255"
packMaybe f (Just a) = "\0" <> f 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.
  , ooDelegate :: Maybe KeyHash
  -- ^ Optional delegate.
  , ooBalance :: Mutez
  -- ^ Initial balance of the contract.
  , ooStorage :: Value st
  -- ^ Initial storage value of the contract.
  , ooContract :: Contract cp st
  -- ^ The contract itself.
  , 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.
  , 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{..} =
    "Originate" ++| alias |++ "with delegate" ++| delegate
      |++ "initial storage" ++| quoteOrIndentF ooStorage
      |++^ "and balance" ++| ooBalance |++ ""
    where
      alias = maybe ("a contract" :: Doc) (("contract" ++|) . (|++ "")) ooAlias
      delegate = maybe "<nobody>" build ooDelegate

-- | Construct 'OperationHash' for an 'OriginationOperation'.
mkOriginationOperationHash :: OriginationOperation -> OperationHash
mkOriginationOperationHash OriginationOperation{..} =
  OperationHash $ blake2b 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 =
      BSL.toStrict (runPut $ putWord64be $ fromIntegral @Word63 @Word64 $ unMutez ooBalance)
      <> packMaybe (toBinary' . toVal) ooDelegate
      -- NB: we don't use typed code directly because there is some mismatch on
      -- when it's a sequence vs a single instruction.
      <> toBinary' (U.contractCode $ convertContractCodeOptimized $ cCode ooContract)
      <> toBinary' 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 opHash) (GlobalCounter counter) =
  ContractAddress
  $ Hash HashContract
  $ blake2b160
  $ opHash <> BSL.toStrict (runPut $ putWord64be 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
  { toDestination :: Address
  , toTxData :: TxData
  , toCounter :: GlobalCounter
  } deriving stock (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 (Constrained dest) TxData{..} _) = case dest of
    ImplicitAddress{} ->
      -- Implicit address' entrypoint and parameter are fixed, so omit them.
      "Transfer" ++| tdAmount |++ "tokens from" ++| tdSenderAddress |++ "to" ++| dest |++ ""
    _ -> "Transfer to" ++| dest |++ "entrypoint" ++| tdEntrypoint
      |++ "from" ++| tdSenderAddress |++ "with parameter" ++| quoteOrIndentF tdParameter
      |++^ "and amount" ++| tdAmount |++ ""

mkTransferOperationHash
  :: ParameterScope t
  => KindedAddress kind
  -> Value t
  -> EpName
  -> Mutez
  -> OperationHash
mkTransferOperationHash to param epName amount =
  OperationHash $ blake2b 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 =
      BSL.toStrict $
        (runPut $ putWord64be $ fromIntegral @Word63 @Word64 $ unMutez amount)
        <> (toBinary $ toVal (EpAddress to epName))
        <> toBinary param

mkTransferTicketOperationHash
  :: TicketKey
  -> Natural
  -> Address
  -> EpName
  -> OperationHash
mkTransferTicketOperationHash (TicketKey (ticketer, contents, ty)) amount dest epName =
  OperationHash $ blake2b 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 =
      BSL.toStrict
        $  toBinary contents
        <> toBinary ty
        <> toBinary (toVal ticketer)
        <> Bi.toLazyByteString (buildInteger (fromIntegral amount))
        <> toBinary (toVal $ EpAddress' dest epName)

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

-- | Set contract's delegate
data SetDelegateOperation = SetDelegateOperation
  { sdoContract :: L1Address
  -- ^ The contract we're setting delegate of
  , sdoDelegate :: Maybe KeyHash
  -- ^ The delegate we're setting
  , sdoCounter :: GlobalCounter
  } deriving stock 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{..} =
    "Set delegate of contract" ++| sdoContract
      |++ "to" ++| maybe "<nobody>" build sdoDelegate |++ ""

-- | Construct 'OperationHash' for a 'SetDelegateOperation'.
mkDelegationOperationHash :: SetDelegateOperation -> OperationHash
mkDelegationOperationHash SetDelegateOperation{..} =
  OperationHash $ blake2b 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 = packMaybe (toBinary' . toVal) sdoDelegate

data EmitOperation = forall t. PackedValScope t => EmitOperation
  { 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 source Emit{..}) =
    "Emit event" ++| quoteF "'" emTag
      |++ "with type" ++| quoteOrIndentF emNotes
      |++^ "and value" ++| quoteOrIndentF emValue
      |++^ "from contract" ++| source
      |++ ""