-- 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 :: ErrorClass
customErrClass = ErrorClass
ErrClassActionException
  customErrDocMdCause :: Markdown
customErrDocMdCause =
    Markdown
"Migration is already in progress. \
    \Raised in repeated attempt to initiate migration."

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

instance CustomErrorHasDoc "migrationTargetDoesNotExist" where
  customErrClass :: ErrorClass
customErrClass = ErrorClass
ErrClassActionException
  customErrDocMdCause :: Markdown
customErrDocMdCause =
    Markdown
"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 :: '[MigrationTarget, storage] :-> '[([Operation], storage)]
initiateMigration = do
  ('[storage] :-> '[storage])
-> '[MigrationTarget, storage] :-> '[MigrationTarget, storage]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (('[storage] :-> '[storage])
 -> '[MigrationTarget, storage] :-> '[MigrationTarget, storage])
-> ('[storage] :-> '[storage])
-> '[MigrationTarget, storage] :-> '[MigrationTarget, storage]
forall a b. (a -> b) -> a -> b
$ do '[storage] :-> '[storage]
ensureAdmin; '[storage] :-> '[storage]
ensureNotMigrated
  '[MigrationTarget, storage] :-> '[Maybe MigrationTarget, storage]
forall a (s :: [*]). (a : s) :-> (Maybe a : s)
some; Label "migrationTarget"
-> '[GetFieldType storage "migrationTarget", storage]
   :-> '[storage]
forall dt (name :: Symbol) (st :: [*]).
InstrSetFieldC dt name =>
Label name -> (GetFieldType dt name : dt : st) :-> (dt : st)
setField Label "migrationTarget"
forall a. IsLabel "migrationTarget" a => a
forall (x :: Symbol) a. IsLabel x a => a
#migrationTarget
  '[storage] :-> '[[Operation], storage]
forall p (s :: [*]). KnownValue p => s :-> (List p : s)
nil; '[[Operation], storage] :-> '[([Operation], storage)]
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair
  where
    ensureAdmin :: '[storage] :-> '[storage]
    ensureAdmin :: '[storage] :-> '[storage]
ensureAdmin = do
      Label "admin"
-> '[storage] :-> '[GetFieldType storage "admin", storage]
forall dt (name :: Symbol) (st :: [*]).
InstrGetFieldC dt name =>
Label name -> (dt : st) :-> (GetFieldType dt name : dt : st)
getField Label "admin"
forall a. IsLabel "admin" a => a
forall (x :: Symbol) a. IsLabel x a => a
#admin
      '[Address, storage] :-> '[Address, Address, storage]
forall (s :: [*]). s :-> (Address : s)
sender
      if Condition
  '[Address, Address, storage]
  '[storage]
  '[storage]
  '[storage]
  '[storage]
forall a (argl :: [*]) (outb :: [*]).
NiceComparable a =>
Condition (a : a : argl) argl argl outb outb
IsEq
      then '[storage] :-> '[storage]
forall (s :: [*]). s :-> s
nop
      else Label "senderIsNotAdmin" -> '[storage] :-> '[storage]
forall (tag :: Symbol) (s :: [*]) (any :: [*]).
(MustHaveErrorArg tag (MText, ()), CustomErrorHasDoc tag) =>
Label tag -> s :-> any
failCustom_ Label "senderIsNotAdmin"
forall a. IsLabel "senderIsNotAdmin" a => a
forall (x :: Symbol) a. IsLabel x a => a
#senderIsNotAdmin

    ensureNotMigrated :: '[storage] :-> '[storage]
    ensureNotMigrated :: '[storage] :-> '[storage]
ensureNotMigrated = do
      Label "migrationTarget"
-> '[storage]
   :-> '[GetFieldType storage "migrationTarget", storage]
forall dt (name :: Symbol) (st :: [*]).
InstrGetFieldC dt name =>
Label name -> (dt : st) :-> (GetFieldType dt name : dt : st)
getField Label "migrationTarget"
forall a. IsLabel "migrationTarget" a => a
forall (x :: Symbol) a. IsLabel x a => a
#migrationTarget
      if Condition
  '[Maybe MigrationTarget, storage]
  '[MigrationTarget, storage]
  '[storage]
  '[storage]
  '[storage]
forall a (argr :: [*]) (outb :: [*]).
Condition (Maybe a : argr) (a : argr) argr outb outb
IsSome
      then Label "alreadyMigrating"
-> '[MigrationTarget, storage] :-> '[storage]
forall (tag :: Symbol) (s :: [*]) (any :: [*]).
(MustHaveErrorArg tag (MText, ()), CustomErrorHasDoc tag) =>
Label tag -> s :-> any
failCustom_ Label "alreadyMigrating"
forall a. IsLabel "alreadyMigrating" a => a
forall (x :: Symbol) a. IsLabel x a => a
#alreadyMigrating
      else '[storage] :-> '[storage]
forall (s :: [*]). s :-> s
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 :: '[Natural, storage] :-> '[([Operation], storage)]
callMigrationTarget = do
  '[Natural, storage] :-> '[Address, Natural, storage]
forall (s :: [*]). s :-> (Address : s)
sender
  '[Address, Natural, storage] :-> '[(Address, Natural), storage]
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair
  '[(Address, Natural), storage] :-> '[(Address, Natural), storage]
forall (s :: [*]). s :-> s
stackType @('[(Address, Natural), storage])
  ('[storage] :-> '[Mutez, ContractRef (Address, Natural), storage])
-> '[(Address, Natural), storage]
   :-> '[(Address, Natural), Mutez, ContractRef (Address, Natural),
         storage]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (('[storage] :-> '[Mutez, ContractRef (Address, Natural), storage])
 -> '[(Address, Natural), storage]
    :-> '[(Address, Natural), Mutez, ContractRef (Address, Natural),
          storage])
-> ('[storage]
    :-> '[Mutez, ContractRef (Address, Natural), storage])
-> '[(Address, Natural), storage]
   :-> '[(Address, Natural), Mutez, ContractRef (Address, Natural),
         storage]
forall a b. (a -> b) -> a -> b
$ do
    Label "migrationTarget"
-> '[storage]
   :-> '[GetFieldType storage "migrationTarget", storage]
forall dt (name :: Symbol) (st :: [*]).
InstrGetFieldC dt name =>
Label name -> (dt : st) :-> (GetFieldType dt name : dt : st)
getField Label "migrationTarget"
forall a. IsLabel "migrationTarget" a => a
forall (x :: Symbol) a. IsLabel x a => a
#migrationTarget
    ('[MigrationTarget, storage] :-> '[MigrationTarget, storage])
-> ('[storage] :-> '[MigrationTarget, storage])
-> '[Maybe MigrationTarget, storage]
   :-> '[MigrationTarget, storage]
forall a (s :: [*]) (s' :: [*]).
((a : s) :-> s') -> (s :-> s') -> (Maybe a : s) :-> s'
ifSome '[MigrationTarget, storage] :-> '[MigrationTarget, storage]
forall (s :: [*]). s :-> s
nop (('[storage] :-> '[MigrationTarget, storage])
 -> '[Maybe MigrationTarget, storage]
    :-> '[MigrationTarget, storage])
-> ('[storage] :-> '[MigrationTarget, storage])
-> '[Maybe MigrationTarget, storage]
   :-> '[MigrationTarget, storage]
forall a b. (a -> b) -> a -> b
$ Label "nowhereToMigrate"
-> '[storage] :-> '[MigrationTarget, storage]
forall (tag :: Symbol) (s :: [*]) (any :: [*]).
(MustHaveErrorArg tag (MText, ()), CustomErrorHasDoc tag) =>
Label tag -> s :-> any
failCustom_ Label "nowhereToMigrate"
forall a. IsLabel "nowhereToMigrate" a => a
forall (x :: Symbol) a. IsLabel x a => a
#nowhereToMigrate
    '[MigrationTarget, storage]
:-> '[MigrationTarget, MigrationTarget, storage]
forall a (s :: [*]). (a : s) :-> (a : a : s)
dup
    '[MigrationTarget, MigrationTarget, storage]
:-> '[Maybe (ContractRef (Address, Natural)), MigrationTarget,
      storage]
forall p (s :: [*]).
NiceParameter p =>
(FutureContract p : s) :-> (Maybe (ContractRef p) : s)
runFutureContract
    if Condition
  '[Maybe (ContractRef (Address, Natural)), MigrationTarget, storage]
  '[ContractRef (Address, Natural), MigrationTarget, storage]
  '[MigrationTarget, storage]
  '[ContractRef (Address, Natural), storage]
  '[ContractRef (Address, Natural), storage]
forall a (argr :: [*]) (outb :: [*]).
Condition (Maybe a : argr) (a : argr) argr outb outb
IsSome
    then ('[MigrationTarget, storage] :-> '[storage])
-> '[ContractRef (Address, Natural), MigrationTarget, storage]
   :-> '[ContractRef (Address, Natural), storage]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip '[MigrationTarget, storage] :-> '[storage]
forall a (s :: [*]). (a : s) :-> s
drop
    else do
      '[MigrationTarget, storage] :-> '[EpAddress, storage]
forall a b (s :: [*]). Castable_ a b => (a : s) :-> (b : s)
checkedCoerce_
      Label "migrationTargetDoesNotExist"
-> '[EpAddress, storage]
   :-> '[ContractRef (Address, Natural), storage]
forall (tag :: Symbol) err (s :: [*]) (any :: [*]).
(MustHaveErrorArg tag (MText, err), CustomErrorHasDoc tag,
 KnownError err) =>
Label tag -> (err : s) :-> any
failCustom Label "migrationTargetDoesNotExist"
forall a. IsLabel "migrationTargetDoesNotExist" a => a
forall (x :: Symbol) a. IsLabel x a => a
#migrationTargetDoesNotExist
    Mutez
-> '[ContractRef (Address, Natural), storage]
   :-> '[Mutez, ContractRef (Address, Natural), storage]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push (Word32 -> Mutez
toMutez Word32
0)

  '[(Address, Natural), Mutez, ContractRef (Address, Natural),
  storage]
:-> '[(Address, Natural), Mutez, ContractRef (Address, Natural),
      storage]
forall (s :: [*]). s :-> s
stackType @('[(Address, Natural), Mutez, ContractRef (Address, Natural), _])
  '[(Address, Natural), Mutez, ContractRef (Address, Natural),
  storage]
:-> '[Operation, storage]
forall p (s :: [*]).
NiceParameter p =>
(p : Mutez : ContractRef p : s) :-> (Operation : s)
transferTokens
  '[Operation, storage] :-> '[Operation, storage]
forall (s :: [*]). s :-> s
stackType @('[Operation, storage])
  ('[storage] :-> '[[Operation], storage])
-> '[Operation, storage] :-> '[Operation, [Operation], storage]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip '[storage] :-> '[[Operation], storage]
forall p (s :: [*]). KnownValue p => s :-> (List p : s)
nil; '[Operation, [Operation], storage] :-> '[[Operation], storage]
forall a (s :: [*]). (a : List a : s) :-> (List a : s)
cons; '[[Operation], storage] :-> '[([Operation], storage)]
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair