{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Cardano.Api.Experimental.Plutus.Internal.Script
( AnyPlutusScript (..)
, decodeAnyPlutusScript
, AnyPlutusScriptLanguage (..)
, PlutusScriptInEra (..)
, PlutusScriptOrReferenceInput (..)
, AsType (..)
, deserialisePlutusScriptInEra
, hashPlutusScriptInEra
, plutusScriptInEraLanguage
, plutusScriptInEraSLanguage
, plutusScriptInEraToScript
, plutusLanguageToText
, textToPlutusLanguage
)
where
import Cardano.Api.Experimental.Era
import Cardano.Api.HasTypeProxy
import Cardano.Api.Ledger.Internal.Reexport qualified as L
import Cardano.Api.Plutus.Internal.Script (removePlutusScriptDoubleEncoding)
import Cardano.Api.Serialise.Cbor
import Cardano.Api.Serialise.TextEnvelope.Internal
import Cardano.Api.Tx.Internal.TxIn (TxIn)
import Cardano.Binary qualified as CBOR
import Cardano.Ledger.Core qualified as L
import Cardano.Ledger.Plutus.Language (PlutusRunnable)
import Cardano.Ledger.Plutus.Language qualified as L
import Cardano.Ledger.Plutus.Language qualified as Plutus
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Short qualified as SBS
import Data.String
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Typeable
import Prettyprinter
data PlutusScriptInEra (lang :: L.Language) era where
PlutusScriptInEra :: L.PlutusLanguage lang => PlutusRunnable lang -> PlutusScriptInEra lang era
deriving instance Show (PlutusScriptInEra lang era)
deriving instance Eq (PlutusScriptInEra lang era)
instance
(Typeable era, Typeable lang, HasTypeProxy (Plutus.SLanguage lang))
=> HasTypeProxy (PlutusScriptInEra lang era)
where
data AsType (PlutusScriptInEra lang era) = AsPlutusScriptInEra (AsType (L.SLanguage lang))
proxyToAsType :: Proxy (PlutusScriptInEra lang era)
-> AsType (PlutusScriptInEra lang era)
proxyToAsType Proxy (PlutusScriptInEra lang era)
_ = AsType (SLanguage lang) -> AsType (PlutusScriptInEra lang era)
forall (lang :: Language) era.
AsType (SLanguage lang) -> AsType (PlutusScriptInEra lang era)
AsPlutusScriptInEra (Proxy (SLanguage lang) -> AsType (SLanguage lang)
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(L.SLanguage lang)))
instance
(Plutus.PlutusLanguage lang, L.Era era, HasTypeProxy (Plutus.SLanguage lang))
=> HasTextEnvelope (PlutusScriptInEra lang era)
where
textEnvelopeType :: AsType (PlutusScriptInEra lang era) -> TextEnvelopeType
textEnvelopeType AsType (PlutusScriptInEra lang era)
_ =
String -> TextEnvelopeType
forall a. IsString a => String -> a
fromString (String -> TextEnvelopeType)
-> (AnyPlutusScriptLanguage -> String)
-> AnyPlutusScriptLanguage
-> TextEnvelopeType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String)
-> (AnyPlutusScriptLanguage -> Text)
-> AnyPlutusScriptLanguage
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyPlutusScriptLanguage -> Text
plutusLanguageToText (AnyPlutusScriptLanguage -> TextEnvelopeType)
-> AnyPlutusScriptLanguage -> TextEnvelopeType
forall a b. (a -> b) -> a -> b
$
SLanguage lang -> AnyPlutusScriptLanguage
forall (lang :: Language).
PlutusLanguage lang =>
SLanguage lang -> AnyPlutusScriptLanguage
AnyPlutusScriptLanguage (SLanguage lang -> AnyPlutusScriptLanguage)
-> SLanguage lang -> AnyPlutusScriptLanguage
forall a b. (a -> b) -> a -> b
$
Proxy lang -> SLanguage lang
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> SLanguage l
L.plutusSLanguage (forall {k} (t :: k). Proxy t
forall (t :: Language). Proxy t
Proxy @lang)
plutusLanguageToText :: AnyPlutusScriptLanguage -> Text
plutusLanguageToText :: AnyPlutusScriptLanguage -> Text
plutusLanguageToText (AnyPlutusScriptLanguage SLanguage lang
slang) =
case SLanguage lang
slang of
SLanguage lang
L.SPlutusV1 -> Text
"PlutusScriptV1"
SLanguage lang
L.SPlutusV2 -> Text
"PlutusScriptV2"
SLanguage lang
L.SPlutusV3 -> Text
"PlutusScriptV3"
SLanguage lang
L.SPlutusV4 -> Text
"PlutusScriptV4"
textToPlutusLanguage :: Text -> Maybe AnyPlutusScriptLanguage
textToPlutusLanguage :: Text -> Maybe AnyPlutusScriptLanguage
textToPlutusLanguage Text
txt =
case Text
txt of
Text
"PlutusScriptV1" -> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a. a -> Maybe a
Just (AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage)
-> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV1 -> AnyPlutusScriptLanguage
forall (lang :: Language).
PlutusLanguage lang =>
SLanguage lang -> AnyPlutusScriptLanguage
AnyPlutusScriptLanguage SLanguage 'PlutusV1
L.SPlutusV1
Text
"PlutusScriptV2" -> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a. a -> Maybe a
Just (AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage)
-> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> AnyPlutusScriptLanguage
forall (lang :: Language).
PlutusLanguage lang =>
SLanguage lang -> AnyPlutusScriptLanguage
AnyPlutusScriptLanguage SLanguage 'PlutusV2
L.SPlutusV2
Text
"PlutusScriptV3" -> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a. a -> Maybe a
Just (AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage)
-> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> AnyPlutusScriptLanguage
forall (lang :: Language).
PlutusLanguage lang =>
SLanguage lang -> AnyPlutusScriptLanguage
AnyPlutusScriptLanguage SLanguage 'PlutusV3
L.SPlutusV3
Text
"PlutusScriptV4" -> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a. a -> Maybe a
Just (AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage)
-> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV4 -> AnyPlutusScriptLanguage
forall (lang :: Language).
PlutusLanguage lang =>
SLanguage lang -> AnyPlutusScriptLanguage
AnyPlutusScriptLanguage SLanguage 'PlutusV4
L.SPlutusV4
Text
_ -> Maybe AnyPlutusScriptLanguage
forall a. Maybe a
Nothing
instance
( L.Era era
, Typeable era
, Typeable lang
, Plutus.PlutusLanguage lang
, HasTypeProxy (Plutus.SLanguage lang)
)
=> SerialiseAsCBOR (PlutusScriptInEra (lang :: L.Language) era)
where
serialiseToCBOR :: PlutusScriptInEra lang era -> ByteString
serialiseToCBOR (PlutusScriptInEra PlutusRunnable lang
s) =
Version -> PlutusRunnable lang -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
L.serialize' (forall era. Era era => Version
L.eraProtVerHigh @era) PlutusRunnable lang
s
deserialiseFromCBOR :: AsType (PlutusScriptInEra lang era)
-> ByteString -> Either DecoderError (PlutusScriptInEra lang era)
deserialiseFromCBOR AsType (PlutusScriptInEra lang era)
_ ByteString
bs = do
let v :: Version
v = forall era. Era era => Version
L.eraProtVerHigh @era
scriptShortBs :: ShortByteString
scriptShortBs = ByteString -> ShortByteString
SBS.toShort (ByteString -> ShortByteString) -> ByteString -> ShortByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
removePlutusScriptDoubleEncoding (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
bs
let plutusScript :: Plutus.Plutus lang
plutusScript :: Plutus lang
plutusScript = PlutusBinary -> Plutus lang
forall (l :: Language). PlutusBinary -> Plutus l
L.Plutus (PlutusBinary -> Plutus lang) -> PlutusBinary -> Plutus lang
forall a b. (a -> b) -> a -> b
$ ShortByteString -> PlutusBinary
L.PlutusBinary ShortByteString
scriptShortBs
case Version
-> Plutus lang -> Either ScriptDecodeError (PlutusRunnable lang)
forall (l :: Language).
PlutusLanguage l =>
Version -> Plutus l -> Either ScriptDecodeError (PlutusRunnable l)
Plutus.decodePlutusRunnable Version
v Plutus lang
plutusScript of
Left ScriptDecodeError
e ->
DecoderError -> Either DecoderError (PlutusScriptInEra lang era)
forall a b. a -> Either a b
Left (DecoderError -> Either DecoderError (PlutusScriptInEra lang era))
-> DecoderError -> Either DecoderError (PlutusScriptInEra lang era)
forall a b. (a -> b) -> a -> b
$
Text -> Text -> DecoderError
CBOR.DecoderErrorCustom Text
"PlutusLedgerApi.Common.ScriptDecodeError" (String -> Text
Text.pack (String -> Text)
-> (Doc (ZonkAny 0) -> String) -> Doc (ZonkAny 0) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc (ZonkAny 0) -> String
forall a. Show a => a -> String
show (Doc (ZonkAny 0) -> Text) -> Doc (ZonkAny 0) -> Text
forall a b. (a -> b) -> a -> b
$ ScriptDecodeError -> Doc (ZonkAny 0)
forall a ann. Pretty a => a -> Doc ann
forall ann. ScriptDecodeError -> Doc ann
pretty ScriptDecodeError
e)
Right PlutusRunnable lang
s -> PlutusScriptInEra lang era
-> Either DecoderError (PlutusScriptInEra lang era)
forall a b. b -> Either a b
Right (PlutusScriptInEra lang era
-> Either DecoderError (PlutusScriptInEra lang era))
-> PlutusScriptInEra lang era
-> Either DecoderError (PlutusScriptInEra lang era)
forall a b. (a -> b) -> a -> b
$ PlutusRunnable lang -> PlutusScriptInEra lang era
forall (lang :: Language) era.
PlutusLanguage lang =>
PlutusRunnable lang -> PlutusScriptInEra lang era
PlutusScriptInEra PlutusRunnable lang
s
deserialisePlutusScriptInEra
:: forall era lang
. (Plutus.PlutusLanguage lang, HasTypeProxy (Plutus.SLanguage lang))
=> L.Era era
=> L.SLanguage lang
-> BS.ByteString
-> Either CBOR.DecoderError (PlutusScriptInEra lang era)
deserialisePlutusScriptInEra :: forall era (lang :: Language).
(PlutusLanguage lang, HasTypeProxy (SLanguage lang), Era era) =>
SLanguage lang
-> ByteString -> Either DecoderError (PlutusScriptInEra lang era)
deserialisePlutusScriptInEra SLanguage lang
_ ByteString
bs =
AsType (PlutusScriptInEra lang era)
-> ByteString -> Either DecoderError (PlutusScriptInEra lang era)
forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
deserialiseFromCBOR (AsType (SLanguage lang) -> AsType (PlutusScriptInEra lang era)
forall (lang :: Language) era.
AsType (SLanguage lang) -> AsType (PlutusScriptInEra lang era)
AsPlutusScriptInEra (Proxy (SLanguage lang) -> AsType (SLanguage lang)
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(L.SLanguage lang)))) ByteString
bs
hashPlutusScriptInEra
:: forall era lang. IsEra era => PlutusScriptInEra lang (LedgerEra era) -> L.ScriptHash
hashPlutusScriptInEra :: forall era (lang :: Language).
IsEra era =>
PlutusScriptInEra lang (LedgerEra era) -> ScriptHash
hashPlutusScriptInEra (PlutusScriptInEra PlutusRunnable lang
pr) =
case forall era. IsEra era => Era era
useEra @era of
Era era
ConwayEra -> Plutus lang -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
L.hashPlutusScript (Plutus lang -> ScriptHash) -> Plutus lang -> ScriptHash
forall a b. (a -> b) -> a -> b
$ PlutusRunnable lang -> Plutus lang
forall (l :: Language). PlutusRunnable l -> Plutus l
L.plutusFromRunnable PlutusRunnable lang
pr
Era era
DijkstraEra -> Plutus lang -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
L.hashPlutusScript (Plutus lang -> ScriptHash) -> Plutus lang -> ScriptHash
forall a b. (a -> b) -> a -> b
$ PlutusRunnable lang -> Plutus lang
forall (l :: Language). PlutusRunnable l -> Plutus l
L.plutusFromRunnable PlutusRunnable lang
pr
plutusScriptInEraSLanguage
:: forall lang era. L.PlutusLanguage lang => PlutusScriptInEra lang era -> L.SLanguage lang
plutusScriptInEraSLanguage :: forall (lang :: Language) era.
PlutusLanguage lang =>
PlutusScriptInEra lang era -> SLanguage lang
plutusScriptInEraSLanguage (PlutusScriptInEra PlutusRunnable lang
_) =
Proxy lang -> SLanguage lang
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> SLanguage l
L.plutusSLanguage (forall {k} (t :: k). Proxy t
forall (t :: Language). Proxy t
Proxy @lang)
plutusScriptInEraLanguage
:: forall lang era. L.PlutusLanguage lang => PlutusScriptInEra lang era -> L.Language
plutusScriptInEraLanguage :: forall (lang :: Language) era.
PlutusLanguage lang =>
PlutusScriptInEra lang era -> Language
plutusScriptInEraLanguage (PlutusScriptInEra PlutusRunnable lang
_) =
Proxy lang -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
L.plutusLanguage (forall {k} (t :: k). Proxy t
forall (t :: Language). Proxy t
Proxy @lang)
plutusScriptInEraToScript
:: forall lang era. L.AlonzoEraScript era => PlutusScriptInEra lang era -> L.Script era
plutusScriptInEraToScript :: forall (lang :: Language) era.
AlonzoEraScript era =>
PlutusScriptInEra lang era -> Script era
plutusScriptInEraToScript (PlutusScriptInEra PlutusRunnable lang
pr) =
case PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
L.fromPlutusScript (PlutusScript era -> Script era)
-> Maybe (PlutusScript era) -> Maybe (Script era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Plutus lang -> Maybe (PlutusScript era)
forall era (l :: Language) (m :: * -> *).
(AlonzoEraScript era, PlutusLanguage l, MonadFail m) =>
Plutus l -> m (PlutusScript era)
forall (l :: Language) (m :: * -> *).
(PlutusLanguage l, MonadFail m) =>
Plutus l -> m (PlutusScript era)
L.mkPlutusScript (PlutusRunnable lang -> Plutus lang
forall (l :: Language). PlutusRunnable l -> Plutus l
L.plutusFromRunnable PlutusRunnable lang
pr) of
Maybe (Script era)
Nothing ->
String -> Script era
forall a. HasCallStack => String -> a
error
String
"plutusScriptInEraToScript: Impossible as the failure would have occurred at the point of deserialising the PlutusRunnable value."
Just Script era
script -> Script era
script
data PlutusScriptOrReferenceInput lang era
= PScript (PlutusScriptInEra lang era)
| PReferenceScript TxIn
deriving (Int -> PlutusScriptOrReferenceInput lang era -> ShowS
[PlutusScriptOrReferenceInput lang era] -> ShowS
PlutusScriptOrReferenceInput lang era -> String
(Int -> PlutusScriptOrReferenceInput lang era -> ShowS)
-> (PlutusScriptOrReferenceInput lang era -> String)
-> ([PlutusScriptOrReferenceInput lang era] -> ShowS)
-> Show (PlutusScriptOrReferenceInput lang era)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (lang :: Language) era.
Int -> PlutusScriptOrReferenceInput lang era -> ShowS
forall (lang :: Language) era.
[PlutusScriptOrReferenceInput lang era] -> ShowS
forall (lang :: Language) era.
PlutusScriptOrReferenceInput lang era -> String
$cshowsPrec :: forall (lang :: Language) era.
Int -> PlutusScriptOrReferenceInput lang era -> ShowS
showsPrec :: Int -> PlutusScriptOrReferenceInput lang era -> ShowS
$cshow :: forall (lang :: Language) era.
PlutusScriptOrReferenceInput lang era -> String
show :: PlutusScriptOrReferenceInput lang era -> String
$cshowList :: forall (lang :: Language) era.
[PlutusScriptOrReferenceInput lang era] -> ShowS
showList :: [PlutusScriptOrReferenceInput lang era] -> ShowS
Show, PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool
(PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool)
-> (PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool)
-> Eq (PlutusScriptOrReferenceInput lang era)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (lang :: Language) era.
PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool
$c== :: forall (lang :: Language) era.
PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool
== :: PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool
$c/= :: forall (lang :: Language) era.
PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool
/= :: PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool
Eq)
data AnyPlutusScript era where
AnyPlutusScript
:: (L.Era era, Typeable lang, L.PlutusLanguage lang)
=> PlutusScriptInEra lang era -> AnyPlutusScript era
decodeAnyPlutusScript
:: L.Era era
=> ByteString
-> AnyPlutusScriptLanguage
-> Either CBOR.DecoderError (AnyPlutusScript era)
decodeAnyPlutusScript :: forall era.
Era era =>
ByteString
-> AnyPlutusScriptLanguage
-> Either DecoderError (AnyPlutusScript era)
decodeAnyPlutusScript ByteString
bs (AnyPlutusScriptLanguage SLanguage lang
lang) =
PlutusScriptInEra lang era -> AnyPlutusScript era
forall era (lang :: Language).
(Era era, Typeable lang, PlutusLanguage lang) =>
PlutusScriptInEra lang era -> AnyPlutusScript era
AnyPlutusScript
(PlutusScriptInEra lang era -> AnyPlutusScript era)
-> Either DecoderError (PlutusScriptInEra lang era)
-> Either DecoderError (AnyPlutusScript era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SLanguage lang
-> ((PlutusLanguage lang, Typeable lang,
HasTypeProxy (SLanguage lang)) =>
Either DecoderError (PlutusScriptInEra lang era))
-> Either DecoderError (PlutusScriptInEra lang era)
forall (lang :: Language) a.
SLanguage lang
-> ((PlutusLanguage lang, Typeable lang,
HasTypeProxy (SLanguage lang)) =>
a)
-> a
obtainLangConstraints SLanguage lang
lang (SLanguage lang
-> ByteString -> Either DecoderError (PlutusScriptInEra lang era)
forall era (lang :: Language).
(PlutusLanguage lang, HasTypeProxy (SLanguage lang), Era era) =>
SLanguage lang
-> ByteString -> Either DecoderError (PlutusScriptInEra lang era)
deserialisePlutusScriptInEra SLanguage lang
lang ByteString
bs)
obtainLangConstraints
:: L.SLanguage lang
-> ((Plutus.PlutusLanguage lang, Typeable lang, HasTypeProxy (Plutus.SLanguage lang)) => a)
-> a
obtainLangConstraints :: forall (lang :: Language) a.
SLanguage lang
-> ((PlutusLanguage lang, Typeable lang,
HasTypeProxy (SLanguage lang)) =>
a)
-> a
obtainLangConstraints SLanguage lang
L.SPlutusV1 (PlutusLanguage lang, Typeable lang,
HasTypeProxy (SLanguage lang)) =>
a
f = a
(PlutusLanguage lang, Typeable lang,
HasTypeProxy (SLanguage lang)) =>
a
f
obtainLangConstraints SLanguage lang
L.SPlutusV2 (PlutusLanguage lang, Typeable lang,
HasTypeProxy (SLanguage lang)) =>
a
f = a
(PlutusLanguage lang, Typeable lang,
HasTypeProxy (SLanguage lang)) =>
a
f
obtainLangConstraints SLanguage lang
L.SPlutusV3 (PlutusLanguage lang, Typeable lang,
HasTypeProxy (SLanguage lang)) =>
a
f = a
(PlutusLanguage lang, Typeable lang,
HasTypeProxy (SLanguage lang)) =>
a
f
obtainLangConstraints SLanguage lang
L.SPlutusV4 (PlutusLanguage lang, Typeable lang,
HasTypeProxy (SLanguage lang)) =>
a
f = a
(PlutusLanguage lang, Typeable lang,
HasTypeProxy (SLanguage lang)) =>
a
f
data AnyPlutusScriptLanguage where
AnyPlutusScriptLanguage
:: L.PlutusLanguage lang
=> L.SLanguage lang -> AnyPlutusScriptLanguage