SerialisedScript.hs

{-# 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 PlutusCore.Default (defaultUniSize)
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.Array.Unboxed ((!))
import Data.ByteString.Lazy qualified as BSL
import Data.ByteString.Short
import Data.Coerce
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
      { sdeAffectedLang :: !PlutusLedgerLanguage
      -- ^ the script's ledger language
      , sdeIntroPv :: !MajorProtocolVersion
      -- ^ the major protocol version that will first introduce/enable the ledger language
      , sdeThisPv :: !MajorProtocolVersion
      -- ^ the current protocol version
      }
  | PlutusCoreLanguageNotAvailableError
      { sdeAffectedVersion :: !UPLC.Version
      -- ^ the Plutus Core language of the script under execution.
      , sdeThisLang :: !PlutusLedgerLanguage
      -- ^ the Plutus ledger language of the script under execution.
      , sdeThisPv :: !MajorProtocolVersion
      -- ^ the current protocol version
      }
  deriving stock (Eq, Show)
  deriving anyclass (Exception)

makeClassyPrisms ''ScriptDecodeError

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

{- 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 =
  -- 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.
  serialiseUPLC . toNameless . getPlcNoAnn
  where
    toNameless
      :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun ()
      -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun ()
    toNameless = over UPLC.progTerm $ UPLC.termMapNames 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 =
  -- 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
  toShort . BSL.toStrict . serialise . SerialiseViaFlat . 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 =
  UPLC.unUnrestrictedProgram . unSerialiseViaFlat . deserialise . BSL.fromStrict . fromShort

-- | A script with named de-bruijn indices.
newtype ScriptNamedDeBruijn
  = ScriptNamedDeBruijn (UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun ())
  deriving stock (Eq, Show, Generic)
  deriving anyclass (NFData)

-- | A Plutus script ready to be evaluated on-chain, via @evaluateScriptRestricting@.
data ScriptForEvaluation = UnsafeScriptForEvaluation !SerialisedScript !ScriptNamedDeBruijn
  deriving stock (Eq, Show, Generic)
  deriving anyclass (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 (UnsafeScriptForEvaluation s _) = s

-- | Get a `ScriptNamedDeBruijn` from a `ScriptForEvaluation`. /O(1)/.
deserialisedScript :: ScriptForEvaluation -> ScriptNamedDeBruijn
deserialisedScript (UnsafeScriptForEvaluation _ s) = 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 ll pv =
  -- See Note [New builtins/language versions and protocol versions]
  let availableBuiltins = builtinsAvailableIn ll pv

      flatDecoder = UPLC.decodeProgram checkConstant checkBuiltin checkConstr

      maxBounds = maxBoundsByPV pv
      maxBoundHeader = mbHeader maxBounds
      maxBoundConstr = mbConstr maxBounds

      checkConstant (Some (ValueOf uni _))
        | defaultUniSize uni <= maxBoundHeader = Nothing
        | otherwise =
            Just $
              "Constant of type "
                ++ show (pretty uni)
                ++ " is not available in protocol version "
                ++ show (pretty pv)

      checkBuiltin f | availableBuiltins ! f = Nothing
      checkBuiltin f =
        Just $
          "Builtin function "
            ++ show f
            ++ " is not available in language "
            ++ show (pretty ll)
            ++ " at and protocol version "
            ++ show (pretty pv)

      checkConstr n
        | n <= maxBoundConstr = Nothing
        | otherwise =
            Just $
              "constr with "
                ++ show n
                ++ " fields is not available in protocol version "
                ++ show (pretty pv)

   in do
        -- Deserialise using 'FakeNamedDeBruijn' to get the fake names added
        (p :: UPLC.Program UPLC.FakeNamedDeBruijn DefaultUni DefaultFun ()) <-
          decodeViaFlatWith flatDecoder
        pure $ coerce 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
  => PlutusLedgerLanguage
  -- ^ the Plutus ledger language of the script.
  -> MajorProtocolVersion
  -- ^ which major protocol version the script was submitted in.
  -> SerialisedScript
  -- ^ the script to deserialise.
  -> m ScriptForEvaluation
deserialiseScript ll pv sScript = do
  -- check that the ledger language version is available
  let llIntroPv = ledgerLanguageIntroducedIn ll
  unless (llIntroPv <= pv) $
    throwing _ScriptDecodeError $
      LedgerLanguageNotAvailableError ll llIntroPv pv

  (remderBS, dScript@(ScriptNamedDeBruijn (UPLC.Program {}))) <- deserialiseSScript sScript
  when (ll /= PlutusV1 && ll /= PlutusV2 && remderBS /= mempty) $
    throwing _ScriptDecodeError $
      RemainderError remderBS

  pure $ UnsafeScriptForEvaluation sScript dScript
  where
    deserialiseSScript :: SerialisedScript -> m (BSL.ByteString, ScriptNamedDeBruijn)
    deserialiseSScript =
      fromShort
        >>> BSL.fromStrict
        >>> CBOR.deserialiseFromBytes (scriptCBORDecoder ll pv)
        -- lift the underlying cbor error to our custom error
        >>> either (throwing _ScriptDecodeError . toScripDecodeError) pure

    -- turn a cborg failure to our own error type
    toScripDecodeError :: CBOR.DeserialiseFailure -> ScriptDecodeError
    toScripDecodeError = CBORDeserialiseError . CBOR.Extras.readDeserialiseFailureInfo