Contracts.hs

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

{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE NoApplicativeDo #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Contracts for tickets tests.
module Test.Lorentz.Tickets.Contracts
  ( atomicMissileLaunchContract

  , PermitTokensStorage (..)
  , PermitTokensParameter
  , permitTokensContract

  , allowancesContract
  ) where

import Prelude (Typeable)

import Lorentz
import Lorentz.Tickets

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

type instance ErrorArg "insufficient_tokens_permitted_by_ticket" =
  ("permitted" :! Natural, "spent" :! Natural)

instance CustomErrorHasDoc "insufficient_tokens_permitted_by_ticket" where
  customErrClass = ErrClassActionException
  customErrDocMdCause =
    "Attempt to spend more tokens than permitted."

----------------------------------------------------------------------------
-- Contract with authorized action
----------------------------------------------------------------------------

atomicMissileLaunchContract
  :: (Typeable ticketer)
  => TAddress ticketer () -> Contract (Ticket Integer) Bool ()
atomicMissileLaunchContract ticketer = defaultContract $ do
  car; push ticketer
  authorizeAction validateCode
  push True; nil; pair
  where
    validateCode =
      push 12345 # eq # if_ nop (failUsing [mt|Bad code|])

----------------------------------------------------------------------------
-- Contract with authorized tokens spend from single address
----------------------------------------------------------------------------

data PermitTokensStorage = PermitTokensStorage
  { ptsPermittedTokens :: Maybe (STicket "tokens" ())
  , ptsAdmin :: Address
    -- ^ Who permits tokens spending
  } deriving stock (Generic)
    deriving anyclass (IsoValue, HasAnnotation)

instance TypeHasDoc PermitTokensStorage where
  typeDocMdDescription = "Storage"

-- TODO: [#585]: avoid uses of next two functions, work with storage
-- as with normal ADT
decomposePermitTokensStorage
  :: PermitTokensStorage : s
  :-> Maybe (STicket "tokens" ()) : Address : s
decomposePermitTokensStorage = forcedCoerce_ # unpair

composePermitTokensStorage
  :: Maybe (STicket "tokens" ()) : Address : s
  :-> PermitTokensStorage : s
composePermitTokensStorage = pair # forcedCoerce_

instance HasFieldOfType PermitTokensStorage name ty =>
         StoreHasField PermitTokensStorage name ty where
  storeFieldOps = storeFieldOpsADT

data PermitTokensParameter
  = PermitSpend Natural
  | PermitAllow (Ticket ())
  | PermitGet (Void_ () Natural)
  | PermitSetAdmin Address
  deriving stock (Generic)
  deriving anyclass (IsoValue)

instance ParameterHasEntrypoints PermitTokensParameter where
  type ParameterEntrypointsDerivation PermitTokensParameter = EpdPlain

-- | A contract that emulates simple allowance functionality, where
-- permission is provided via tickets.
permitTokensContract
  :: Contract PermitTokensParameter PermitTokensStorage ()
permitTokensContract = defaultContract $ do
  doc $ dStorage @PermitTokensStorage
  unpair; caseT
    ( #cPermitSpend /-> do
        dip decomposePermitTokensStorage
        subtractSTicket (failCustom #insufficient_tokens_permitted_by_ticket)
        composePermitTokensStorage
    , #cPermitAllow /-> do
        dip decomposePermitTokensStorage
        dupN @3; checkedCoerce_ @Address
        dip toSTicket; verifyTicketer; drop @()
        addSTicket
        composePermitTokensStorage
    , #cPermitGet /-> void_ do
        drop @()
        stToField #ptsPermittedTokens
        sTicketAmount
    , #cPermitSetAdmin /-> do
        dip $ drop @PermitTokensStorage
        none
        composePermitTokensStorage
    )
  nil; pair

----------------------------------------------------------------------------
-- Contract with authorized tokens spend from many addresses
----------------------------------------------------------------------------

type AllowancesStorage =
  BigMap Address (STicket "allowances" ())

data AllowancesParameter
  = AllowancesSpend (Address, Natural)
  | AllowancesAllow (Ticket ())
  | AllowancesGet (Void_ Address Natural)
  deriving stock (Generic)
  deriving anyclass (IsoValue, HasAnnotation)

instance ParameterHasEntrypoints AllowancesParameter where
  type ParameterEntrypointsDerivation AllowancesParameter = EpdPlain

-- | A contract that emulates simple allowance functionality, where
-- permission is provided via tickets.
allowancesContract
  :: Contract AllowancesParameter AllowancesStorage ()
allowancesContract = defaultContract $ do
  unpair; caseT
    ( #cAllowancesSpend /-> do
        unpair @Address @Natural; swap
        dupN @2 @Address
        dip @Address $ do
          dip @Natural $ do
            dip none; getAndUpdate
          subtractSTicket (failCustom #insufficient_tokens_permitted_by_ticket)
        update
    , #cAllowancesAllow /-> do
        toSTicket; dip (drop @())
        dip swap
        stackType @[Address, AllowancesStorage, STicket _ _]
        dup; dip @Address $ do
          dip none; getAndUpdate
          dig @2
          addSTicket
        update
    , #cAllowancesGet /-> void_ do
        get; sTicketAmount
    )
  nil; pair