{-# OPTIONS_GHC -Wno-orphans #-}
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]
type instance ErrorArg "alreadyMigrating" = ()
type instance ErrorArg "nowhereToMigrate" = ()
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"
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
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