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

module Hydra.Contract.Util where

import Hydra.Contract.Commit
import Hydra.Contract.HeadError (HeadError (..), errorCode)
import Hydra.Contract.UtilError (UtilError (..))
import Hydra.Data.Party (Party)
import PlutusLedgerApi.V1.Value (isZero)
import PlutusLedgerApi.V3 (
  Address (..),
  Credential (..),
  CurrencySymbol,
  MintValue,
  OutputDatum (..),
  ScriptContext (..),
  ScriptHash (..),
  TokenName (..),
  TxInfo (..),
  TxOut (..),
  TxOutRef (..),
  Value (getValue),
  mintValueBurned,
  mintValueMinted,
  mintValueToMap,
  txInInfoResolved,
 )
import PlutusLedgerApi.V3.Contexts (findOwnInput)
import PlutusTx.AssocMap qualified as AssocMap
import PlutusTx.Builtins qualified as Builtins
import PlutusTx.Builtins.HasOpaque (stringToBuiltinByteString)
import PlutusTx.Foldable qualified as F
import PlutusTx.List qualified as L
import PlutusTx.Prelude

hydraHeadV2 :: BuiltinByteString
hydraHeadV2 :: BuiltinByteString
hydraHeadV2 = String -> BuiltinByteString
stringToBuiltinByteString String
"HydraHeadV2"
{-# INLINEABLE hydraHeadV2 #-}

-- | Checks that the output contains the state token (ST) with the head
-- 'CurrencySymbol' and 'TokenName' of 'hydraHeadV2'
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
hydraHeadV2) 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 :: MintValue -> CurrencySymbol -> [Party] -> Bool
mustBurnAllHeadTokens :: MintValue -> CurrencySymbol -> [Party] -> Bool
mustBurnAllHeadTokens MintValue
mintValue 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 a. [a] -> Integer
L.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 (MintValue -> Map CurrencySymbol (Map TokenName Integer)
mintValueToMap MintValue
mintValue) 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
F.sum Map TokenName Integer
tokenMap
{-# INLINEABLE mustBurnAllHeadTokens #-}

mustNotMintOrBurn :: TxInfo -> Bool
mustNotMintOrBurn :: TxInfo -> Bool
mustNotMintOrBurn TxInfo{MintValue
txInfoMint :: MintValue
txInfoMint :: TxInfo -> MintValue
txInfoMint} =
  BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode MintingOrBurningIsForbidden) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    Value -> Bool
isZero (MintValue -> Value
mintValueMinted MintValue
txInfoMint) Bool -> Bool -> Bool
&& Value -> Bool
isZero (MintValue -> Value
mintValueBurned MintValue
txInfoMint)
{-# INLINEABLE mustNotMintOrBurn #-}

-- | Check whether own input and first output preserve value exactly.
mustPreserveHeadValue :: ScriptContext -> Bool
mustPreserveHeadValue :: ScriptContext -> Bool
mustPreserveHeadValue ScriptContext
ctx =
  BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode HeadValueIsNotPreserved) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    Value
val' Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
val
 where
  val :: Value
val = Value -> (TxInInfo -> Value) -> Maybe TxInInfo -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
forall a. Monoid a => a
mempty (TxOut -> Value
txOutValue (TxOut -> Value) -> (TxInInfo -> TxOut) -> TxInInfo -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxInInfo -> TxOut
txInInfoResolved) (Maybe TxInInfo -> Value) -> Maybe TxInInfo -> Value
forall a b. (a -> b) -> a -> b
$ ScriptContext -> Maybe TxInInfo
findOwnInput ScriptContext
ctx

  val' :: Value
val' = TxOut -> Value
txOutValue (TxOut -> Value) -> ([TxOut] -> TxOut) -> [TxOut] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxOut] -> TxOut
forall a. [a] -> a
L.head ([TxOut] -> Value) -> [TxOut] -> Value
forall a b. (a -> b) -> a -> b
$ TxInfo -> [TxOut]
txInfoOutputs TxInfo
txInfo

  ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo = TxInfo
txInfo} = ScriptContext
ctx
{-# INLINEABLE mustPreserveHeadValue #-}

-- | Hash a potentially unordered list of commits by sorting them, concatenating
-- their 'preSerializedOutput' bytes and creating a SHA2_256 digest over that.
--
-- NOTE: See note from `hashTxOuts`.
hashPreSerializedCommits :: [Commit] -> BuiltinByteString
hashPreSerializedCommits :: [Commit] -> BuiltinByteString
hashPreSerializedCommits [Commit]
commits =
  BuiltinByteString -> BuiltinByteString
sha2_256 (BuiltinByteString -> BuiltinByteString)
-> ([Commit] -> BuiltinByteString) -> [Commit] -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Commit -> BuiltinByteString) -> [Commit] -> BuiltinByteString
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Commit -> BuiltinByteString
preSerializedOutput ([Commit] -> BuiltinByteString) -> [Commit] -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$
    (Commit -> Commit -> Ordering) -> [Commit] -> [Commit]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (\Commit
a Commit
b -> TxOutRef -> TxOutRef -> Ordering
compareRef (Commit -> TxOutRef
input Commit
a) (Commit -> TxOutRef
input Commit
b)) [Commit]
commits
{-# INLINEABLE hashPreSerializedCommits #-}

-- | Hash a pre-ordered list of transaction outputs by serializing each
-- individual 'TxOut', concatenating all bytes together and creating a SHA2_256
-- digest over that.
--
-- NOTE: In general, from asserting that `hash(x || y) = hash (x' || y')` it is
-- not safe to conclude that `(x,y) = (x', y')` as the same hash could be
-- obtained by moving one or more bytes from the end of `x` to the beginning of
-- `y`, but in the context of Hydra validators it seems impossible to exploit
-- this property without breaking other logic or verification (eg. producing a
-- valid and meaningful `TxOut`).
hashTxOuts :: [TxOut] -> BuiltinByteString
hashTxOuts :: [TxOut] -> BuiltinByteString
hashTxOuts =
  BuiltinByteString -> BuiltinByteString
sha2_256 (BuiltinByteString -> BuiltinByteString)
-> ([TxOut] -> BuiltinByteString) -> [TxOut] -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut -> BuiltinByteString) -> [TxOut] -> BuiltinByteString
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap (BuiltinData -> BuiltinByteString
Builtins.serialiseData (BuiltinData -> BuiltinByteString)
-> (TxOut -> BuiltinData) -> TxOut -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData)
{-# INLINEABLE hashTxOuts #-}

compareRef :: TxOutRef -> TxOutRef -> Ordering
TxOutRef{TxId
txOutRefId :: TxId
txOutRefId :: TxOutRef -> TxId
txOutRefId, Integer
txOutRefIdx :: Integer
txOutRefIdx :: TxOutRef -> Integer
txOutRefIdx} compareRef :: TxOutRef -> TxOutRef -> Ordering
`compareRef` TxOutRef{txOutRefId :: TxOutRef -> TxId
txOutRefId = TxId
id', txOutRefIdx :: TxOutRef -> Integer
txOutRefIdx = Integer
idx'} =
  case TxId -> TxId -> Ordering
forall a. Ord a => a -> a -> Ordering
compare TxId
txOutRefId TxId
id' of
    Ordering
EQ -> Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Integer
txOutRefIdx Integer
idx'
    Ordering
ord -> Ordering
ord
{-# INLINEABLE compareRef #-}

-- | 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 :: TxOut -> Value
txOutValue :: 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 #-}