StorageDriven.hs

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

-- | Contracts based on storage-driven upgrages.
--
-- Here entrypoints are declared as part of UStore template, then
-- we automatically derive public API of the contract from it.
--
-- Migration mechanism for storage (see 'Lorentz.UStore.Migration') also applies
-- to these entrypoints.
--
-- This approach differs from one in "Lorentz.Contracts.Upgradeable.EntrypointWise"
-- in the following points:
-- 1. Storage migrations are not handled here, only 'UContractRouter' creation.
--    The former is comprehensively handled by 'Lorentz.UStore.Migration'.
-- 2. Contract interface is declared via storage - 'UStoreEntrypoint' entries
--    in storage define which public entrypoints (those which are callable via
--    passing 'UParam') the contract will have.
-- 3. Parameter dispatch fallback is made part of 'UContractRouter',
--    not storing it in storage here for simplicity.
--    The user can still decide to keep fallback implementation in storage if it
--    is big and then refer to it in 'SduFallback'.
module Lorentz.Contracts.Upgradeable.StorageDriven
  ( UStoreEntrypoint
  , UMarkerEntrypoint
  , SduEntrypoint
  , pattern UStoreEntrypoint
  , mkSduEntrypoint
  , mkUStoreEntrypoint
  , SduFallback
  , UStoreEpInterface
  , mkSduContract
  , callUStoreEntrypoint
  , sduFallbackFail

    -- * Documentation
  , sduDocument
  , SduDocumentTW
  , sduAddEntrypointDoc
  , SduAddEntrypointDocTW
  , sduContractDoc
  ) where

import Lorentz
import Prelude (Const(..), Identity(..), Typeable, id)

import qualified Data.Kind as Kind

import Lorentz.Contracts.Upgradeable.Common
import qualified Lorentz.Instr as L
import Lorentz.UStore
import Lorentz.UStore.Doc
import Lorentz.UStore.Traversal
import Util.TypeLits

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

type SduEntrypointUntyped store =
  Lambda (ByteString, UStore store) ([Operation], UStore store)

-- | An entrypoint which is assumed to be kept in 'UStore'.
--   It accepts a packed argument.
newtype SduEntrypoint (store :: Kind.Type) (arg :: Kind.Type) = SduEntrypoint
  { unSduEntrypoint :: SduEntrypointUntyped store
  } deriving stock (Eq, Generic)
    deriving anyclass (IsoValue, Wrappable)

instance ( Typeable store, Typeable arg
         , TypeHasDoc (UStore store), TypeHasDoc arg
         ) =>
         TypeHasDoc (SduEntrypoint store arg) where
  typeDocMdDescription =
    "Public upgradeable entrypoint of a contract."
  typeDocMdReference tp =
    customTypeDocMdReference ("SduEntrypoint", DType tp) [DType (Proxy @arg)]
  typeDocHaskellRep =
    concreteTypeDocHaskellRep @(SduEntrypoint () Integer)
  typeDocMichelsonRep =
    concreteTypeDocMichelsonRep @(SduEntrypoint () Integer)
  typeDocDependencies p = mconcat
    [ [SomeDocDefinitionItem $ DUStoreTemplate $ Proxy @()]
        --- ^ for example of repr
    , genericTypeDocDependencies p
    ]

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

-- | Public entrypoint of a contract kept in 'UStore'.
--
-- These are mere 'UStore' fields but treated specially by 'mkSduContract'
-- function which produces 'UContractRouter' capable of calling these
-- entrypoints.
--
-- This type is not intended for keeping internal code, in such case consider
-- using 'UStoreField' instead.
type UStoreEntrypoint store arg =
  UStoreFieldExt UMarkerEntrypoint (SduEntrypoint store arg)
data UMarkerEntrypoint :: UStoreMarkerType

-- | Access code of 'UStoreEntrypoint'.
pattern UStoreEntrypoint :: SduEntrypointUntyped store -> UStoreEntrypoint store arg
pattern UStoreEntrypoint code = UStoreField (SduEntrypoint code)

type UStoreEpKey = (Lambda () (), MText)

instance KnownUStoreMarker UMarkerEntrypoint where
  mkFieldMarkerUKey field =
    -- Using special encoding to avoid finding non-entrypoints in parameter
    -- dispatch.
    -- Packing an empty lambda is quite cheap, and seems to fit semantically
    -- best.
    lPackValueRaw @UStoreEpKey (L.nop, field)

  type ShowUStoreField UMarkerEntrypoint (SduEntrypoint store arg) =
    'Text "entrypoint with argument " ':<>: 'ShowType arg ':<>:
    'Text " over storage " ':<>: 'ShowType store

instance UStoreMarkerHasDoc UMarkerEntrypoint where
  ustoreMarkerKeyEncoding k = "pack ({} :: lambda, " <> k <> ")"

----------------------------------------------------------------------------
-- Logic
----------------------------------------------------------------------------

-- | Get the set of entrypoints (i.e. 'UStoreEntrypoint' entries) stored in UStore
-- with given template.
type UStoreEpInterface utemplate =
  ExtractInterface utemplate (PickMarkedFields UMarkerEntrypoint utemplate)

type family ExtractInterface (utemplate :: Kind.Type) (ufields :: [(Symbol, Kind.Type)])
              :: [EntrypointKind] where
  ExtractInterface _ '[] = '[]
  ExtractInterface utemplate (entry ': entries) =
    ExtractEntrypoint utemplate entry ': ExtractInterface utemplate entries

type family ExtractEntrypoint (utemplate :: Kind.Type) (ufields :: (Symbol, Kind.Type))
              :: EntrypointKind where
  ExtractEntrypoint utemplate '(name, SduEntrypoint utemplate arg) =
    name ?: arg
  ExtractEntrypoint _ '(name, SduEntrypoint (UStore _) _) =
    TypeError ('Text "UStore passed to entrypoint, expected UStore template" ':$$:
               'Text "In UStore field " ':<>: 'ShowType name
              )
  ExtractEntrypoint utemplate' '(name, SduEntrypoint utemplate _) =
    TypeError ('Text "Entrypoint polymorphic over foreign storage: UStore " ':<>:
               'ShowType utemplate ':$$:
               'Text "In storage UStore " ':<>: 'ShowType utemplate' ':$$:
               'Text "In field " ':<>: 'ShowType name
              )
  ExtractEntrypoint _ v =
    TypeError ('Text "Field with entrypoint of unknown type " ':<>: 'ShowType v)

-- | Construct 'UContractRouter' which allows calling all entrypoints stored
-- as 'UStoreEntrypoint' entries of 'UStore'.
mkSduContract
  :: (Typeable (VerUStoreTemplate ver))
  => SduFallback (VerUStoreTemplate ver) -> UContractRouter ver
mkSduContract fallback = mkUContractRouter $ do
  dup @(UParam _)
  unwrapUParam; car
  dip (duupX @2)
  -- Further fetching UStore field manually because field name comes from stack
  push nop; pair; packRaw @UStoreEpKey
  get
  if IsSome
  then do
    unpackRaw @(SduEntrypointUntyped _)
    -- This error normally should not occur by construction of @interface@ type
    assertSome [mt|Wrong sdu entrypoint type|]
    dip $ do
      unwrapUParam; cdr
      pair
    swap
    exec
  else do
    unwrapUParam
    pair
    fallback

-- | Construct public entrypoint.
mkSduEntrypoint
  :: NiceUnpackedValue arg
  => Entrypoint arg (UStore store)
  -> SduEntrypoint store arg
mkSduEntrypoint code = SduEntrypoint $ do
  unpair
  unpackRaw
  ifSome nop $ failCustom_ #uparamArgumentUnpackFailed
  code

-- | Construct public entrypoint for 'UStore'.
mkUStoreEntrypoint
  :: NiceUnpackedValue arg
  => Entrypoint arg (UStore store)
  -> UStoreEntrypoint store arg
mkUStoreEntrypoint = UStoreField . mkSduEntrypoint

-- | Call an entrypoint since it appeared on stack.
callSduEntrypoint
  :: NicePackedValue arg
  => arg : SduEntrypoint store arg : UStore store : s
     :-> ([Operation], UStore store) : s
callSduEntrypoint = do
  dip $ coerceUnwrap >> swap
  packRaw
  pair
  exec

-- | Call an entrypoint stored under the given field.
callUStoreEntrypoint
  :: (NicePackedValue arg, HasUField field (SduEntrypoint store arg) store)
  => Label field
  -> arg : UStore store : s :-> ([Operation], UStore store) : s
callUStoreEntrypoint label = do
  dip $ ustoreGetField label
  callSduEntrypoint

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

----------------------------------------------------------------------------
-- Documentation
----------------------------------------------------------------------------

-- | Gather documentation of entrypoints kept in given storage.
-- Unfortunatelly, this seems to be the only place where we can pick the code
-- for documenting it.
--
-- Note: in most cases you want to use this function is couple with
-- 'sduAddEntrypointDoc'.
sduDocument
  :: UStoreTraversable SduDocumentTW template
  => template -> Lambda () ()
sduDocument = foldUStore SduDocumentTW

data SduDocumentTW = SduDocumentTW

instance UStoreTraversalWay SduDocumentTW where
  type UStoreTraversalArgumentWrapper SduDocumentTW = Identity
  type UStoreTraversalMonad SduDocumentTW = Const (Lambda () ())

instance {-# OVERLAPPING #-}
         UStoreTraversalFieldHandler SduDocumentTW
           UMarkerEntrypoint (SduEntrypoint store arg) where
  ustoreTraversalFieldHandler
      SduDocumentTW (Label :: Label fieldName) (Identity (SduEntrypoint ep)) =
    Const $
    cutLorentzNonDoc $ clarifyParamBuildingSteps (pbsUParam @fieldName) ep

instance UStoreTraversalFieldHandler SduDocumentTW marker v where
  ustoreTraversalFieldHandler SduDocumentTW _ _ = Const mempty
instance UStoreTraversalSubmapHandler SduDocumentTW k v where
  ustoreTraversalSubmapHandler SduDocumentTW _ _ = Const mempty

-- | Mark all public code kept in given storage as atomic entrypoints.
--
-- Sometimes you want your 'SduEntrypoint's to contain multiple sub-entrypoints
-- inside, in this case using 'entryCase' function you get documentation for each
-- of sub-entrypoints automatically and calling this function is not necessary.
-- In case when this __does not__ hold and 'SduEntrypoint' keeps exactly one
-- entrypoint, you still need to mark it as such in order for 'sduDocument'
-- to handle it properly. This function does exactly that - it finds all
-- UStore entrypoints and marks them for documentation.
sduAddEntrypointDoc
  :: ( UStoreTraversable SduAddEntrypointDocTW template
     , DocItem (DEntrypoint epKind)
     )
  => Proxy epKind -> template -> template
sduAddEntrypointDoc epKindP = modifyUStore (SduAddEntrypointDocTW epKindP)

data SduAddEntrypointDocTW =
  -- I don't want this type to be polymorphic over @epKind@ because this way
  -- phantom type would appear in 'sduAddEntrypointDoc' signature and any
  -- helper over this function would need to write the respective constraint
  -- with @epKind@. So using existential quantification.
  forall epKind. (DocItem (DEntrypoint epKind)) =>
  SduAddEntrypointDocTW (Proxy epKind)

instance UStoreTraversalWay SduAddEntrypointDocTW where
  type UStoreTraversalArgumentWrapper SduAddEntrypointDocTW = Identity
  type UStoreTraversalMonad SduAddEntrypointDocTW = Identity

instance {-# OVERLAPPING #-}
         ( TypeHasDoc arg, NiceParameterFull arg
         ) =>
         UStoreTraversalFieldHandler SduAddEntrypointDocTW
           UMarkerEntrypoint (SduEntrypoint store arg) where
  ustoreTraversalFieldHandler
      (SduAddEntrypointDocTW (_ :: Proxy epKind))
      (Label :: Label fieldName) (Identity (SduEntrypoint ep)) =
    Identity . SduEntrypoint $
      docGroup (DEntrypoint @epKind (symbolValT' @fieldName))
        (doc (constructDEpArg @arg) # ep)

instance UStoreTraversalFieldHandler SduAddEntrypointDocTW marker v where
  ustoreTraversalFieldHandler _ _ = id
instance UStoreTraversalSubmapHandler SduAddEntrypointDocTW k v where
  ustoreTraversalSubmapHandler _ _ = id

-- | By given storage make up a fake contract which contains
-- documentation of all entrypoints declared by this storage.
--
-- Note: in most cases you want to use this function in couple with
-- 'sduAddEntrypointDoc'.
--
-- Note: we intentionally allow accepted @UStore@ template not to correspond
-- to the contract version storage, this is useful when one does not want to
-- provide the full storage (construction of which may require passing some
-- parameters), rather only part of storage with entrypoints.
sduContractDoc
  :: forall utemplate ver.
     ( NiceVersion ver
     , KnownContractVersion ver
     , UStoreTraversable SduDocumentTW utemplate
     , PermConstraint ver
     )
  => utemplate
  -> PermanentImpl ver
  -> Lambda () ()
sduContractDoc store permImpl = do
    doc $ DVersion (contractVersion (Proxy @ver))
    fakeCoercing $
      cCode $ upgradeableContract @ver
    finalizeParamCallingDoc @(Parameter 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 $
        sduDocument store
    finalizeParamCallingDoc @(Parameter ver) . fakeCoercing $
      clarifyParamBuildingSteps pbsContainedInRunPerm $
        unPermanentImpl permImpl