Contract.hs

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

{-# LANGUAGE FunctionalDependencies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

{- | Template for upgradeable contract.

It provides the following features:
1. Contract with upgradeable storage format and entrypoints set.
2. Two way to upgrade the contract - one shot and entrypoint-wise.

-}
module Lorentz.Contracts.Upgradeable.Common.Contract
  ( Parameter(..)
  , UTAddress
  , UContractRef
  , PermConstraint
  , Storage
  , UpgradeableContract
  , PermanentImpl
  , InitUpgradeableContract
  , OneShotUpgradeParameters
  , DVersion (..)
  , NiceVersion
  , upgradeableContract
  , mkEmptyStorage
  , pbsContainedInRun
  , pbsContainedInRunPerm
  ) where

import Lorentz
import Prelude (Typeable)

import qualified Data.Text as T
import Fmt (Buildable(..), fmt)

import qualified Michelson.Typed as T
import Util.Instances ()
import Util.Markdown

import Lorentz.Contracts.Upgradeable.Common.Base
import Lorentz.Contracts.Upgradeable.Common.Doc
import Lorentz.UStore

{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}

-- Types
----------------------------------------------------------------------------

-- | Parameter of upgradeable contract. It contains, among others:
--
-- 1. Entrypoint for running one of upgradeable entrypoints.
-- 2. Entrypoint for running one of permanent entrypoints, suitable e.g. for
--    implementing interfaces.
-- 3a. Entrypoint for upgrade in a single call.
-- 3b. Entrypoints for entrypoint-wise upgrade.
data Parameter (ver :: VersionKind)
  = Run (VerParam ver)
  | RunPerm (VerPermanent ver)
  | Upgrade (OneShotUpgradeParameters ver)
  | GetVersion (View () Version)
  | SetAdministrator Address

  -- Entrypoint-wise upgrades are currently not protected from version mismatch
  -- in subsequent transactions, so the user ought to be careful with them.
  -- This behavior may change in future if deemed desirable.
  | EpwBeginUpgrade ("current" :! Version, "new" :! Version)
  | EpwApplyMigration (MigrationScriptFrom (VerUStoreTemplate ver))
  | EpwSetCode SomeUContractRouter
  | EpwSetPermCode (SomePermanentImpl (VerPermanent ver))
  | EpwFinishUpgrade
  deriving stock (Generic)

deriving stock instance
  (Show (VerParam ver), Show (VerPermanent ver)) => Show (Parameter ver)

instance IsoValue (VerPermanent ver) => IsoValue (Parameter ver)

instance ( interface ~ VerInterface ver
         , UnpackUParam Buildable interface
         , Buildable (VerPermanent ver)
         ) =>
         Buildable (Parameter ver) where
  build = \case
    Run uParam ->
      case unpackUParam @Buildable @interface uParam of
        Left err -> "Run with inconsistent UParam: " <> build err
        Right (name, something) ->
          "Run " <> build name <> " with argument: " <> build something
    RunPerm permParam ->
      "Run permanent entrypoint: " <> build permParam
    Upgrade ( arg #currentVersion -> curVersion
            , arg #newVersion -> newVersion, _, _, _) ->
      "Upgrade " <> build curVersion <> " -> " <> build newVersion
    GetVersion v ->
      "GetVersion (callback to " <> build (viewCallbackTo v) <> ")"
    SetAdministrator addr ->
      "SetAdministrator " <> build addr
    EpwBeginUpgrade (arg #current -> curVersion, arg #new -> newVersion) ->
      "Begin EPW upgrade " <> build curVersion <> " -> " <> build newVersion
    EpwApplyMigration _ ->
      "Apply migration during EPW upgrade"
    EpwSetCode _ ->
      "Set code during EPW upgrade"
    EpwSetPermCode _ ->
      "Set permanent code during EPW upgrade"
    EpwFinishUpgrade ->
      "Finish EPW upgrade"

-- | Constraint on abstract set of permanent entrypoints.
type PermConstraint ver =
  -- If we want to perform calls to top-level entrypoints
  -- (including calls where we pass the whole parameter), then
  -- the following constraints are necessary
  ( NiceParameterFull (VerPermanent ver)
  , NoExplicitDefaultEntrypoint (VerPermanent ver)
  , HasAnnotation (VerPermanent ver)
  , RequireAllUniqueEntrypoints (Parameter ver)
  , Typeable ver
  , Typeable (VerInterface ver)
  , Typeable (VerUStoreTemplate ver)
  )

instance (PermConstraint ver) =>
         ParameterHasEntrypoints (Parameter ver) where
  type ParameterEntrypointsDerivation (Parameter ver) = EpdDelegate

type NiceVersion ver =
  ( Typeable (VerInterface ver), Typeable (VerUStoreTemplate ver)
  , UStoreTemplateHasDoc (VerUStoreTemplate ver)
  , TypeHasDoc (VerPermanent ver), KnownValue (VerPermanent ver)
  , HasAnnotation (VerPermanent ver), Typeable ver, WellTypedIsoValue (VerPermanent ver)
  )

instance NiceVersion ver => TypeHasDoc (Parameter ver) where
  typeDocName _ = "Global.Parameter"
  typeDocMdDescription =
    "Top-level parameter of upgradeable contract.\n\
    \Use `Run` and `RunPerm` entrypoints in order to access contract logic, \
    \other top-level entrypoints are intended solely for migrations purposes."
  typeDocMdReference tp =
    customTypeDocMdReference ("Global.Parameter", DType tp) []
  typeDocHaskellRep = homomorphicTypeDocHaskellRep
  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep

-- | Parameters of one-shot upgrade.
--
-- Do not construct this value manually, consider using 'makeOneShotUpgradeParameters'.
type OneShotUpgradeParameters ver =
  ( "currentVersion" :! Version
  , "newVersion" :! Version
  , "migrationScript" :! MigrationScriptFrom (VerUStoreTemplate ver)
  , "newCode" :! Maybe SomeUContractRouter
  , "newPermCode" :! Maybe (SomePermanentImpl (VerPermanent ver))
  )

type UTAddress ver = TAddress (Parameter ver)
type UContractRef ver = ContractRef (Parameter ver)

data StorageFields (ver :: VersionKind) = StorageFields
  { code :: UContractRouter ver
  , permCode :: PermanentImpl ver
  , admin :: Address
  , currentVersion :: Version
  , paused :: Bool
  } deriving stock Generic

deriving anyclass instance (WellTypedIsoValue (VerPermanent ver)) => IsoValue (StorageFields ver)
deriving anyclass instance (HasAnnotation (VerPermanent ver)) => HasAnnotation (StorageFields ver)

data Storage (ver :: VersionKind) = Storage
  { dataMap :: VerUStore ver
  , fields :: StorageFields ver
  } deriving stock Generic

deriving anyclass instance (WellTypedIsoValue (VerPermanent ver)) => IsoValue (Storage ver)
deriving anyclass instance (HasAnnotation (VerPermanent ver)) => HasAnnotation (Storage ver)

instance NiceVersion ver => TypeHasDoc (StorageFields ver) where
  typeDocName _ = "StorageFields"
  typeDocMdDescription =
    "StorageFields of upgradeable contract.\n\
    \This type keeps general information about upgradeable \
    \contract and the logic responsible for calling entrypoints \
    \implementations kept in UStore."
  typeDocMdReference tp =
    customTypeDocMdReference ("StorageFields", DType tp) []
  typeDocHaskellRep = homomorphicTypeDocHaskellRep
  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep

instance NiceVersion ver => TypeHasDoc (Storage ver) where
  typeDocName _ = "Storage"
  typeDocMdDescription =
    "Type which defines storage of the upgradeable contract.\n\
    \It contains UStore with data related to actual contract logic \
    \and fields which relate to upgradeability logic."
  typeDocMdReference tp =
    customTypeDocMdReference ("Storage", DType tp) []
  typeDocHaskellRep = homomorphicTypeDocHaskellRep
  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep

-- Errors
----------------------------------------------------------------------------

-- | The reuested operation requires the contract to be running but
--   it is paused.
type instance ErrorArg "upgContractIsPaused" = ()

-- | The reuested operation requires the contract to be paused but
--   it is not.
type instance ErrorArg "upgContractIsNotPaused" = ()

-- | The provided expected current version differs from actual one.
type instance ErrorArg "upgVersionMismatch" =
  ("expectedCurrent" :! Version, "actualCurrent" :! Version)


instance Buildable (CustomError "upgContractIsPaused") where
  build (CustomError _ (_, ())) =
    "The requested operation requires the contract to be running but \
    \it is paused"

instance Buildable (CustomError "upgContractIsNotPaused") where
  build (CustomError _ (_, ())) =
    "The requested operation requires the contract to be paused but \
    \it is not."

instance Buildable (CustomError "upgVersionMismatch") where
  build (CustomError _ (_, ( arg #expectedCurrent -> expected
                           , arg #actualCurrent -> actual))) =
    "The provided expected current version " <> build expected <> " \
    \differs from actual one " <> build actual <> "."


instance CustomErrorHasDoc "upgContractIsPaused" where
  customErrClass = ErrClassActionException
  customErrDocMdCause =
    "The contract is in paused state (for migrations)."

instance CustomErrorHasDoc "upgContractIsNotPaused" where
  customErrClass = ErrClassActionException
  customErrDocMdCause =
    "The contract is not in paused state (for migrations)."

instance CustomErrorHasDoc "upgVersionMismatch" where
  customErrClass = ErrClassActionException
  customErrDocMdCause =
    "Current contract version differs from the one passed in the upgrade."

-- Doc
----------------------------------------------------------------------------

-- | Specify version if given contract.
data DVersion = DVersion Version

instance DocItem DVersion where
  docItemPos = 103
  docItemSectionName = Nothing
  docItemToMarkdown _ (DVersion (Version ver)) =
    mdSubsection "Version" (build ver)


-- | Mentions that parameter should be wrapped into 'Run' entry point.
pbsContainedInRun, pbsContainedInRunPerm :: ParamBuildingStep
(pbsContainedInRun, pbsContainedInRunPerm) =
  ( let uparam = UParamUnsafe ([mt|s|], "a")
        mich = mkMich uparam (Run @(EmptyContractVersion ()) uparam)
    in mkPbsWrapIn "Run" mich
  , let a = 999 :: Integer
        mich = mkMich a (RunPerm @(EmptyContractVersion Integer) a)
    in mkPbsWrapIn "RunPerm" mich
  )
  where
    mkMich woCtor wCtor = ParamBuilder $ \p ->
      build $
      T.replace
        (fmt . build . T.untypeValue $ toVal woCtor)
        ("(" <> fmt p <> ")")
        (fmt . build . T.untypeValue $ toVal wCtor)
        --- ^ Kinda hacky way to show how 'Run' is represented in Michelson.
        --- It should be safe though (no extra parts of text should be replaced)
        --- because we expect wCtor to be of form
        --- @{Left|Right}+ (woCtor)@


-- Initialization
----------------------------------------------------------------------------

-- Allowing custom V0 versions in functions below, not only
-- 'EmptyContractVersion' - in case if user wishes to declare his own zero
-- version identifier.

emptyCode :: (VerInterface ver ~ '[]) => UContractRouter ver
emptyCode = mkUContractRouter (drop # nil # pair)

notInitPermCode :: PermanentImpl ver
notInitPermCode = PermanentImpl $
  -- In V0 there most probably won't be a sane way to initialize permanent
  -- entrypoints implementation because storage is yet empty and its future
  -- structure depends on particular target version.
  -- Failing with text here because in practice no one should ever notice such
  -- error.
  failUsing [mt|Permanent entrypoints implementation is not yet initialized|]

mkEmptyStorage
  :: (VerInterface ver ~ '[], VerUStoreTemplate ver ~ ())
  => Address -> Storage ver
mkEmptyStorage admin = Storage
  { dataMap = mkUStore ()
  , fields = StorageFields
    { code = emptyCode
    , permCode = notInitPermCode
    , admin = admin
    , currentVersion = 0
    , paused = False
    }
  }

-- Aliases
----------------------------------------------------------------------------

type UpgradeableContract ver = Contract (Parameter ver) (Storage ver)

type InitUpgradeableContract perm = UpgradeableContract (EmptyContractVersion perm)

-- Code
----------------------------------------------------------------------------

upgradeableContract
  :: forall ver. (NiceVersion ver, NiceParameterFull (Parameter ver))
  => UpgradeableContract ver
upgradeableContract = defaultContract $ do
  doc $ DUpgradeability contractDoc
  doc $ T.DStorageType $ DType $ Proxy @(Storage ver)
  unpair
  entryCase @(Parameter ver) (Proxy @UpgradeableEntrypointsKind)
    ( #cRun /-> do
        doc $ DDescription runDoc
        dip $ do
          ensureNotPaused
          getField #dataMap
          dip $ do
            getField #fields
            toField #code; coerceUnwrap
        pair
        exec
        unpair
        dip $ setField #dataMap
        pair
    , #cRunPerm /-> do
        doc $ DDescription runPermDoc
        dip $ do
          ensureNotPaused
          getField #dataMap
        duupX @3; toField #fields; toField #permCode; coerceUnwrap
        execute
        unpair
        dip $ setField #dataMap
        pair
    , #cUpgrade /-> do
        doc $ DDescription upgradeDoc
        dip (ensureAdmin # ensureNotPaused)
        dup; dip (toField #currentVersion >> toNamed #current >> (checkVersion @ver))
        dup; dip (toField #newVersion >> toNamed #new >> updateVersion)
        getField #migrationScript; swap; dip applyMigration
        getField #newCode; swap; dip $ whenSome migrateCode
        toField #newPermCode; whenSome migratePermCode
        nil; pair
    , #cGetVersion /-> view_ $ do
        doc $ DDescription getVersionDoc
        drop @(); toField #fields; toField #currentVersion
    , #cSetAdministrator /-> do
        doc $ DDescription setAdministratorDoc
        dip (ensureAdmin # getField #fields)
        setField #admin
        setField #fields
        nil; pair
    , #cEpwBeginUpgrade /-> do
        doc $ DDescription epwBeginUpgradeDoc
        dip (ensureAdmin # ensureNotPaused)
        dup; dip (toFieldNamed #current >> (checkVersion @ver))
        toFieldNamed #new >> updateVersion
        setPaused True
        nil; pair
    , #cEpwApplyMigration /-> do
        doc $ DDescription epwApplyMigrationDoc
        dip (ensureAdmin # ensurePaused)
        applyMigration
        nil; pair
    , #cEpwSetCode /-> do
        doc $ DDescription epwSetCodeDoc
        dip (ensureAdmin # ensurePaused)
        migrateCode
        nil; pair
    , #cEpwSetPermCode /-> do
        doc $ DDescription epwSetPermCodeDoc
        dip (ensureAdmin # ensurePaused)
        migratePermCode
        nil; pair
    , #cEpwFinishUpgrade /-> do
        doc $ DDescription epwFinishUpgradeDoc
        ensureAdmin
        ensurePaused
        setPaused False
        nil; pair
    )

ensureAdmin :: (WellTypedIsoValue (VerPermanent ver)) => '[Storage ver] :-> '[Storage ver]
ensureAdmin = do
  getField #fields; toField #admin
  sender; eq
  if_ (nop) (failCustom_ #senderIsNotAdmin)

setPaused :: (WellTypedIsoValue (VerPermanent ver)) => Bool -> '[Storage ver] :-> '[Storage ver]
setPaused newState = do
  getField #fields
  push newState
  setField #paused
  setField #fields

ensurePaused :: (WellTypedIsoValue (VerPermanent ver)) => '[Storage ver] :-> '[Storage ver]
ensurePaused = do
  getField #fields; toField #paused
  if_ (nop) (failCustom_ #upgContractIsNotPaused)

ensureNotPaused :: (WellTypedIsoValue (VerPermanent ver)) => '[Storage ver] :-> '[Storage ver]
ensureNotPaused = do
  getField #fields; toField #paused
  if_ (failCustom_ #upgContractIsPaused) (nop)

checkVersion :: forall ver. (WellTypedIsoValue (VerPermanent ver)) => '["current" :! Version, Storage ver] :-> '[Storage ver]
checkVersion = do
  fromNamed #current; toNamed #expectedCurrent
  dip (getField #fields >> toField #currentVersion >> toNamed #actualCurrent)
  if keepIfArgs (#expectedCurrent ==. #actualCurrent)
  then nop
  else do pair; failCustom #upgVersionMismatch

updateVersion :: forall ver.(WellTypedIsoValue (VerPermanent ver)) =>  '["new" :! Version, Storage ver] :-> '[Storage ver]
updateVersion = do
  fromNamed #new
  dip $ getField #fields
  setField #currentVersion; setField #fields

applyMigration
  :: (WellTypedIsoValue (VerPermanent ver)) =>  '[MigrationScriptFrom (VerUStoreTemplate ver), Storage ver] :-> '[Storage ver]
applyMigration = do
  coerceUnwrap
  dip $ getField #dataMap
  checkedCoerce_
  swap
  exec
  setField #dataMap

migrateCode
  :: (WellTypedIsoValue (VerPermanent ver)) =>  '[SomeUContractRouter, Storage ver]
  :-> '[Storage ver]
migrateCode = do
  dip (getField #fields)
  checkedCoerce_
  setField #code
  setField #fields

migratePermCode
  :: (WellTypedIsoValue (VerPermanent ver)) =>  '[SomePermanentImpl (VerPermanent ver), Storage ver]
  :-> '[Storage ver]
migratePermCode = do
  dip (getField #fields)
  checkedCoerce_
  setField #permCode
  setField #fields