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

{-# OPTIONS_GHC -Wno-orphans #-}

-- | The second version of a minimal user-upgradeable ledger. This version
-- is not designed to be upgraded further — it lacks InitiateMigration and
-- MigrateMyTokens entrypoints. However, it has MigrateFrom (callable from V1),
-- and mints new tokens when a user calls V1.MigrateMyTokens. Other functions
-- (either upgradeability-related or standard Transfer/GetTotalSupply may be
-- added if deemed desirable).
--
-- 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. Thus, MigrationScript here is a lambda
-- that forges an operation to migrate user's funds rather than a function
-- that upgrades storage in-place.

module Lorentz.Contracts.UserUpgradeable.V2
  ( Parameter(..)
  , Storage(..)
  , mkStorage
  , userUpgradeableContract
  ) where

import Lorentz

import Lorentz.Contracts.UserUpgradeable.Migrations (MigrationTarget)
import qualified Lorentz.Contracts.UserUpgradeable.V1 as V1

data Storage = Storage
  { Storage -> Map Address Natural
ledger :: Map Address Natural
    -- ^ We use a Map instead of a BigMap to simplify the implementation a bit.
  , Storage -> Maybe (TAddress Parameter)
previousVersion :: Maybe (TAddress V1.Parameter)
  , Storage -> Maybe MigrationTarget
migrationTarget :: Maybe MigrationTarget
  }
  deriving stock (forall x. Storage -> Rep Storage x)
-> (forall x. Rep Storage x -> Storage) -> Generic Storage
forall x. Rep Storage x -> Storage
forall x. Storage -> Rep Storage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Storage x -> Storage
$cfrom :: forall x. Storage -> Rep Storage x
Generic
  deriving anyclass (WellTypedToT Storage
WellTypedToT Storage
-> (Storage -> Value (ToT Storage))
-> (Value (ToT Storage) -> Storage)
-> IsoValue Storage
Value (ToT Storage) -> Storage
Storage -> Value (ToT Storage)
forall a.
WellTypedToT a
-> (a -> Value (ToT a)) -> (Value (ToT a) -> a) -> IsoValue a
fromVal :: Value (ToT Storage) -> Storage
$cfromVal :: Value (ToT Storage) -> Storage
toVal :: Storage -> Value (ToT Storage)
$ctoVal :: Storage -> Value (ToT Storage)
$cp1IsoValue :: WellTypedToT Storage
IsoValue, AnnOptions
FollowEntrypointFlag -> Notes (ToT Storage)
(FollowEntrypointFlag -> Notes (ToT Storage))
-> AnnOptions -> HasAnnotation Storage
forall a.
(FollowEntrypointFlag -> Notes (ToT a))
-> AnnOptions -> HasAnnotation a
annOptions :: AnnOptions
$cannOptions :: AnnOptions
getAnnotation :: FollowEntrypointFlag -> Notes (ToT Storage)
$cgetAnnotation :: FollowEntrypointFlag -> Notes (ToT Storage)
HasAnnotation)

type instance ErrorArg "userUpgradable'unauthorizedMigrateFrom" = ()

instance CustomErrorHasDoc "userUpgradable'unauthorizedMigrateFrom" where
  customErrClass :: ErrorClass
customErrClass = ErrorClass
ErrClassActionException
  customErrDocMdCause :: Markdown
customErrDocMdCause = Markdown
"Unauthorized call is performed."

mkStorage :: TAddress V1.Parameter -> Storage
mkStorage :: TAddress Parameter -> Storage
mkStorage TAddress Parameter
prevVersion = Storage :: Map Address Natural
-> Maybe (TAddress Parameter) -> Maybe MigrationTarget -> Storage
Storage
  { ledger :: Map Address Natural
ledger = Map Address Natural
forall a. Monoid a => a
mempty
  , previousVersion :: Maybe (TAddress Parameter)
previousVersion = TAddress Parameter -> Maybe (TAddress Parameter)
forall a. a -> Maybe a
Just TAddress Parameter
prevVersion
  , migrationTarget :: Maybe MigrationTarget
migrationTarget = Maybe MigrationTarget
forall a. Maybe a
Nothing
  }

data Parameter
  = MigrateFrom (Address, Natural)
  -- ^ When called by V1, mints new tokens to Address
  | GetBalance (View Address Natural)
  -- ^ Returns the balance of a holder.
  deriving stock (forall x. Parameter -> Rep Parameter x)
-> (forall x. Rep Parameter x -> Parameter) -> Generic Parameter
forall x. Rep Parameter x -> Parameter
forall x. Parameter -> Rep Parameter x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Parameter x -> Parameter
$cfrom :: forall x. Parameter -> Rep Parameter x
Generic
  deriving anyclass WellTypedToT Parameter
WellTypedToT Parameter
-> (Parameter -> Value (ToT Parameter))
-> (Value (ToT Parameter) -> Parameter)
-> IsoValue Parameter
Value (ToT Parameter) -> Parameter
Parameter -> Value (ToT Parameter)
forall a.
WellTypedToT a
-> (a -> Value (ToT a)) -> (Value (ToT a) -> a) -> IsoValue a
fromVal :: Value (ToT Parameter) -> Parameter
$cfromVal :: Value (ToT Parameter) -> Parameter
toVal :: Parameter -> Value (ToT Parameter)
$ctoVal :: Parameter -> Value (ToT Parameter)
$cp1IsoValue :: WellTypedToT Parameter
IsoValue

instance ParameterHasEntrypoints Parameter where
  type ParameterEntrypointsDerivation Parameter = EpdPlain

userUpgradeableContract :: Contract Parameter Storage
userUpgradeableContract :: Contract Parameter Storage
userUpgradeableContract = ContractCode Parameter Storage -> Contract Parameter Storage
forall cp st.
(NiceParameterFull cp, HasCallStack) =>
ContractCode cp st -> Contract cp st
defaultContract (ContractCode Parameter Storage -> Contract Parameter Storage)
-> ContractCode Parameter Storage -> Contract Parameter Storage
forall a b. (a -> b) -> a -> b
$ do
  '[(Parameter, Storage)] :-> '[Parameter, Storage]
forall a b (s :: [*]). ((a, b) : s) :-> (a : b : s)
unpair
  IsoRecTuple
  (Rec
     (CaseClauseL '[Storage] (ContractOut Storage))
     '[ 'CaseClauseParam "MigrateFrom" ('OneField (Address, Natural)),
        'CaseClauseParam "GetBalance" ('OneField (View Address Natural))])
-> '[Parameter, Storage] :-> ContractOut Storage
forall dt (out :: [*]) (inp :: [*]) clauses.
CaseTC dt out inp clauses =>
IsoRecTuple clauses -> (dt : inp) :-> out
caseT @Parameter
    ( Label "cMigrateFrom"
forall a. IsLabel "cMigrateFrom" a => a
forall (x :: Symbol) a. IsLabel x a => a
#cMigrateFrom Label "cMigrateFrom"
-> ('[(Address, Natural), Storage] :-> ContractOut Storage)
-> CaseClauseL
     '[Storage]
     (ContractOut Storage)
     ('CaseClauseParam "MigrateFrom" ('OneField (Address, Natural)))
forall (name :: Symbol) body clause.
CaseArrow name body clause =>
Label name -> body -> clause
/-> '[(Address, Natural), Storage] :-> '[(Address, Natural), Storage]
forall a b (s :: [*]). Castable_ a b => (a : s) :-> (b : s)
checkedCoerce_ ('[(Address, Natural), Storage] :-> '[(Address, Natural), Storage])
-> ('[(Address, Natural), Storage] :-> ContractOut Storage)
-> '[(Address, Natural), Storage] :-> ContractOut Storage
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[(Address, Natural), Storage] :-> ContractOut Storage
migrateFrom
    , Label "cGetBalance"
forall a. IsLabel "cGetBalance" a => a
forall (x :: Symbol) a. IsLabel x a => a
#cGetBalance Label "cGetBalance"
-> ('[View Address Natural, Storage] :-> ContractOut Storage)
-> CaseClauseL
     '[Storage]
     (ContractOut Storage)
     ('CaseClauseParam "GetBalance" ('OneField (View Address Natural)))
forall (name :: Symbol) body clause.
CaseArrow name body clause =>
Label name -> body -> clause
/-> (forall (s0 :: [*]). (Address : Storage : s0) :-> (Natural : s0))
-> '[View Address Natural, Storage] :-> ContractOut Storage
forall r a storage (s :: [*]).
NiceParameter r =>
(forall (s0 :: [*]). (a : storage : s0) :-> (r : s0))
-> (View a r : storage : s) :-> ((List Operation, storage) : s)
view_ ((forall (s0 :: [*]). (Address : Storage : s0) :-> (Natural : s0))
 -> '[View Address Natural, Storage] :-> ContractOut Storage)
-> (forall (s0 :: [*]).
    (Address : Storage : s0) :-> (Natural : s0))
-> '[View Address Natural, Storage] :-> ContractOut Storage
forall a b. (a -> b) -> a -> b
$ do
        ((Storage : s0) :-> (Map Address Natural : s0))
-> (Address : Storage : s0)
   :-> (Address : Map Address Natural : s0)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (Label "ledger"
-> (Storage : s0) :-> (GetFieldType Storage "ledger" : s0)
forall dt (name :: Symbol) (st :: [*]).
InstrGetFieldC dt name =>
Label name -> (dt : st) :-> (GetFieldType dt name : st)
toField Label "ledger"
forall a. IsLabel "ledger" a => a
forall (x :: Symbol) a. IsLabel x a => a
#ledger); (Address : Map Address Natural : s0) :-> (Maybe Natural : s0)
forall c (s :: [*]).
(GetOpHs c, KnownValue (GetOpValHs c)) =>
(GetOpKeyHs c : c : s) :-> (Maybe (GetOpValHs c) : s)
get; ((Natural : s0) :-> (Natural : s0))
-> (s0 :-> (Natural : s0))
-> (Maybe Natural : s0) :-> (Natural : s0)
forall a (s :: [*]) (s' :: [*]).
((a : s) :-> s') -> (s :-> s') -> (Maybe a : s) :-> s'
ifSome (Natural : s0) :-> (Natural : s0)
forall (s :: [*]). s :-> s
nop (Natural -> s0 :-> (Natural : s0)
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push Natural
0)
    )

-- | Mints new tokens to Address if called by V1
migrateFrom :: '[(Address, Natural), Storage] :-> '[([Operation], Storage)]
migrateFrom :: '[(Address, Natural), Storage] :-> ContractOut Storage
migrateFrom = do
  ('[Storage] :-> '[Storage])
-> '[(Address, Natural), Storage]
   :-> '[(Address, Natural), Storage]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip '[Storage] :-> '[Storage]
ensurePrevVersion
  ('[Storage] :-> '[Map Address Natural, Storage])
-> '[(Address, Natural), Storage]
   :-> '[(Address, Natural), Map Address Natural, Storage]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (('[Storage] :-> '[Map Address Natural, Storage])
 -> '[(Address, Natural), Storage]
    :-> '[(Address, Natural), Map Address Natural, Storage])
-> ('[Storage] :-> '[Map Address Natural, Storage])
-> '[(Address, Natural), Storage]
   :-> '[(Address, Natural), Map Address Natural, Storage]
forall a b. (a -> b) -> a -> b
$ Label "ledger"
-> '[Storage] :-> '[GetFieldType Storage "ledger", Storage]
forall dt (name :: Symbol) (st :: [*]).
InstrGetFieldC dt name =>
Label name -> (dt : st) :-> (GetFieldType dt name : dt : st)
getField Label "ledger"
forall a. IsLabel "ledger" a => a
forall (x :: Symbol) a. IsLabel x a => a
#ledger
  '[(Address, Natural), Map Address Natural, Storage]
:-> '[Address, Natural, Map Address Natural, Storage]
forall a b (s :: [*]). ((a, b) : s) :-> (a : b : s)
unpair; '[Address, Natural, Map Address Natural, Storage]
:-> '[Natural, Address, Map Address Natural, Storage]
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
swap
  ('[Address, Map Address Natural, Storage]
 :-> '[Natural, Address, Map Address Natural, Storage])
-> '[Natural, Address, Map Address Natural, Storage]
   :-> '[Natural, Natural, Address, Map Address Natural, Storage]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (('[Address, Map Address Natural, Storage]
  :-> '[Natural, Address, Map Address Natural, Storage])
 -> '[Natural, Address, Map Address Natural, Storage]
    :-> '[Natural, Natural, Address, Map Address Natural, Storage])
-> ('[Address, Map Address Natural, Storage]
    :-> '[Natural, Address, Map Address Natural, Storage])
-> '[Natural, Address, Map Address Natural, Storage]
   :-> '[Natural, Natural, Address, Map Address Natural, Storage]
forall a b. (a -> b) -> a -> b
$ do
    '[Address, Map Address Natural, Storage]
:-> '[Address, Address, Map Address Natural, Storage]
forall a (s :: [*]). (a : s) :-> (a : a : s)
dup
    ('[Address, Map Address Natural, Storage]
 :-> '[Natural, Map Address Natural, Storage])
-> '[Address, Address, Map Address Natural, Storage]
   :-> '[Address, Natural, Map Address Natural, Storage]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip (('[Address, Map Address Natural, Storage]
  :-> '[Natural, Map Address Natural, Storage])
 -> '[Address, Address, Map Address Natural, Storage]
    :-> '[Address, Natural, Map Address Natural, Storage])
-> ('[Address, Map Address Natural, Storage]
    :-> '[Natural, Map Address Natural, Storage])
-> '[Address, Address, Map Address Natural, Storage]
   :-> '[Address, Natural, Map Address Natural, Storage]
forall a b. (a -> b) -> a -> b
$ do ('[Map Address Natural, Storage]
 :-> '[Map Address Natural, Map Address Natural, Storage])
-> '[Address, Map Address Natural, Storage]
   :-> '[Address, Map Address Natural, Map Address Natural, Storage]
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
dip '[Map Address Natural, Storage]
:-> '[Map Address Natural, Map Address Natural, Storage]
forall a (s :: [*]). (a : s) :-> (a : a : s)
dup; '[Address, Map Address Natural, Map Address Natural, Storage]
:-> '[Maybe Natural, Map Address Natural, Storage]
forall c (s :: [*]).
(GetOpHs c, KnownValue (GetOpValHs c)) =>
(GetOpKeyHs c : c : s) :-> (Maybe (GetOpValHs c) : s)
get; ('[Natural, Map Address Natural, Storage]
 :-> '[Natural, Map Address Natural, Storage])
-> ('[Map Address Natural, Storage]
    :-> '[Natural, Map Address Natural, Storage])
-> '[Maybe Natural, Map Address Natural, Storage]
   :-> '[Natural, Map Address Natural, Storage]
forall a (s :: [*]) (s' :: [*]).
((a : s) :-> s') -> (s :-> s') -> (Maybe a : s) :-> s'
ifSome '[Natural, Map Address Natural, Storage]
:-> '[Natural, Map Address Natural, Storage]
forall (s :: [*]). s :-> s
nop (Natural
-> '[Map Address Natural, Storage]
   :-> '[Natural, Map Address Natural, Storage]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push @Natural Natural
0)
    '[Address, Natural, Map Address Natural, Storage]
:-> '[Natural, Address, Map Address Natural, Storage]
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
swap
  '[Natural, Natural, Address, Map Address Natural, Storage]
:-> '[Natural, Natural, Address, Map Address Natural, Storage]
forall (s :: [*]). s :-> s
stackType @('[Natural, Natural, Address, Map Address Natural, Storage])
  '[Natural, Natural, Address, Map Address Natural, Storage]
:-> '[Natural, Address, Map Address Natural, Storage]
forall n m (s :: [*]).
ArithOpHs Add n m =>
(n : m : s) :-> (ArithResHs Add n m : s)
add; '[Natural, Address, Map Address Natural, Storage]
:-> '[Maybe Natural, Address, Map Address Natural, Storage]
forall a (s :: [*]). (a : s) :-> (Maybe a : s)
some; '[Maybe Natural, Address, Map Address Natural, Storage]
:-> '[Address, Maybe Natural, Map Address Natural, Storage]
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
swap; '[Address, Maybe Natural, Map Address Natural, Storage]
:-> '[Map Address Natural, Storage]
forall c (s :: [*]).
UpdOpHs c =>
(UpdOpKeyHs c : UpdOpParamsHs c : c : s) :-> (c : s)
update
  Label "ledger"
-> '[GetFieldType Storage "ledger", Storage] :-> '[Storage]
forall dt (name :: Symbol) (st :: [*]).
InstrSetFieldC dt name =>
Label name -> (GetFieldType dt name : dt : st) :-> (dt : st)
setField Label "ledger"
forall a. IsLabel "ledger" a => a
forall (x :: Symbol) a. IsLabel x a => a
#ledger
  '[Storage] :-> '[List Operation, Storage]
forall p (s :: [*]). KnownValue p => s :-> (List p : s)
nil; '[List Operation, Storage] :-> ContractOut Storage
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair
  where
    ensurePrevVersion :: '[Storage] :-> '[Storage]
    ensurePrevVersion :: '[Storage] :-> '[Storage]
ensurePrevVersion = do
      Label "previousVersion"
-> '[Storage]
   :-> '[GetFieldType Storage "previousVersion", Storage]
forall dt (name :: Symbol) (st :: [*]).
InstrGetFieldC dt name =>
Label name -> (dt : st) :-> (GetFieldType dt name : dt : st)
getField Label "previousVersion"
forall a. IsLabel "previousVersion" a => a
forall (x :: Symbol) a. IsLabel x a => a
#previousVersion; '[Maybe (TAddress Parameter), Storage]
:-> '[Maybe Address, Storage]
forall a b (s :: [*]). Castable_ a b => (a : s) :-> (b : s)
checkedCoerce_
      ('[Address, Storage] :-> '[Bool, Storage])
-> ('[Storage] :-> '[Bool, Storage])
-> '[Maybe Address, Storage] :-> '[Bool, Storage]
forall a (s :: [*]) (s' :: [*]).
((a : s) :-> s') -> (s :-> s') -> (Maybe a : s) :-> s'
ifSome ('[Address, Storage] :-> '[Address, Address, Storage]
forall (s :: [*]). s :-> (Address : s)
sender ('[Address, Storage] :-> '[Address, Address, Storage])
-> ('[Address, Address, Storage] :-> '[Bool, Storage])
-> '[Address, Storage] :-> '[Bool, Storage]
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# '[Address, Address, Storage] :-> '[Bool, Storage]
forall n (s :: [*]). NiceComparable n => (n : n : s) :-> (Bool : s)
eq) (Bool -> '[Storage] :-> '[Bool, Storage]
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push Bool
False)
      ('[Storage] :-> '[Storage])
-> ('[Storage] :-> '[Storage]) -> '[Bool, Storage] :-> '[Storage]
forall (s :: [*]) (s' :: [*]).
(s :-> s') -> (s :-> s') -> (Bool : s) :-> s'
if_ '[Storage] :-> '[Storage]
forall (s :: [*]). s :-> s
nop (('[Storage] :-> '[Storage]) -> '[Bool, Storage] :-> '[Storage])
-> ('[Storage] :-> '[Storage]) -> '[Bool, Storage] :-> '[Storage]
forall a b. (a -> b) -> a -> b
$ Label "userUpgradable'unauthorizedMigrateFrom"
-> '[Storage] :-> '[Storage]
forall (tag :: Symbol) (s :: [*]) (any :: [*]).
(MustHaveErrorArg tag (MText, ()), CustomErrorHasDoc tag) =>
Label tag -> s :-> any
failCustom_ Label "userUpgradable'unauthorizedMigrateFrom"
forall a. IsLabel "userUpgradable'unauthorizedMigrateFrom" a => a
forall (x :: Symbol) a. IsLabel x a => a
#userUpgradable'unauthorizedMigrateFrom