{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DerivingVia       #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}

module PlutusLedgerApi.Common.SerialisedScript (
  SerialisedScript,
  serialiseCompiledCode,
  serialiseUPLC,
  uncheckedDeserialiseUPLC,
  scriptCBORDecoder,
  ScriptNamedDeBruijn (..),
  ScriptForEvaluation, -- Do not export data constructor
  ScriptDecodeError (..),
  AsScriptDecodeError (..),
  DeserialiseFailureInfo (..),
  DeserialiseFailureReason (..),
  deserialiseScript,
  serialisedScript,
  deserialisedScript,
) where

import PlutusCore
import PlutusLedgerApi.Common.Versions
import PlutusTx.Code
import UntypedPlutusCore qualified as UPLC

-- this allows us to safe, 0-cost coerce from FND->ND. Unfortunately, since Coercible is symmetric,
-- we cannot expose this safe Coercible FND ND w.o. also allowing the unsafe Coercible ND FND.
import PlutusCore.DeBruijn.Internal (FakeNamedDeBruijn (FakeNamedDeBruijn))

import Codec.CBOR.Decoding qualified as CBOR
import Codec.CBOR.Read qualified as CBOR
import Codec.Extras.SerialiseViaFlat as CBOR.Extras
import Codec.Serialise
import Control.Arrow ((>>>))
import Control.DeepSeq (NFData)
import Control.Exception
import Control.Lens
import Control.Monad (unless, when)
import Control.Monad.Error.Lens
import Control.Monad.Except (MonadError)
import Data.ByteString.Lazy qualified as BSL
import Data.ByteString.Short
import Data.Coerce
import Data.Set as Set
import GHC.Generics
import NoThunks.Class
import Prettyprinter

-- | An error that occurred during script deserialization.
data ScriptDecodeError
  = -- | an error from the underlying CBOR/serialise library
    CBORDeserialiseError !CBOR.Extras.DeserialiseFailureInfo
  | -- | Script was successfully parsed, but more (runaway) bytes encountered
    -- after script's position
    RemainderError !BSL.ByteString
  | -- | the plutus version of the given script is not enabled yet
    LedgerLanguageNotAvailableError
      { ScriptDecodeError -> PlutusLedgerLanguage
sdeAffectedLang :: !PlutusLedgerLanguage
      -- ^ the script's ledger language
      , ScriptDecodeError -> MajorProtocolVersion
sdeIntroPv      :: !MajorProtocolVersion
      -- ^ the major protocol version that will first introduce/enable the ledger language
      , ScriptDecodeError -> MajorProtocolVersion
sdeThisPv       :: !MajorProtocolVersion
      -- ^ the current protocol version
      }
  | PlutusCoreLanguageNotAvailableError
      { ScriptDecodeError -> Version
sdeAffectedVersion :: !UPLC.Version
      -- ^ the Plutus Core language of the script under execution.
      , ScriptDecodeError -> PlutusLedgerLanguage
sdeThisLang        :: !PlutusLedgerLanguage
      -- ^ the Plutus ledger language of the script under execution.
      , sdeThisPv          :: !MajorProtocolVersion
      -- ^ the current protocol version
      }
  deriving stock (ScriptDecodeError -> ScriptDecodeError -> Bool
(ScriptDecodeError -> ScriptDecodeError -> Bool)
-> (ScriptDecodeError -> ScriptDecodeError -> Bool)
-> Eq ScriptDecodeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScriptDecodeError -> ScriptDecodeError -> Bool
== :: ScriptDecodeError -> ScriptDecodeError -> Bool
$c/= :: ScriptDecodeError -> ScriptDecodeError -> Bool
/= :: ScriptDecodeError -> ScriptDecodeError -> Bool
Eq, Int -> ScriptDecodeError -> ShowS
[ScriptDecodeError] -> ShowS
ScriptDecodeError -> String
(Int -> ScriptDecodeError -> ShowS)
-> (ScriptDecodeError -> String)
-> ([ScriptDecodeError] -> ShowS)
-> Show ScriptDecodeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptDecodeError -> ShowS
showsPrec :: Int -> ScriptDecodeError -> ShowS
$cshow :: ScriptDecodeError -> String
show :: ScriptDecodeError -> String
$cshowList :: [ScriptDecodeError] -> ShowS
showList :: [ScriptDecodeError] -> ShowS
Show)
  deriving anyclass (Show ScriptDecodeError
Typeable ScriptDecodeError
(Typeable ScriptDecodeError, Show ScriptDecodeError) =>
(ScriptDecodeError -> SomeException)
-> (SomeException -> Maybe ScriptDecodeError)
-> (ScriptDecodeError -> String)
-> Exception ScriptDecodeError
SomeException -> Maybe ScriptDecodeError
ScriptDecodeError -> String
ScriptDecodeError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ScriptDecodeError -> SomeException
toException :: ScriptDecodeError -> SomeException
$cfromException :: SomeException -> Maybe ScriptDecodeError
fromException :: SomeException -> Maybe ScriptDecodeError
$cdisplayException :: ScriptDecodeError -> String
displayException :: ScriptDecodeError -> String
Exception)

makeClassyPrisms ''ScriptDecodeError

instance Pretty ScriptDecodeError where
  pretty :: forall ann. ScriptDecodeError -> Doc ann
pretty = \case
    CBORDeserialiseError DeserialiseFailureInfo
e ->
      Doc ann
"Failed to deserialise a script:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> DeserialiseFailureInfo -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. DeserialiseFailureInfo -> Doc ann
pretty DeserialiseFailureInfo
e
    RemainderError ByteString
bs ->
      Doc ann
"Script was successfully deserialised, but"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int64 -> Doc ann
forall ann. Int64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> Int64
BSL.length ByteString
bs)
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"more bytes were encountered after the script's position."
    LedgerLanguageNotAvailableError{MajorProtocolVersion
PlutusLedgerLanguage
sdeAffectedLang :: ScriptDecodeError -> PlutusLedgerLanguage
sdeIntroPv :: ScriptDecodeError -> MajorProtocolVersion
sdeThisPv :: ScriptDecodeError -> MajorProtocolVersion
sdeAffectedLang :: PlutusLedgerLanguage
sdeIntroPv :: MajorProtocolVersion
sdeThisPv :: MajorProtocolVersion
..} ->
      Doc ann
"Your script has a Plutus Ledger Language version of"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> PlutusLedgerLanguage -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. PlutusLedgerLanguage -> Doc ann
pretty PlutusLedgerLanguage
sdeAffectedLang Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"."
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"This is not yet supported by the current major protocol version"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MajorProtocolVersion -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MajorProtocolVersion -> Doc ann
pretty MajorProtocolVersion
sdeThisPv Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"."
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"The major protocol version that introduces \
            \this Plutus Ledger Language is"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MajorProtocolVersion -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MajorProtocolVersion -> Doc ann
pretty MajorProtocolVersion
sdeIntroPv Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"."
    PlutusCoreLanguageNotAvailableError{Version
MajorProtocolVersion
PlutusLedgerLanguage
sdeThisPv :: ScriptDecodeError -> MajorProtocolVersion
sdeAffectedVersion :: ScriptDecodeError -> Version
sdeThisLang :: ScriptDecodeError -> PlutusLedgerLanguage
sdeAffectedVersion :: Version
sdeThisLang :: PlutusLedgerLanguage
sdeThisPv :: MajorProtocolVersion
..} ->
      Doc ann
"Your script has a Plutus Core version of"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Version -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Version -> Doc ann
pretty Version
sdeAffectedVersion Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"."
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"This is not supported in"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> PlutusLedgerLanguage -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. PlutusLedgerLanguage -> Doc ann
pretty PlutusLedgerLanguage
sdeThisLang
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"and major protocol version"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MajorProtocolVersion -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MajorProtocolVersion -> Doc ann
pretty MajorProtocolVersion
sdeThisPv Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"."

{- Note [Size checking of constants in PLC programs]
We impose a 64-byte *on-the-wire* limit on the constants inside PLC programs. This prevents
people from inserting Mickey Mouse entire.

This is somewhat inconvenient for users, but they can always send multiple bytestrings and
concatenate them at runtime.

Unfortunately this check was broken in the ledger Plutus language version V1, and so for
backwards compatibility we only perform it in V2 and above.
-}

-- | Scripts to the ledger are serialised bytestrings.
type SerialisedScript = ShortByteString

{- Note [Using Flat for serialising/deserialising Script]
`plutus-ledger` uses CBOR for data serialisation and `plutus-core` uses Flat. The
choice to use Flat was made to have a more efficient (most wins are in uncompressed
size) data serialisation format and use less space on-chain.

To make `plutus-ledger` work with scripts serialised with Flat, and keep the CBOR
format otherwise, we have defined the `serialiseUPLC` and `uncheckedDeserialiseUPLC` functions.

Because Flat is not self-describing and it gets used in the encoding of Programs,
data structures that include scripts (for example, transactions) no-longer benefit
from CBOR's ability to self-describe its format.
-}

{- | Turns a program which was compiled using the \'PlutusTx\' toolchain into
a binary format that is understood by the network and can be stored on-chain.
-}
serialiseCompiledCode :: forall a. CompiledCode a -> SerialisedScript
serialiseCompiledCode :: forall a. CompiledCode a -> SerialisedScript
serialiseCompiledCode =
  -- MAYBE: Instead of this `serialiseUPLC . toNameLess` we could instead
  -- call `serialise(coerce @(Prog ND) @(Prog FND))` which, despite violating momentarily the
  -- invariant `fnd.name==fakeName`, would be faster.
  Program DeBruijn DefaultUni DefaultFun () -> SerialisedScript
serialiseUPLC (Program DeBruijn DefaultUni DefaultFun () -> SerialisedScript)
-> (CompiledCode a -> Program DeBruijn DefaultUni DefaultFun ())
-> CompiledCode a
-> SerialisedScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program NamedDeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
toNameless (Program NamedDeBruijn DefaultUni DefaultFun ()
 -> Program DeBruijn DefaultUni DefaultFun ())
-> (CompiledCode a
    -> Program NamedDeBruijn DefaultUni DefaultFun ())
-> CompiledCode a
-> Program DeBruijn DefaultUni DefaultFun ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompiledCode a -> Program NamedDeBruijn DefaultUni DefaultFun ()
forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Program NamedDeBruijn uni fun ()
getPlcNoAnn
  where
    toNameless ::
      UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () ->
      UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun ()
    toNameless :: Program NamedDeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
toNameless = ASetter
  (Program NamedDeBruijn DefaultUni DefaultFun ())
  (Program DeBruijn DefaultUni DefaultFun ())
  (Term NamedDeBruijn DefaultUni DefaultFun ())
  (Term DeBruijn DefaultUni DefaultFun ())
-> (Term NamedDeBruijn DefaultUni DefaultFun ()
    -> Term DeBruijn DefaultUni DefaultFun ())
-> Program NamedDeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (Program NamedDeBruijn DefaultUni DefaultFun ())
  (Program DeBruijn DefaultUni DefaultFun ())
  (Term NamedDeBruijn DefaultUni DefaultFun ())
  (Term DeBruijn DefaultUni DefaultFun ())
forall name1 (uni1 :: * -> *) fun1 ann name2 (uni2 :: * -> *) fun2
       (f :: * -> *).
Functor f =>
(Term name1 uni1 fun1 ann -> f (Term name2 uni2 fun2 ann))
-> Program name1 uni1 fun1 ann -> f (Program name2 uni2 fun2 ann)
UPLC.progTerm ((Term NamedDeBruijn DefaultUni DefaultFun ()
  -> Term DeBruijn DefaultUni DefaultFun ())
 -> Program NamedDeBruijn DefaultUni DefaultFun ()
 -> Program DeBruijn DefaultUni DefaultFun ())
-> (Term NamedDeBruijn DefaultUni DefaultFun ()
    -> Term DeBruijn DefaultUni DefaultFun ())
-> Program NamedDeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$ (NamedDeBruijn -> DeBruijn)
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
forall name name' (uni :: * -> *) fun ann.
(name -> name') -> Term name uni fun ann -> Term name' uni fun ann
UPLC.termMapNames NamedDeBruijn -> DeBruijn
UPLC.unNameDeBruijn

{- | Turns a program's AST (most likely manually constructed)
into a binary format that is understood by the network and can be stored on-chain.
-}
serialiseUPLC :: UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () -> SerialisedScript
serialiseUPLC :: Program DeBruijn DefaultUni DefaultFun () -> SerialisedScript
serialiseUPLC =
  -- See Note [Using Flat for serialising/deserialising Script]
  -- Currently, this is off because the old implementation didn't actually work, so we
  -- need to be careful about introducing a working version
  ByteString -> SerialisedScript
toShort (ByteString -> SerialisedScript)
-> (Program DeBruijn DefaultUni DefaultFun () -> ByteString)
-> Program DeBruijn DefaultUni DefaultFun ()
-> SerialisedScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> (Program DeBruijn DefaultUni DefaultFun () -> ByteString)
-> Program DeBruijn DefaultUni DefaultFun ()
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerialiseViaFlat
  (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
-> ByteString
forall a. Serialise a => a -> ByteString
serialise (SerialiseViaFlat
   (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
 -> ByteString)
-> (Program DeBruijn DefaultUni DefaultFun ()
    -> SerialiseViaFlat
         (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()))
-> Program DeBruijn DefaultUni DefaultFun ()
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
-> SerialiseViaFlat
     (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
forall a. a -> SerialiseViaFlat a
SerialiseViaFlat (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
 -> SerialiseViaFlat
      (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()))
-> (Program DeBruijn DefaultUni DefaultFun ()
    -> UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
-> Program DeBruijn DefaultUni DefaultFun ()
-> SerialiseViaFlat
     (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program DeBruijn DefaultUni DefaultFun ()
-> UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> UnrestrictedProgram name uni fun ann
UPLC.UnrestrictedProgram

{- | Deserialises a 'SerialisedScript' back into an AST. Does *not* do
ledger-language-version-specific checks like for allowable builtins.
-}
uncheckedDeserialiseUPLC :: SerialisedScript -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun ()
uncheckedDeserialiseUPLC :: SerialisedScript -> Program DeBruijn DefaultUni DefaultFun ()
uncheckedDeserialiseUPLC =
    UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
UnrestrictedProgram name uni fun ann -> Program name uni fun ann
UPLC.unUnrestrictedProgram (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
 -> Program DeBruijn DefaultUni DefaultFun ())
-> (SerialisedScript
    -> UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
-> SerialisedScript
-> Program DeBruijn DefaultUni DefaultFun ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerialiseViaFlat
  (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
-> UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
forall a. SerialiseViaFlat a -> a
unSerialiseViaFlat (SerialiseViaFlat
   (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
 -> UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
-> (SerialisedScript
    -> SerialiseViaFlat
         (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()))
-> SerialisedScript
-> UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> SerialiseViaFlat
     (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
forall a. Serialise a => ByteString -> a
deserialise (ByteString
 -> SerialiseViaFlat
      (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()))
-> (SerialisedScript -> ByteString)
-> SerialisedScript
-> SerialiseViaFlat
     (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString)
-> (SerialisedScript -> ByteString)
-> SerialisedScript
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerialisedScript -> ByteString
fromShort

-- | A script with named de-bruijn indices.
newtype ScriptNamedDeBruijn
  = ScriptNamedDeBruijn (UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun ())
  deriving stock (ScriptNamedDeBruijn -> ScriptNamedDeBruijn -> Bool
(ScriptNamedDeBruijn -> ScriptNamedDeBruijn -> Bool)
-> (ScriptNamedDeBruijn -> ScriptNamedDeBruijn -> Bool)
-> Eq ScriptNamedDeBruijn
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScriptNamedDeBruijn -> ScriptNamedDeBruijn -> Bool
== :: ScriptNamedDeBruijn -> ScriptNamedDeBruijn -> Bool
$c/= :: ScriptNamedDeBruijn -> ScriptNamedDeBruijn -> Bool
/= :: ScriptNamedDeBruijn -> ScriptNamedDeBruijn -> Bool
Eq, Int -> ScriptNamedDeBruijn -> ShowS
[ScriptNamedDeBruijn] -> ShowS
ScriptNamedDeBruijn -> String
(Int -> ScriptNamedDeBruijn -> ShowS)
-> (ScriptNamedDeBruijn -> String)
-> ([ScriptNamedDeBruijn] -> ShowS)
-> Show ScriptNamedDeBruijn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptNamedDeBruijn -> ShowS
showsPrec :: Int -> ScriptNamedDeBruijn -> ShowS
$cshow :: ScriptNamedDeBruijn -> String
show :: ScriptNamedDeBruijn -> String
$cshowList :: [ScriptNamedDeBruijn] -> ShowS
showList :: [ScriptNamedDeBruijn] -> ShowS
Show, (forall x. ScriptNamedDeBruijn -> Rep ScriptNamedDeBruijn x)
-> (forall x. Rep ScriptNamedDeBruijn x -> ScriptNamedDeBruijn)
-> Generic ScriptNamedDeBruijn
forall x. Rep ScriptNamedDeBruijn x -> ScriptNamedDeBruijn
forall x. ScriptNamedDeBruijn -> Rep ScriptNamedDeBruijn x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ScriptNamedDeBruijn -> Rep ScriptNamedDeBruijn x
from :: forall x. ScriptNamedDeBruijn -> Rep ScriptNamedDeBruijn x
$cto :: forall x. Rep ScriptNamedDeBruijn x -> ScriptNamedDeBruijn
to :: forall x. Rep ScriptNamedDeBruijn x -> ScriptNamedDeBruijn
Generic)
  deriving anyclass (ScriptNamedDeBruijn -> ()
(ScriptNamedDeBruijn -> ()) -> NFData ScriptNamedDeBruijn
forall a. (a -> ()) -> NFData a
$crnf :: ScriptNamedDeBruijn -> ()
rnf :: ScriptNamedDeBruijn -> ()
NFData)

-- | A Plutus script ready to be evaluated on-chain, via @evaluateScriptRestricting@.
data ScriptForEvaluation = UnsafeScriptForEvaluation !SerialisedScript !ScriptNamedDeBruijn
  deriving stock (ScriptForEvaluation -> ScriptForEvaluation -> Bool
(ScriptForEvaluation -> ScriptForEvaluation -> Bool)
-> (ScriptForEvaluation -> ScriptForEvaluation -> Bool)
-> Eq ScriptForEvaluation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScriptForEvaluation -> ScriptForEvaluation -> Bool
== :: ScriptForEvaluation -> ScriptForEvaluation -> Bool
$c/= :: ScriptForEvaluation -> ScriptForEvaluation -> Bool
/= :: ScriptForEvaluation -> ScriptForEvaluation -> Bool
Eq, Int -> ScriptForEvaluation -> ShowS
[ScriptForEvaluation] -> ShowS
ScriptForEvaluation -> String
(Int -> ScriptForEvaluation -> ShowS)
-> (ScriptForEvaluation -> String)
-> ([ScriptForEvaluation] -> ShowS)
-> Show ScriptForEvaluation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptForEvaluation -> ShowS
showsPrec :: Int -> ScriptForEvaluation -> ShowS
$cshow :: ScriptForEvaluation -> String
show :: ScriptForEvaluation -> String
$cshowList :: [ScriptForEvaluation] -> ShowS
showList :: [ScriptForEvaluation] -> ShowS
Show, (forall x. ScriptForEvaluation -> Rep ScriptForEvaluation x)
-> (forall x. Rep ScriptForEvaluation x -> ScriptForEvaluation)
-> Generic ScriptForEvaluation
forall x. Rep ScriptForEvaluation x -> ScriptForEvaluation
forall x. ScriptForEvaluation -> Rep ScriptForEvaluation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ScriptForEvaluation -> Rep ScriptForEvaluation x
from :: forall x. ScriptForEvaluation -> Rep ScriptForEvaluation x
$cto :: forall x. Rep ScriptForEvaluation x -> ScriptForEvaluation
to :: forall x. Rep ScriptForEvaluation x -> ScriptForEvaluation
Generic)
  deriving anyclass (ScriptForEvaluation -> ()
(ScriptForEvaluation -> ()) -> NFData ScriptForEvaluation
forall a. (a -> ()) -> NFData a
$crnf :: ScriptForEvaluation -> ()
rnf :: ScriptForEvaluation -> ()
NFData)

-- Only check WHNF for NoThunks, since the only way to obtain a ScriptForEvaluation
-- is `deserialiseScript`.
deriving via OnlyCheckWhnf ScriptForEvaluation instance NoThunks ScriptForEvaluation

-- | Get a `SerialisedScript` from a `ScriptForEvaluation`. /O(1)/.
serialisedScript :: ScriptForEvaluation -> SerialisedScript
serialisedScript :: ScriptForEvaluation -> SerialisedScript
serialisedScript (UnsafeScriptForEvaluation SerialisedScript
s ScriptNamedDeBruijn
_) = SerialisedScript
s

-- | Get a `ScriptNamedDeBruijn` from a `ScriptForEvaluation`. /O(1)/.
deserialisedScript :: ScriptForEvaluation -> ScriptNamedDeBruijn
deserialisedScript :: ScriptForEvaluation -> ScriptNamedDeBruijn
deserialisedScript (UnsafeScriptForEvaluation SerialisedScript
_ ScriptNamedDeBruijn
s) = ScriptNamedDeBruijn
s

{- | This decoder decodes the names directly into `NamedDeBruijn`s rather than `DeBruijn`s.
This is needed because the CEK machine expects `NameDeBruijn`s, but there are obviously no
names in the serialised form of a `Script`. Rather than traversing the term and inserting
fake names after deserialising, this lets us do at the same time as deserialising.
-}
scriptCBORDecoder ::
  PlutusLedgerLanguage ->
  MajorProtocolVersion ->
  CBOR.Decoder s ScriptNamedDeBruijn
scriptCBORDecoder :: forall s.
PlutusLedgerLanguage
-> MajorProtocolVersion -> Decoder s ScriptNamedDeBruijn
scriptCBORDecoder PlutusLedgerLanguage
ll MajorProtocolVersion
pv =
  -- See Note [New builtins/language versions and protocol versions]
  let availableBuiltins :: Set DefaultFun
availableBuiltins = PlutusLedgerLanguage -> MajorProtocolVersion -> Set DefaultFun
builtinsAvailableIn PlutusLedgerLanguage
ll MajorProtocolVersion
pv
      flatDecoder :: Get (Program FakeNamedDeBruijn DefaultUni DefaultFun ())
flatDecoder = (DefaultFun -> Maybe String)
-> Get (Program FakeNamedDeBruijn DefaultUni DefaultFun ())
forall name (uni :: * -> *) fun ann.
(Closed uni, Everywhere uni Flat, Flat fun, Flat ann, Flat name,
 Flat (Binder name)) =>
(fun -> Maybe String) -> Get (Program name uni fun ann)
UPLC.decodeProgram DefaultFun -> Maybe String
checkBuiltin
      -- TODO: optimize this by using a better datastructure e.g. 'IntSet'
      checkBuiltin :: DefaultFun -> Maybe String
checkBuiltin DefaultFun
f | DefaultFun
f DefaultFun -> Set DefaultFun -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DefaultFun
availableBuiltins = Maybe String
forall a. Maybe a
Nothing
      checkBuiltin DefaultFun
f =
        String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
          String
"Builtin function "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ DefaultFun -> String
forall a. Show a => a -> String
show DefaultFun
f
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not available in language "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (PlutusLedgerLanguage -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. PlutusLedgerLanguage -> Doc ann
pretty PlutusLedgerLanguage
ll)
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" at and protocol version "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (MajorProtocolVersion -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. MajorProtocolVersion -> Doc ann
pretty MajorProtocolVersion
pv)
   in do
        -- Deserialise using 'FakeNamedDeBruijn' to get the fake names added
        (Program FakeNamedDeBruijn DefaultUni DefaultFun ()
p :: UPLC.Program UPLC.FakeNamedDeBruijn DefaultUni DefaultFun ()) <-
          Get (Program FakeNamedDeBruijn DefaultUni DefaultFun ())
-> Decoder s (Program FakeNamedDeBruijn DefaultUni DefaultFun ())
forall a s. Get a -> Decoder s a
decodeViaFlatWith Get (Program FakeNamedDeBruijn DefaultUni DefaultFun ())
flatDecoder
        ScriptNamedDeBruijn -> Decoder s ScriptNamedDeBruijn
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptNamedDeBruijn -> Decoder s ScriptNamedDeBruijn)
-> ScriptNamedDeBruijn -> Decoder s ScriptNamedDeBruijn
forall a b. (a -> b) -> a -> b
$ Program FakeNamedDeBruijn DefaultUni DefaultFun ()
-> ScriptNamedDeBruijn
forall a b. Coercible a b => a -> b
coerce Program FakeNamedDeBruijn DefaultUni DefaultFun ()
p

{- | The deserialization from a serialised script into a `ScriptForEvaluation`,
ready to be evaluated on-chain.
Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error).
-}
deserialiseScript ::
  forall m.
  (MonadError ScriptDecodeError m) =>
  -- | the Plutus ledger language of the script.
  PlutusLedgerLanguage ->
  -- | which major protocol version the script was submitted in.
  MajorProtocolVersion ->
  -- | the script to deserialise.
  SerialisedScript ->
  m ScriptForEvaluation
deserialiseScript :: forall (m :: * -> *).
MonadError ScriptDecodeError m =>
PlutusLedgerLanguage
-> MajorProtocolVersion
-> SerialisedScript
-> m ScriptForEvaluation
deserialiseScript PlutusLedgerLanguage
ll MajorProtocolVersion
pv SerialisedScript
sScript = do
  -- check that the ledger language version is available
  let llIntroPv :: MajorProtocolVersion
llIntroPv = PlutusLedgerLanguage -> MajorProtocolVersion
ledgerLanguageIntroducedIn PlutusLedgerLanguage
ll
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (MajorProtocolVersion
llIntroPv MajorProtocolVersion -> MajorProtocolVersion -> Bool
forall a. Ord a => a -> a -> Bool
<= MajorProtocolVersion
pv) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    AReview ScriptDecodeError ScriptDecodeError
-> ScriptDecodeError -> m ()
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview ScriptDecodeError ScriptDecodeError
forall r. AsScriptDecodeError r => Prism' r ScriptDecodeError
Prism' ScriptDecodeError ScriptDecodeError
_ScriptDecodeError (ScriptDecodeError -> m ()) -> ScriptDecodeError -> m ()
forall a b. (a -> b) -> a -> b
$
      PlutusLedgerLanguage
-> MajorProtocolVersion
-> MajorProtocolVersion
-> ScriptDecodeError
LedgerLanguageNotAvailableError PlutusLedgerLanguage
ll MajorProtocolVersion
llIntroPv MajorProtocolVersion
pv

  (ByteString
remderBS, dScript :: ScriptNamedDeBruijn
dScript@(ScriptNamedDeBruijn (UPLC.Program{}))) <- SerialisedScript -> m (ByteString, ScriptNamedDeBruijn)
deserialiseSScript SerialisedScript
sScript
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PlutusLedgerLanguage
ll PlutusLedgerLanguage -> PlutusLedgerLanguage -> Bool
forall a. Eq a => a -> a -> Bool
/= PlutusLedgerLanguage
PlutusV1 Bool -> Bool -> Bool
&& PlutusLedgerLanguage
ll PlutusLedgerLanguage -> PlutusLedgerLanguage -> Bool
forall a. Eq a => a -> a -> Bool
/= PlutusLedgerLanguage
PlutusV2 Bool -> Bool -> Bool
&& ByteString
remderBS ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
forall a. Monoid a => a
mempty) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    AReview ScriptDecodeError ScriptDecodeError
-> ScriptDecodeError -> m ()
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview ScriptDecodeError ScriptDecodeError
forall r. AsScriptDecodeError r => Prism' r ScriptDecodeError
Prism' ScriptDecodeError ScriptDecodeError
_ScriptDecodeError (ScriptDecodeError -> m ()) -> ScriptDecodeError -> m ()
forall a b. (a -> b) -> a -> b
$
      ByteString -> ScriptDecodeError
RemainderError ByteString
remderBS

  ScriptForEvaluation -> m ScriptForEvaluation
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptForEvaluation -> m ScriptForEvaluation)
-> ScriptForEvaluation -> m ScriptForEvaluation
forall a b. (a -> b) -> a -> b
$ SerialisedScript -> ScriptNamedDeBruijn -> ScriptForEvaluation
UnsafeScriptForEvaluation SerialisedScript
sScript ScriptNamedDeBruijn
dScript
  where
    deserialiseSScript :: SerialisedScript -> m (BSL.ByteString, ScriptNamedDeBruijn)
    deserialiseSScript :: SerialisedScript -> m (ByteString, ScriptNamedDeBruijn)
deserialiseSScript =
      SerialisedScript -> ByteString
fromShort
        (SerialisedScript -> ByteString)
-> (ByteString -> m (ByteString, ScriptNamedDeBruijn))
-> SerialisedScript
-> m (ByteString, ScriptNamedDeBruijn)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ByteString -> ByteString
BSL.fromStrict
        (ByteString -> ByteString)
-> (ByteString -> m (ByteString, ScriptNamedDeBruijn))
-> ByteString
-> m (ByteString, ScriptNamedDeBruijn)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall s. Decoder s ScriptNamedDeBruijn)
-> ByteString
-> Either DeserialiseFailure (ByteString, ScriptNamedDeBruijn)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes (PlutusLedgerLanguage
-> MajorProtocolVersion -> Decoder s ScriptNamedDeBruijn
forall s.
PlutusLedgerLanguage
-> MajorProtocolVersion -> Decoder s ScriptNamedDeBruijn
scriptCBORDecoder PlutusLedgerLanguage
ll MajorProtocolVersion
pv)
        -- lift the underlying cbor error to our custom error
        (ByteString
 -> Either DeserialiseFailure (ByteString, ScriptNamedDeBruijn))
-> (Either DeserialiseFailure (ByteString, ScriptNamedDeBruijn)
    -> m (ByteString, ScriptNamedDeBruijn))
-> ByteString
-> m (ByteString, ScriptNamedDeBruijn)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (DeserialiseFailure -> m (ByteString, ScriptNamedDeBruijn))
-> ((ByteString, ScriptNamedDeBruijn)
    -> m (ByteString, ScriptNamedDeBruijn))
-> Either DeserialiseFailure (ByteString, ScriptNamedDeBruijn)
-> m (ByteString, ScriptNamedDeBruijn)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (AReview ScriptDecodeError ScriptDecodeError
-> ScriptDecodeError -> m (ByteString, ScriptNamedDeBruijn)
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview ScriptDecodeError ScriptDecodeError
forall r. AsScriptDecodeError r => Prism' r ScriptDecodeError
Prism' ScriptDecodeError ScriptDecodeError
_ScriptDecodeError (ScriptDecodeError -> m (ByteString, ScriptNamedDeBruijn))
-> (DeserialiseFailure -> ScriptDecodeError)
-> DeserialiseFailure
-> m (ByteString, ScriptNamedDeBruijn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeserialiseFailure -> ScriptDecodeError
toScripDecodeError) (ByteString, ScriptNamedDeBruijn)
-> m (ByteString, ScriptNamedDeBruijn)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    -- turn a cborg failure to our own error type
    toScripDecodeError :: CBOR.DeserialiseFailure -> ScriptDecodeError
    toScripDecodeError :: DeserialiseFailure -> ScriptDecodeError
toScripDecodeError = DeserialiseFailureInfo -> ScriptDecodeError
CBORDeserialiseError (DeserialiseFailureInfo -> ScriptDecodeError)
-> (DeserialiseFailure -> DeserialiseFailureInfo)
-> DeserialiseFailure
-> ScriptDecodeError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeserialiseFailure -> DeserialiseFailureInfo
CBOR.Extras.readDeserialiseFailureInfo