V2.hs

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

{-# OPTIONS_GHC -Wno-orphans #-}

module Lorentz.Contracts.UpgradeableCounterSdu.V2
  ( CounterSduV
  , counterContract
  , migration
  , counterUpgradeParameters
  , counterUpgradeParametersFromV0
  , counterRollbackParameters
  ) where

import Lorentz
import Prelude (Identity)

import Lorentz.Contracts.Upgradeable.Common
import Lorentz.Contracts.Upgradeable.StorageDriven
import Lorentz.Contracts.UpgradeableCounterSdu
import qualified Lorentz.Contracts.UpgradeableCounterSdu.V1 as V1
import Lorentz.UStore
import Lorentz.UStore.Migration
import Util.Named

-- Moved all entrypoints to a dedicated datatype for convenience
data UStoreEntrypoints store = UStoreEntrypoints
  { epInc :: UStoreEntrypoint store ()
  , epDec :: UStoreEntrypoint store ()
  , epGetCounterValue :: UStoreEntrypoint store (Void_ () Integer)
  } deriving stock (Eq, Generic)

data UStoreTemplate = UStoreTemplate
  { -- We want to keep a value of significantly different type comparing to V1
    counterValue :: UStoreField ("i" :! Integer, ())
  , code :: UStoreEntrypoints UStoreTemplate
  } deriving stock (Eq, Generic)

type UStorage = UStore UStoreTemplate

type Interface = UStoreEpInterface UStoreTemplate

instance KnownContractVersion (CounterSduV 2) where
  type VerInterface (CounterSduV 2) = Interface
  type VerUStoreTemplate (CounterSduV 2) = UStoreTemplate
  type VerPermanent (CounterSduV 2) = Permanent

addInt :: Integer -> Entrypoint () UStorage
addInt x = do
  drop @()
  ustoreGetField #counterValue
  getField #i
  push x
  add
  setField #i
  ustoreSetField #counterValue
  nil; pair

runInc :: Entrypoint () UStorage
runInc = addInt 1

runDec :: Entrypoint () UStorage
runDec = addInt (-1)

runGetCounterValue :: Entrypoint (Void_ () Integer) UStorage
runGetCounterValue = void_ $ do
  drop @()
  ustoreGetField #counterValue
  toField #i
  dip drop

counterContract :: UContractRouter (CounterSduV 2)
counterContract = mkSduContract sduFallbackFail

permImpl :: PermanentImpl (CounterSduV 2)
permImpl = mkSmallPermanentImpl
  ( #cGetCounter /-> void_ $ do
      drop @(); ustoreToField #counterValue; toField #i
  , #cGetNothing /-> absurd_
  )

mkStorage :: UStoreTemplate
mkStorage = UStoreTemplate
  { counterValue = UStoreField (#i .! 0, ())
  , code = UStoreEntrypoints
    { epInc = mkUStoreEntrypoint runInc
    , epDec = mkUStoreEntrypoint runDec
    , epGetCounterValue = mkUStoreEntrypoint runGetCounterValue
    }
  }

migration :: UStoreMigration (VerUStoreTemplate (CounterSduV 1)) UStoreTemplate
migration = mkUStoreMigration $ do
  migrateExtractField #counterValue
  int; toNamed #i
  unit; swap; pair
  migrateAddField #counterValue

  migrateRemoveField #epAdd

  push (mkSduEntrypoint runInc)
  migrateOverwriteField #epInc

  push (mkSduEntrypoint runDec)
  migrateAddField #epDec

  push (mkSduEntrypoint runGetCounterValue)
  migrateOverwriteField #epGetCounterValue

  migrationFinish

counterUpgradeParameters :: EpwUpgradeParameters Identity (CounterSduV 1) (CounterSduV 2)
counterUpgradeParameters = EpwUpgradeParameters
  { upMigrationScripts = migrationToScriptI migration
  , upNewCode = counterContract
  , upNewPermCode = permImpl
  }

counterUpgradeParametersFromV0 :: EpwUpgradeParameters Identity (CounterSduV 0) (CounterSduV 2)
counterUpgradeParametersFromV0 = EpwUpgradeParameters
  { upMigrationScripts = migrationToScriptI $ fillUStore mkStorage
  , upNewCode = counterContract
  , upNewPermCode = permImpl
  }

rollback :: UStoreMigration UStoreTemplate (VerUStoreTemplate (CounterSduV 1))
rollback = mkUStoreMigration $ do
  migrateExtractField #counterValue
  toField #i; isNat
  assertSome [mt|Rollback is impossible|]
  migrateAddField #counterValue

  push (mkSduEntrypoint V1.runAdd)
  migrateAddField #epAdd

  migrateCoerceUnsafe #epInc

  migrateRemoveField #epDec

  push (mkSduEntrypoint V1.runGetCounterValue)
  migrateOverwriteField #epGetCounterValue

  migrationFinish

-- Needed for one of our tests
counterRollbackParameters :: EpwUpgradeParameters Identity (CounterSduV 2) (CounterSduV 1)
counterRollbackParameters = EpwUpgradeParameters
  { upMigrationScripts = migrationToScriptI rollback
  , upNewCode = V1.counterContract
  , upNewPermCode = V1.permImpl
  }