{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoPolyKinds #-}
{-# OPTIONS_GHC -fplugin Plinth.Plugin #-}
{-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:defer-errors #-}
{-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:target-version=1.1.0 #-}

-- | Simple asserting validators that are primarily useful for testing.
module Hydra.Contract.Dummy where

import Hydra.Prelude hiding (foldMap, (<$>), (==))

import Hydra.Cardano.Api (PlutusScript, pattern PlutusScriptSerialised)
import Hydra.Plutus.Extras (wrapValidator)
import PlutusLedgerApi.V3 (
  CurrencySymbol,
  ScriptContext (..),
  ScriptInfo (..),
  TokenName,
  Value (..),
  serialiseCompiledCode,
  txInfoOutputs,
  txOutValue,
  unsafeFromBuiltinData,
 )
import PlutusTx (compile, unstableMakeIsData)
import PlutusTx.AssocMap qualified as AssocMap
import PlutusTx.Eq ((==))
import PlutusTx.Foldable (foldMap)
import PlutusTx.Functor ((<$>))
import PlutusTx.List qualified as L
import PlutusTx.Prelude (check, traceIfFalse)

dummyValidatorScript :: PlutusScript
dummyValidatorScript :: PlutusScript
dummyValidatorScript =
  ShortByteString -> PlutusScript
PlutusScriptSerialised (ShortByteString -> PlutusScript)
-> ShortByteString -> PlutusScript
forall a b. (a -> b) -> a -> b
$
    CompiledCode (BuiltinData -> BuiltinUnit) -> ShortByteString
forall a. CompiledCode a -> ShortByteString
serialiseCompiledCode
      $$( PlutusTx.compile
            [||
            \ctx ->
              check $ case unsafeFromBuiltinData ctx of
                ScriptContext{scriptContextScriptInfo = SpendingScript{}} -> True
                _ -> False
            ||]
        )

alwaysFailingScript :: () -> () -> ScriptContext -> Bool
alwaysFailingScript :: () -> () -> ScriptContext -> Bool
alwaysFailingScript ()
_ ()
_ ScriptContext
_ = BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"alwaysFailingScript" Bool
False

dummyValidatorScriptAlwaysFails :: PlutusScript
dummyValidatorScriptAlwaysFails :: PlutusScript
dummyValidatorScriptAlwaysFails =
  ShortByteString -> PlutusScript
PlutusScriptSerialised (ShortByteString -> PlutusScript)
-> ShortByteString -> PlutusScript
forall a b. (a -> b) -> a -> b
$
    CompiledCode (BuiltinData -> BuiltinUnit) -> ShortByteString
forall a. CompiledCode a -> ShortByteString
serialiseCompiledCode
      $$(PlutusTx.compile [||wrap alwaysFailingScript||])
 where
  wrap :: (() -> () -> ScriptContext -> Bool) -> BuiltinData -> BuiltinUnit
wrap = forall datum redeemer.
(UnsafeFromData datum, UnsafeFromData redeemer) =>
(datum -> redeemer -> ScriptContext -> Bool)
-> BuiltinData -> BuiltinUnit
wrapValidator @() @()

dummyMintingScript :: PlutusScript
dummyMintingScript :: PlutusScript
dummyMintingScript =
  ShortByteString -> PlutusScript
PlutusScriptSerialised (ShortByteString -> PlutusScript)
-> ShortByteString -> PlutusScript
forall a b. (a -> b) -> a -> b
$
    CompiledCode (BuiltinData -> BuiltinUnit) -> ShortByteString
forall a. CompiledCode a -> ShortByteString
serialiseCompiledCode
      $$( PlutusTx.compile
            [||
            \ctx ->
              check $ case unsafeFromBuiltinData ctx of
                ScriptContext{scriptContextScriptInfo = MintingScript{}} -> True
                _ -> False
            ||]
        )

dummyRewardingScript :: PlutusScript
dummyRewardingScript :: PlutusScript
dummyRewardingScript =
  ShortByteString -> PlutusScript
PlutusScriptSerialised (ShortByteString -> PlutusScript)
-> ShortByteString -> PlutusScript
forall a b. (a -> b) -> a -> b
$
    CompiledCode (BuiltinData -> BuiltinUnit) -> ShortByteString
forall a. CompiledCode a -> ShortByteString
serialiseCompiledCode
      $$( PlutusTx.compile
            [||
            \ctx ->
              check $ case unsafeFromBuiltinData ctx of
                ScriptContext{scriptContextScriptInfo = CertifyingScript{}} -> True
                ScriptContext{scriptContextScriptInfo = RewardingScript{}} -> True
                _ -> False
            ||]
        )

-------------------------------------------------------------------
-- Example user script to demonstrate committing to correct Head --
-------------------------------------------------------------------
newtype R = R
  { R -> CurrencySymbol
expectedHeadId :: CurrencySymbol
  }
  deriving stock (Int -> R -> ShowS
[R] -> ShowS
R -> String
(Int -> R -> ShowS) -> (R -> String) -> ([R] -> ShowS) -> Show R
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> R -> ShowS
showsPrec :: Int -> R -> ShowS
$cshow :: R -> String
show :: R -> String
$cshowList :: [R] -> ShowS
showList :: [R] -> ShowS
Show, (forall x. R -> Rep R x) -> (forall x. Rep R x -> R) -> Generic R
forall x. Rep R x -> R
forall x. R -> Rep R x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. R -> Rep R x
from :: forall x. R -> Rep R x
$cto :: forall x. Rep R x -> R
to :: forall x. Rep R x -> R
Generic)

unstableMakeIsData ''R

exampleValidator ::
  () ->
  R ->
  ScriptContext ->
  Bool
exampleValidator :: () -> R -> ScriptContext -> Bool
exampleValidator ()
_ R
redeemer ScriptContext
ctx =
  Bool
checkCorrectHeadId
 where
  checkCorrectHeadId :: Bool
checkCorrectHeadId =
    let outputValue :: Value
outputValue = (TxOut -> Value) -> [TxOut] -> Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut -> Value
txOutValue (TxInfo -> [TxOut]
txInfoOutputs (ScriptContext -> TxInfo
scriptContextTxInfo ScriptContext
ctx))
        pts :: [(TokenName, Integer)]
pts = CurrencySymbol -> Value -> [(TokenName, Integer)]
findParticipationToken CurrencySymbol
expectedHeadId Value
outputValue
     in BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"HeadId is not correct" ([(TokenName, Integer)] -> Integer
forall a. [a] -> Integer
L.length [(TokenName, Integer)]
pts Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1)

  findParticipationToken :: CurrencySymbol -> Value -> [(TokenName, Integer)]
  findParticipationToken :: CurrencySymbol -> Value -> [(TokenName, Integer)]
findParticipationToken CurrencySymbol
headCurrency (Value Map CurrencySymbol (Map TokenName Integer)
val) =
    case Map TokenName Integer -> [(TokenName, Integer)]
forall k v. Map k v -> [(k, v)]
AssocMap.toList (Map TokenName Integer -> [(TokenName, Integer)])
-> Maybe (Map TokenName Integer) -> Maybe [(TokenName, Integer)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CurrencySymbol
-> Map CurrencySymbol (Map TokenName Integer)
-> Maybe (Map TokenName Integer)
forall k v. Eq k => k -> Map k v -> Maybe v
AssocMap.lookup CurrencySymbol
headCurrency Map CurrencySymbol (Map TokenName Integer)
val of
      Just [(TokenName, Integer)]
tokens ->
        ((TokenName, Integer) -> Bool)
-> [(TokenName, Integer)] -> [(TokenName, Integer)]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (\(TokenName
_, Integer
n) -> Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1) [(TokenName, Integer)]
tokens
      Maybe [(TokenName, Integer)]
_ ->
        []
  {-# INLINEABLE findParticipationToken #-}

  R{CurrencySymbol
expectedHeadId :: R -> CurrencySymbol
expectedHeadId :: CurrencySymbol
expectedHeadId} = R
redeemer

exampleSecureValidatorScript :: PlutusScript
exampleSecureValidatorScript :: PlutusScript
exampleSecureValidatorScript =
  ShortByteString -> PlutusScript
PlutusScriptSerialised (ShortByteString -> PlutusScript)
-> ShortByteString -> PlutusScript
forall a b. (a -> b) -> a -> b
$
    CompiledCode (BuiltinData -> BuiltinUnit) -> ShortByteString
forall a. CompiledCode a -> ShortByteString
serialiseCompiledCode
      $$( PlutusTx.compile
            [||wrap exampleValidator||]
        )
 where
  wrap :: (() -> R -> ScriptContext -> Bool) -> BuiltinData -> BuiltinUnit
wrap = forall datum redeemer.
(UnsafeFromData datum, UnsafeFromData redeemer) =>
(datum -> redeemer -> ScriptContext -> Bool)
-> BuiltinData -> BuiltinUnit
wrapValidator @() @R