From 44bb3b2a9ae9857ab359966d2a37944c3c1fbff1 Mon Sep 17 00:00:00 2001 From: Alex Byaly Date: Tue, 10 Nov 2020 14:35:49 -0600 Subject: [PATCH] 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 --- .../src/Cardano/Ledger/Mary/Translation.hs | 10 +- .../impl/src/Cardano/Ledger/Mary/Value.hs | 163 +++++++++++++++--- .../Cardano/Ledger/ShelleyMA/Rules/Utxow.hs | 4 +- .../src/Cardano/Ledger/ShelleyMA/TxBody.hs | 17 +- .../cddl-files/shelley-ma.cddl | 14 ++ .../Test/Cardano/Ledger/ShelleyMA/TxBody.hs | 34 ++-- .../Ledger/Mary/Examples/MultiAssets.hs | 4 +- .../Ledger/ShelleyMA/Serialisation/CDDL.hs | 6 +- .../src/Cardano/Ledger/Compactible.hs | 19 +- .../src/Cardano/Ledger/Shelley.hs | 3 +- .../executable-spec/src/Cardano/Ledger/Val.hs | 36 ++++ .../src/Shelley/Spec/Ledger/Coin.hs | 7 +- .../src/Shelley/Spec/Ledger/Serialization.hs | 10 +- .../src/Shelley/Spec/Ledger/TxBody.hs | 24 +-- .../bench/BenchUTxOAggregate.hs | 3 +- .../Ledger/Serialisation/Tripping/CBOR.hs | 14 +- 16 files changed, 283 insertions(+), 85 deletions(-) diff --git a/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs b/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs index d4175ceb424..498b5041bc1 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/Mary/Translation.hs +++ b/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 @@ -29,6 +29,7 @@ import Control.Iterate.SetAlgebra (biMapFromList, lifo) import Data.Coerce (coerce) import Data.Foldable (Foldable (toList)) import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) import qualified Data.Set as Set import Data.Typeable (Typeable) import Shelley.Spec.Ledger.API hiding (TxBody) @@ -362,4 +363,7 @@ translateValue :: Era era => Coin -> Value era translateValue = Val.inject translateCompactValue :: Era era => CompactForm Coin -> CompactForm (Value era) -translateCompactValue = toCompact . translateValue . fromCompact +translateCompactValue = + fromMaybe (error msg) . toCompact . translateValue . fromCompact + where + msg = "impossible error: compact coin is out of range" diff --git a/shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs b/shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs index 73a349ba81e..62b59484337 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs +++ b/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 #-} @@ -20,17 +22,28 @@ module Cardano.Ledger.Mary.Value where import Cardano.Binary - ( FromCBOR, + ( Decoder, + Encoding, + FromCBOR, ToCBOR, - encodeListLen, + 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 +54,14 @@ import Data.CannonicalMaps cannonicalMapUnion, pointWise, ) +import Data.Coders + ( Decode (..), + Encode (..), + decode, + encode, + (!>), + ( 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 + + 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 +276,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 +302,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 +395,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) diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs index abc72c05c94..e63e41c7ac1 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs +++ b/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), diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs index fffeea2157e..07503ca4690 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs +++ b/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 diff --git a/shelley-ma/shelley-ma-test/cddl-files/shelley-ma.cddl b/shelley-ma/shelley-ma-test/cddl-files/shelley-ma.cddl index ef76c4ae6ad..aa07b325716 100644 --- a/shelley-ma/shelley-ma-test/cddl-files/shelley-ma.cddl +++ b/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 + , 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] diff --git a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/TxBody.hs b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/TxBody.hs index f8631e07011..6242e143c4d 100644 --- a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/TxBody.hs +++ b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/TxBody.hs @@ -19,17 +19,24 @@ module Test.Cardano.Ledger.ShelleyMA.TxBody ) where import Cardano.Binary(ToCBOR(..)) -import Cardano.Ledger.Core (Value) -import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..)) +import Cardano.Ledger.Mary.Value + ( AssetName (..), + PolicyID (..), + Value (..), + ) +import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..), Timelock (..)) import qualified Cardano.Ledger.ShelleyMA.TxBody as Mary import Cardano.Ledger.Val (Val (..)) import Cardano.Slotting.Slot (SlotNo (..)) +import Shelley.Spec.Ledger.Tx (hashScript) import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as Short import qualified Data.Map.Strict as Map import Data.MemoBytes (MemoBytes (Memo), roundTripMemo) import Data.Sequence.Strict (StrictSeq, fromList) import Data.Set (empty) +import Data.String (fromString) import GHC.Records import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (SJust, SNothing)) import Shelley.Spec.Ledger.Coin (Coin (..)) @@ -89,7 +96,13 @@ txM = (ValidityInterval (SJust (SlotNo 3)) (SJust (SlotNo 42))) SNothing SNothing - (inject (Coin 2)) + mint + +mint :: Value TestEra +mint = Value 0 (Map.singleton policyId (Map.singleton aname 2)) + where + policyId = PolicyID . hashScript . RequireAnyOf $ fromList [] + aname = AssetName $ fromString "asset name" bytes :: Mary.TxBody era -> ShortByteString bytes (Mary.TxBodyConstr (Memo _ b)) = b @@ -106,14 +119,15 @@ fieldTests = testCase "vldt" (assertEqual "vldt" (getField @"vldt" txM) (ValidityInterval (SJust (SlotNo 3)) (SJust (SlotNo 42)))), testCase "update" (assertEqual "update" (getField @"update" txM) SNothing), testCase "mdHash" (assertEqual "mdHash" (getField @"mdHash" txM) SNothing), - testCase "forge" (assertEqual "forge" (getField @"forge" txM) (inject (Coin 2))) + testCase "forge" (assertEqual "forge" (getField @"forge" txM) mint) ] -roundtrip :: Mary.TxBody TestEra -> Bool +roundtrip :: Mary.TxBody TestEra -> Assertion roundtrip (Mary.TxBodyConstr memo) = case roundTripMemo memo of - Right ("", new) -> new == memo - _other -> False + Right ("", new) -> new @?= memo + Right (extra, _new) -> error ("extra bytes: " <> show extra) + Left s -> error (show s) -- ===================================================================== -- Now some random property tests @@ -132,7 +146,7 @@ embedTest = do Right(left,_) -> error ("left over input: "++show left) Left s -> error (show s) -getTxSparse :: (Val (Value era),FamsFrom era) => Decode ('Closed 'Dense) (TxBodyRaw era) +getTxSparse :: (Val (Core.Value era),FamsFrom era) => Decode ('Closed 'Dense) (TxBodyRaw era) getTxSparse = SparseKeyed "TxBodyRaw" initial bodyFields [(0,"inputs"),(1,"outputs"),(2,"txfee")] oldStyleRoundTrip:: TxBodyRaw TestEra -> RoundTripResult (TxBodyRaw TestEra) @@ -166,8 +180,8 @@ txBodyTest = testGroup "TxBody" [ fieldTests - , testCase "length" (assertEqual "length" 16 (Short.length (bytes txM))) - , testCase "roundtrip txM" (assertBool "rountrip" (roundtrip txM)) + , testCase "length" (assertEqual "length" 36 (Short.length (bytes txM))) + , testCase "roundtrip txM" (roundtrip txM) , testProperty "roundtrip sparse TxBodyRaw" checkSparse , testProperty "embed Shelley sparse TxBodyRaw" embedTest , testProperty "routrip sparse TxBody" checkSparseAnn diff --git a/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/Mary/Examples/MultiAssets.hs b/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/Mary/Examples/MultiAssets.hs index 5504f120a2c..bbb00fbf953 100644 --- a/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/Mary/Examples/MultiAssets.hs +++ b/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/Mary/Examples/MultiAssets.hs @@ -49,7 +49,7 @@ import Test.Cardano.Ledger.EraBuffet (MaryTest) import Test.Cardano.Ledger.Mary.Examples (testMaryNoDelegLEDGER) import qualified Test.Cardano.Ledger.Mary.Examples.Cast as Cast import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=)) +import Test.Tasty.HUnit (Assertion, assertFailure, testCase) ------------------------------ -- Set Up the Initial State -- @@ -528,7 +528,7 @@ testNegEx2 :: Assertion testNegEx2 = do r <- try (evaluate $ txbodyNegEx2 == txbodyNegEx2) case r of - Left (ErrorCall e) -> e @?= "out of bounds : -1" + Left (ErrorCall _) -> pure () Right _ -> assertFailure $ "constructed negative TxOut Value" -- diff --git a/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/CDDL.hs b/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/CDDL.hs index fc7323dc28c..9e3d852c458 100644 --- a/shelley-ma/shelley-ma-test/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/CDDL.hs +++ b/shelley-ma/shelley-ma-test/test/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", diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Compactible.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Compactible.hs index efe30e7f687..6729f7f6e83 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Compactible.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Compactible.hs @@ -7,13 +7,10 @@ module Cardano.Ledger.Compactible ( -- * Compactible Compactible (..), - Compact (..), ) where -import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Data.Kind (Type) -import Data.Typeable (Typeable) -------------------------------------------------------------------------------- @@ -27,23 +24,9 @@ import Data.Typeable (Typeable) class Compactible a where data CompactForm a :: Type - toCompact :: a -> CompactForm a + toCompact :: a -> Maybe (CompactForm a) fromCompact :: CompactForm a -> a -newtype Compact a = Compact {unCompact :: a} - -instance - (Typeable a, Compactible a, ToCBOR (CompactForm a)) => - ToCBOR (Compact a) - where - toCBOR = toCBOR . toCompact . unCompact - -instance - (Typeable a, Compactible a, FromCBOR (CompactForm a)) => - FromCBOR (Compact a) - where - fromCBOR = Compact . fromCompact <$> fromCBOR - -- TODO: consider if this is better the other way around instance (Eq a, Compactible a) => Eq (CompactForm a) where a == b = fromCompact a == fromCompact b diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs index 4c0870c024e..0991437ceda 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs @@ -11,7 +11,7 @@ import Cardano.Ledger.Core import qualified Cardano.Ledger.Crypto as CryptoClass import Cardano.Ledger.Era import Cardano.Ledger.Torsor (Torsor (..)) -import Cardano.Ledger.Val (Val) +import Cardano.Ledger.Val (DecodeNonNegative, Val) import Shelley.Spec.Ledger.Coin (Coin) import Shelley.Spec.Ledger.Hashing (EraIndependentTxBody, HashAnnotated (..)) @@ -38,6 +38,7 @@ type ShelleyBased era = -- Value constraints Val (Value era), Compactible (Value era), + DecodeNonNegative (Value era), ChainData (Value era), SerialisableData (Value era), SerialisableData (CompactForm (Value era)), diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Val.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Val.hs index 160338c023b..14f039ea466 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Val.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Val.hs @@ -19,9 +19,14 @@ module Cardano.Ledger.Val invert, sumVal, scaledMinDeposit, + DecodeNonNegative (..), + DecodeMint (..), + EncodeMint (..), ) where +import Cardano.Binary (Decoder, Encoding, decodeWord64, toCBOR) +import Cardano.Ledger.Compactible (Compactible (..)) import Data.Group (Abelian) import Shelley.Spec.Ledger.Coin (Coin (..), DeltaCoin (..)) @@ -164,3 +169,34 @@ scaledMinDeposit v (Coin mv) -- parameter is implicit from the minAdaValue parameter adaPerUTxOByte :: Integer adaPerUTxOByte = quot mv (utxoEntrySizeWithoutVal + uint) + +-- ============================================================= + +class DecodeNonNegative v where + decodeNonNegative :: Decoder s v + +instance DecodeNonNegative Coin where + decodeNonNegative = Coin . fromIntegral <$> decodeWord64 + +instance (DecodeNonNegative a, Compactible a, Show a) => DecodeNonNegative (CompactForm a) where + decodeNonNegative = do + v <- decodeNonNegative + maybe (fail $ "illegal value: " <> show v) pure (toCompact v) + +-- ============================================================= + +class DecodeMint v where + decodeMint :: Decoder s v + +instance DecodeMint Coin where + decodeMint = fail "cannot have coin in mint field" + +-- ============================================================= + +class EncodeMint v where + encodeMint :: v -> Encoding + +instance EncodeMint Coin where + --we expect nothing to be able to successfully decode this + --this is an alternative to throwing an error at encoding + encodeMint = toCBOR diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Coin.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Coin.hs index f93976f6285..fe5532dfbd9 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Coin.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Coin.hs @@ -44,9 +44,8 @@ newtype Coin = Coin {unCoin :: Integer} NFData ) deriving (Show) via Quiet Coin - deriving (ToCBOR, FromCBOR) via Compact Coin deriving (Semigroup, Monoid, Group, Abelian) via Sum Integer - deriving newtype (PartialOrd) + deriving newtype (PartialOrd, FromCBOR, ToCBOR) newtype DeltaCoin = DeltaCoin Integer deriving (Eq, Ord, Generic, Enum, NoThunks, NFData, FromCBOR, ToCBOR) @@ -80,9 +79,7 @@ rationalToCoinViaFloor r = Coin . floor $ r -- with an erroring bounds check here. where should this really live? instance Compactible Coin where newtype CompactForm Coin = CompactCoin Word64 - toCompact (Coin c) = case integerToWord64 c of - Nothing -> error $ "out of bounds : " ++ show c - Just x -> CompactCoin x + toCompact (Coin c) = CompactCoin <$> integerToWord64 c fromCompact (CompactCoin c) = word64ToCoin c -- It's odd for this to live here. Where should it go? diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Serialization.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Serialization.hs index a971c1683d0..173a9059cda 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Serialization.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Serialization.hs @@ -27,6 +27,7 @@ module Shelley.Spec.Ledger.Serialization encodeFoldableEncoder, encodeFoldableMapEncoder, encodeNullMaybe, + encodeMap, groupRecord, ratioToCBOR, ratioFromCBOR, @@ -149,12 +150,15 @@ instance (FromCBORGroup a, ToCBORGroup a) => FromCBOR (CBORGroup a) where groupRecord :: forall a s. (ToCBORGroup a, FromCBORGroup a) => Decoder s a groupRecord = decodeRecordNamed "CBORGroup" (fromIntegral . toInteger . listLen) fromCBORGroup -mapToCBOR :: (ToCBOR a, ToCBOR b) => Map a b -> Encoding -mapToCBOR m = +encodeMap :: (a -> Encoding) -> (b -> Encoding) -> Map a b -> Encoding +encodeMap encodeKey encodeValue m = let l = fromIntegral $ Map.size m - contents = Map.foldMapWithKey (\k v -> toCBOR k <> toCBOR v) m + contents = Map.foldMapWithKey (\k v -> encodeKey k <> encodeValue v) m in wrapCBORMap l contents +mapToCBOR :: (ToCBOR a, ToCBOR b) => Map a b -> Encoding +mapToCBOR = encodeMap toCBOR toCBOR + mapFromCBOR :: (Ord a, FromCBOR a, FromCBOR b) => Decoder s (Map a b) mapFromCBOR = decodeMap fromCBOR fromCBOR diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs index 0dbc7dee2ca..fae7eb6dcbb 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/TxBody.hs @@ -84,7 +84,7 @@ import Cardano.Ledger.Compactible import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era import Cardano.Ledger.Shelley (ShelleyBased, ShelleyEra) -import Cardano.Ledger.Val (Val) +import Cardano.Ledger.Val (DecodeNonNegative (..), Val) import Cardano.Prelude ( decodeEitherBase16, panic, @@ -115,7 +115,7 @@ import Data.Foldable (asum) import Data.IP (IPv4, IPv6) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, fromMaybe) import Data.MemoBytes (Mem, MemoBytes (..), memoBytes) import Data.Ord (comparing) import Data.Proxy (Proxy (..)) @@ -483,7 +483,9 @@ pattern TxOut addr vl <- (viewCompactTxOut -> (addr, vl)) where TxOut addr vl = - TxOutCompact (compactAddr addr) (toCompact vl) + TxOutCompact + (compactAddr addr) + (fromMaybe (error $ "illegal value in txout: " <> show vl) $ toCompact vl) {-# COMPLETE TxOut #-} @@ -598,10 +600,11 @@ type ProperVal era = type ProperFrom era = ( Era era, Typeable era, - FromCBOR (Core.Value era), + DecodeNonNegative (Core.Value era), + Compactible (Core.Value era), + Show (Core.Value era), Typeable (Core.Script era), Typeable (Core.Metadata era), - FromCBOR (CompactForm (Core.Value era)), FromCBOR (Annotator (Core.Script era)), FromCBOR (Annotator (Core.Metadata era)) ) @@ -610,9 +613,10 @@ type ProperFrom era = type ProperTo era = ( Era era, ToCBOR (Core.Value era), - ToCBOR (Core.Script era), + Compactible (Core.Value era), + ToCBOR (CompactForm (Core.Value era)), ToCBOR (Core.Metadata era), - ToCBOR (CompactForm (Core.Value era)) + ToCBOR (Core.Script era) ) -- ============================== @@ -973,7 +977,7 @@ instance instance-- use the weakest constraint necessary - (Era era, ToCBOR (Core.Value era), ToCBOR (CompactForm (Core.Value era))) => + (Era era, ToCBOR (CompactForm (Core.Value era)), Compactible (Core.Value era)) => ToCBOR (TxOut era) where toCBOR (TxOutCompact addr coin) = @@ -983,12 +987,12 @@ instance-- use the weakest constraint necessary instance-- use the weakest constraint necessary - (Era era, FromCBOR (Core.Value era), FromCBOR (CompactForm (Core.Value era))) => + (Era era, DecodeNonNegative (CompactForm (Core.Value era)), Compactible (Core.Value era)) => FromCBOR (TxOut era) where fromCBOR = decodeRecordNamed "TxOut" (const 2) $ do cAddr <- fromCBOR - coin <- fromCBOR + coin <- decodeNonNegative pure $ TxOutCompact cAddr coin instance diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchUTxOAggregate.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchUTxOAggregate.hs index 6fca06bc282..19575c86ea9 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchUTxOAggregate.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchUTxOAggregate.hs @@ -13,6 +13,7 @@ import Control.Iterate.SetAlgebra (compile, compute, run) import Control.SetAlgebra (Bimap, biMapFromList, dom, (▷), (◁)) import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (fromJust) import qualified Data.Sequence as Seq import Shelley.Spec.Ledger.Address ( Addr (..), @@ -60,7 +61,7 @@ genTestCase numUTxO numAddr = do pure $ TxOutCompact (compactAddr addr) - (toCompact $ Val.inject (Coin $ fromIntegral i)) + (fromJust $ toCompact $ Val.inject (Coin $ fromIntegral i)) let mktxid i = TxId $ mkDummyHash i let mktxin i = TxIn (mktxid i) (fromIntegral i) let utxo = Map.fromList $ zip (mktxin <$> [1 ..]) txOuts diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Tripping/CBOR.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Tripping/CBOR.hs index d9b6ca43e9d..04ad09f00ae 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Tripping/CBOR.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Tripping/CBOR.hs @@ -40,13 +40,16 @@ import Cardano.Binary ToCBOR (..), toCBOR, ) +import Cardano.Ledger.Compactible (Compactible (..)) import Codec.CBOR.Decoding (Decoder) import Codec.CBOR.Encoding (Encoding) import Codec.CBOR.Read (deserialiseFromBytes) import Codec.CBOR.Write (toLazyByteString) import qualified Data.ByteString.Lazy as Lazy +import Data.Maybe (fromJust) import qualified Shelley.Spec.Ledger.API as Ledger import Shelley.Spec.Ledger.Genesis (ShelleyGenesis) +import Shelley.Spec.Ledger.Coin (Coin (..)) import qualified Shelley.Spec.Ledger.STS.Ledgers as STS import qualified Shelley.Spec.Ledger.STS.Prtcl as STS (PrtclState) import qualified Test.Shelley.Spec.Ledger.ConcreteCryptoTypes as Mock @@ -147,6 +150,13 @@ prop_roundtrip_metadata = roundtrip' toCBOR ((. Full) . runAnnotator <$> fromCBO prop_roundtrip_ShelleyGenesis :: ShelleyGenesis Mock.C -> Property prop_roundtrip_ShelleyGenesis = roundtrip toCBOR fromCBOR +prop_roundtrip_Coin_1 :: Coin -> Property +prop_roundtrip_Coin_1 = roundtrip (toCBOR . fromJust . toCompact) fromCBOR + +prop_roundtrip_Coin_2 :: Coin -> Property +prop_roundtrip_Coin_2 = roundtrip toCBOR (fromCompact <$> fromCBOR) + + -- TODO -- roundTripIpv4 :: Property @@ -187,5 +197,7 @@ tests = testProperty "roundtrip NewEpoch State" prop_roundtrip_NewEpochState, testProperty "roundtrip MultiSig" prop_roundtrip_MultiSig, testProperty "roundtrip MetaData" prop_roundtrip_metadata, - testProperty "roundtrip Shelley Genesis" prop_roundtrip_ShelleyGenesis + testProperty "roundtrip Shelley Genesis" prop_roundtrip_ShelleyGenesis, + testProperty "roundtrip coin compactcoin cbor" prop_roundtrip_Coin_1, + testProperty "roundtrip coin cbor compactcoin" prop_roundtrip_Coin_2 ]