Interface.hs

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

-- TODO: Replace 'Empty' with 'Never' from morley
{-# OPTIONS_GHC -Wno-deprecations #-}

-- | Type-safe interface for constructing contract upgrades.
--
-- Use this module as follows:
-- 1. Construct 'EpwUpgradeParameters';
-- 2. Use one of the respective functions to convert it to an actual upgrade,
--    one-shot or entrypoint-wise, for tests or production.
module Lorentz.Contracts.Upgradeable.Common.Interface
  ( EpwUpgradeParameters (..)
  , fvUpgrade
  , makeOneShotUpgradeParameters
  , makeOneShotUpgrade
  , makeEpwUpgrade
  , UpgradeWay (..)
  , SimpleUpgradeWay
  , integrationalTestUpgrade
  ) where

import Data.Constraint ((:-)(..), Constraint, Dict(..), (\\))
import Data.Foldable (toList)
import qualified Data.Kind as Kind
import Lorentz
import Prelude (Identity(..), Traversable, Void, absurd, mapM_, maybe, (<$), (<$>))

import Data.Coerce (coerce)
import Unsafe.Coerce (unsafeCoerce)

import Lorentz.Test
import Util.Instances ()
import Util.Named ((.!))
import Util.TypeLits

import Lorentz.Contracts.Upgradeable.Common.Base
import Lorentz.Contracts.Upgradeable.Common.Contract

----------------------------------------------------------------------------
-- Particular pieces updates
----------------------------------------------------------------------------

-- These datatypes are not part of the interface, they only keep
-- information about upgrade and respective invariants
data UContractRouterUpdate curVer newVer where
  -- | Do update.
  UcrUpdate :: UContractRouter newVer -> UContractRouterUpdate curVer newVer
  -- | Retain the same 'UContractRouter'.
  UcrRetain :: UContractRouterUpdate curVer newVer

data PermanentImplUpdate curVer newVer where
  -- | Do update.
  PiUpdate :: PermanentImpl newVer -> PermanentImplUpdate curVer newVer
  -- | Retain the same 'PermanentImpl'.
  PiRetain :: PermanentImplUpdate curVer newVer

-- Interface conveniences
----------------------------------------------------------------------------

-- | Helps to provide a pleasant interface, it would be inconvenient for
-- user to use 'UcrUpdate' and stuff.
class RecognizeUpgPiece expected given where
  recognizeUpgPiece :: given -> expected

instance (newVerE ~ newVerG) =>
         RecognizeUpgPiece
           (UContractRouterUpdate curVerE newVerE)
           (UContractRouter newVerG) where
  recognizeUpgPiece = UcrUpdate

instance ( RequireSameVersionStorageParts curVer newVer
             "upgradeable part implementation"
         , RequireSameVersionInterfaces curVer newVer
         , x ~ Void
         ) =>
         RecognizeUpgPiece (UContractRouterUpdate curVer newVer) (Maybe x) where
  recognizeUpgPiece = maybe UcrRetain absurd

instance (newVerE ~ newVerG) =>
         RecognizeUpgPiece
           (PermanentImplUpdate curVerE newVerE)
           (PermanentImpl newVerG) where
  recognizeUpgPiece = PiUpdate

instance ( RequireSameVersionStorageParts curVer newVer
           "permanent part implementation"
         , RequireSameVersionPermanents curVer newVer
         , x ~ Void
         ) =>
         RecognizeUpgPiece (PermanentImplUpdate curVer newVer) (Maybe x) where
  recognizeUpgPiece = maybe PiRetain absurd

-- Type errors
----------------------------------------------------------------------------

type family RequireSameStorageParts curStore newStore desc :: Constraint where
  RequireSameStorageParts store store _ = ()
  RequireSameStorageParts curStore newStore desc = TypeError
    ( 'Text "Leaving " ':<>: 'Text desc ':<>:
        'Text " unchanged is not safe when storage format changes" ':$$:
      'Text "Old storage is `" ':<>: 'ShowType curStore ':<>: 'Text "`" ':$$:
      'Text "while new one is `" ':<>: 'ShowType newStore ':<>: 'Text "`"
    )
    -- Updates which error tells about are not safe because old code may refer
    -- to a field which was removed in new version of storage.

type RequireSameVersionStorageParts curVer newVer desc =
  RequireSameStorageParts
    (VerUStoreTemplate curVer)
    (VerUStoreTemplate newVer)
    desc

type family RequireSameInterfaces curInterface newInterface :: Constraint where
  RequireSameInterfaces interface interface = ()
  RequireSameInterfaces curInterface newInterface = TypeError
    ( 'Text "Need to update interface" ':$$:
      'Text "Old interface is `" ':<>: 'ShowType curInterface ':<>: 'Text "`" ':$$:
      'Text "while new one is `" ':<>: 'ShowType newInterface ':<>: 'Text "`"
    )

type RequireSameVersionInterfaces curVer newVer =
  RequireSameInterfaces (VerInterface curVer) (VerInterface newVer)

type family RequireSamePermanents (curPerm :: Kind.Type) (newPerm :: Kind.Type)
              :: Kind.Constraint where
  RequireSamePermanents perm perm = ()
  RequireSamePermanents curPerm Empty =
    TypeError
      ( 'Text "Permanent part of contract version is set to default" ':$$:
        'Text "while in existing contract version it is `"
          ':<>: 'ShowType curPerm ':<>: 'Text "`" ':$$:
        'Text "Have you set it in KnownContractVersion instance?"
      )
  RequireSamePermanents curPerm newPerm =
    TypeError
      ( 'Text "Need to update permanent part implementation" ':$$:
        'Text "Parameter of previous version part is of type `"
          ':<>: 'ShowType curPerm ':<>: 'Text "`" ':$$:
        'Text "while in new one it is `" ':<>: 'ShowType newPerm ':<>: 'Text "`"
      )

type RequireSameVersionPermanents curVer newVer =
  RequireSamePermanents (VerPermanent curVer) (VerPermanent newVer)

----------------------------------------------------------------------------
-- Exposed interface
----------------------------------------------------------------------------

-- | Type-safe upgrade construction.
data EpwUpgradeParameters (t :: Kind.Type -> Kind.Type)
                          (curVer :: VersionKind)
                          (newVer :: VersionKind) =
  forall code codePerm.
  ( Traversable t
  , KnownContractVersion curVer, KnownContractVersion newVer
  , RequireSamePermanents (VerPermanent curVer) (VerPermanent newVer)
  , RecognizeUpgPiece (UContractRouterUpdate curVer newVer) code
  , RecognizeUpgPiece (PermanentImplUpdate curVer newVer) codePerm
  ) =>
  EpwUpgradeParameters
  { upMigrationScripts :: t (MigrationScript (VerUStoreTemplate curVer) (VerUStoreTemplate newVer))
    -- ^ Storage migration script.
    -- Supply this field with result of 'migrationToScriptI' or
    -- 'migrationToScripts' call.

  , upNewCode :: code
    -- ^ Updated parameter dispatching logic.
    -- Pass 'UContractRouter' or 'Nothing'.

  , upNewPermCode :: codePerm
    -- ^ Updates implementation of permanent part.
    -- Pass 'PermanentImpl' or 'Nothing'.
  }

permanentsAreSameEvi
  :: RequireSamePermanents (VerPermanent ver1) (VerPermanent ver2)
  :- (VerPermanent ver1 ~ VerPermanent ver2)
permanentsAreSameEvi = Sub $
  unsafeCoerce $ Dict @(Integer ~ Integer)

-- | New version getter.
upNewVersion
  :: forall t curVer newVer.
     EpwUpgradeParameters t curVer newVer -> Version
upNewVersion EpwUpgradeParameters{} =
  contractVersion (Proxy @newVer)

-- | The current version getter.
upCurVersion
  :: forall t curVer newVer.
     EpwUpgradeParameters t curVer newVer -> Version
upCurVersion EpwUpgradeParameters{} =
  contractVersion (Proxy @curVer)

-- | New 'UContractRouter' getter.
upNewCode'
  :: forall curVer newVer t.
      EpwUpgradeParameters t curVer newVer -> Maybe (UContractRouter newVer)
upNewCode' EpwUpgradeParameters{..} =
  case recognizeUpgPiece @(UContractRouterUpdate curVer newVer) upNewCode of
    UcrUpdate code -> Just code
    UcrRetain -> Nothing

-- | New 'PermanentImpl' getter.
upNewPermCode'
  :: forall curVer newVer t.
      EpwUpgradeParameters t curVer newVer -> Maybe (PermanentImpl newVer)
upNewPermCode' EpwUpgradeParameters{..} =
  case recognizeUpgPiece @(PermanentImplUpdate curVer newVer) upNewPermCode of
    PiUpdate code -> Just code
    PiRetain -> Nothing

-- | Make up a "fixed version" upgrade.
-- As argument you supply result of 'migrationToScriptI' or 'migrationToScripts'
-- and entrypoint-wise migration will be used inside.
--
-- Use this method in case you need to authoritatively perform arbitrary
-- modifications of contract storage.
fvUpgrade
  :: forall ver t.
     (KnownContractVersion ver, Traversable t)
  => t (MigrationScript (VerUStoreTemplate ver) (VerUStoreTemplate ver))
  -> EpwUpgradeParameters t ver ver
fvUpgrade migrationScripts = EpwUpgradeParameters
  { upMigrationScripts = migrationScripts
  , upNewCode = Nothing
  , upNewPermCode = Nothing
  }

-- | Construct 'OneShotUpgradeParameters'.
--
-- Naturally, you can construct this kind of upgrade only if your migration
-- has exactly one stage; for batched migrations use 'makeEpwUpgrade'.
makeOneShotUpgradeParameters
  :: forall curVer newVer.
     EpwUpgradeParameters Identity curVer newVer
  -> OneShotUpgradeParameters curVer
makeOneShotUpgradeParameters epw@EpwUpgradeParameters{} =
  ( #currentVersion .!
      upCurVersion epw
  , #newVersion .!
      upNewVersion epw
  , #migrationScript .!
      checkedCoerce (runIdentity $ upMigrationScripts epw)
  , #newCode .! (coerceUContractRouter <$> upNewCode' epw)
  , #newPermCode .! (checkedCoerce <$> upNewPermCode' epw)
                    \\ permanentsAreSameEvi @curVer @newVer
  )

-- | Construct a call which should be performed in order to perform migration.
makeOneShotUpgrade
  :: forall oldVer newVer.
     (EpwUpgradeParameters Identity oldVer newVer)
  -> Parameter oldVer
makeOneShotUpgrade =
  Upgrade . makeOneShotUpgradeParameters

-- | Construct calls which should be performed in order to perform full
-- entrypoint-wise migration.
makeEpwUpgrade
  :: forall curVer newVer t.
     (EpwUpgradeParameters t curVer newVer)
  -> [Parameter curVer]
makeEpwUpgrade epw@EpwUpgradeParameters{} =
  mconcat
  [ [EpwBeginUpgrade (#current .! upCurVersion epw, #new .! upNewVersion epw)]
  , EpwApplyMigration . checkedCoerce <$> toList (upMigrationScripts epw)
  , [EpwSetCode $ coerceUContractRouter code
      | Just code <- pure $ upNewCode' epw
      ]
  , [EpwSetPermCode $ checkedCoerce code
      | Just code <- pure $ upNewPermCode' epw
      ]
     \\ permanentsAreSameEvi @curVer @newVer
  , [EpwFinishUpgrade]
  ]

-- | Way of performing an upgrade.
data UpgradeWay (t :: Kind.Type -> Kind.Type) where
  -- | Perform upgrade in a single transaction.
  -- This, naturally, cannot be used with batched migrations.
  UpgOneShot :: UpgradeWay Identity

  -- | Perform upgrade calling one entrypoint per transaction.
  UpgEntrypointWise :: UpgradeWay t

deriving stock instance Show (UpgradeWay t)

-- | 'UpgradeWay' which can be used with simple (non-batched) migrations.
type SimpleUpgradeWay = UpgradeWay Identity

-- | Perform a contract upgrade in an integrational test scenario.
integrationalTestUpgrade
  :: (PermConstraint curVer)
  => EpwUpgradeParameters t curVer newVer
  -> UpgradeWay t
  -> UTAddress curVer
  -> IntegrationalScenarioM (UTAddress newVer)
integrationalTestUpgrade upgParams way addr =
  coerce addr <$ case way of
    UpgOneShot -> lCallDef addr (makeOneShotUpgrade upgParams)
    UpgEntrypointWise -> mapM_ (lCallDef addr) (makeEpwUpgrade upgParams)