V2.hs

-- 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
  { ledger :: Map Address Natural
    -- ^ We use a Map instead of a BigMap to simplify the implementation a bit.
  , previousVersion :: Maybe (TAddress V1.Parameter)
  , migrationTarget :: Maybe MigrationTarget
  }
  deriving stock Generic
  deriving anyclass (IsoValue, HasAnnotation)

type instance ErrorArg "userUpgradable'unauthorizedMigrateFrom" = ()

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

mkStorage :: TAddress V1.Parameter -> Storage
mkStorage prevVersion = Storage
  { ledger = mempty
  , previousVersion = Just prevVersion
  , migrationTarget = 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 Generic
  deriving anyclass IsoValue

instance ParameterHasEntrypoints Parameter where
  type ParameterEntrypointsDerivation Parameter = EpdPlain

userUpgradeableContract :: Contract Parameter Storage
userUpgradeableContract = defaultContract $ do
  unpair
  caseT @Parameter
    ( #cMigrateFrom /-> checkedCoerce_ # migrateFrom
    , #cGetBalance /-> view_ $ do
        dip (toField #ledger); get; ifSome nop (push 0)
    )

-- | Mints new tokens to Address if called by V1
migrateFrom :: '[(Address, Natural), Storage] :-> '[([Operation], Storage)]
migrateFrom = do
  dip ensurePrevVersion
  dip $ getField #ledger
  unpair; swap
  dip $ do
    dup
    dip $ do dip dup; get; ifSome nop (push @Natural 0)
    swap
  stackType @('[Natural, Natural, Address, Map Address Natural, Storage])
  add; some; swap; update
  setField #ledger
  nil; pair
  where
    ensurePrevVersion :: '[Storage] :-> '[Storage]
    ensurePrevVersion = do
      getField #previousVersion; checkedCoerce_
      ifSome (sender # eq) (push False)
      if_ nop $ failCustom_ #userUpgradable'unauthorizedMigrateFrom