{-# 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.V3 (
  Address (..),
  Credential (..),
  CurrencySymbol,
  OutputDatum (..),
  ScriptHash (..),
  TokenName (..),
  TxInInfo (..),
  TxInfo (..),
  TxOut (..),
  TxOutRef (..),
  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 :: Value
txInfoMint :: TxInfo -> 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"

-- | Get the list of 'TxOut' outputs of the pending transaction at
-- a given script address.
scriptOutputsAt :: ScriptHash -> TxInfo -> [(OutputDatum, Value)]
scriptOutputsAt :: ScriptHash -> TxInfo -> [(OutputDatum, Value)]
scriptOutputsAt ScriptHash
h TxInfo
p =
  let flt :: TxOut -> Maybe (OutputDatum, Value)
flt TxOut{txOutDatum :: TxOut -> OutputDatum
txOutDatum = OutputDatum
d, txOutAddress :: TxOut -> Address
txOutAddress = Address (ScriptCredential ScriptHash
s) Maybe StakingCredential
_, Value
txOutValue :: Value
txOutValue :: TxOut -> Value
txOutValue} | ScriptHash
s ScriptHash -> ScriptHash -> Bool
forall a. Eq a => a -> a -> Bool
== ScriptHash
h = (OutputDatum, Value) -> Maybe (OutputDatum, Value)
forall a. a -> Maybe a
Just (OutputDatum
d, Value
txOutValue)
      flt TxOut
_ = Maybe (OutputDatum, Value)
forall a. Maybe a
Nothing
   in (TxOut -> Maybe (OutputDatum, Value))
-> [TxOut] -> [(OutputDatum, Value)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxOut -> Maybe (OutputDatum, Value)
flt (TxInfo -> [TxOut]
txInfoOutputs TxInfo
p)
{-# INLINEABLE scriptOutputsAt #-}

-- | Get the total value locked by the given validator in this transaction.
valueLockedBy :: TxInfo -> ScriptHash -> Value
valueLockedBy :: TxInfo -> ScriptHash -> Value
valueLockedBy TxInfo
ptx ScriptHash
h =
  let outputs :: [Value]
outputs = ((OutputDatum, Value) -> Value)
-> [(OutputDatum, Value)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (OutputDatum, Value) -> Value
forall a b. (a, b) -> b
snd (ScriptHash -> TxInfo -> [(OutputDatum, Value)]
scriptOutputsAt ScriptHash
h TxInfo
ptx)
   in [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat [Value]
outputs
{-# INLINEABLE valueLockedBy #-}

-- | Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of the transaction's inputs (`TxInInfo`).
findTxInByTxOutRef :: TxOutRef -> TxInfo -> Maybe TxInInfo
findTxInByTxOutRef :: TxOutRef -> TxInfo -> Maybe TxInInfo
findTxInByTxOutRef TxOutRef
outRef TxInfo{[TxInInfo]
txInfoInputs :: [TxInInfo]
txInfoInputs :: TxInfo -> [TxInInfo]
txInfoInputs} =
  (TxInInfo -> Bool) -> [TxInInfo] -> Maybe TxInInfo
forall a. (a -> Bool) -> [a] -> Maybe a
find (\TxInInfo{TxOutRef
txInInfoOutRef :: TxOutRef
txInInfoOutRef :: TxInInfo -> TxOutRef
txInInfoOutRef} -> TxOutRef
txInInfoOutRef TxOutRef -> TxOutRef -> Bool
forall a. Eq a => a -> a -> Bool
== TxOutRef
outRef) [TxInInfo]
txInfoInputs
{-# INLINEABLE findTxInByTxOutRef #-}