EntrypointWise.hs

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

module Lorentz.Contracts.Upgradeable.EntrypointWise
  ( EntrypointImpl
  , EpwFallback
  , EpwContract (..)
  , EpwCaseClause (..)
  , mkEpwContract
  , mkEpwContractT
  , epwFallbackFail
  , (/==>)
  , removeEndpoint
  , EpwDocumented (..)
  , epwContractDoc
  ) where

import Lorentz
import Prelude (Typeable, fmap)

import Lorentz.Contracts.Upgradeable.Common
import Lorentz.UStore
import Michelson.Text
import Util.TypeLits
import Util.TypeTuple

-- | This data type represents the new contract code and migrations necessary
--   to upgrade the contract endpoints to the new version.
data EpwContract ver = EpwContract
  { epwServe :: UContractRouter ver
  -- ^ `epwServe` does  the dispatching logic and is assumed to be used for
  --   the `code` lambda of the upgradeable contract.

  , epwCodeMigrations :: forall oldStore. [MigrationScript oldStore (VerUStoreTemplate ver)]
  -- ^ `epwCodeMigrations` is a list of packed migrations the client ought to
  --   pass to the `EpwUpgrade` method in order to upgrade the implementation.
  }


-- | Creates the EpwContract data structure from a Rec of case clauses
mkEpwContract
  :: forall (ver :: VersionKind) (interface :: [EntrypointKind]) store.
  ( interface ~ VerInterface ver, store ~ VerUStoreTemplate ver
  , CodeMigrations interface
  , HasUStore "code" MText (EntrypointImpl store) store
  , HasUField "fallback" (EpwFallback store) store
  , Typeable store
  )
  => Rec (EpwCaseClause store) interface
  -> EpwFallback store
  -> EpwContract ver
mkEpwContract entries fallback = EpwContract
  { epwServe = mkUContractRouter $
      caseUParamUnsafe' @store @interface
  , epwCodeMigrations =
      fmap (MigrationScript . checkedCoercing_ @UStore_ @(UStore store)) $
        (push fallback # ustoreSetField #fallback) : mkMigrations entries
  }

-- | Like 'mkEpwContract', but accepts a tuple of clauses, not a 'Rec'.
mkEpwContractT
  :: forall clauses ver (interface :: [EntrypointKind]) store.
  ( interface ~ VerInterface ver, store ~ VerUStoreTemplate ver
  , clauses ~ Rec (EpwCaseClause store) interface
  , RecFromTuple clauses
  , CodeMigrations interface
  , HasUStore "code" MText (EntrypointImpl store) store
  , HasUField "fallback" (EpwFallback store) store
  , Typeable store
  )
  => IsoRecTuple clauses
  -> EpwFallback store
  -> EpwContract ver
mkEpwContractT clauses fallback = mkEpwContract (recFromTuple clauses) fallback

-- | A helper type that defines an entrypoint that receives
--   an unpacked argument
type TypedEntrypointImpl arg store =
  Lambda (arg, UStore store) ([Operation], UStore store)

-- | A helper type that defines an entrypoint that receives
--   a packed argument, i.e. it's basically an unpack instruction
--   followed by a TypedEntrypoint code
type EntrypointImpl store =
  Lambda (ByteString, UStore store) ([Operation], UStore store)

-- | A helper type that defines a function being called in case
--   no implementation matches the requested entrypoint
type EpwFallback store =
  Lambda ((MText, ByteString), UStore store) ([Operation], UStore store)

-- | A data type representing a full case clause with the name
--   and implementation of an entrypoint.
data EpwCaseClause store (entry :: EntrypointKind) where
  EpwCaseClause
    :: TypedEntrypointImpl arg store
    -> EpwCaseClause store '(name, arg)

(/==>)
  :: Label name
  -> Lambda (arg, UStore store) ([Operation], UStore store)
  -> EpwCaseClause store '(name, arg)
(/==>) _ = EpwCaseClause
infixr 0 /==>

-- | A greatly simplified version of UParam lookup code.
--
--   While it does not provide the same safety guarantees as UParam's lookup,
--   it does a map search instead of a linear search, and thus it may consume
--   less gas in practice.
caseUParamUnsafe'
  :: forall store (entries :: [EntrypointKind]).
  ( HasUStore "code" MText (EntrypointImpl store) store
  , HasUField "fallback" (EpwFallback store) store
  )
  => '[UParam entries, UStore store] :-> '[([Operation], UStore store)]
caseUParamUnsafe' = do
  dup
  unwrapUParam
  unpair
  dip (duupX @3)
  ustoreGet #code
  if IsSome
  then dip (dip (drop) # pair) # swap # exec
  else do
    drop
    dip (ustoreGetField #fallback # swap)
    unwrapUParam
    pair
    exec

-- | Default implementation for 'EpwFallback' reports an error just like its
--   UParam counterpart
epwFallbackFail :: EpwFallback store
epwFallbackFail =
  car # car # failCustom #uparamNoSuchEntrypoint

-- | These functions create the code blocks one has to supply in order
--   upgrade a contract. These code blocks write the code of the contract
--   to a submap of UStore. Code migrations _do not delete_ the old code
--   blocks from UStore, so would still be possible to call the old entry
--   points manually after applying migrations.
class CodeMigrations (entries :: [EntrypointKind]) where
  mkMigrations
    :: forall store.
    ( Typeable store
    , GetUStoreKey store "code" ~ MText
    , GetUStoreValue store "code" ~ EntrypointImpl store
    )
    =>  Rec (EpwCaseClause store) entries
    -> ['[UStore store] :-> '[UStore store]]

instance
  ( CodeMigrations entries
  , KnownSymbol name
  , NiceUnpackedValue arg
  )
  => CodeMigrations ((name ?: arg) ': entries) where
    mkMigrations (EpwCaseClause impl :& clauses) =
      (push untypedLambda # push (symbolToMText @name) # ustoreInsert #code)
      : mkMigrations clauses
      where
        untypedLambda = do
          unpair
          unpackRaw @arg
          ifSome nop $ failCustom_ #uparamArgumentUnpackFailed
          pair
          impl

instance CodeMigrations '[] where
  mkMigrations _ = []

-- | Removes an endpoint from the #code submap
removeEndpoint
  :: forall store name s.
     GetUStoreKey store "code" ~ MText
  => Label name
  -> UStore store ': s :-> UStore store ': s
removeEndpoint Label = do
  push $ symbolToMText @name
  ustoreDelete #code

-- | Helper for documenting entrypoints with EPW interface.
class EpwDocumented (entries :: [EntrypointKind]) where
  -- | Make up documentation for given entry points.
  --
  -- As result you get a fake contract from which you can later build desired
  -- documentation. Although, you may want to add contract name and
  -- description first.
  epwDocument
    :: Rec (EpwCaseClause store) entries
    -> Lambda () ()

instance EpwDocumented '[] where
  epwDocument RNil = nop

instance (KnownSymbol name, EpwDocumented es) =>
         EpwDocumented ('(name, a) ': es) where
  epwDocument (EpwCaseClause code :& es) =
    let documentedCode = clarifyParamBuildingSteps (pbsUParam @name) code
    in cutLorentzNonDoc documentedCode # epwDocument es

-- | By given list of entrypoints make up a fake contract which contains
-- documentation for the body of given upgradeable contract.
epwContractDoc
  :: forall ver.
     ( NiceVersion ver
     , KnownContractVersion ver
     , EpwDocumented (VerInterface ver)
     , PermConstraint ver
     )
  => Rec (EpwCaseClause (VerUStoreTemplate ver)) (VerInterface ver)
  -> PermanentImpl ver
  -> Lambda () ()
epwContractDoc upgImpl permImpl =
  fakeCoercing . finalizeParamCallingDoc @(Parameter ver) $ do
    doc $ DVersion (contractVersion (Proxy @ver))
    fakeCoercing $
      cCode $ upgradeableContract @ver
    fakeCoercing $
      -- We have to put this part (which describes actual logic of our contract)
      -- separately, because this is not directly part of @Run@ entrypoint of
      -- 'upgradeableContract', and also because Markdown editors usually do not
      -- render deeply nested headers well.
      clarifyParamBuildingSteps pbsContainedInRun $
        epwDocument upgImpl
    fakeCoercing $
      clarifyParamBuildingSteps pbsContainedInRunPerm $
        unPermanentImpl permImpl