{-# LANGUAGE TemplateHaskell #-}

-- | Module to load and provide the Hydra scripts.
--
-- The plutus blueprint in 'plutus.json' is embedded in the binary and serves as
-- the ground truth for validator scripts and hashes.
--
-- NOTE: All scripts are PlutusV3 scripts (defined by the 'PlutusScript' synonym pattern).
--
-- XXX: We are using a hardcoded indices to access validators in plutus.json.
-- This is fragile and depends on the validator names not changing.
module Hydra.Plutus where

import Hydra.Prelude

import Control.Lens ((^.))
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (key, nth, _String)
import Data.ByteString.Base16 qualified as Base16
import Data.FileEmbed (embedFile, makeRelativeToProject)
import Hydra.Cardano.Api (PlutusScript, pattern PlutusScriptSerialised)
import Hydra.Plutus.Extras (scriptValidatorHash)
import PlutusCore.Core (plcVersion110)
import PlutusCore.MkPlc qualified as UPLC
import PlutusLedgerApi.Common (serialiseUPLC, toData, uncheckedDeserialiseUPLC)
import UntypedPlutusCore qualified as UPLC

-- | Loads the embedded "plutus.json" blueprint and provides the decoded JSON.
blueprintJSON :: Aeson.Value
blueprintJSON :: Value
blueprintJSON =
  case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict $(makeRelativeToProject "./plutus.json" >>= embedFile) of
    Maybe Value
Nothing -> Text -> Value
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Invalid blueprint: plutus.json"
    Just Value
value -> Value
value

-- | Get the commit validator by decoding it from 'blueprintJSON'.
commitValidatorScript :: PlutusScript
commitValidatorScript :: PlutusScript
commitValidatorScript =
  ShortByteString -> PlutusScript
PlutusScriptSerialised (ShortByteString -> PlutusScript)
-> (Text -> ShortByteString) -> Text -> PlutusScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShortByteString
toShort (ByteString -> ShortByteString)
-> (Text -> ByteString) -> Text -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.decodeLenient (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> PlutusScript) -> Text -> PlutusScript
forall a b. (a -> b) -> a -> b
$
    Value
blueprintJSON Value -> Getting Text Value Text -> Text
forall s a. s -> Getting a s a -> a
^. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"validators" ((Value -> Const Text Value) -> Value -> Const Text Value)
-> Getting Text Value Text -> Getting Text Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Traversal' Value Value
forall t. AsValue t => Int -> Traversal' t Value
nth Int
0 ((Value -> Const Text Value) -> Value -> Const Text Value)
-> Getting Text Value Text -> Getting Text Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"compiledCode" ((Value -> Const Text Value) -> Value -> Const Text Value)
-> Getting Text Value Text -> Getting Text Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Text Value Text
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String

-- | Get the initial validator by decoding the parameterized initial validator
-- from the 'blueprintJSON' and applying the 'commitValidatorScriptHash' to it.
initialValidatorScript :: PlutusScript
initialValidatorScript :: PlutusScript
initialValidatorScript =
  ShortByteString -> PlutusScript
PlutusScriptSerialised (ShortByteString -> PlutusScript)
-> ShortByteString -> PlutusScript
forall a b. (a -> b) -> a -> b
$ Program DeBruijn DefaultUni DefaultFun () -> ShortByteString
serialiseUPLC Program DeBruijn DefaultUni DefaultFun ()
appliedProgram
 where
  appliedProgram :: Program DeBruijn DefaultUni DefaultFun ()
appliedProgram = case Program DeBruijn DefaultUni DefaultFun ()
unappliedProgram Program DeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
-> Either
     ApplyProgramError (Program DeBruijn DefaultUni DefaultFun ())
forall (m :: * -> *) a name (uni :: * -> *) fun.
(MonadError ApplyProgramError m, Semigroup a) =>
Program name uni fun a
-> Program name uni fun a -> m (Program name uni fun a)
`UPLC.applyProgram` Program DeBruijn DefaultUni DefaultFun ()
argumentProgram of
    Left ApplyProgramError
e -> Text -> Program DeBruijn DefaultUni DefaultFun ()
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Program DeBruijn DefaultUni DefaultFun ())
-> Text -> Program DeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to applyProgram: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ApplyProgramError -> Text
forall b a. (Show a, IsString b) => a -> b
show ApplyProgramError
e
    Right Program DeBruijn DefaultUni DefaultFun ()
x -> Program DeBruijn DefaultUni DefaultFun ()
x

  unappliedProgram :: Program DeBruijn DefaultUni DefaultFun ()
unappliedProgram = ShortByteString -> Program DeBruijn DefaultUni DefaultFun ()
uncheckedDeserialiseUPLC ShortByteString
unappliedScript

  argumentProgram :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()
  argumentProgram :: Program DeBruijn DefaultUni DefaultFun ()
argumentProgram =
    ()
-> Version
-> Term DeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> Version -> Term name uni fun ann -> Program name uni fun ann
UPLC.Program () Version
plcVersion110 (Term DeBruijn DefaultUni DefaultFun ()
 -> Program DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$
      () -> Data -> Term DeBruijn DefaultUni DefaultFun ()
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
UPLC.mkConstant () (Data -> Term DeBruijn DefaultUni DefaultFun ())
-> Data -> Term DeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$
        ScriptHash -> Data
forall a. ToData a => a -> Data
toData (PlutusScript -> ScriptHash
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> ScriptHash
scriptValidatorHash PlutusScript
commitValidatorScript)

  unappliedScript :: ShortByteString
unappliedScript =
    ByteString -> ShortByteString
toShort (ByteString -> ShortByteString)
-> (Text -> ByteString) -> Text -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.decodeLenient (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ShortByteString) -> Text -> ShortByteString
forall a b. (a -> b) -> a -> b
$
      Value
blueprintJSON Value -> Getting Text Value Text -> Text
forall s a. s -> Getting a s a -> a
^. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"validators" ((Value -> Const Text Value) -> Value -> Const Text Value)
-> Getting Text Value Text -> Getting Text Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Traversal' Value Value
forall t. AsValue t => Int -> Traversal' t Value
nth Int
4 ((Value -> Const Text Value) -> Value -> Const Text Value)
-> Getting Text Value Text -> Getting Text Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"compiledCode" ((Value -> Const Text Value) -> Value -> Const Text Value)
-> Getting Text Value Text -> Getting Text Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Text Value Text
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String

-- | Get the deposit validator by decoding it from 'blueprintJSON'.
depositValidatorScript :: PlutusScript
depositValidatorScript :: PlutusScript
depositValidatorScript =
  ShortByteString -> PlutusScript
PlutusScriptSerialised (ShortByteString -> PlutusScript)
-> (Text -> ShortByteString) -> Text -> PlutusScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShortByteString
toShort (ByteString -> ShortByteString)
-> (Text -> ByteString) -> Text -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.decodeLenient (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> PlutusScript) -> Text -> PlutusScript
forall a b. (a -> b) -> a -> b
$
    Value
blueprintJSON Value -> Getting Text Value Text -> Text
forall s a. s -> Getting a s a -> a
^. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"validators" ((Value -> Const Text Value) -> Value -> Const Text Value)
-> Getting Text Value Text -> Getting Text Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Traversal' Value Value
forall t. AsValue t => Int -> Traversal' t Value
nth Int
2 ((Value -> Const Text Value) -> Value -> Const Text Value)
-> Getting Text Value Text -> Getting Text Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"compiledCode" ((Value -> Const Text Value) -> Value -> Const Text Value)
-> Getting Text Value Text -> Getting Text Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Text Value Text
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String