Refactored Serialise/Flat-Via. Fixes #6083 (#6144)

Co-authored-by: Nikolaos Bezirgiannis <bezirg@users.noreply.github.com>

plutus-core/changelog.d/20240528_112406_bezirg.md

@@ -0,0 +1,4 @@
+### Changed
+
+- Renamed decodeViaFlat to decodeViaFlatWith
+- Renamed AsSerialize to FlatViaSerialise

plutus-core/executables/plutus/AnyProgram/IO.hs

@@ -17,7 +17,7 @@ import PlutusCore.Pretty qualified as PP
 import PlutusPrelude hiding ((%~))
 import Types
 
-import Codec.CBOR.Extras
+import Codec.Extras.SerialiseViaFlat
 import Codec.Serialise (deserialiseOrFail, serialise)
 import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as BSL

plutus-core/plutus-core.cabal

@@ -82,7 +82,8 @@ common lang
 library
   import:             lang
   exposed-modules:
-    Codec.CBOR.Extras
+    Codec.Extras.FlatViaSerialise
+    Codec.Extras.SerialiseViaFlat
     Data.Aeson.THReader
     Data.Either.Extras
     Data.List.Extras

plutus-core/plutus-core/src/Codec/Extras/FlatViaSerialise.hs

@@ -0,0 +1,40 @@
+module Codec.Extras.FlatViaSerialise
+    ( FlatViaSerialise (..)
+    ) where
+
+import Codec.Serialise (Serialise, deserialiseOrFail, serialise)
+import Data.ByteString.Lazy qualified as BSL (toStrict)
+import Flat
+
+{- Note [Flat serialisation for strict and lazy bytestrings]
+The `flat` serialisation of a bytestring consists of a sequence of chunks, with each chunk preceded
+by a single byte saying how long it is.  The end of a serialised bytestring is marked by a
+zero-length chunk.  In the Plutus Core specification we recommend that all bytestrings should be
+serialised in a canonical way as a sequence of zero or more 255-byte chunks followed by an optional
+final chunk of length less than 255 followed by a zero-length chunk (ie, a 0x00 byte). We do allow
+the decoder to accept non-canonical encodings.  The `flat` library always encodes strict Haskell
+bytestrings in this way, but lazy bytestrings, which are essentially lists of strict bytestrings,
+may be encoded non-canonically since it's more efficient just to emit a short chunk as is.  The
+Plutus Core `bytestring` type is strict so bytestring values are always encoded canonically.
+However, we serialise `Data` objects (and perhaps objects of other types as well) by encoding them
+to CBOR and then flat-serialising the resulting bytestring; but the `serialise` method from
+`Codec.Serialise` produces lazy bytestrings and if we were to serialise them directly then we could
+end up with non-canonical encodings, which would mean that identical `Data` objects might be
+serialised into different bytestrings.  To avoid this we convert the output of `serialise` into a
+strict bytestring before flat-encoding it.  This may lead to a small loss of efficiency during
+encoding, but this doesn't matter because we only ever do flat serialisation off the chain.  We can
+convert `Data` objects to bytestrings on the chain using the `serialiseData` builtin, but this
+performs CBOR serialisation and the result is always in a canonical form. -}
+
+-- | For deriving 'Flat' instances via 'Serialize'.
+newtype FlatViaSerialise a = FlatViaSerialise { unFlatViaSerialise :: a }
+
+instance Serialise a => Flat (FlatViaSerialise a) where
+    -- See Note [Flat serialisation for strict and lazy bytestrings]
+    encode = encode . BSL.toStrict . serialise . unFlatViaSerialise
+    decode = do
+        errOrX <- deserialiseOrFail <$> decode
+        case errOrX of
+            Left err -> fail $ show err  -- Here we embed a 'Serialise' error into a 'Flat' one.
+            Right x  -> pure $ FlatViaSerialise x
+    size = size . BSL.toStrict . serialise . unFlatViaSerialise

plutus-core/plutus-core/src/Codec/CBOR/Extras.hs → plutus-core/plutus-core/src/Codec/Extras/SerialiseViaFlat.hs

@@ -1,13 +1,12 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
-
-module Codec.CBOR.Extras (
-  SerialiseViaFlat (..),
-  decodeViaFlat,
-  DeserialiseFailureInfo (..),
-  DeserialiseFailureReason (..),
-  readDeserialiseFailureInfo,
-) where
+module Codec.Extras.SerialiseViaFlat
+    ( SerialiseViaFlat (..)
+    , decodeViaFlatWith
+    , DeserialiseFailureInfo (..)
+    , DeserialiseFailureReason (..)
+    , readDeserialiseFailureInfo
+    ) where
 
 import Codec.CBOR.Decoding qualified as CBOR
 import Codec.CBOR.Read qualified as CBOR
@@ -20,14 +19,14 @@ import Prettyprinter (Pretty (pretty), (<+>))
 {- | Newtype to provide 'Serialise' instances for types with a 'Flat' instance
   that just encodes the flat-serialized value as a CBOR bytestring
 -}
-newtype SerialiseViaFlat a = SerialiseViaFlat a
+newtype SerialiseViaFlat a = SerialiseViaFlat { unSerialiseViaFlat :: a }
 
 instance (Flat.Flat a) => Serialise (SerialiseViaFlat a) where
-  encode (SerialiseViaFlat a) = encode $ Flat.flat a
-  decode = SerialiseViaFlat <$> decodeViaFlat Flat.decode
+  encode = encode . Flat.flat . unSerialiseViaFlat
+  decode = SerialiseViaFlat <$> decodeViaFlatWith Flat.decode
 
-decodeViaFlat :: Flat.Get a -> CBOR.Decoder s a
-decodeViaFlat decoder = do
+decodeViaFlatWith :: Flat.Get a -> CBOR.Decoder s a
+decodeViaFlatWith decoder = do
   bs <- CBOR.decodeBytes
   -- lift any flat's failures to be cborg failures (MonadFail)
   fromRightM (fail . show) $ Flat.unflatWith decoder bs
@@ -45,16 +44,16 @@ readDeserialiseFailureInfo (CBOR.DeserialiseFailure byteOffset reason) =
   DeserialiseFailureInfo byteOffset $ interpretReason reason
  where
   -- Note that this is subject to change if `cborg` dependency changes.
-  -- Currently: cborg-0.2.9.0
+  -- Currently: cborg-0.2.10.0
   interpretReason :: String -> DeserialiseFailureReason
   interpretReason = \case
     -- Relevant Sources:
-    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.9.0/cborg/src/Codec/CBOR/Read.hs#L226>
-    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.9.0/cborg/src/Codec/CBOR/Read.hs#L1424>
-    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.9.0/cborg/src/Codec/CBOR/Read.hs#L1441>
+    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.10.0/cborg/src/Codec/CBOR/Read.hs#L226>
+    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.10.0/cborg/src/Codec/CBOR/Read.hs#L1424>
+    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.10.0/cborg/src/Codec/CBOR/Read.hs#L1441>
     "end of input" -> EndOfInput
     -- Relevant Sources:
-    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.9.0/cborg/src/Codec/CBOR/Read.hs#L1051>
+    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.10.0/cborg/src/Codec/CBOR/Read.hs#L1051>
     "expected bytes" -> ExpectedBytes
     msg -> OtherReason msg
 
@@ -80,8 +79,8 @@ data DeserialiseFailureReason
     EndOfInput
   | -- | The bytes inside the input are malformed.
     ExpectedBytes
-  | -- | A failure reason we (plutus) are not aware of, use whatever
-    -- message that `cborg` returns.
+  | -- | This is either a cbor failure that we (plutus) are not aware of,
+    -- or an underlying flat failure. We use whatever message `cborg` or flat returns.
     OtherReason String
   deriving stock (Eq, Show)
 

plutus-core/plutus-core/src/PlutusCore/Flat.hs

@@ -12,17 +12,15 @@
 -- encoding of TPLC] and Note [Stable encoding of UPLC] before touching anything
 -- in this file.
 module PlutusCore.Flat
-    ( AsSerialize (..)
-    , safeEncodeBits
+    ( safeEncodeBits
     ) where
 
+import Codec.Extras.FlatViaSerialise
 import PlutusCore.Core
 import PlutusCore.Data (Data)
 import PlutusCore.DeBruijn
 import PlutusCore.Name.Unique
 
-import Codec.Serialise (Serialise, deserialiseOrFail, serialise)
-import Data.ByteString.Lazy qualified as BSL (toStrict)
 import Data.Proxy
 import Flat
 import Flat.Decoder
@@ -105,41 +103,6 @@ This phase-1 validation is in place both for normal (locked scripts) and for inl
 so the nodes' behavior does not change.
 -}
 
-{- Note [Flat serialisation for strict and lazy bytestrings]
-The `flat` serialisation of a bytestring consists of a sequence of chunks, with each chunk preceded
-by a single byte saying how long it is.  The end of a serialised bytestring is marked by a
-zero-length chunk.  In the Plutus Core specification we recommend that all bytestrings should be
-serialised in a canonical way as a sequence of zero or more 255-byte chunks followed by an optional
-final chunk of length less than 255 followed by a zero-length chunk (ie, a 0x00 byte). We do allow
-the decoder to accept non-canonical encodings.  The `flat` library always encodes strict Haskell
-bytestrings in this way, but lazy bytestrings, which are essentially lists of strict bytestrings,
-may be encoded non-canonically since it's more efficient just to emit a short chunk as is.  The
-Plutus Core `bytestring` type is strict so bytestring values are always encoded canonically.
-However, we serialise `Data` objects (and perhaps objects of other types as well) by encoding them
-to CBOR and then flat-serialising the resulting bytestring; but the `serialise` method from
-`Codec.Serialise` produces lazy bytestrings and if we were to serialise them directly then we could
-end up with non-canonical encodings, which would mean that identical `Data` objects might be
-serialised into different bytestrings.  To avoid this we convert the output of `serialise` into a
-strict bytestring before flat-encoding it.  This may lead to a small loss of efficiency during
-encoding, but this doesn't matter because we only ever do flat serialisation off the chain.  We can
-convert `Data` objects to bytestrings on the chain using the `serialiseData` builtin, but this
-performs CBOR serialisation and the result is always in a canonical form. -}
-
--- | For deriving 'Flat' instances via 'Serialize'.
-newtype AsSerialize a = AsSerialize
-    { unAsSerialize :: a
-    } deriving newtype (Serialise)
-
-instance Serialise a => Flat (AsSerialize a) where
-    -- See Note [Flat serialisation for strict and lazy bytestrings]
-    encode = encode . BSL.toStrict . serialise
-    decode = do
-        errOrX <- deserialiseOrFail <$> decode
-        case errOrX of
-            Left err -> fail $ show err  -- Here we embed a 'Serialise' error into a 'Flat' one.
-            Right x  -> pure x
-    size = size . BSL.toStrict . serialise
-
 safeEncodeBits :: NumBits -> Word8 -> Encoding
 safeEncodeBits maxBits v =
   if 2 ^ maxBits <= v
@@ -156,7 +119,7 @@ encodeConstant = safeEncodeBits constantWidth
 decodeConstant :: Get Word8
 decodeConstant = dBEBits8 constantWidth
 
-deriving via AsSerialize Data instance Flat Data
+deriving via FlatViaSerialise Data instance Flat Data
 
 decodeKindedUniFlat :: Closed uni => Get (SomeTypeIn (Kinded uni))
 decodeKindedUniFlat =

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

@@ -23,6 +23,7 @@ import Data.Vector qualified as V
 import Flat
 import Flat.Decoder
 import Flat.Encoder
+import Flat.Encoder.Strict (sizeListWith)
 import Universe
 
 {-
@@ -91,17 +92,6 @@ encoding of bytestrings is a sequence of 255-byte chunks. This is okay, since us
 be broken up by the chunk metadata.
 -}
 
--- TODO: This is present upstream in newer versions of flat, remove once we get there.
--- | Compute the size needed for a list using the given size function for the elements.
--- Goes with 'encodeListWith'.
-sizeListWith :: (a -> NumBits -> NumBits) -> [a] -> NumBits -> NumBits
-sizeListWith sizer = go
-  where
-    -- Single bit to say stop
-    go [] sz     = sz + 1
-    -- Size for the rest plus size for the element, plus one for a tag to say keep going
-    go (x:xs) sz = go xs $ sizer x $ sz + 1
-
 -- | Using 4 bits to encode term tags.
 termTagWidth :: NumBits
 termTagWidth = 4

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

@@ -32,8 +32,8 @@ import UntypedPlutusCore qualified as UPLC
 import PlutusCore.DeBruijn.Internal (FakeNamedDeBruijn (FakeNamedDeBruijn))
 
 import Codec.CBOR.Decoding qualified as CBOR
-import Codec.CBOR.Extras as CBOR.Extras
 import Codec.CBOR.Read qualified as CBOR
+import Codec.Extras.SerialiseViaFlat as CBOR.Extras
 import Codec.Serialise
 import Control.Arrow ((>>>))
 import Control.DeepSeq (NFData)
@@ -159,9 +159,8 @@ serialiseUPLC =
 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 (UPLC.UnrestrictedProgram a)) = a
+uncheckedDeserialiseUPLC =
+    UPLC.unUnrestrictedProgram . unSerialiseViaFlat . deserialise . BSL.fromStrict . fromShort
 
 -- | A script with named de-bruijn indices.
 newtype ScriptNamedDeBruijn
@@ -212,7 +211,7 @@ scriptCBORDecoder ll pv =
    in do
         -- Deserialise using 'FakeNamedDeBruijn' to get the fake names added
         (p :: UPLC.Program UPLC.FakeNamedDeBruijn DefaultUni DefaultFun ()) <-
-          decodeViaFlat flatDecoder
+          decodeViaFlatWith flatDecoder
         pure $ coerce p
 
 {- | The deserialization from a serialised script into a `ScriptForEvaluation`,

plutus-ledger-api/test/Spec/CBOR/DeserialiseFailureInfo.hs

@@ -4,8 +4,8 @@
 module Spec.CBOR.DeserialiseFailureInfo (tests) where
 
 import Codec.CBOR.Decoding qualified as CBOR
-import Codec.CBOR.Extras qualified as CBOR
 import Codec.CBOR.Read qualified as CBOR
+import Codec.Extras.SerialiseViaFlat qualified as CBOR
 
 import Data.Bifunctor
 import Data.ByteString.Lazy qualified as LBS

plutus-ledger-api/test/Spec/ScriptDecodeError.hs

@@ -2,7 +2,7 @@
 
 module Spec.ScriptDecodeError where
 
-import Codec.CBOR.Extras (DeserialiseFailureInfo (..), DeserialiseFailureReason (..))
+import Codec.Extras.SerialiseViaFlat (DeserialiseFailureInfo (..), DeserialiseFailureReason (..))
 import PlutusCore.Version (plcVersion100)
 import PlutusLedgerApi.Common (ScriptDecodeError (..))
 import PlutusLedgerApi.Common.Versions (PlutusLedgerLanguage (..), conwayPV, vasilPV)