{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-specialize #-}

module Hydra.Contract.Util where

import Hydra.Contract.Error (ToErrorCode (..))
import Hydra.Contract.HeadError (HeadError (..), errorCode)
import Hydra.Data.Party (Party)
import Hydra.Prelude (Show)
import PlutusLedgerApi.V1.Value (isZero)
import PlutusLedgerApi.V2 (
  CurrencySymbol,
  TokenName (..),
  TxInfo (TxInfo, txInfoMint),
  Value (getValue),
  toBuiltinData,
 )
import PlutusTx.AssocMap qualified as AssocMap
import PlutusTx.Builtins (serialiseData)
import PlutusTx.Prelude

hydraHeadV1 :: BuiltinByteString
hydraHeadV1 :: BuiltinByteString
hydraHeadV1 = BuiltinByteString
"HydraHeadV1"

-- | Checks that the output contains the state token (ST) with the head
-- 'CurrencySymbol' and 'TokenName' of 'hydraHeadV1'
hasST :: CurrencySymbol -> Value -> Bool
hasST :: CurrencySymbol -> Value -> Bool
hasST CurrencySymbol
headPolicyId Value
v =
  Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
    Map TokenName Integer
tokenMap <- CurrencySymbol
-> Map CurrencySymbol (Map TokenName Integer)
-> Maybe (Map TokenName Integer)
forall k v. Eq k => k -> Map k v -> Maybe v
AssocMap.lookup CurrencySymbol
headPolicyId (Map CurrencySymbol (Map TokenName Integer)
 -> Maybe (Map TokenName Integer))
-> Map CurrencySymbol (Map TokenName Integer)
-> Maybe (Map TokenName Integer)
forall a b. (a -> b) -> a -> b
$ Value -> Map CurrencySymbol (Map TokenName Integer)
getValue Value
v
    Integer
quantity <- TokenName -> Map TokenName Integer -> Maybe Integer
forall k v. Eq k => k -> Map k v -> Maybe v
AssocMap.lookup (BuiltinByteString -> TokenName
TokenName BuiltinByteString
hydraHeadV1) Map TokenName Integer
tokenMap
    Bool -> Maybe Bool
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Integer
quantity Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
{-# INLINEABLE hasST #-}

-- | Checks all tokens related to some specific `CurrencySymbol`.
--
-- This checks both PTs and ST are burnt.
mustBurnAllHeadTokens :: Value -> CurrencySymbol -> [Party] -> Bool
mustBurnAllHeadTokens :: Value -> CurrencySymbol -> [Party] -> Bool
mustBurnAllHeadTokens Value
minted CurrencySymbol
headCurrencySymbol [Party]
parties =
  BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode BurntTokenNumberMismatch) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    Integer
burntTokens Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== [Party] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length [Party]
parties Integer -> Integer -> Integer
forall a. AdditiveSemigroup a => a -> a -> a
+ Integer
1
 where
  burntTokens :: Integer
burntTokens =
    case CurrencySymbol
-> Map CurrencySymbol (Map TokenName Integer)
-> Maybe (Map TokenName Integer)
forall k v. Eq k => k -> Map k v -> Maybe v
AssocMap.lookup CurrencySymbol
headCurrencySymbol (Value -> Map CurrencySymbol (Map TokenName Integer)
getValue Value
minted) of
      Maybe (Map TokenName Integer)
Nothing -> Integer
0
      Just Map TokenName Integer
tokenMap -> Integer -> Integer
forall a. AdditiveGroup a => a -> a
negate (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Map TokenName Integer -> Integer
forall (t :: * -> *) a. (Foldable t, AdditiveMonoid a) => t a -> a
sum Map TokenName Integer
tokenMap
{-# INLINEABLE mustBurnAllHeadTokens #-}

-- | Checks if the state token (ST) for list of parties containing specific
-- 'CurrencySymbol' are burnt.
mustBurnST :: Value -> CurrencySymbol -> Bool
mustBurnST :: Value -> CurrencySymbol -> Bool
mustBurnST Value
val CurrencySymbol
headCurrencySymbol =
  case CurrencySymbol
-> Map CurrencySymbol (Map TokenName Integer)
-> Maybe (Map TokenName Integer)
forall k v. Eq k => k -> Map k v -> Maybe v
AssocMap.lookup CurrencySymbol
headCurrencySymbol (Value -> Map CurrencySymbol (Map TokenName Integer)
getValue Value
val) of
    Maybe (Map TokenName Integer)
Nothing -> Bool
False
    Just Map TokenName Integer
tokenMap ->
      case TokenName -> Map TokenName Integer -> Maybe Integer
forall k v. Eq k => k -> Map k v -> Maybe v
AssocMap.lookup (BuiltinByteString -> TokenName
TokenName BuiltinByteString
hydraHeadV1) Map TokenName Integer
tokenMap of
        Maybe Integer
Nothing -> Bool
False
        Just Integer
v -> Integer
v Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Integer
forall a. AdditiveGroup a => a -> a
negate Integer
1
{-# INLINEABLE mustBurnST #-}

mustNotMintOrBurn :: TxInfo -> Bool
mustNotMintOrBurn :: TxInfo -> Bool
mustNotMintOrBurn TxInfo{Value
txInfoMint :: TxInfo -> Value
txInfoMint :: Value
txInfoMint} =
  BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"U01" (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    Value -> Bool
isZero Value
txInfoMint
{-# INLINEABLE mustNotMintOrBurn #-}

infix 4 ===

-- | Checks for exact equality between two serialized values.
-- Equality on value is very memory intensive as it's defined on associative
-- lists and `AssocMap` equality is implemented. Instead we can be more strict and
-- require EXACTLY the same value and compare using the serialised bytes.
(===) :: Value -> Value -> Bool
=== :: Value -> Value -> Bool
(===) Value
val Value
val' =
  BuiltinData -> BuiltinByteString
serialiseData (Value -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData Value
val) BuiltinByteString -> BuiltinByteString -> Bool
forall a. Eq a => a -> a -> Bool
== BuiltinData -> BuiltinByteString
serialiseData (Value -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData Value
val')
{-# INLINEABLE (===) #-}

-- * Errors

data UtilError
  = MintingOrBurningIsForbidden
  deriving stock (Int -> UtilError -> ShowS
[UtilError] -> ShowS
UtilError -> String
(Int -> UtilError -> ShowS)
-> (UtilError -> String)
-> ([UtilError] -> ShowS)
-> Show UtilError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UtilError -> ShowS
showsPrec :: Int -> UtilError -> ShowS
$cshow :: UtilError -> String
show :: UtilError -> String
$cshowList :: [UtilError] -> ShowS
showList :: [UtilError] -> ShowS
Show)

instance ToErrorCode UtilError where
  toErrorCode :: UtilError -> Text
toErrorCode = \case
    UtilError
MintingOrBurningIsForbidden -> Text
"U01"