-- editorconfig-checker-disable-file
{-# LANGUAGE DeriveAnyClass  #-}
{-# LANGUAGE TemplateHaskell #-}
module PlutusLedgerApi.Common.SerialisedScript
    ( SerialisedScript
    , serialiseCompiledCode
    , serialiseUPLC
    , deserialiseUPLC
    , scriptCBORDecoder
    , ScriptForExecution (..)
    , ScriptDecodeError (..)
    , AsScriptDecodeError (..)
    , fromSerialisedScript
    , assertScriptWellFormed
    ) where

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

import Codec.CBOR.Decoding qualified as CBOR
import Codec.CBOR.Extras
import Codec.CBOR.Read qualified as CBOR
import Codec.Serialise
import Control.Arrow ((>>>))
import Control.Exception
import Control.Lens
import Control.Monad.Error.Lens
import Control.Monad.Except
import Data.ByteString.Lazy as BSL (ByteString, fromStrict, toStrict)
import Data.ByteString.Short
import Data.Coerce
import Data.Set as Set
import Prettyprinter

data ScriptDecodeError =
      CBORDeserialiseError CBOR.DeserialiseFailure
    | RemainderError BSL.ByteString
    | LanguageNotAvailableError
        { ScriptDecodeError -> LedgerPlutusVersion
sdeAffectedLang :: LedgerPlutusVersion
        , ScriptDecodeError -> ProtocolVersion
sdeIntroPv      :: ProtocolVersion
        , ScriptDecodeError -> ProtocolVersion
sdeCurrentPv    :: ProtocolVersion
        }
    deriving stock (ScriptDecodeError -> ScriptDecodeError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptDecodeError -> ScriptDecodeError -> Bool
$c/= :: ScriptDecodeError -> ScriptDecodeError -> Bool
== :: ScriptDecodeError -> ScriptDecodeError -> Bool
$c== :: ScriptDecodeError -> ScriptDecodeError -> Bool
Eq, Int -> ScriptDecodeError -> ShowS
[ScriptDecodeError] -> ShowS
ScriptDecodeError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptDecodeError] -> ShowS
$cshowList :: [ScriptDecodeError] -> ShowS
show :: ScriptDecodeError -> String
$cshow :: ScriptDecodeError -> String
showsPrec :: Int -> ScriptDecodeError -> ShowS
$cshowsPrec :: Int -> ScriptDecodeError -> ShowS
Show)
    deriving anyclass Show ScriptDecodeError
Typeable ScriptDecodeError
SomeException -> Maybe ScriptDecodeError
ScriptDecodeError -> String
ScriptDecodeError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: ScriptDecodeError -> String
$cdisplayException :: ScriptDecodeError -> String
fromException :: SomeException -> Maybe ScriptDecodeError
$cfromException :: SomeException -> Maybe ScriptDecodeError
toException :: ScriptDecodeError -> SomeException
$ctoException :: ScriptDecodeError -> SomeException
Exception
makeClassyPrisms ''ScriptDecodeError

{- 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 `deserialiseUPLC` 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
for CBOR's ability to self-describe it's format.
-}

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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialise a => a -> ByteString
serialise forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> SerialiseViaFlat a
SerialiseViaFlat

deserialiseUPLC :: SerialisedScript -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun ()
deserialiseUPLC :: SerialisedScript -> Program DeBruijn DefaultUni DefaultFun ()
deserialiseUPLC = forall {a}. SerialiseViaFlat a -> a
unSerialiseViaFlat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialise a => ByteString -> a
deserialise forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. SerialisedScript -> ByteString
fromShort
  where
    unSerialiseViaFlat :: SerialiseViaFlat a -> a
unSerialiseViaFlat (SerialiseViaFlat a
a) = a
a

serialiseCompiledCode :: forall a. CompiledCode a -> SerialisedScript
serialiseCompiledCode :: forall a. CompiledCode a -> SerialisedScript
serialiseCompiledCode = Program DeBruijn DefaultUni DefaultFun () -> SerialisedScript
serialiseUPLC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program NamedDeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
toNameless forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Program NamedDeBruijn uni fun ()
getPlc
    where
        toNameless :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun ()
                -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun ()
        toNameless :: Program NamedDeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
toNameless = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall name1 (uni1 :: * -> *) fun1 ann name2 (uni2 :: * -> *) fun2.
Lens
  (Program name1 uni1 fun1 ann)
  (Program name2 uni2 fun2 ann)
  (Term name1 uni1 fun1 ann)
  (Term name2 uni2 fun2 ann)
UPLC.progTerm forall a b. (a -> b) -> a -> b
$ forall name name' (uni :: * -> *) fun ann.
(name -> name') -> Term name uni fun ann -> Term name' uni fun ann
UPLC.termMapNames NamedDeBruijn -> DeBruijn
UPLC.unNameDeBruijn

-- | A variant of `Script` with a specialized decoder.
newtype ScriptForExecution = ScriptForExecution (UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun ())

{-| 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 :: LedgerPlutusVersion -> ProtocolVersion -> CBOR.Decoder s ScriptForExecution
scriptCBORDecoder :: forall s.
LedgerPlutusVersion
-> ProtocolVersion -> Decoder s ScriptForExecution
scriptCBORDecoder LedgerPlutusVersion
lv ProtocolVersion
pv =
    -- See Note [New builtins and protocol versions]
    let availableBuiltins :: Set DefaultFun
availableBuiltins = LedgerPlutusVersion -> ProtocolVersion -> Set DefaultFun
builtinsAvailableIn LedgerPlutusVersion
lv ProtocolVersion
pv
        flatDecoder :: Get (Program FakeNamedDeBruijn DefaultUni DefaultFun ())
flatDecoder = 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 forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DefaultFun
availableBuiltins = forall a. Maybe a
Nothing
        checkBuiltin DefaultFun
f = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"Builtin function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DefaultFun
f forall a. [a] -> [a] -> [a]
++ String
" is not available in language " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a ann. Pretty a => a -> Doc ann
pretty LedgerPlutusVersion
lv) forall a. [a] -> [a] -> [a]
++ String
" at and protocol version " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a ann. Pretty a => a -> Doc ann
pretty ProtocolVersion
pv)
    in do
        -- Deserialise using 'FakeNamedDeBruijn' to get the fake names added
        (Program FakeNamedDeBruijn DefaultUni DefaultFun ()
p :: UPLC.Program UPLC.FakeNamedDeBruijn DefaultUni DefaultFun ()) <- forall a s. Get a -> Decoder s a
decodeViaFlat Get (Program FakeNamedDeBruijn DefaultUni DefaultFun ())
flatDecoder
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce Program FakeNamedDeBruijn DefaultUni DefaultFun ()
p

-- | The deserialization from a serialised script to a Script (for execution).
-- Called inside phase-1 validation (assertScriptWellFormed) and inside phase-2's `mkTermToEvaluate`
fromSerialisedScript :: forall e m. (AsScriptDecodeError e, MonadError e m)
                     => LedgerPlutusVersion
                     -> ProtocolVersion
                     -> SerialisedScript
                     -> m ScriptForExecution
fromSerialisedScript :: forall e (m :: * -> *).
(AsScriptDecodeError e, MonadError e m) =>
LedgerPlutusVersion
-> ProtocolVersion -> SerialisedScript -> m ScriptForExecution
fromSerialisedScript LedgerPlutusVersion
lv ProtocolVersion
currentPv SerialisedScript
sScript = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtocolVersion
introPv forall a. Ord a => a -> a -> Bool
> ProtocolVersion
currentPv)  forall a b. (a -> b) -> a -> b
$
        forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing forall r. AsScriptDecodeError r => Prism' r ScriptDecodeError
_ScriptDecodeError forall a b. (a -> b) -> a -> b
$ LedgerPlutusVersion
-> ProtocolVersion -> ProtocolVersion -> ScriptDecodeError
LanguageNotAvailableError LedgerPlutusVersion
lv ProtocolVersion
introPv ProtocolVersion
currentPv
    (ByteString
remderBS, ScriptForExecution
script) <- SerialisedScript -> m (ByteString, ScriptForExecution)
deserialiseSScript SerialisedScript
sScript
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LedgerPlutusVersion
lv forall a. Eq a => a -> a -> Bool
/= LedgerPlutusVersion
PlutusV1 Bool -> Bool -> Bool
&& LedgerPlutusVersion
lv forall a. Eq a => a -> a -> Bool
/= LedgerPlutusVersion
PlutusV2 Bool -> Bool -> Bool
&& ByteString
remderBS forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$
        forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing forall r. AsScriptDecodeError r => Prism' r ScriptDecodeError
_ScriptDecodeError forall a b. (a -> b) -> a -> b
$ ByteString -> ScriptDecodeError
RemainderError ByteString
remderBS
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptForExecution
script
  where
    introPv :: ProtocolVersion
introPv = LedgerPlutusVersion -> ProtocolVersion
languageIntroducedIn LedgerPlutusVersion
lv
    deserialiseSScript :: SerialisedScript -> m (BSL.ByteString, ScriptForExecution)
    deserialiseSScript :: SerialisedScript -> m (ByteString, ScriptForExecution)
deserialiseSScript = SerialisedScript -> ByteString
fromShort
                       forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ByteString -> ByteString
fromStrict
                       forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes (forall s.
LedgerPlutusVersion
-> ProtocolVersion -> Decoder s ScriptForExecution
scriptCBORDecoder LedgerPlutusVersion
lv ProtocolVersion
currentPv)
                       -- lift the underlying cbor error to our custom error
                       forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing forall r. AsScriptDecodeError r => Prism' r ScriptDecodeError
_ScriptDecodeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeserialiseFailure -> ScriptDecodeError
CBORDeserialiseError) forall (f :: * -> *) a. Applicative f => a -> f a
pure

{-| Check if a 'Script' is "valid" according to a protocol version. At the moment this means "deserialises correctly", which in particular
implies that it is (almost certainly) an encoded script and the script does not mention any builtins unavailable in the given protocol version.

Note: Parameterized over the ledger-plutus-version since the builtins allowed (during decoding) differs.
-}
assertScriptWellFormed :: MonadError ScriptDecodeError m
                       => LedgerPlutusVersion
                       -> ProtocolVersion
                       -> SerialisedScript
                       -> m ()
assertScriptWellFormed :: forall (m :: * -> *).
MonadError ScriptDecodeError m =>
LedgerPlutusVersion -> ProtocolVersion -> SerialisedScript -> m ()
assertScriptWellFormed LedgerPlutusVersion
lv ProtocolVersion
pv =
    -- We opt to throw away the ScriptExecution result. for not "leaking" the actual Script through the API.
    forall (f :: * -> *) a. Functor f => f a -> f ()
void
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *).
(AsScriptDecodeError e, MonadError e m) =>
LedgerPlutusVersion
-> ProtocolVersion -> SerialisedScript -> m ScriptForExecution
fromSerialisedScript LedgerPlutusVersion
lv ProtocolVersion
pv