V1.hs

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

{-# OPTIONS_GHC -Wno-orphans #-}

-- | The first version of a minimal user-upgradeable ledger. It does not
-- offer common ledger functions like Transfer/GetTotalSupply/etc. to
-- demonstrate a concept and keep the code consise.
--
-- 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.V1
  ( Parameter(..)
  , Storage(..)
  , mkStorage
  , userUpgradeableContract
  ) where

import Lorentz

import Lorentz.Contracts.UserUpgradeable.Migrations
  (MigrationTarget, callMigrationTarget, initiateMigration)

data Storage = Storage
  { ledger :: BigMap Address Natural
  , admin :: Address
  , migrationTarget :: Maybe MigrationTarget
  }
  deriving stock Generic
  deriving anyclass (IsoValue, HasAnnotation)

mkStorage :: BigMap Address Natural -> Address -> Storage
mkStorage balances admin = Storage
  { ledger = balances
  , admin = admin
  , migrationTarget = Nothing
  }

data Parameter
  = InitiateMigration MigrationTarget
  -- ^ Token admin calls this entrypoint and provides a lambda to forge
  -- V2.MigrateFrom operation.
  | MigrateMyTokens Natural
  -- ^ Users are supposed to call this entrypoint if they want to upgrade
  -- their tokens.
  | GetBalance (View Address Natural)
  -- ^ Returns the balance of a holder.
  deriving stock Generic
  deriving anyclass IsoValue

instance ParameterHasEntrypoints Parameter where
  type ParameterEntrypointsDerivation Parameter = EpdPlain

type instance ErrorArg "userUpgradable'notEnoughTokens" = ()

instance CustomErrorHasDoc "userUpgradable'notEnoughTokens" where
  customErrClass = ErrClassActionException
  customErrDocMdCause = "Not enough tokens."

userUpgradeableContract :: Contract Parameter Storage
userUpgradeableContract = defaultContract $ do
  unpair
  caseT @Parameter
    ( #cInitiateMigration /-> initiateMigration
    , #cMigrateMyTokens /-> do dup; dip burnFromSender; callMigrationTarget
    , #cGetBalance /-> view_ $ do
        dip (toField #ledger); get; ifSome nop (push 0)
    )

-- | Burns tokens from the sender
burnFromSender :: '[Natural, Storage] :-> '[Storage]
burnFromSender = do
  dip $ do
    getField #ledger
    sender
    get
    ifSome nop $ failCustom_ #userUpgradable'notEnoughTokens
  swap
  stackType @('[Natural, Natural, Storage])
  sub
  isNat
  ifSome nop $ failCustom_ #userUpgradable'notEnoughTokens
  dup; push @Natural 0
  if IsEq
  then drop # none
  else some
  stackType @('[Maybe Natural, Storage])
  dip (getField #ledger);
  sender; update; setField #ledger