Remove Flat instances for UPLC terms and programs (#5238)

These aren't really safe, since they don't perform the allowable
builtins checks. We don't use them in `plutus-ledger-api`, but it's
quite hard to be sure or enforce that. It's also easy to use the
unrestricted class methods in the definitions of the restricted
functions. It's a mess. So better to remove them, and keep the class
implementation only for a special newtype.

I also renamed a function in `plutus-ledger-api` which relies on this
behaviour to make it clearer that it's somewhat unsafe.

plutus-benchmark/ed25519-throughput/Main.hs

@@ -198,7 +198,7 @@ evaluate (UPLC.Program _ _ prog) =
 printStatistics :: Integer -> IO ()
 printStatistics n = do
     let script = mkSigCheckScript n
-        serialised = Flat.flat (toAnonDeBruijnProg script)
+        serialised = Flat.flat (UPLC.UnrestrictedProgram $ toAnonDeBruijnProg script)
         size = BS.length serialised
         (cpu, mem) = evaluate script
     printf "  %3d %7d %8s %15d %8s %15d %8s \n"

plutus-benchmark/nofib/exe/Main.hs

@@ -203,10 +203,10 @@ evaluateWithCek :: UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () -> UPLC
 evaluateWithCek = UPLC.unsafeExtractEvaluationResult . (\(fstT,_,_) -> fstT) . UPLC.runCekDeBruijn PLC.defaultCekParameters UPLC.restrictingEnormous UPLC.noEmitter
 
 writeFlatNamed :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () -> IO ()
-writeFlatNamed prog = BS.putStr $ Flat.flat prog
+writeFlatNamed prog = BS.putStr . Flat.flat . UPLC.UnrestrictedProgram $ prog
 
 writeFlatDeBruijn ::UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () -> IO ()
-writeFlatDeBruijn  prog = BS.putStr . Flat.flat $ prog
+writeFlatDeBruijn  prog = BS.putStr . Flat.flat . UPLC.UnrestrictedProgram $ prog
 
 description :: Hs.String
 description = "This program provides operations on a number of Plutus programs "

plutus-benchmark/validation/Common.hs

@@ -87,7 +87,7 @@ unsafeUnflat :: String -> BS.ByteString -> UPLC.Program UPLC.DeBruijn UPLC.Defau
 unsafeUnflat file contents =
     case unflat contents of
         Left e     -> errorWithoutStackTrace $ "Flat deserialisation failure for " ++ file ++ ": " ++ show e
-        Right prog -> prog
+        Right (UPLC.UnrestrictedProgram prog) -> prog
 
 ----------------------- Main -----------------------
 

plutus-core/changelog.d/20230328_150430_michael.peyton-jones_remove_flat_instances.md

@@ -0,0 +1,8 @@
+### Removed
+
+- `Flat` instances for UPLC terms and programs. These were potentially unsafe as they don't perform the builtin checks that are required on chain, so it is important not to use them by accident. 
+
+### Added
+
+- `UnrestrictedProgram` newtype that performs unchecked serializatin/deserialization of programs for when that's appropriate.
+

plutus-core/executables/src/PlutusCore/Executable/Common.hs

@@ -132,9 +132,9 @@ instance ProgramLike UplcProg where
     checkUniques = UPLC.checkProgram (const True)
     serialiseProgramFlat nameType p =
         case nameType of
-            Named         -> pure $ BSL.fromStrict $ flat p
-            DeBruijn      -> BSL.fromStrict . flat <$> toDeBruijn p
-            NamedDeBruijn -> BSL.fromStrict . flat <$> toNamedDeBruijn p
+            Named         -> pure $ BSL.fromStrict $ flat $ UPLC.UnrestrictedProgram p
+            DeBruijn      -> BSL.fromStrict . flat . UPLC.UnrestrictedProgram <$> toDeBruijn p
+            NamedDeBruijn -> BSL.fromStrict . flat . UPLC.UnrestrictedProgram <$> toNamedDeBruijn p
     loadASTfromFlat = loadUplcASTfromFlat
 
 -- We don't support de Bruijn names for typed programs because we really only
@@ -411,13 +411,13 @@ loadUplcASTfromFlat :: Flat ann => AstNameType -> Input -> IO (UplcProg ann)
 loadUplcASTfromFlat flatMode inp = do
     input <- getBinaryInput inp
     case flatMode of
-        Named -> handleResult $ unflat input
+        Named -> fmap UPLC.unUnrestrictedProgram . handleResult $ unflat input
         DeBruijn -> do
-            deserialised <- handleResult $ unflat input
+            (UPLC.UnrestrictedProgram deserialised) <- handleResult $ unflat input
             let namedProgram = UPLC.programMapNames UPLC.fakeNameDeBruijn deserialised
             fromDeBruijn namedProgram
         NamedDeBruijn -> do
-            deserialised <- handleResult $ unflat input
+            (UPLC.UnrestrictedProgram deserialised) <- handleResult $ unflat input
             fromDeBruijn deserialised
   where
     handleResult =

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs

@@ -3,10 +3,8 @@
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE KindSignatures       #-}
 {-# LANGUAGE LambdaCase           #-}
-{-# LANGUAGE NamedFieldPuns       #-}
 {-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module UntypedPlutusCore.Core.Instance.Flat where
 
@@ -157,15 +155,35 @@ sizeTerm
     => Term name uni fun ann
     -> NumBits
     -> NumBits
-sizeTerm tm sz = termTagWidth + sz + case tm of
-    Var      ann n    -> getSize ann + getSize n
-    Delay    ann t    -> getSize ann + getSize t
-    LamAbs   ann n t  -> getSize ann + getSize n + getSize t
-    Apply    ann t t' -> getSize ann + getSize t + getSize t'
-    Constant ann c    -> getSize ann + getSize c
-    Force    ann t    -> getSize ann + getSize t
-    Error    ann      -> getSize ann
-    Builtin  ann bn   -> getSize ann + getSize bn
+sizeTerm tm sz =
+  let
+    sz' = termTagWidth + sz
+  in case tm of
+    Var      ann n    -> size ann $ size n sz'
+    Delay    ann t    -> size ann $ sizeTerm t sz'
+    LamAbs   ann n t  -> size ann $ size n $ sizeTerm t sz'
+    Apply    ann t t' -> size ann $ sizeTerm t $ sizeTerm t' sz'
+    Constant ann c    -> size ann $ size c sz'
+    Force    ann t    -> size ann $ sizeTerm t sz'
+    Error    ann      -> size ann sz'
+    Builtin  ann bn   -> size ann $ size bn sz'
+
+-- | An encoder for programs.
+--
+-- It is not easy to use this correctly with @flat@. The simplest thing
+-- is to go via the instance for 'UnrestrictedProgram', which uses this
+encodeProgram
+    :: forall name uni fun ann
+    . ( Closed uni
+    , uni `Everywhere` Flat
+    , Flat fun
+    , Flat ann
+    , Flat name
+    , Flat (Binder name)
+    )
+    => Program name uni fun ann
+    -> Encoding
+encodeProgram (Program ann v t) = encode ann <> encode v <> encodeTerm t
 
 decodeProgram
     :: forall name uni fun ann
@@ -180,34 +198,34 @@ decodeProgram
     -> Get (Program name uni fun ann)
 decodeProgram builtinPred = Program <$> decode <*> decode <*> decodeTerm builtinPred
 
-{- Note [Deserialization on the chain]
-As discussed in Note [Deserialization size limits], we want to limit how big constants are when deserializing.
-But the 'Flat' instances for plain terms and programs provided here don't do that: they implement unrestricted deserialization.
-
-In practice we use a specialized decoder for the on-chain decoding which calls 'decodeProgram' directly.
-Possibly we should remove these instances in future and only have instances for newtypes that clearly communicate
-the expected behaviour.
--}
+sizeProgram
+    :: forall name uni fun ann
+    . ( Closed uni
+    , uni `Everywhere` Flat
+    , Flat fun
+    , Flat ann
+    , Flat name
+    , Flat (Binder name)
+    )
+    => Program name uni fun ann
+    -> NumBits
+    -> NumBits
+sizeProgram (Program ann v t) sz = size ann $ size v $ sizeTerm t sz
 
-instance ( Closed uni
-         , uni `Everywhere` Flat
-         , Flat fun
-         , Flat ann
-         , Flat name
-         , Flat (Binder name)
-         ) => Flat (Term name uni fun ann) where
-    encode = encodeTerm
-    decode = decodeTerm (const Nothing)
-    size = sizeTerm
+-- | A program that can be serialized without any restrictions, e.g.
+-- on the set of allowable builtins or term constructs. It is generally
+-- safe to use this newtype for serializing, but it should only be used
+-- for deserializing in tests.
+newtype UnrestrictedProgram name uni fun ann = UnrestrictedProgram { unUnrestrictedProgram :: Program name uni fun ann }
 
--- This instance could probably be derived, but better to write it explicitly ourselves so we have control!
 instance ( Closed uni
          , uni `Everywhere` Flat
          , Flat fun
          , Flat ann
          , Flat name
          , Flat (Binder name)
-         ) => Flat (Program name uni fun ann) where
-    encode (Program ann v t) = encode ann <> encode v <> encode t
+         ) => Flat (UnrestrictedProgram name uni fun ann) where
+    encode (UnrestrictedProgram p) = encodeProgram p
+    decode = UnrestrictedProgram <$> decodeProgram (const Nothing)
 
-    size (Program a v t) n = n + getSize a + getSize v + getSize t
+    size (UnrestrictedProgram p) = sizeProgram p

plutus-core/untyped-plutus-core/test/Generators.hs

@@ -19,6 +19,7 @@ import PlutusCore.Generators.Hedgehog.AST qualified as AST
 import PlutusCore.Parser (defaultUni, parseGen)
 import PlutusCore.Pretty (displayPlcDef)
 import PlutusCore.Quote (QuoteT, runQuoteT)
+import UntypedPlutusCore qualified as UPLC
 import UntypedPlutusCore.Core.Type (Program (Program),
                                     Term (Apply, Builtin, Constant, Delay, Error, Force, LamAbs, Var),
                                     progTerm, termAnn)
@@ -72,7 +73,7 @@ genProgram = fmap eraseProgram AST.genProgram
 propFlat :: TestTree
 propFlat = testPropertyNamed "Flat" "Flat" $ property $ do
     prog <- forAllPretty $ runAstGen (Generators.genProgram @DefaultFun)
-    tripping prog Flat.flat Flat.unflat
+    tripping prog (Flat.flat . UPLC.UnrestrictedProgram) (fmap UPLC.unUnrestrictedProgram . Flat.unflat)
 
 propParser :: TestTree
 propParser = testPropertyNamed "Parser" "parser" $ property $ do

plutus-ledger-api/changelog.d/20230328_150603_michael.peyton-jones_remove_flat_instances.md

@@ -0,0 +1,4 @@
+### Changed
+
+- `deserialiseUPLC` renamed to `uncheckedDeserialiseUPLC` since it doesn't do the checks for allowable builtins. This is dangerous in the ledger setting where this check is mandatory, so it needs a scarier name.
+

plutus-ledger-api/src/PlutusLedgerApi/Common.hs

@@ -4,7 +4,7 @@ module PlutusLedgerApi.Common
       SerialisedScript
     , serialiseCompiledCode
     , serialiseUPLC
-    , deserialiseUPLC
+    , uncheckedDeserialiseUPLC
     , ScriptDecodeError (..)
     , assertScriptWellFormed
 

plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs

@@ -5,7 +5,7 @@ module PlutusLedgerApi.Common.SerialisedScript
     ( SerialisedScript
     , serialiseCompiledCode
     , serialiseUPLC
-    , deserialiseUPLC
+    , uncheckedDeserialiseUPLC
     , scriptCBORDecoder
     , ScriptForExecution (..)
     , ScriptDecodeError (..)
@@ -67,7 +67,7 @@ choice to use Flat was made to have a more efficient (most wins are in uncompres
 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.
+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
@@ -90,13 +90,14 @@ 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
+    toShort . BSL.toStrict . serialise . SerialiseViaFlat . UPLC.UnrestrictedProgram
 
--- | Deserialises a 'SerialisedScript' back into an AST.
-deserialiseUPLC :: SerialisedScript -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun ()
-deserialiseUPLC = unSerialiseViaFlat . deserialise . BSL.fromStrict . fromShort
+-- | 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 = unSerialiseViaFlat . deserialise . BSL.fromStrict . fromShort
   where
-    unSerialiseViaFlat (SerialiseViaFlat a) = a
+    unSerialiseViaFlat (SerialiseViaFlat (UPLC.UnrestrictedProgram a)) = a
 
 -- | A variant of `Script` with a specialized decoder.
 newtype ScriptForExecution = ScriptForExecution (UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun ())

plutus-ledger-api/src/PlutusLedgerApi/V1.hs

@@ -5,7 +5,7 @@ module PlutusLedgerApi.V1 (
       SerialisedScript
     , serialiseCompiledCode
     , serialiseUPLC
-    , deserialiseUPLC
+    , uncheckedDeserialiseUPLC
     -- * Validating scripts
     , assertScriptWellFormed
     -- * Running scripts

plutus-ledger-api/src/PlutusLedgerApi/V2.hs

@@ -5,7 +5,7 @@ module PlutusLedgerApi.V2 (
       SerialisedScript
     , serialiseCompiledCode
     , serialiseUPLC
-    , deserialiseUPLC
+    , uncheckedDeserialiseUPLC
     -- * Validating scripts
     , assertScriptWellFormed
     -- * Running scripts

plutus-ledger-api/src/PlutusLedgerApi/V3.hs

@@ -6,7 +6,7 @@ module PlutusLedgerApi.V3 (
       SerialisedScript
     , serialiseCompiledCode
     , serialiseUPLC
-    , deserialiseUPLC
+    , uncheckedDeserialiseUPLC
     -- * Validating scripts
     , assertScriptWellFormed
     -- * Running scripts

plutus-ledger-api/testlib/PlutusLedgerApi/Test/Examples.hs

@@ -45,7 +45,7 @@ summingFunction = serialiseUPLC $ UPLC.Program () PLC.plcVersion100 body
 saltFunction :: Integer -> SerialisedScript -> SerialisedScript
 saltFunction salt b0 = serialiseUPLC $ UPLC.Program () version body
     where
-        UPLC.Program () version b1 = deserialiseUPLC b0
+        UPLC.Program () version b1 = uncheckedDeserialiseUPLC b0
 
         body = UPLC.Apply ()
             (UPLC.LamAbs () (UPLC.DeBruijn 0) b1)

plutus-tx-plugin/src/PlutusTx/Plugin.hs

@@ -344,7 +344,7 @@ compileMarkedExpr locStr codeTy origE = do
 
     -- serialize the PIR, PLC, and coverageindex outputs into a bytestring.
     bsPir <- makeByteStringLiteral $ flat pirP
-    bsPlc <- makeByteStringLiteral $ flat uplcP
+    bsPlc <- makeByteStringLiteral $ flat (UPLC.UnrestrictedProgram uplcP)
     covIdxFlat <- makeByteStringLiteral $ flat covIdx
 
     builder <- lift . lift . GHC.lookupId =<< thNameToGhcNameOrFail 'mkCompiledCode
@@ -434,7 +434,7 @@ runCompiler moduleName opts expr = do
     dbT <- liftExcept $ UPLC.deBruijnTerm uplcT
     let uplcPNoAnn = UPLC.Program () PLC.latestVersion $ void dbT
         uplcP = UPLC.Program mempty PLC.latestVersion . fmap getSrcSpans $ dbT
-    when (_posDumpUPlc opts) . liftIO $ dumpFlat uplcPNoAnn "untyped PLC program" (moduleName ++ ".uplc.flat")
+    when (_posDumpUPlc opts) . liftIO $ dumpFlat (UPLC.UnrestrictedProgram uplcPNoAnn) "untyped PLC program" (moduleName ++ ".uplc.flat")
     pure (spirP, uplcP)
 
   where

plutus-tx/src/PlutusTx/Code.hs

@@ -106,8 +106,8 @@ getPlc
     => CompiledCodeIn uni fun a -> UPLC.Program UPLC.NamedDeBruijn uni fun SrcSpans
 getPlc wrapper = case wrapper of
     SerializedCode plc _ _ -> case unflat (BSL.fromStrict plc) of
-        Left e  -> throw $ ImpossibleDeserialisationFailure e
-        Right p -> p
+        Left e                             -> throw $ ImpossibleDeserialisationFailure e
+        Right (UPLC.UnrestrictedProgram p) -> p
     DeserializedCode plc _ _ -> plc
 
 getPlcNoAnn