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 ]