Different serializations for Value

The Value type is used in both TxOuts and in the Mint field of the
transaction body, but negative values are only allowed in the latter.
The rules already enforce this, but now the serialization does too.

Resolves: CAD-1667 and CAD-2148

shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs

@@ -16,11 +16,11 @@ shadowing warnings for the named field puns when used with a pattern synonym.
 module Cardano.Ledger.Mary.Translation where
 
 import Cardano.Ledger.Allegra (AllegraEra)
-import Cardano.Ledger.Compactible
+import Cardano.Ledger.Compactible (Compactible (..))
 import Cardano.Ledger.Crypto (Crypto)
 import Cardano.Ledger.Era hiding (Crypto)
 import Cardano.Ledger.Mary (MaryEra)
-import Cardano.Ledger.Mary.Value
+import Cardano.Ledger.Mary.Value (Value (..))
 import Cardano.Ledger.ShelleyMA.Metadata (Metadata (..), pattern Metadata)
 import Cardano.Ledger.ShelleyMA.Scripts (Timelock)
 import Cardano.Ledger.ShelleyMA.TxBody
@@ -362,4 +362,7 @@ translateValue :: Era era => Coin -> Value era
 translateValue = Val.inject
 
 translateCompactValue :: Era era => CompactForm Coin -> CompactForm (Value era)
-translateCompactValue = toCompact . translateValue . fromCompact
+translateCompactValue = assume . toCompact . translateValue . fromCompact
+  where
+    assume Nothing = error "impossible error: compact coin is out of range"
+    assume (Just x) = x

shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs

@@ -5,6 +5,8 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -19,18 +21,18 @@ module Cardano.Ledger.Mary.Value
   )
 where
 
-import Cardano.Binary
-  ( FromCBOR,
-    ToCBOR,
-    encodeListLen,
-    fromCBOR,
-    toCBOR,
-  )
+import Cardano.Binary (Decoder, Encoding, FromCBOR, ToCBOR, TokenType (..), decodeInt64, decodeWord64, fromCBOR, peekTokenType, toCBOR)
+import qualified Cardano.Crypto.Hash.Class as Hash
 import Cardano.Ledger.Compactible (Compactible (..))
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Era
 import Cardano.Ledger.Torsor (Torsor (..))
-import Cardano.Ledger.Val (Val (..))
+import Cardano.Ledger.Val
+  ( DecodeMint (..),
+    DecodeNonNegative (..),
+    EncodeMint (..),
+    Val (..),
+  )
 import Control.DeepSeq (NFData (..))
 import Control.Monad (guard)
 import Data.Array (Array)
@@ -41,6 +43,14 @@ import Data.CannonicalMaps
     cannonicalMapUnion,
     pointWise,
   )
+import Data.Coders
+  ( Decode (..),
+    Encode (..),
+    decode,
+    encode,
+    (!>),
+    (<!),
+  )
 import Data.Group (Abelian, Group (..))
 import Data.Map.Internal
   ( Map (..),
@@ -58,8 +68,8 @@ import Data.Word (Word64)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks (..))
 import Shelley.Spec.Ledger.Coin (Coin (..), integerToWord64)
-import Shelley.Spec.Ledger.Scripts (ScriptHash)
-import Shelley.Spec.Ledger.Serialization (decodeRecordNamed)
+import Shelley.Spec.Ledger.Scripts (ScriptHash (..))
+import Shelley.Spec.Ledger.Serialization (decodeMap, encodeMap)
 import Prelude hiding (lookup)
 
 -- | Asset Name
@@ -147,24 +157,106 @@ instance Era era => Val (Value era) where
 -- TODO Probably the actual serialization will be of the formal Coin OR Value type
 -- Maybe better to make this distinction in the TxOut de/serialization
 
+decodeInteger :: Decoder s Integer
+decodeInteger = fromIntegral <$> decodeInt64
+
+decodeValue ::
+  ( Typeable (Core.Script era),
+    Era era
+  ) =>
+  Decoder s (Value era)
+decodeValue = do
+  tt <- peekTokenType
+  case tt of
+    TypeUInt -> inject . Coin <$> decodeInteger
+    TypeNInt -> inject . Coin <$> decodeInteger
+    TypeListLen -> decodeValuePair decodeInteger
+    TypeListLen64 -> decodeValuePair decodeInteger
+    TypeListLenIndef -> decodeValuePair decodeInteger
+    _ -> fail $ "Value: expected array or int"
+
+decodeValuePair ::
+  ( Typeable (Core.Script era),
+    Era era
+  ) =>
+  (forall t. Decoder t Integer) ->
+  Decoder s (Value era)
+decodeValuePair decodeAmount =
+  decode $
+    RecD Value
+      <! D decodeAmount
+      <! D (decodeMultiAssetMaps decodeAmount)
+
+encodeMultiAssetMaps ::
+  ( Typeable (Core.Script era),
+    Era era
+  ) =>
+  Map (PolicyID era) (Map AssetName Integer) ->
+  Encoding
+encodeMultiAssetMaps = encodeMap toCBOR (encodeMap toCBOR toCBOR)
+
+decodeMultiAssetMaps ::
+  ( Typeable (Core.Script era),
+    Era era
+  ) =>
+  Decoder s Integer ->
+  Decoder s (Map (PolicyID era) (Map AssetName Integer))
+decodeMultiAssetMaps decodeAmount =
+  prune <$> decodeMap fromCBOR (decodeMap fromCBOR decodeAmount)
+
+decodeNonNegativeInteger :: Decoder s Integer
+decodeNonNegativeInteger = fromIntegral <$> decodeWord64
+
+decodeNonNegativeValue ::
+  ( Typeable (Core.Script era),
+    Era era
+  ) =>
+  Decoder s (Value era)
+decodeNonNegativeValue = do
+  tt <- peekTokenType
+  case tt of
+    TypeUInt -> inject . Coin <$> decodeNonNegativeInteger
+    TypeListLen -> decodeValuePair decodeNonNegativeInteger
+    TypeListLen64 -> decodeValuePair decodeNonNegativeInteger
+    TypeListLenIndef -> decodeValuePair decodeNonNegativeInteger
+    _ -> fail $ "Value: expected array or int"
+
 instance
   (Era era, Typeable (Core.Script era)) =>
   ToCBOR (Value era)
   where
   toCBOR (Value c v) =
-    encodeListLen 2
-      <> toCBOR c
-      <> toCBOR v
+    if Map.null v
+      then toCBOR c
+      else
+        encode $
+          Rec Value
+            !> To c
+            !> E encodeMultiAssetMaps v
 
 instance
   (Era era, Typeable (Core.Script era)) =>
   FromCBOR (Value era)
   where
-  fromCBOR = do
-    decodeRecordNamed "Value" (const 2) $ do
-      c <- fromCBOR
-      v <- fromCBOR
-      pure $ Value c v
+  fromCBOR = decodeValue
+
+instance
+  (Era era, Typeable (Core.Script era)) =>
+  DecodeNonNegative (Value era)
+  where
+  decodeNonNegative = decodeNonNegativeValue
+
+instance
+  (Era era, Typeable (Core.Script era)) =>
+  DecodeMint (Value era)
+  where
+  decodeMint = Value 0 <$> decodeMultiAssetMaps decodeInteger
+
+instance
+  (Era era, Typeable (Core.Script era)) =>
+  EncodeMint (Value era)
+  where
+  encodeMint (Value _ multiasset) = encodeMultiAssetMaps multiasset
 
 -- ========================================================================
 -- Compactible
@@ -173,14 +265,20 @@ instance
 instance Era era => Compactible (Value era) where
   newtype CompactForm (Value era) = CompactValue (CV era)
     deriving (ToCBOR, FromCBOR)
-  toCompact = CompactValue . toCV
+  toCompact x = CompactValue <$> toCV x
   fromCompact (CompactValue x) = fromCV x
 
 instance (Typeable (Core.Script era), Era era) => ToCBOR (CV era) where
   toCBOR = toCBOR . fromCV
 
 instance (Typeable (Core.Script era), Era era) => FromCBOR (CV era) where
-  fromCBOR = toCV <$> fromCBOR
+  fromCBOR = do
+    v <- decodeNonNegativeValue
+    case toCV v of
+      Nothing ->
+        fail
+          "impossible failure: decoded nonnegative value that cannot be compacted"
+      Just x -> pure x
 
 data CV era
   = CV
@@ -193,24 +291,23 @@ data CVPart era
       {-# UNPACK #-} !AssetName
       {-# UNPACK #-} !Word64
 
-toCV :: Value era -> CV era
-toCV v =
+toCV :: Value era -> Maybe (CV era)
+toCV v = do
   let (c, triples) = gettriples v
       policyIDs = Set.fromList $ (\(x, _, _) -> x) <$> triples
       n = length triples - 1
-      arr = array (0, n) (zip [0 .. n] (toCVPart policyIDs <$> triples))
-   in CV (convert c) arr
+  cvParts <- traverse (toCVPart policyIDs) triples
+  let arr = array (0, n) (zip [0 .. n] cvParts)
+  c' <- integerToWord64 c
+  pure $ CV c' arr
   where
     deduplicate xs x = fromMaybe x $ do
       r <- Set.lookupLE x xs
       guard (x == r)
       pure r
     toCVPart policyIdSet (policyId, aname, amount) =
-      CVPart (deduplicate policyIdSet policyId) aname (convert amount)
-    convert x =
-      fromMaybe
-        (error $ "out of bounds : " ++ show x)
-        (integerToWord64 x)
+      CVPart (deduplicate policyIdSet policyId) aname
+        <$> integerToWord64 amount
 
 fromCV :: Era era => CV era -> Value era
 fromCV (CV w vs) = foldr f (inject . Coin . fromIntegral $ w) vs
@@ -287,6 +384,13 @@ insert combine pid aid new (Value cn m1) =
 
 -- ========================================================
 
+-- | Remove 0 assets from a map
+prune ::
+  Map (PolicyID era) (Map AssetName Integer) ->
+  Map (PolicyID era) (Map AssetName Integer)
+prune assets =
+  Map.filter (not . null) $ Map.filter (/= 0) <$> assets
+
 -- | Display a Value as a String, one token per line
 showValue :: Value era -> String
 showValue v = show c ++ "\n" ++ unlines (map trans ts)

shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs

@@ -22,7 +22,7 @@ import Cardano.Ledger.ShelleyMA.Rules.Utxo ()
 import Cardano.Ledger.ShelleyMA.Scripts ()
 import Cardano.Ledger.ShelleyMA.TxBody ()
 import Cardano.Ledger.Torsor (Torsor (..))
-import Cardano.Ledger.Val (Val)
+import Cardano.Ledger.Val (DecodeMint, DecodeNonNegative, Val)
 import Control.State.Transition.Extended
 import Data.Foldable (Foldable (toList))
 import qualified Data.Map.Strict as Map
@@ -120,6 +120,8 @@ instance
     Typeable ma,
     STS (UTXO (ShelleyMAEra ma c)),
     BaseM (UTXO (ShelleyMAEra ma c)) ~ ShelleyBase,
+    DecodeMint (Core.Value (ShelleyMAEra ma c)),
+    DecodeNonNegative (Core.Value (ShelleyMAEra ma c)),
     Compactible (Core.Value (ShelleyMAEra ma c)),
     Val (Core.Value (ShelleyMAEra ma c)),
     GetPolicies (Core.Value (ShelleyMAEra ma c)) (ShelleyMAEra ma c),

shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs

@@ -42,7 +42,12 @@ import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Era (Era)
 import Cardano.Ledger.ShelleyMA (MaryOrAllegra, ShelleyMAEra)
 import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..))
-import Cardano.Ledger.Val (Val (..))
+import Cardano.Ledger.Val
+  ( DecodeMint (..),
+    DecodeNonNegative,
+    EncodeMint (..),
+    Val (..),
+  )
 import Control.DeepSeq (NFData (..))
 import Data.Coders
   ( Decode (..),
@@ -88,6 +93,10 @@ type FamsFrom era =
     Typeable era,
     Typeable (Script era),
     Typeable (Core.Metadata era),
+    Show (Value era),
+    Compactible (Value era),
+    DecodeNonNegative (Value era),
+    DecodeMint (Value era),
     FromCBOR (CompactForm (Value era)), -- Arises because TxOut uses Compact form
     FromCBOR (Value era),
     FromCBOR (Annotator (Script era)) -- Arises becaause DCert memoizes its bytes
@@ -96,6 +105,8 @@ type FamsFrom era =
 type FamsTo era =
   ( Era era,
     ToCBOR (Value era),
+    Compactible (Value era),
+    EncodeMint (Value era),
     ToCBOR (CompactForm (Value era)), -- Arises because TxOut uses Compact form
     ToCBOR (Script era),
     Typeable (Core.Metadata era)
@@ -173,7 +184,7 @@ txSparse (TxBodyRaw inp out cert wdrl fee (ValidityInterval bot top) up hash frg
     !> encodeKeyedStrictMaybe 6 up
     !> encodeKeyedStrictMaybe 7 hash
     !> encodeKeyedStrictMaybe 8 bot
-    !> Omit isZero (Key 9 (To frge))
+    !> Omit isZero (Key 9 (E encodeMint frge))
 
 bodyFields :: FamsFrom era => Word -> Field (TxBodyRaw era)
 bodyFields 0 = field (\x tx -> tx {inputs = x}) (D (decodeSet fromCBOR))
@@ -185,7 +196,7 @@ bodyFields 5 = field (\x tx -> tx {wdrls = x}) From
 bodyFields 6 = field (\x tx -> tx {update = x}) (D (SJust <$> fromCBOR))
 bodyFields 7 = field (\x tx -> tx {mdHash = x}) (D (SJust <$> fromCBOR))
 bodyFields 8 = field (\x tx -> tx {vldt = (vldt tx) {validFrom = x}}) (D (SJust <$> fromCBOR))
-bodyFields 9 = field (\x tx -> tx {forge = x}) From
+bodyFields 9 = field (\x tx -> tx {forge = x}) (D decodeMint)
 bodyFields n = field (\_ t -> t) (Invalid n)
 
 initial :: (Val (Value era)) => TxBodyRaw era

shelley-ma/shelley-ma-test/cddl-files/shelley-ma.cddl

@@ -260,3 +260,17 @@ genesishash           = $hash28
 
 vrf_keyhash           = $hash32
 metadata_hash         = $hash32
+
+; allegra differences
+transaction_body_allegra =
+  { 0 : set<transaction_input>
+  , 1 : [* transaction_output_allegra]
+  , 2 : coin ; fee
+  , ? 3 : uint ; ttl
+  , ? 4 : [* certificate]
+  , ? 5 : withdrawals
+  , ? 6 : update
+  , ? 7 : metadata_hash
+  , ? 8 : uint ; validity interval start
+  }
+transaction_output_allegra = [address, amount : coin]

shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/CDDL.hs

@@ -25,9 +25,9 @@ cddlTests :: Int -> TestTree
 cddlTests n = withResource combinedCDDL (const (pure ())) $ \cddl ->
   testGroup "CDDL roundtrip tests" $
     [ cddlTest @(Core.Value A) n "coin",
-      -- cddlTest @(Core.Value M) n "value",
-      -- cddlTest' @(Core.TxBody M) n "transaction_body",
-      -- cddlTest' @(Core.TxBody A) n "transaction_body",
+      cddlTest @(Core.Value M) n "value",
+      cddlTest' @(Core.TxBody M) n "transaction_body",
+      cddlTest' @(Core.TxBody A) n "transaction_body_allegra",
       cddlTest' @(Core.Script M) n "native_script",
       cddlTest' @(Core.Script A) n "native_script",
       cddlTest' @(Core.Metadata M) n "transaction_metadata",