Migrations.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# OPTIONS_GHC -Wno-orphans #-}

-- | This module contains common functions and types related to user-defined
-- upgrades. It intentionally does not include mint- and burn-related
-- functionality because these should be handled by particular token
-- implementations (V2 and V1 correspondingly).
--
-- Note that the naming in this module is different from
-- Lorentz.Contracts.Upgradeable: by "migration" here we mean the process
-- of transferring the value from an old contract to the new one rather than
-- applying a transformation to storage.

module Lorentz.Contracts.UserUpgradeable.Migrations
  ( MigrationTarget
  , callMigrationTarget
  , initiateMigration
  ) where

import Lorentz

type MigrationTarget = FutureContract (Address, Natural)

type HasMigrationTarget storage =
  storage `HasFieldsOfType` '["migrationTarget" := Maybe MigrationTarget]

type HasAdmin storage =
  storage `HasFieldsOfType` '["admin" := Address]

-- | Migration is already in progress and cannot be initiated again.
type instance ErrorArg "alreadyMigrating" = ()

-- | Migration script has not been set.
type instance ErrorArg "nowhereToMigrate" = ()

-- | Specified contract (which keeps the new version of the code) does not exist
-- or does not have the specified entrypoint of type (Address, Natural)
type instance ErrorArg "migrationTargetDoesNotExist" = EpAddress


instance CustomErrorHasDoc "alreadyMigrating" where
  customErrClass = ErrClassActionException
  customErrDocMdCause =
    "Migration is already in progress. \
    \Raised in repeated attempt to initiate migration."

instance CustomErrorHasDoc "nowhereToMigrate" where
  customErrClass = ErrClassActionException
  customErrDocMdCause =
    "Migration script has not been set. \
    \Raised on attempt to initiate migration."

instance CustomErrorHasDoc "migrationTargetDoesNotExist" where
  customErrClass = ErrClassActionException
  customErrDocMdCause =
    "Contract with specified address (to which we migrate) does \
    \not exist or has unexpected parameter type"

-- | Starts a migration from an old version of a contract to a new one.
initiateMigration
  :: forall storage. (HasAdmin storage, HasMigrationTarget storage)
  => '[MigrationTarget, storage] :-> '[([Operation], storage)]
initiateMigration = do
  dip $ do ensureAdmin; ensureNotMigrated
  some; setField #migrationTarget
  nil; pair
  where
    ensureAdmin :: '[storage] :-> '[storage]
    ensureAdmin = do
      getField #admin
      sender
      if IsEq
      then nop
      else failCustom_ #senderIsNotAdmin

    ensureNotMigrated :: '[storage] :-> '[storage]
    ensureNotMigrated = do
      getField #migrationTarget
      if IsSome
      then failCustom_ #alreadyMigrating
      else nop

-- |Forges a call to the new version; the forged operation contans the
-- address of the sender, and the amount of tokens to mint.
callMigrationTarget
  :: forall storage. HasMigrationTarget storage
  => '[Natural, storage] :-> '[([Operation], storage)]
callMigrationTarget = do
  sender
  pair
  stackType @('[(Address, Natural), storage])
  dip $ do
    getField #migrationTarget
    ifSome nop $ failCustom_ #nowhereToMigrate
    dup
    runFutureContract
    if IsSome
    then dip drop
    else do
      checkedCoerce_
      failCustom #migrationTargetDoesNotExist
    push (toMutez 0)

  stackType @('[(Address, Natural), Mutez, ContractRef (Address, Natural), _])
  transferTokens
  stackType @('[Operation, storage])
  dip nil; cons; pair