From b80f18ae28f482669896b6e9da8e171a05c5e0c0 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Thu, 29 Oct 2020 07:13:06 -0700 Subject: [PATCH] Extended Coder.hs to handle redefining TxBody as sparse encoded MemoBytes. Made extensive changes to Coders.hs to handle sparse encoding. Applied these changes to TxBody, so that it is now defined as a sparsely encoded MemoBytes --- semantics/executable-spec/small-steps.cabal | 3 +- semantics/executable-spec/src/Data/Coders.hs | 417 +++++++++++---- .../executable-spec/src/Data/MemoBytes.hs | 7 + .../impl/cardano-ledger-shelley-ma.cabal | 4 + .../src/Cardano/Ledger/ShelleyMA/Scripts.hs | 3 +- .../src/Cardano/Ledger/ShelleyMA/Timelocks.hs | 23 +- .../src/Cardano/Ledger/ShelleyMA/TxBody.hs | 33 +- .../Test/Cardano/Ledger/ShelleyMA/Coders.hs | 482 ++++++++++++++++++ .../Cardano/Ledger/ShelleyMA/Timelocks.hs | 225 +------- .../Test/Cardano/Ledger/ShelleyMA/TxBody.hs | 10 +- shelley-ma/impl/test/Tests.hs | 8 +- .../executable-spec/shelley-spec-ledger.cabal | 1 + .../src/Shelley/Spec/Ledger/LedgerState.hs | 5 +- .../src/Shelley/Spec/Ledger/STS/Utxo.hs | 2 +- .../src/Shelley/Spec/Ledger/Tx.hs | 7 +- .../src/Shelley/Spec/Ledger/TxBody.hs | 396 +++++++------- 16 files changed, 1080 insertions(+), 546 deletions(-) create mode 100644 shelley-ma/impl/test/Test/Cardano/Ledger/ShelleyMA/Coders.hs diff --git a/semantics/executable-spec/small-steps.cabal b/semantics/executable-spec/small-steps.cabal index 3ffe65482b6..5e53551af61 100644 --- a/semantics/executable-spec/small-steps.cabal +++ b/semantics/executable-spec/small-steps.cabal @@ -40,7 +40,8 @@ library , Control.SetAlgebra -- other-modules: -- other-extensions: - build-depends: base >=4.11 && <5 + build-depends: array + , base >=4.11 && <5 , bytestring , cardano-prelude , containers diff --git a/semantics/executable-spec/src/Data/Coders.hs b/semantics/executable-spec/src/Data/Coders.hs index b0634b60207..b9dc3e3b2ff 100644 --- a/semantics/executable-spec/src/Data/Coders.hs +++ b/semantics/executable-spec/src/Data/Coders.hs @@ -16,6 +16,13 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FunctionalDependencies #-} + + +-- {-# OPTIONS_GHC -fno-warn-orphans #-} -- | MemoBytes is an abstration for a datetype that encodes its own seriialization. -- The idea is to use a newtype around a MemoBytes non-memoizing version. @@ -27,7 +34,11 @@ module Data.Coders Decode (..), (!>), ( (a -> Int) -> Decoder s a -> Decoder s a +decodeRecordNamed :: Text.Text -> (a -> Int) -> Decoder s a -> Decoder s a decodeRecordNamed name getRecordSize decoder = do lenOrIndef <- decodeListLenOrIndef x <- decoder @@ -155,106 +178,139 @@ wrapCBORArray len contents = -- =============================================================================== --- Encode and Decode are typed data structures which specify encoders and decoders. --- The types keep one from making mistakes, and count the correct number fields --- in an encoding and decoding. They are somewhat dual, and are designed that visual --- inspection of a Encode and its dual Decode can help the user conclude that the --- two are self-consistent. They are also reusable abstractions that can be defined --- once, and then used many places. +-- Encode and Decode are typed data structures which specify encoders and decoders +-- for Algebraic data structures written in Haskell. They exploit types and count +-- the correct number fields in an encoding and decoding, which are automatically computed. +-- They are somewhat dual, and are designed so that visual inspection of a Encode and +-- its dual Decode can help the user conclude that the two are self-consistent. +-- They are also reusable abstractions that can be defined once, and then used many places. -- -- (Encode t) is a data structure from which 3 things can be recovered -- Given: x :: Encode t -- 1) get a value of type t -- 2) get an Encoding for that value, which correctly encodes the number of "fields" --- written to the ByteString. Care must still be taken that the tags are correct. +-- written to the ByteString. Care must still be taken that the Keys are correct. -- 3) get a (MemoBytes t) -- The advantage of using Encode with a MemoBytes, is we don't have to make a ToCBOR -- instance. Instead the "instance" is spread amongst the pattern constuctors by using -- (memoBytes encoding) in the where clause of the pattern contructor. -- See some examples of this see the file Timelocks.hs -- --- The Encode and Decode mechanism can also be used to encode Algebraic datatypes --- in a uniform way. (Decode t) is dual to (Encode t). A decoder can be extracted --- from it. And it will consistently decode it's dual. We now give some examples. --- In the examples Let Int and C have ToCBOR instances, and --- encodeB :: B -> Encoding, and decodeB :: Decoder s B +-- The Encode and Decode mechanism are meant to specify the encoding and decoding of +-- Algebraic datatypes in a uniform way. (Decode t) is dual to (Encode t). In some cases +-- a decoder can be extracted from an encoder by visual inspection. We now give some +-- examples. In the examples Let Int and C have ToCBOR instances, and dualB :: Dual B {- -- An example with 1 constructor (a record) uses Rec and RecD +data C = C Text.Text +instance ToCBOR C where toCBOR (C t) = toCBOR t +instance FromCBOR C where fromCBOR = C <$> fromCBOR + +data B = B Text.Text +dualB = Dual (\ (B t) ->toCBOR t) (B <$> fromCBOR) + data A = ACon Int B C encodeA :: A -> Encode 'Closed A -encodeA (ACon i b c) = Rec ACon !> To i !> E encodeB b !> To c +encodeA (ACon i b c) = Rec ACon !> To i !> ED dualB b !> To c decodeA :: Decode 'Closed A -decodeA = RecD ACon Encode 'Open M -encodeM (M1 i) = Sum M1 0 !> To i -encodeM (M2 b tf) = Sum M2 1 !> E encodeB b !> To tf -encodeM (M3 a) = Sum M3 2 !> To a +encodeN :: N -> Encode 'Nary N +encodeN (N1 i) = Sum N1 0 !> To i +encodeN (N2 b tf) = Sum N2 1 !> ED dualB b !> To tf +encodeN (N3 a) = Sum N3 2 !> To a -decodeM :: Decode 'Closed M -decodeM = Summands "M" decodeMx - where decodeMx 0 = SumD M1 arg where + +-- | Analogous to paired ToCBOR and FromCBOR instances with out freezing out +-- alternate ways to code. There can be multiple Duals with the same type. +data Dual t = Dual (t -> Encoding) (forall s . Decoder s t) + +-- | A Field pairs an update function and a decoder for one field of a Sparse record. +data Field t where + Field:: (x -> t -> t) -> Decode 'Closed x -> Field t -- =========================================================== +-- The coders and the decoders as GADT datatypes +-- =========================================================== data Encode (w :: Wrapped) t where - Sum :: t -> Word -> Encode 'Open t - Rec :: t -> Encode 'Closed t + Rec :: t -> Encode 'Closed t -- No closer needed, already closed + Sum :: t -> Word -> Encode 'Nary t -- Its closer is Summands + Sparse :: t -> Encode 'Thin t -- Its closer is SparseKeyed To :: ToCBOR a => a -> Encode 'Closed a E :: (t -> Encoding) -> t -> Encode 'Closed t - ApplyE :: Encode w (a -> t) -> Encode 'Closed a -> Encode w t - --- The Wrapped index of ApplyE is determined by the index --- at the bottom of its left spine. The LEFT arg of ApplyE --- must be a function type, and the only Encode with function --- types are (Sum c tag) and (Rec c). So if the leftmost spine --- is (Sum c tag) it is 'Open, and if is (Rec c) it is 'Closed. --- The RIGHT arg of ApplyE must be 'Closed. This allows us to --- inline anything in a RIGHT arg, supporting CBORGroup capability. + ED :: Dual t -> t -> Encode 'Closed t + OmitC :: (Eq t,FromCBOR t) => t -> Encode w t + Omit:: (t -> Bool) -> Encode w t -> Encode w t + Key :: Word -> Encode w t -> Encode 'Thin t + ApplyE ::(Applys w1 w2) => Encode w1 (a -> t) -> Encode w2 a -> Encode w1 t + + -- The Wrapped index of ApplyE is determined by the index + -- at the bottom of its left spine. The choices are 'Nary (Sum c tag), + -- 'Closed (Rec c), and 'Thin (Sparse c). The Wrapped index of the arg + -- is limited by the Applys instances. This ensures that Coders that + -- need wrapping are always wrapped correctly. + +instance Applys 'Nary 'Closed where +instance Applys 'Thin 'Thin where +instance Applys 'Closed 'Closed infixl 4 !> -(!>) :: Encode w (a -> t) -> Encode 'Closed a -> Encode w t +(!>) :: (Applys w1 w2) => Encode w1 (a -> t) -> Encode w2 a -> Encode w1 t x !> y = ApplyE x y runE :: Encode w t -> t -runE (Sum c _) = c -runE (Rec c) = c +runE (Sum cn _) = cn +runE (Rec cn) = cn runE (ApplyE f x) = runE f (runE x) runE (To x) = x runE (E _ x) = x +runE (ED _ x) = x +runE (OmitC x) = x +runE (Omit _ x) = runE x +runE (Key _ x) = runE x +runE (Sparse cn) = cn gsize :: Encode w t -> Word gsize (Sum _ _) = 0 @@ -262,55 +318,88 @@ gsize (Rec _) = 0 gsize (To _) = 1 gsize (E _ _) = 1 gsize (ApplyE f x) = gsize f + gsize x +gsize (ED _ _) = 1 +gsize (OmitC _) = 0 +gsize (Omit p x) = if p (runE x) then 0 else gsize x +gsize (Key _ x) = gsize x +gsize (Sparse _) = 0 encode :: Encode w t -> Encoding encode sym = encodeCountPrefix 0 sym where encodeCountPrefix :: Word -> Encode w t -> Encoding + -- n is the number of fields we must write in the prefix. encodeCountPrefix n (Sum _ tag) = encodeListLen (n + 1) <> encodeWord tag + encodeCountPrefix n (Sparse _) = encodeMapLen n encodeCountPrefix n (Rec _) = encodeListLen n - -- n is the number of fields we must write in the prefx. encodeCountPrefix _ (To x) = toCBOR x encodeCountPrefix _ (E enc x) = enc x - encodeCountPrefix n (ApplyE f x) = - encodeCountPrefix (n + gsize x) f <> encodeClosed x - -- The RIGHT arg may be any 'Closed Encode, and is inlined - -- by design. Its left spine must end in a (Rec c). We count (gsize x) - -- the 'fields' in x, and add them to the number things we - -- must add to the prefix of the enclosing type. - - encodeClosed :: Encode 'Closed t -> Encoding - -- encodeClosed (Sum _ _) -- By design this case is unreachable by type considerations. - encodeClosed (Rec _) = mempty - encodeClosed (To x) = toCBOR x - encodeClosed (E enc x) = enc x - encodeClosed (ApplyE f x) = encodeClosed f <> encodeClosed x - --- ===================== + encodeCountPrefix _ (ED (Dual enc _) x) = enc x + encodeCountPrefix _ (OmitC _) = mempty + encodeCountPrefix n (Key tag x) = encodeWord tag <> encodeCountPrefix n x + encodeCountPrefix n (Omit p x) = + if p (runE x) then mempty else encodeCountPrefix n x + encodeCountPrefix n (ApplyE ff xx) = encodeCountPrefix (n + gsize xx) ff <> encodeClosed xx + where encodeClosed :: Encode w t -> Encoding + -- The Applys constraint shows w is either 'Closed or 'Thin + encodeClosed (Sum _ _) = error ("Not possible") -- There is NO instance (Apply x Nary) so this is unreachable + encodeClosed (Rec _) = mempty + encodeClosed (To x) = toCBOR x + encodeClosed (E enc x) = enc x + encodeClosed (ApplyE f x) = encodeClosed f <> encodeClosed x + encodeClosed (ED (Dual enc _) x) = enc x + encodeClosed (OmitC _) = mempty + encodeClosed (Omit p x) = + if p (runE x) then mempty else encodeClosed x + encodeClosed (Key tag x) = encodeWord tag <> encodeClosed x + encodeClosed (Sparse _) = mempty + +-- ================================================================== +-- Decode +-- =================================================================== + data Decode (w :: Wrapped) t where - Summands :: String -> (Word -> Decode 'Open t) -> Decode 'Closed t - SumD :: t -> Decode 'Open t + Summands :: String -> (Word -> Decode 'Nary t) -> Decode 'Closed t + SparseKeyed :: Typeable t => t -> (Word -> Field t) -> [Word] -> Decode 'Closed t + SumD :: t -> Decode 'Nary t RecD :: t -> Decode 'Closed t - From :: FromCBOR t => Decode 'Closed t + SparseD :: t -> Decode 'Thin t + From :: FromCBOR t => Decode w t D :: (forall s. Decoder s t) -> Decode 'Closed t - ApplyD :: Decode w (a -> t) -> Decode 'Closed a -> Decode w t + ApplyD :: (Applys w1 w2) => Decode w1 (a -> t) -> Decode w2 a -> Decode w1 t Invalid :: Word -> Decode w t Map :: (a -> b) -> Decode w a -> Decode w b + DD :: Dual t -> Decode 'Closed t + Emit :: t -> Decode w t + + -- The next two could be generalized to any (Applicative f) rather than Annotator + Ann :: Decode w t -> Decode w (Annotator t) + ApplyAnn :: (Applys w1 w2) => Decode w1 (Annotator(a -> t)) -> Decode w2 (Annotator a) -> Decode w1 (Annotator t) infixl 4 t) -> Decode 'Closed a -> Decode w t +( Decode w1 (a -> t) -> Decode w2 a -> Decode w1 t x Decode w1 (Annotator(a -> t)) -> Decode w2 (Annotator a) -> Decode w1 (Annotator t) +x <*! y = ApplyAnn x y + hsize :: Decode w t -> Int hsize (Summands _ _) = 1 hsize (SumD _) = 0 hsize (RecD _) = 0 +hsize (SparseD _) = 0 hsize From = 1 hsize (D _) = 1 +hsize (DD _) = 1 hsize (ApplyD f x) = hsize f + hsize x hsize (Invalid _) = 0 hsize (Map _ x) = hsize x +hsize (Emit _) = 0 +hsize (SparseKeyed _ _ _) = 1 +hsize (Ann x) = hsize x +hsize (ApplyAnn f x) = hsize f + hsize x decode :: Decode w t -> Decoder s t decode x = fmap snd (decodE x) @@ -320,56 +409,162 @@ decodE x = decodeCount x 0 decodeCount :: Decode w t -> Int -> Decoder s (Int, t) decodeCount (Summands nm f) n = (n + 1,) <$> decodeRecordSum nm (\x -> decodE (f x)) -decodeCount (SumD c) n = pure (n + 1, c) -decodeCount (RecD c) n = decodeRecordNamed "RecD" (const n) (pure (n, c)) -decodeCount From n = do x <- fromCBOR; pure (n, x) -decodeCount (D dec) n = do x <- dec; pure (n, x) -decodeCount (ApplyD c g) n = do - (i, f) <- decodeCount c (n + hsize g) +decodeCount (SumD cn) n = pure (n + 1, cn) +decodeCount (SparseD cn) n = pure(n+1,cn) +decodeCount (RecD cn) n = decodeRecordNamed "RecD" (const n) (pure (n, cn)) +decodeCount From n = (n,) <$> fromCBOR +decodeCount (D dec) n = (n,) <$> dec +decodeCount (ApplyD cn g) n = do + (i, f) <- decodeCount cn (n + hsize g) y <- decodeClosed g pure (i, f y) decodeCount (Invalid k) _ = invalidKey k decodeCount (Map f x) n = do (m, y) <- decodeCount x n; pure (m, f y) - -decodeClosed :: Decode 'Closed t -> Decoder s t +decodeCount (DD (Dual _enc dec)) n = (n,) <$> dec +decodeCount (Emit x) n = pure(n,x) +decodeCount (u@(SparseKeyed _ _ _)) n = (n+1,) <$> decodeClosed u +decodeCount (Ann x) n = do (m,y) <- decodeCount x n; pure(m,pure y) +decodeCount (ApplyAnn g x) n = do + (i,f) <- decodeCount g (n + hsize x) + y <- decodeClosed x + pure (i,f <*> y) + +decodeClosed :: Decode w t -> Decoder s t decodeClosed (Summands nm f) = decodeRecordSum nm (\x -> decodE (f x)) --- decodeClosed (SumD _) = undefined -- This case, by design, is unreachable by type considerations -decodeClosed (RecD c) = pure c + -- This case, by design, is unreachable by type considerations + -- There is no instance of (Applys x Nary) for any 'x' +decodeClosed (SumD _) = error "Not Possible" +decodeClosed (SparseD cn) = pure cn +decodeClosed (RecD cn) = pure cn decodeClosed From = do x <- fromCBOR; pure x -decodeClosed (D dec) = do x <- dec; pure x -decodeClosed (ApplyD c g) = do - f <- decodeClosed c +decodeClosed (D dec) = dec +decodeClosed (ApplyD cn g) = do + f <- decodeClosed cn y <- decodeClosed g pure (f y) decodeClosed (Invalid k) = invalidKey k decodeClosed (Map f x) = f <$> decodeClosed x +decodeClosed (DD (Dual _enc dec)) = dec +decodeClosed (Emit n) = pure n +decodeClosed (SparseKeyed initial pick required) = do + lenOrIndef <- decodeMapLenOrIndef + case lenOrIndef of + Just i -> do (v,used) <- getSparseFields initial pick (Set.empty) i + if all (`member` used) required + then pure v + else unusedKeys used required (show(typeOf initial)) + Nothing -> defaultError "SparseKeyed NOT ListLen encoded" +decodeClosed (Ann x) = fmap pure (decodeClosed x) +decodeClosed (ApplyAnn g x) = do + f <- decodeClosed g + y <- decodeClosed x + pure (f <*> y) + +unusedKeys :: Set Word -> [Word] -> String -> Decoder s a +unusedKeys used required name = + error ("Required key(s) of type "++name++" with tags "++show unused++" not decoded.") + where unused = filter (\ x -> not(member x used)) required + +defaultError :: String -> Decoder s a +defaultError message = cborError $ DecoderErrorCustom "Default encoding:" (Text.pack $ show message) + +-- | Given a function that picks a Field from a key, decodes that field +-- and returns a (t -> t) transformer, which when applied, will +-- update the record with the value decoded. + +applyField :: (Word -> Field t) -> Set Word -> Decoder s (t -> t,Set Word) +applyField f seen = do + tag <- decodeWord + case f tag of + Field update d -> do v <- decode d; pure (update v,insert tag seen) + +-- | Decode a (length n) series of key encoded data for type t +-- given a function that picks the right box for a given key, and an +-- initial value for the record (usually starts filled with default values). + +getSparseFields :: t -> (Word -> Field t) -> Set Word -> Int -> Decoder s (t,Set Word) +getSparseFields t _ seen n | n <= 0 = pure (t, seen) +getSparseFields t pick seen n = do + (transform,seen2) <- applyField pick seen + getSparseFields (transform t) pick seen2 (n-1) + +-- ====================================================== +-- (Decode 'Closed) and (Decode 'Thin) are applicative +-- (Decode 'Nary) is not applicative since there is no +-- (Applys 'Nary 'Nary) instance. And there should never be one. instance Functor (Decode w) where fmap f (Map g x) = Map (f . g) x fmap f x = Map f x +instance Applicative (Decode 'Closed) where + pure x = Emit x + f <*> x = ApplyD f x + +instance Applicative (Decode 'Thin) where + pure x = Emit x + f <*> x = ApplyD f x + -- =========================================================================================== --- These functions are the dual analogs to --- Shelley.Spec.Ledger.Serialization(decodeList, decodeSeq, decodeStrictSeq, decodeSet) --- It is not well documented how to use encodeFoldable. --- They are provided here as compatible pairs for use with the (E x) and (D x) constructors --- of the Encode and Decode types. (E encodeList xs) and (D (decodeList fromCBOR)) should be duals. +-- A Dual pairs an Encoding and a Decoder with a roundtrip property. +-- They are used with the (E and D) constructors of Encode and Decode +-- If you are trying to code something not in the CBOR classes +-- or you want something not traditional, make you own Dual and use E or D + +-- data Dual t = Dual (t -> Encoding) (forall s . Decoder s t) + +dualList :: (ToCBOR a, FromCBOR a) => Dual [a] +dualList = Dual encodeFoldable (decodeList fromCBOR) + +dualSeq :: (ToCBOR a, FromCBOR a) => Dual (Seq a) +dualSeq = Dual encodeFoldable (decodeSeq fromCBOR) + +dualSet :: (Ord a,ToCBOR a, FromCBOR a) => Dual (Set a) +dualSet = Dual encodeFoldable (decodeSet fromCBOR) -encodeList :: ToCBOR a => [a] -> Encoding -encodeList = encodeFoldable +dualMaybe :: (ToCBOR a, FromCBOR a) => Dual (Maybe a) +dualMaybe = Dual toCBOR fromCBOR -encodeStrictSeq :: ToCBOR a => StrictSeq a -> Encoding -encodeStrictSeq = encodeFoldable +dualStrictSeq :: (ToCBOR a, FromCBOR a) => Dual (StrictSeq a) +dualStrictSeq = Dual encodeFoldable (decodeStrictSeq fromCBOR) -encodeSeq :: ToCBOR a => Seq a -> Encoding -encodeSeq = encodeFoldable +dualText :: Dual Text.Text +dualText = Dual toCBOR fromCBOR -encodeSet :: ToCBOR a => Set a -> Encoding -encodeSet = encodeFoldable +dualCBOR :: (ToCBOR a, FromCBOR a) => Dual a +dualCBOR = Dual toCBOR fromCBOR --- =========================================== --- For a worked out EXAMPLE see the testfile: --- cardano-ledger-specs/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/MemoBytes.hs +-- Use to and from, when you want to guarantee that a type has both +-- ToCBOR and FromCBR instances. -roundTrip :: (ToCBOR t,FromCBOR t) => t -> Either Codec.CBOR.Read.DeserialiseFailure (Lazy.ByteString, t) +to :: (ToCBOR t, FromCBOR t) => t -> Encode 'Closed t +to xs = ED dualCBOR xs + +from :: (ToCBOR t, FromCBOR t) => Decode 'Closed t +from = DD dualCBOR + +-- Writing roundTrip properties + +type Answer t = Either Codec.CBOR.Read.DeserialiseFailure (Lazy.ByteString, t) + +roundTrip :: (ToCBOR t,FromCBOR t) => t -> Answer t roundTrip s = deserialiseFromBytes fromCBOR (toLazyByteString (toCBOR s)) + +roundTrip' ::(t -> Encoding) -> (forall s. Decoder s t) -> t -> Answer t +roundTrip' enc dec t = deserialiseFromBytes dec (toLazyByteString (enc t)) + +-- ================================================================== +-- A Guide to Visual inspection of Duality in Encode and Decode +-- +-- 1) (Sum c) and (SumD c) are duals +-- 2) (Rec c) and (RecD c) are duals +-- 3) (Sparse c) and (SparseD c) are duals +-- 4) (OmitC x) and (Emit x) are duals +-- 5) (Omit p ..) and (Emit x) are duals if (p x) is True +-- 6) (To x) and (From) are duals if (x::T) and (forall (y::T). isRight (roundTrip y)) +-- 7) (E enc x) and (D dec) are duals if (forall x . isRight (roundTrip' enc dec x)) +-- 6) (ED d x) and (DD f) are duals as long as d=(Dual enc dec) and (forall x . isRight (roundTrip' enc dec x)) +-- 7) f !> x and g MemoBytes t memoBytes t = Memo (runE t) (shorten (toLazyByteString (encode t))) +memoBytesAnn :: Encode w (Annotator t) -> MemoBytes t +memoBytesAnn t = Memo term (shorten bytes) + where bytes = toLazyByteString (encode t) + Annotator f = runE t + term = f (Full bytes) roundTripMemo:: (FromCBOR t) => MemoBytes t -> Either Codec.CBOR.Read.DeserialiseFailure (Lazy.ByteString, MemoBytes t) roundTripMemo (Memo _t bytes) = diff --git a/shelley-ma/impl/cardano-ledger-shelley-ma.cabal b/shelley-ma/impl/cardano-ledger-shelley-ma.cabal index 14b232cbc04..a8752d43d95 100644 --- a/shelley-ma/impl/cardano-ledger-shelley-ma.cabal +++ b/shelley-ma/impl/cardano-ledger-shelley-ma.cabal @@ -60,12 +60,14 @@ library default-language: Haskell2010 + test-suite cardano-ledger-test type: exitcode-stdio-1.0 main-is: Tests.hs other-modules: Test.Cardano.Ledger.ShelleyMA.TxBody Test.Cardano.Ledger.ShelleyMA.Timelocks + Test.Cardano.Ledger.ShelleyMA.Coders hs-source-dirs: test default-language: Haskell2010 @@ -85,6 +87,7 @@ test-suite cardano-ledger-test -- determined ad-hoc. "-with-rtsopts=-K4m -M250m" build-depends: + array, cardano-ledger-shelley-ma, base >=4.9 && <4.15, bytestring, @@ -105,3 +108,4 @@ test-suite cardano-ledger-test tasty-hunit, tasty-quickcheck, tasty, + text, diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Scripts.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Scripts.hs index c42bab95826..57e056117d4 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Scripts.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Scripts.hs @@ -26,7 +26,7 @@ import Cardano.Ledger.ShelleyMA.Timelocks hashTimelockScript, validateTimelock, ) -import Data.Coders (decodeRecordSum) +import Data.Coders (decodeRecordSum, invalidKey) import Data.Typeable (Typeable) import Data.Word (Word8) import GHC.Generics (Generic) @@ -61,6 +61,7 @@ instance Era era => FromCBOR (Annotator (Script era)) where 1 -> do tl <- fromCBOR pure (2, ScriptTimelock <$> tl) + n -> invalidKey n type instance Core.Script (ShelleyMAEra (ma :: MaryOrAllegra) c) = diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs index 285e540e64e..aa25f2ba9aa 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs @@ -44,7 +44,7 @@ import Cardano.Ledger.Era import qualified Cardano.Ledger.Shelley as Shelley import Cardano.Slotting.Slot (SlotNo (..)) import qualified Data.ByteString as BS -import Data.Coders (Decode (..), Encode (..), Wrapped (..), decode, encode, (!>), (), ( Word -> Decode 'Nary (Annotator (Timelock' era)) +decTimelock' 0 = Ann (SumD Interval' decodeStrictSeq fromCBOR) +decTimelock' 3 = Ann (SumD TimelockOr') <*! D (sequence <$> decodeStrictSeq fromCBOR) +decTimelock' k = Invalid k + +instance Era era => FromCBOR (Annotator (Timelock' era)) where + fromCBOR = decode (Summands "Annotator(Timelock' era)" decTimelock') + +{- The decTimelok' function replaces things like this: instance Era era => FromCBOR (Annotator (Timelock' era)) @@ -133,6 +143,7 @@ instance timelks <- sequence <$> decodeStrictSeq fromCBOR pure (2, TimelockOr' <$> timelks) k -> invalidKey k +-} -- ============================================================================== -- Now all the problematic Timelock instances are derived. No thinking required @@ -164,7 +175,7 @@ pattern Multi :: Era era => MultiSig era -> Timelock era pattern Multi m <- Timelock (Memo (Multi' m) _) where - Multi m = Timelock $ memoBytes $ Sum Multi' 1 !> To m + Multi m = Timelock $ memoBytes $ (Sum Multi' 1) !> To m pattern TimelockAnd :: Era era => StrictSeq (Timelock era) -> Timelock era pattern TimelockAnd ms <- @@ -249,6 +260,8 @@ hashTimelockScript = . Hash.hashWith (\x -> nativeTimelockTag <> serialize' x) {- +-- At some point we will need a class, analogous to MultiSignatureScript +-- which relates scripts and their validators. instance ( Era era, HasField "vldt" (Core.TxBody era) ValidityInterval, diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs index 82b53af3029..33c52c69aa5 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs @@ -29,13 +29,9 @@ where import Cardano.Binary (Annotator, FromCBOR (..), ToCBOR (..)) import Cardano.Ledger.Compactible (CompactForm (..), Compactible (..)) import Cardano.Ledger.Core (Script, Value) -<<<<<<< HEAD import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (Era) import Cardano.Ledger.ShelleyMA (MaryOrAllegra, ShelleyMAEra) -======= -import Cardano.Ledger.Era (Era) ->>>>>>> 622da3ac... "Added the TxBody type with validity intervals and forge fields. Tied this import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..), decodeVI, encodeVI) import Data.Coders ( Decode (..), @@ -54,10 +50,7 @@ import GHC.Records import NoThunks.Class (NoThunks (..)) import Shelley.Spec.Ledger.BaseTypes (StrictMaybe) import Shelley.Spec.Ledger.Coin (Coin (..)) -<<<<<<< HEAD import Shelley.Spec.Ledger.Hashing (EraIndependentTxBody, HashAnnotated (..)) -======= ->>>>>>> 622da3ac... "Added the TxBody type with validity intervals and forge fields. Tied this import Shelley.Spec.Ledger.MetaData (MetaDataHash) import Shelley.Spec.Ledger.PParams (Update) import Shelley.Spec.Ledger.Serialization (encodeFoldable) @@ -80,8 +73,7 @@ type FamsFrom era = Typeable (Script era), FromCBOR (CompactForm (Value era)), -- Arises because TxOut uses Compact form FromCBOR (Value era), - FromCBOR (Annotator (Script era)), -- Arises becaause DCert memoizes its bytes - FromCBOR (Script era) + FromCBOR (Annotator (Script era)) -- Arises becaause DCert memoizes its bytes ) type FamsTo era = @@ -96,12 +88,12 @@ type FamsTo era = data TxBody' era = TxBody' { inputs :: !(Set (TxIn era)), outputs :: !(StrictSeq (TxOut era)), - dcerts :: !(StrictSeq (DCert era)), + certs :: !(StrictSeq (DCert era)), wdrls :: !(Wdrl era), txfee :: !Coin, vldt :: !ValidityInterval, -- imported from Timelocks - txupdate :: !(StrictMaybe (Update era)), - mdhash :: !(StrictMaybe (MetaDataHash era)), + update :: !(StrictMaybe (Update era)), + mdHash :: !(StrictMaybe (MetaDataHash era)), forge :: !(Value era) } deriving (Typeable) @@ -114,7 +106,6 @@ deriving instance (Compactible (Value era), Eq (Value era)) => Eq (TxBody' era) deriving instance (Era era, Compactible (Value era), Show (Value era)) => Show (TxBody' era) - deriving instance Generic (TxBody' era) deriving instance NoThunks (Value era) => NoThunks (TxBody' era) @@ -148,6 +139,10 @@ instance newtype TxBody e = STxBody (MemoBytes (TxBody' e)) deriving (Typeable) +type instance + Core.TxBody (ShelleyMAEra (ma :: MaryOrAllegra) c) = + TxBody (ShelleyMAEra ma c) + deriving instance (Compactible (Value era), Eq (Value era)) => Eq (TxBody era) deriving instance (Era era, Compactible (Value era), Show (Value era)) => Show (TxBody era) @@ -223,8 +218,8 @@ instance HasField "inputs" (TxBody e) (Set (TxIn e)) where instance HasField "outputs" (TxBody e) (StrictSeq (TxOut e)) where getField (STxBody (Memo m _)) = getField @"outputs" m -instance HasField "dcerts" (TxBody e) (StrictSeq (DCert e)) where - getField (STxBody (Memo m _)) = getField @"dcerts" m +instance HasField "certs" (TxBody e) (StrictSeq (DCert e)) where + getField (STxBody (Memo m _)) = getField @"certs" m instance HasField "wdrls" (TxBody e) (Wdrl e) where getField (STxBody (Memo m _)) = getField @"wdrls" m @@ -235,11 +230,11 @@ instance HasField "txfee" (TxBody e) Coin where instance HasField "vldt" (TxBody e) ValidityInterval where getField (STxBody (Memo m _)) = getField @"vldt" m -instance HasField "txupdate" (TxBody e) (StrictMaybe (Update e)) where - getField (STxBody (Memo m _)) = getField @"txupdate" m +instance HasField "update" (TxBody e) (StrictMaybe (Update e)) where + getField (STxBody (Memo m _)) = getField @"update" m -instance HasField "mdhash" (TxBody e) (StrictMaybe (MetaDataHash e)) where - getField (STxBody (Memo m _)) = getField @"mdhash" m +instance HasField "mdHash" (TxBody e) (StrictMaybe (MetaDataHash e)) where + getField (STxBody (Memo m _)) = getField @"mdHash" m instance (Value e ~ vv) => HasField "forge" (TxBody e) vv where getField (STxBody (Memo m _)) = getField @"forge" m diff --git a/shelley-ma/impl/test/Test/Cardano/Ledger/ShelleyMA/Coders.hs b/shelley-ma/impl/test/Test/Cardano/Ledger/ShelleyMA/Coders.hs new file mode 100644 index 00000000000..557a90f31d3 --- /dev/null +++ b/shelley-ma/impl/test/Test/Cardano/Ledger/ShelleyMA/Coders.hs @@ -0,0 +1,482 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +module Test.Cardano.Ledger.ShelleyMA.Coders where + +-- Used in testing +-- Used in testing + +-- Duals + +import Cardano.Binary + ( Annotator (..), + DecoderError (DecoderErrorCustom), + FromCBOR (fromCBOR), + ToCBOR (toCBOR), + decodeBreakOr, + decodeListLenOrIndef, + decodeMapLenOrIndef, + decodeWord, + encodeBreak, + encodeListLen, + encodeListLenIndef, + encodeMapLen, + encodeWord, + matchSize, + ) +import Cardano.Prelude (cborError) +import Codec.CBOR.Decoding (Decoder) +import Codec.CBOR.Encoding (Encoding) +import Codec.CBOR.FlatTerm (TermToken, toFlatTerm) +import Codec.CBOR.Read (DeserialiseFailure, deserialiseFromBytes) +import Codec.CBOR.Write (toLazyByteString) +import Control.Monad (replicateM, unless) +import Data.Array +import qualified Data.ByteString.Lazy as Lazy +import Data.Coders + ( Annotator (..), + Decode (..), + Dual (..), + Encode (..), + Field (..), + Wrapped (..), + decode, + decodeClosed, + decodeCollection, + decodeCollectionWithLen, + decodeList, + decodeRecordNamed, + decodeRecordSum, + decodeSeq, + decodeSet, + decodeStrictSeq, + dualList, + dualMaybe, + dualSeq, + dualSet, + dualStrictSeq, + dualText, + encode, + encodeFoldable, + encodeFoldableEncoder, + from, + invalidKey, + roundTrip, + roundTrip', + runE, + to, + wrapCBORArray, + (!>), + ( case n of + 0 -> do i <- fromCBOR; pure (2, A i) -- Tag for A is 0 + 1 -> do i <- fromCBOR; b <- fromCBOR; pure (3, B i b) -- Tag for B is 1 + 2 -> do l <- decodeList fromCBOR; pure (2, G l) -- Tag for G is 2 + 3 -> do i <- decodeStrictSeq fromCBOR; pure (2, H i) -- Tag for H is 3 + k -> invalidKey k + +-- ============================================================================================= +-- JUST A NOTE about the (instance ToCBOR a => ToCBOR [a]). This uses the Begin .. End encoding, +-- while encodeList uses the list-length encoding. +-- toCBOR [5::Int,2] --> [TkListBegin,TkInt 5,TkInt 2,TkBreak]. +-- encodeList [5::Int,2] --> [TkListLen 2,TkInt 5,TkInt 2] +-- the (instance FromCBOR a => FromCBOR [a]) will ONLY RECOGNIZE THE BEGIN END ENCODING. +-- but the decoder (decodeList fromCBOR) will recognize both styles of encoding. So in a decoder +-- or FromCBOR instance it is always preferable to use (decodeList fromCBOR) over (fromCBOR) +-- For example in the instance above, we could write either of these 2 lines +-- 2 -> do { l <- decodeList fromCBOR; pure(2,G l) } +-- 2 -> do { l <- fromCBOR; pure(2,G l) } +-- BUT THE FIRST IS MORE GENERAL. The following instance should be replaced +-- instance FromCBOR a => FromCBOR [a] -- Defined in ‘cardano-binary-1.5.0:Cardano.Binary.FromCBOR’ + +instance ToCBOR TT where + toCBOR (A i) = encodeListLen 2 <> encodeWord 0 <> toCBOR i + toCBOR (B i b) = encodeListLen 3 <> encodeWord 1 <> toCBOR i <> toCBOR b + toCBOR (G is) = encodeListLen 2 <> encodeWord 2 <> toCBOR is + toCBOR (H bs) = encodeListLen 2 <> encodeWord 3 <> encodeStrictSeq bs + +-- The Key is that in (G constr tag <@> ...) +-- The 'tag' for 'constr' aligns with the Tag in the case match +-- in the FromCBOR instance for TT above. + +sA, sB, sG, sGa, sH :: Encode 'Nary TT +sA = Sum A 0 !> To 7 -- Tag for A is 0 +sB = Sum B 1 !> To 13 !> To True -- Tag for B is 1 +sG = Sum G 2 !> To [3, 4, 5] -- Tag for G is 2 +sGa = Sum G 2 !> E encodeList [2, 5] -- Tag for G is 2 +sH = Sum H 3 !> E encodeStrictSeq (fromList [False, True]) -- Tag for H is 3 + +encodeList :: ToCBOR t => [t] -> Encoding +encodeList = encodeFoldable + +encodeStrictSeq :: ToCBOR t => StrictSeq t -> Encoding +encodeStrictSeq = encodeFoldable + +-- =============================================================== + +-- =================================== +-- Examples + +data Two = Two Int Bool + deriving (Show) + +decTwo :: Decode 'Closed Two +encTwo :: Two -> Encode 'Closed Two +decTwo = (RecD Two To a !> To b) + +instance ToCBOR Two where + toCBOR two = encode $ encTwo two + +instance FromCBOR Two where + fromCBOR = decode decTwo + +-- ============ + +data Test = Test Int Two Integer + deriving (Show) + +test1 :: Test +test1 = Test 3 (Two 9 True) 33 + +decTestWithGroupForTwo :: Decode 'Closed Test +encTestWithGroupForTwo :: Test -> Encode 'Closed Test +decTestWithGroupForTwo = (RecD Test To a !> encTwo b !> To c) + +instance ToCBOR Test where + toCBOR = encode . encTestWithGroupForTwo + +instance FromCBOR Test where + fromCBOR = decode decTestWithGroupForTwo + +-- =========== + +data Three = In Int | N Bool Integer | F Two + deriving (Show) + +three1, three2, three3 :: Three +three1 = In 7 +three2 = N True 22 +three3 = F (Two 1 False) + +-- The following values 'decThree' and 'encThree' are meant to simulate the following instances +{- +instance ToCBOR Three where + toCBOR (In x) = encodeListLen 2 <> encodeWord 0 <> toCBOR x + toCBOR (N b i) = encodeListLen 3 <> encodeWord 1 <> toCBOR b <> toCBOR i + toCBOR (F (Two i b)) = encodeListLen 3 <> encodeWord 2 <> toCBOR i <> toCBOR b + -- even though F has only 1 argument, we inline the two parts of Two, + -- so it appears to have 2 arguments. This mimics CBORGROUP instances + +instance FromCBOR Three where + fromCBOR = decodeRecordSum "Three" $ + \case + 0 -> do + x <- fromCBOR + pure (2, In x) + 1 -> do + b <- fromCBOR + i <- fromCBOR + pure (3, N b i) + 2 -> do + i <- fromCBOR + b <- fromCBOR + pure (3,F (Two i b)) + k -> invalidKey k +-} + +decThree :: Word -> Decode 'Nary Three +decThree 0 = (SumD In Encode 'Nary Three +encThree (In x) = (Sum In 0) !> To x +encThree (N b i) = (Sum N 1) !> To b !> To i +encThree (F t) = (Sum F 2) !> encTwo t + +instance FromCBOR Three where + fromCBOR = decode (Summands "Three" decThree) + +instance ToCBOR Three where + toCBOR x = encode (encThree x) + +-- ================================================================ +-- In this test we nest many Records, and flatten out everything + +data Big = Big Int Bool Integer deriving (Show) + +data Bigger = Bigger Test Two Big deriving (Show) + +bigger :: Bigger +bigger = Bigger (Test 2 (Two 4 True) 99) (Two 7 False) (Big 5 False 102) + +-- Note there are 9 individual items, each which fits in one CBOR Token +-- So we expect the encoding to have 10 items, 1 prefix and 9 others + +biggerItems :: [TermToken] +biggerItems = toFlatTerm (encode (encBigger bigger)) + +decBigger :: Decode 'Closed Bigger +decBigger = + RecD Bigger Encode 'Closed Bigger +encBigger (Bigger (Test a (Two b c) d) (Two e f) (Big g h i)) = + Rec Bigger !> (Rec Test !> To a !> (Rec Two !> To b !> To c) !> To d) + !> (Rec Two !> To e !> To f) + !> (Rec Big !> To g !> To h !> To i) + +instance ToCBOR Bigger where + toCBOR = encode . encBigger + +instance FromCBOR Bigger where + fromCBOR = decode decBigger + +-- ====================================================================== +-- There are two ways to write smart encoders and decoders that don't put +-- fields with default values in the Encoding, and that reconstruct them +-- on the decoding side. These techniques work on record datatypes, i.e. +-- those with only one constructor. We will illustrate the two approaches +-- in the datatype A + +data M = M Int [Bool] Text + deriving (Show, Typeable) + +a0, a1, a2, a3 :: M +a0 = M 0 [] "ABC" +a1 = M 0 [True] "ABC" +a2 = M 9 [] "ABC" +a3 = M 9 [False] "ABC" + +-- ================================================================================ +-- The Sparse encoding strategy uses N keys, one for each field that is not defaulted +-- encode (baz (M 9 [True] (pack "hi"))) --Here No fields are defaulted, should be 3 keys +-- [TkMapLen 3,TkInt 0,TkInt 9,TkInt 1,TkListBegin,TkBool True,TkBreak,TkInt 2,TkString "hi"] +-- ^key ^key ^key +-- So the user supplies a function, that encodes every field, each field must use a unique +-- key, and fields with default values have Omit wrapped around the Key encoding. +-- The user must ensure that there is NOT an Omit on a required field. 'baz' is an example. + +baz :: M -> Encode 'Thin M +baz (M n xs t) = Sparse M !> Omit (== 0) (Key 0 (To n)) !> Omit null (Key 1 (To xs)) !> Key 2 (To t) + +-- To write an Decoder we must pair a decoder for each field, with a function that updates only +-- that field. We use the Field GADT to construct these pairs, and we must write a function, that +-- for each field tag, picks out the correct pair. If the Encode and Decode don't agree on how the +-- tags correspond to a particular field, things will fail. + +boxM :: Word -> Field M +boxM 0 = Field update0 From + where + update0 n (M _ xs t) = M n xs t +boxM 1 = Field update1 (From) + where + update1 xs (M n _ t) = M n xs t +boxM 2 = Field update2 (From) + where + update2 t (M n xs _) = M n xs t +boxM n = Field (\_ t -> t) (Invalid n) + +-- Finally there is a new constructor for Decode, called SparseKeyed, that decodes field +-- keyed sparse objects. The user supplies an initial value and pick function, and a list +-- of tags of the required fields. The initial value should have default values and +-- any well type value in required fields. If the encode function (baz above) is +-- encoded properly the required fields in the initial value should always be over +-- overwritten. If it is not written properly, or a bad encoding comes from somewhere +-- else, the intial values in the required fields might survive decoding. The list +-- of required fields is checked. + +decodeM :: Decode 'Closed M +decodeM = SparseKeyed (M 0 [] (pack "a")) boxM [2] -- Only the field with Key 2 is required + +dualM = Dual (encode . baz) (decode decodeM) + +type Answer t = Either Codec.CBOR.Read.DeserialiseFailure (Lazy.ByteString, t) + +testM :: M -> Answer M +testM m = roundTrip' (encode . baz) (decode decodeM) m + +roundtrip :: Show t => String -> Dual t -> t -> TestTree +roundtrip name (Dual enc dec) v = + testCase + ("roundtrip " ++ name ++ " =(" ++ show v ++ ")") + ( assertBool + name + ( case (roundTrip' enc dec v) of + Right _ -> True + Left _ -> False + ) + ) + +testEncode :: + (FromCBOR t) => + Encode w t -> + Either Codec.CBOR.Read.DeserialiseFailure (Lazy.ByteString, t) +testEncode s = deserialiseFromBytes fromCBOR (toLazyByteString (encode s)) + +deCodeTest :: (FromCBOR t, Show t) => String -> Encode w t -> TestTree +deCodeTest name sym = + testProperty (name ++ ": Decoding " ++ show (runE sym)) $ + case testEncode sym of + Right _ -> True + Left s -> error ("Fail to decode " ++ show (runE sym) ++ " with error " ++ show s) + +-- ==================================================================== +-- Some tests + +q0, q1, q2, q3 :: Answer M +q0 = roundTrip' (\x -> encode (baz x)) (decode decodeM) (M 0 [] (pack "MBC")) +q1 = roundTrip' (\x -> encode (baz x)) (decode decodeM) (M 0 [True] (pack "MBC")) +q2 = roundTrip' (\x -> encode (baz x)) (decode decodeM) (M 42 [] (pack "MBC")) +q3 = roundTrip' (\x -> encode (baz x)) (decode decodeM) (M 9 [True, False] (pack "MBC")) + +ok :: Bool +ok = all isRight [q0, q1, q2, q3] + where + isRight (Right _) = True + isRight (Left _) = False + +-- In the examples Let Int and C have ToCBOR instances, and dualB :: Dual B +-- An example with 1 constructor (a record) uses Rec and RecD + +data C = C Text deriving (Show) + +instance ToCBOR C where toCBOR (C t) = toCBOR t + +instance FromCBOR C where fromCBOR = C <$> fromCBOR + +data BB = BB Text deriving (Show) + +dualBB :: Dual BB +dualBB = Dual (\(BB t) -> toCBOR t) (BB <$> fromCBOR) + +-- Record Type + +data A = ACon Int BB C deriving (Show) + +encodeA :: A -> Encode 'Closed A +encodeA (ACon i b c) = Rec ACon !> To i !> ED dualBB b !> To c + +decodeA :: Decode 'Closed A +decodeA = RecD ACon Encode 'Nary N +encodeN (N1 i) = Sum N1 0 !> To i +encodeN (N2 b tf) = Sum N2 1 !> ED dualBB b !> To tf +encodeN (N3 a) = Sum N3 2 !> To a + +decodeN :: Decode 'Closed N +decodeN = Summands "N" decodeNx + where + decodeNx 0 = SumD N1 ), - ( case n of - 0 -> do i <- fromCBOR; pure (2, A i) -- Tag for A is 0 - 1 -> do i <- fromCBOR; b <- fromCBOR; pure (3, B i b) -- Tag for B is 1 - 2 -> do l <- decodeList fromCBOR; pure (2, G l) -- Tag for G is 2 - 3 -> do i <- decodeStrictSeq fromCBOR; pure (2, H i) -- Tag for H is 3 - k -> invalidKey k - --- ============================================================================================= --- JUST A NOTE about the (instance ToCBOR a => ToCBOR [a]). This uses the Begin .. End encoding, --- while encodeList uses the list-length encoding. --- toCBOR [5::Int,2] --> [TkListBegin,TkInt 5,TkInt 2,TkBreak]. --- encodeList [5::Int,2] --> [TkListLen 2,TkInt 5,TkInt 2] --- the (instance FromCBOR a => FromCBOR [a]) will ONLY RECOGNIZE THE BEGIN END ENCODING. --- but the decoder (decodeList fromCBOR) will recognize both styles of encoding. So in a decoder --- or FromCBOR instance it is always preferable to use (decodeList fromCBOR) over (fromCBOR) --- For example in the instance above, we could write either of these 2 lines --- 2 -> do { l <- decodeList fromCBOR; pure(2,G l) } --- 2 -> do { l <- fromCBOR; pure(2,G l) } --- BUT THE FIRST IS MORE GENERAL. The following instance should be replaced --- instance FromCBOR a => FromCBOR [a] -- Defined in ‘cardano-binary-1.5.0:Cardano.Binary.FromCBOR’ - -instance ToCBOR TT where - toCBOR (A i) = encodeListLen 2 <> encodeWord 0 <> toCBOR i - toCBOR (B i b) = encodeListLen 3 <> encodeWord 1 <> toCBOR i <> toCBOR b - toCBOR (G is) = encodeListLen 2 <> encodeWord 2 <> toCBOR is - toCBOR (H bs) = encodeListLen 2 <> encodeWord 3 <> encodeStrictSeq bs - --- The Key is that in (G constr tag <@> ...) --- The 'tag' for 'constr' aligns with the Tag in the case match --- in the FromCBOR instance for TT above. - -sA, sB, sG, sGa, sH :: Encode 'Open TT -sA = Sum A 0 !> To 7 -- Tag for A is 0 -sB = Sum B 1 !> To 13 !> To True -- Tag for B is 1 -sG = Sum G 2 !> To [3, 4, 5] -- Tag for G is 2 -sGa = Sum G 2 !> E encodeList [2, 5] -- Tag for G is 2 -sH = Sum H 3 !> E encodeStrictSeq (fromList [False, True]) -- Tag for H is 3 - --- =============================================================== - --- =================================== --- Examples - -data Two = Two Int Bool - deriving (Show) - -decTwo :: Decode 'Closed Two -encTwo :: Two -> Encode 'Closed Two -decTwo = (RecD Two To a !> To b) - -instance ToCBOR Two where - toCBOR two = encode $ encTwo two - -instance FromCBOR Two where - fromCBOR = decode decTwo - --- ============ - -data Test = Test Int Two Integer - deriving (Show) - -test1 :: Test -test1 = Test 3 (Two 9 True) 33 - -decTestWithGroupForTwo :: Decode 'Closed Test -encTestWithGroupForTwo :: Test -> Encode 'Closed Test -decTestWithGroupForTwo = (RecD Test To a !> encTwo b !> To c) - -instance ToCBOR Test where - toCBOR = encode . encTestWithGroupForTwo - -instance FromCBOR Test where - fromCBOR = decode decTestWithGroupForTwo - --- =========== - -data Three = M Int | N Bool Integer | F Two - deriving (Show) - -three1, three2, three3 :: Three -three1 = M 7 -three2 = N True 22 -three3 = F (Two 1 False) - --- The following values 'decThree' and 'encThree' are meant to simulate the following instances -{- -instance ToCBOR Three where - toCBOR (M x) = encodeListLen 2 <> encodeWord 0 <> toCBOR x - toCBOR (N b i) = encodeListLen 3 <> encodeWord 1 <> toCBOR b <> toCBOR i - toCBOR (F (Two i b)) = encodeListLen 3 <> encodeWord 2 <> toCBOR i <> toCBOR b - -- even though F has only 1 argument, we inline the two parts of Two, - -- so it appears to have 2 arguments. This mimics CBORGROUP instances - -instance FromCBOR Three where - fromCBOR = decodeRecordSum "Three" $ - \case - 0 -> do - x <- fromCBOR - pure (2, M x) - 1 -> do - b <- fromCBOR - i <- fromCBOR - pure (3, N b i) - 2 -> do - i <- fromCBOR - b <- fromCBOR - pure (3,F (Two i b)) - k -> invalidKey k --} - -decThree :: Word -> Decode 'Open Three -decThree 0 = (SumD M Encode 'Open Three -encThree (M x) = (Sum M 0) !> To x -encThree (N b i) = (Sum N 1) !> To b !> To i -encThree (F t) = (Sum F 2) !> encTwo t - -instance FromCBOR Three where - fromCBOR = decode (Summands "Three" decThree) - -instance ToCBOR Three where - toCBOR x = encode (encThree x) - --- ================================================================ --- In this test we nest many Records, and flatten out everything - -data Big = Big Int Bool Integer deriving (Show) - -data Bigger = Bigger Test Two Big deriving (Show) - -bigger :: Bigger -bigger = Bigger (Test 2 (Two 4 True) 99) (Two 7 False) (Big 5 False 102) - --- Note there are 9 individual items, each which fits in one CBOR Token --- So we expect the encoding to have 10 items, 1 prefix and 9 others - -biggerItems :: [TermToken] -biggerItems = toFlatTerm (encode (encBigger bigger)) - -decBigger :: Decode 'Closed Bigger -decBigger = - RecD Bigger Encode 'Closed Bigger -encBigger (Bigger (Test a (Two b c) d) (Two e f) (Big g h i)) = - Rec Bigger !> (Rec Test !> To a !> (Rec Two !> To b !> To c) !> To d) - !> (Rec Two !> To e !> To f) - !> (Rec Big !> To g !> To h !> To i) - -instance ToCBOR Bigger where - toCBOR = encode . encBigger - -instance FromCBOR Bigger where - fromCBOR = decode decBigger - -- ================================================================ s1 :: Timelock TestEra @@ -227,12 +38,6 @@ s4 = TimelockAnd (fromList [s1, s2]) -- ================================================================ -testEncode :: - (FromCBOR t) => - Encode w t -> - Either Codec.CBOR.Read.DeserialiseFailure (Lazy.ByteString, t) -testEncode s = deserialiseFromBytes fromCBOR (toLazyByteString (encode s)) - testT :: (ToCBOR t, FromCBOR t) => t -> Either Codec.CBOR.Read.DeserialiseFailure (Lazy.ByteString, t) testT s = deserialiseFromBytes fromCBOR (toLazyByteString (toCBOR s)) @@ -243,13 +48,6 @@ testAnn s = Left err -> Left err Right (leftover, Annotator f) -> Right (leftover, f (Full bytes)) -deCodeTest :: (FromCBOR t, Show t) => String -> Encode w t -> TestTree -deCodeTest name sym = - testProperty (name ++ ": Decoding " ++ show (runE sym)) $ - case testEncode sym of - Right _ -> True - Left s -> error ("Fail to decode " ++ show (runE sym) ++ " with error " ++ show s) - annTest :: (FromCBOR (Annotator t), ToCBOR t, Show t) => String -> t -> TestTree annTest nm t = testProperty ("RoundTrip: " ++ nm) $ case testAnn t of @@ -265,20 +63,9 @@ timelocktests = annTest ("s4 " ++ showTimelock s4) s4 ] -timelockAndDecodeTests :: TestTree -timelockAndDecodeTests = +timelockTests :: TestTree +timelockTests = testGroup "MemoBytesTest" - [ deCodeTest "sA" sA, - deCodeTest "sB" sB, - deCodeTest "sG" sG, - deCodeTest "sGA" sGa, - deCodeTest "sH" sH, - deCodeTest "Three1" (encThree three1), - deCodeTest "Three2" (encThree three2), - deCodeTest "Three3" (encThree three3), - deCodeTest "test1" (encTestWithGroupForTwo test1), - testProperty "encode Bigger is compact" (length biggerItems === 10), - deCodeTest "Bigger inlines" (encBigger bigger), - timelocktests + [ timelocktests ] diff --git a/shelley-ma/impl/test/Test/Cardano/Ledger/ShelleyMA/TxBody.hs b/shelley-ma/impl/test/Test/Cardano/Ledger/ShelleyMA/TxBody.hs index ba37203f8c3..bba6da8a06e 100644 --- a/shelley-ma/impl/test/Test/Cardano/Ledger/ShelleyMA/TxBody.hs +++ b/shelley-ma/impl/test/Test/Cardano/Ledger/ShelleyMA/TxBody.hs @@ -19,10 +19,10 @@ import Cardano.Ledger.Core (Script, TxBody, Value) import Cardano.Ledger.Crypto (HASH) import qualified Cardano.Ledger.Crypto as CryptoClass import Cardano.Ledger.Era (Crypto, Era) +import qualified Cardano.Ledger.Mary.Value () +import qualified Cardano.Ledger.Mary.Value as ConcreteValue import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..)) import qualified Cardano.Ledger.ShelleyMA.TxBody as Mary -import qualified Cardano.Ledger.ShelleyMA.Value () -import qualified Cardano.Ledger.ShelleyMA.Value as ConcreteValue import Cardano.Ledger.Val (Val (..)) import Cardano.Slotting.Slot (SlotNo (..)) import Data.ByteString.Short (ShortByteString) @@ -103,12 +103,12 @@ fieldTests = "getField tests" [ testCase "inputs" (assertEqual "inputs" (getField @"inputs" tx) empty), testCase "outputs" (assertEqual "outputs" (getField @"outputs" tx) eseq), - testCase "dcerts" (assertEqual "dcerts" (getField @"dcerts" tx) eseq), + testCase "certs" (assertEqual "certs" (getField @"certs" tx) eseq), testCase "wdrls" (assertEqual "wdrls" (getField @"wdrls" tx) (Wdrl Map.empty)), testCase "txfree" (assertEqual "txfree" (getField @"txfee" tx) (Coin 6)), testCase "vldt" (assertEqual "vldt" (getField @"vldt" tx) (ValidityInterval (SJust (SlotNo 3)) (SJust (SlotNo 42)))), - testCase "txupdate" (assertEqual "txupdate" (getField @"txupdate" tx) SNothing), - testCase "mdhash" (assertEqual "mdhash" (getField @"mdhash" tx) SNothing), + testCase "update" (assertEqual "update" (getField @"update" tx) SNothing), + testCase "mdHash" (assertEqual "mdHash" (getField @"mdHash" tx) SNothing), testCase "forge" (assertEqual "forge" (getField @"forge" tx) (inject (Coin 2))) ] diff --git a/shelley-ma/impl/test/Tests.hs b/shelley-ma/impl/test/Tests.hs index 00ea11cd686..83888b9e3fc 100644 --- a/shelley-ma/impl/test/Tests.hs +++ b/shelley-ma/impl/test/Tests.hs @@ -1,6 +1,7 @@ module Main where -import Test.Cardano.Ledger.ShelleyMA.Timelocks (timelockAndDecodeTests) +import Test.Cardano.Ledger.ShelleyMA.Coders (codersTest) +import Test.Cardano.Ledger.ShelleyMA.Timelocks (timelockTests) import Test.Cardano.Ledger.ShelleyMA.TxBody (txBodyTest) import Test.Tasty import Test.Tasty.HUnit () @@ -9,8 +10,9 @@ tests :: TestTree tests = testGroup "Cardano-Legder-Tests" - [ txBodyTest, - timelockAndDecodeTests + [ codersTest, + txBodyTest, + timelockTests ] -- main entry point diff --git a/shelley/chain-and-ledger/executable-spec/shelley-spec-ledger.cabal b/shelley/chain-and-ledger/executable-spec/shelley-spec-ledger.cabal index 5cf19ae4a43..3a92fca6c33 100644 --- a/shelley/chain-and-ledger/executable-spec/shelley-spec-ledger.cabal +++ b/shelley/chain-and-ledger/executable-spec/shelley-spec-ledger.cabal @@ -105,6 +105,7 @@ library cardano-crypto-class, cardano-crypto-wrapper, cardano-ledger, + cardano-crypto-praos, cardano-prelude, cardano-slotting, cborg, diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index 7959eafe296..0790657586a 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -116,7 +116,6 @@ import qualified Data.ByteString.Lazy as BSL (length) import Data.Coerce (coerce) import Data.Foldable (fold, toList) import Data.Group (invert) -import Data.Int (Int64) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) @@ -737,7 +736,6 @@ txsize = fromIntegral . BSL.length . txFullBytes txsizeBound :: forall era. ( ShelleyBased era, - HasField "extraSize" (Core.TxBody era) Int64, HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "inputs" (Core.TxBody era) (Set (TxIn era)) ) => @@ -757,7 +755,7 @@ txsizeBound tx = numInputs * inputSize + numOutputs * outputSize + rest inputSize = smallArray + uint + hashObj numOutputs = toInteger . length . getField @"outputs" $ txbody outputSize = smallArray + uint + address - rest = fromIntegral $ BSL.length (txFullBytes tx) - getField @"extraSize" txbody + rest = fromIntegral $ BSL.length (txFullBytes tx) -- | Minimum fee calculation minfee :: PParams era -> Tx era -> Coin @@ -770,7 +768,6 @@ minfee pp tx = minfeeBound :: forall era. ( ShelleyBased era, - HasField "extraSize" (Core.TxBody era) Int64, HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)), HasField "inputs" (Core.TxBody era) (Set (TxIn era)) ) => diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs index 0b0bb68e736..93adc7c9f1d 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs @@ -248,7 +248,7 @@ instance k -> invalidKey k instance - (CryptoClass.Crypto c) => + (CryptoClass.Crypto c, Core.TxBody (ShelleyEra c) ~ TxBody (ShelleyEra c)) => STS (UTXO (ShelleyEra c)) where type State (UTXO (ShelleyEra c)) = UTxOState (ShelleyEra c) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs index bc8a68a50b6..368826b9c4e 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs @@ -74,7 +74,7 @@ import Cardano.Binary import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CryptoClass import Cardano.Ledger.Era -import Cardano.Ledger.Shelley (ShelleyBased, ShelleyEra) +import Cardano.Ledger.Shelley (ShelleyBased, ShelleyEra, TxBodyConstraints) import qualified Cardano.Ledger.Shelley as Shelley import qualified Data.ByteString.Lazy as BSL import Data.Foldable (fold) @@ -352,7 +352,10 @@ class hashScript :: Core.Script era -> ScriptHash era -- | instance of MultiSignatureScript type class -instance CryptoClass.Crypto c => ValidateScript (ShelleyEra c) where +instance + (CryptoClass.Crypto c, TxBodyConstraints (ShelleyEra c)) => + ValidateScript (ShelleyEra c) + where validateScript = validateNativeMultiSigScript hashScript = hashMultiSigScript 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 cad29ed0645..d3eb7a0a2ed 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -21,6 +22,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} module Shelley.Spec.Ledger.TxBody ( DCert (..), @@ -39,7 +42,7 @@ module Shelley.Spec.Ledger.TxBody StakePoolRelay (..), TxBody ( TxBody, - TxBody', + TxBodyY, _inputs, _outputs, _certs, @@ -47,9 +50,9 @@ module Shelley.Spec.Ledger.TxBody _txfee, _ttl, _txUpdate, - _mdHash, - extraSize + _mdHash ), + -- TxBodyY(TxBodyZ,..), TxId (..), TxIn (TxIn, ..), EraIndependentTxBody, @@ -70,6 +73,8 @@ import Cardano.Binary ( Annotator (..), Case (..), Decoder, + DecoderError (..), + Encoding, FromCBOR (fromCBOR), Size, ToCBOR (..), @@ -88,6 +93,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.Prelude ( decodeEitherBase16, panic, @@ -103,13 +109,29 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Short as BSS +import Data.Coders + ( Decode (..), + Dual (..), + Encode (..), + Field (..), + Wrapped (..), + decode, + encode, + roundTrip, + roundTrip', + (!>), + ( Eq (TxBodyX era) + +deriving instance (Era era, ProperVal era) => Show (TxBodyX era) + +instance ProperFrom era => FromCBOR (TxBodyX era) where + fromCBOR = decode (SparseKeyed baseTxBodyX boxBody [0, 1, 2, 3]) + +-- The required keys [(0, "inputs"),(1, "outputs"),(2, "fee"),(3, "ttl")] + +instance ProperFrom era => FromCBOR (Annotator (TxBodyX era)) where + fromCBOR = pure <$> fromCBOR + +-- ================================================================= +-- Composable components for building TxBody optional sparse serialisers. +-- The order of serializing optional fields, and their key values is +-- demanded by backward compatibility concerns. + +-- | This Dual follows strategy of the the old code, for backward compatibility, +-- of serializing StrictMaybe values. The strategy is to serialise only the +-- value: 'x' in a (SJust x). The SNothing and the SJust part are never +-- written to the serialised bytes but are supplied by the Omit capability. +-- Be sure and wrap a (Omit isNothing (Key v _)) around use of this Dual. +-- Like this: (Omit isNothing (Key v (ED omitStrictNothingDual x))). +-- Neither the Omit or the key is needed for Decoders. +omitStrictNothingDual :: (FromCBOR t, ToCBOR t) => Dual (StrictMaybe t) +omitStrictNothingDual = Dual (toCBOR . fromJust . strictMaybeToMaybe) (SJust <$> fromCBOR) + +isSNothing :: StrictMaybe a -> Bool +isSNothing SNothing = True +isSNothing _ = False + +-- | Choose a de-serialiser when given the key (of type Word). +-- Wrap it in a Field which pairs it with its update function which +-- changes only the field being deserialised. +boxBody :: ProperFrom era => Word -> Field (TxBodyX era) +boxBody 0 = Field (\x tx -> tx {_inputsX = x}) (D (decodeSet fromCBOR)) +boxBody 1 = Field (\x tx -> tx {_outputsX = x}) (D (decodeStrictSeq fromCBOR)) +boxBody 4 = Field (\x tx -> tx {_certsX = x}) (D (decodeStrictSeq fromCBOR)) +boxBody 5 = Field (\x tx -> tx {_wdrlsX = x}) From +boxBody 2 = Field (\x tx -> tx {_txfeeX = x}) From +boxBody 3 = Field (\x tx -> tx {_ttlX = x}) From +boxBody 6 = Field (\x tx -> tx {_txUpdateX = x}) (DD omitStrictNothingDual) +boxBody 7 = Field (\x tx -> tx {_mdHashX = x}) (DD omitStrictNothingDual) +boxBody n = Field (\_ t -> t) (Invalid n) + +-- | Tells how to serialise each field, and what tag to label it with in the +-- serialisation. boxBody and txSparse should be Duals, visually inspect +-- The key order looks strange but was choosen for backward compatibility. +txSparse :: ProperTo era => TxBodyX era -> Encode 'Thin (TxBodyX era) +txSparse (TxBodyX input output cert wdrl fee ttl update hash) = + Sparse (\i o f t c w u h -> TxBodyX i o c w f t u h) + !> Key 0 (E encodeFoldable input) -- We don't have to send these in TxBodyX order + !> Key 1 (E encodeFoldable output) -- Just hack up a fake constructor with the lambda. + !> Key 2 (To fee) + !> Key 3 (To ttl) + !> Omit null (Key 4 (E encodeFoldable cert)) + !> Omit (null . unWdrl) (Key 5 (To wdrl)) + !> Omit isSNothing (Key 6 (ED omitStrictNothingDual update)) + !> Omit isSNothing (Key 7 (ED omitStrictNothingDual hash)) + +-- The initial TxBody. We will overide some of these fields as we build a TxBody, +-- adding one field at a time, using optional serialisers, inside the Pattern. +baseTxBodyX :: TxBodyX era +baseTxBodyX = + TxBodyX + { _inputsX = Set.empty, + _outputsX = StrictSeq.empty, + _txfeeX = Coin 0, + _ttlX = SlotNo 0, + _certsX = StrictSeq.empty, + _wdrlsX = Wdrl Map.empty, + _txUpdateX = SNothing, + _mdHashX = SNothing + } -instance HasField "mdHash" (TxBody era) (StrictMaybe (MetaDataHash era)) where - getField = _mdHash' +instance ProperTo era => ToCBOR (TxBodyX era) where + toCBOR x = encode (txSparse x) -type instance Core.TxBody (ShelleyEra c) = TxBody (ShelleyEra c) +-- ==================================================== +-- Introduce TxBody as a newtype around a MemoBytes -deriving instance (ShelleyBased era) => Eq (TxBody era) +newtype TxBody era = TxBodyY (MemoBytes (TxBodyX era)) + deriving (Generic, Typeable) + deriving newtype (NoThunks) -deriving instance (ShelleyBased era) => Show (TxBody era) +deriving instance ProperVal era => Show (TxBody era) -deriving via AllowThunksIn '["bodyBytes"] (TxBody era) instance Era era => NoThunks (TxBody era) +deriving instance ProperVal era => Eq (TxBody era) -instance Era era => HashAnnotated (TxBody era) era where - type HashIndex (TxBody era) = EraIndependentTxBody +deriving via + (Mem (TxBodyX era)) + instance + (ProperFrom era) => + FromCBOR (Annotator (TxBody era)) +-- | Pattern for use by external users pattern TxBody :: - ShelleyBased era => + ProperTo era => Set (TxIn era) -> StrictSeq (TxOut era) -> StrictSeq (DCert era) -> @@ -641,58 +752,67 @@ pattern TxBody :: StrictMaybe (MetaDataHash era) -> TxBody era pattern TxBody {_inputs, _outputs, _certs, _wdrls, _txfee, _ttl, _txUpdate, _mdHash} <- - TxBody' - { _inputs' = _inputs, - _outputs' = _outputs, - _certs' = _certs, - _wdrls' = _wdrls, - _txfee' = _txfee, - _ttl' = _ttl, - _txUpdate' = _txUpdate, - _mdHash' = _mdHash - } + TxBodyY + ( Memo + ( TxBodyX + { _inputsX = _inputs, + _outputsX = _outputs, + _certsX = _certs, + _wdrlsX = _wdrls, + _txfeeX = _txfee, + _ttlX = _ttl, + _txUpdateX = _txUpdate, + _mdHashX = _mdHash + } + ) + _ + ) where TxBody _inputs _outputs _certs _wdrls _txfee _ttl _txUpdate _mdHash = - let encodeMapElement ix enc x = Just (encodeWord ix <> enc x) - encodeMapElementUnless condition ix enc x = - if condition x - then Nothing - else encodeMapElement ix enc x - l = - catMaybes - [ encodeMapElement 0 encodePreEncoded inputBytes, - encodeMapElement 1 encodePreEncoded outputBytes, - encodeMapElement 2 encodePreEncoded feeBytes, - encodeMapElement 3 toCBOR _ttl, - encodeMapElementUnless null 4 encodeFoldable _certs, - encodeMapElementUnless (null . unWdrl) 5 toCBOR _wdrls, - encodeMapElement 6 toCBOR =<< strictMaybeToMaybe _txUpdate, - encodeMapElement 7 toCBOR =<< strictMaybeToMaybe _mdHash - ] - inputBytes = serializeEncoding' $ encodeFoldable _inputs - outputBytes = serializeEncoding' $ encodeFoldable _outputs - feeBytes = serializeEncoding' $ toCBOR _txfee - es = - fromIntegral $ - BS.length inputBytes - + BS.length outputBytes - + BS.length feeBytes - n = fromIntegral $ length l - bytes = serializeEncoding $ encodeMapLen n <> fold l - in TxBody' - _inputs - _outputs - _certs - _wdrls - _txfee - _ttl - _txUpdate - _mdHash - bytes - es + TxBodyY $ memoBytes (txSparse (TxBodyX _inputs _outputs _certs _wdrls _txfee _ttl _txUpdate _mdHash)) {-# COMPLETE TxBody #-} +instance Era era => HashAnnotated (TxBody era) era where + type HashIndex (TxBody era) = EraIndependentTxBody + +instance (Era era) => ToCBOR (TxBody era) where + toCBOR (TxBodyY memo) = toCBOR memo + +-- ========================================================================== +-- Here is where we declare that in the (ShelleyEra c) The abstract type family +-- Core.TxBody is set to THIS TxBody,The one we defined a few lines above. + +type instance Core.TxBody (ShelleyEra c) = TxBody (ShelleyEra c) + +-- =========================================================================== + +instance HasField "inputs" (TxBody e) (Set (TxIn e)) where + getField (TxBodyY (Memo m _)) = getField @"_inputsX" m + +instance HasField "outputs" (TxBody era) (StrictSeq (TxOut era)) where + getField (TxBodyY (Memo m _)) = getField @"_outputsX" m + +instance HasField "certs" (TxBody era) (StrictSeq (DCert era)) where + getField (TxBodyY (Memo m _)) = getField @"_certsX" m + +instance HasField "wdrls" (TxBody era) (Wdrl era) where + getField (TxBodyY (Memo m _)) = getField @"_wdrlsX" m + +instance HasField "txfee" (TxBody era) Coin where + getField (TxBodyY (Memo m _)) = getField @"_txfeeX" m + +instance HasField "ttl" (TxBody era) SlotNo where + getField (TxBodyY (Memo m _)) = getField @"_ttlX" m + +instance HasField "update" (TxBody era) (StrictMaybe (Update era)) where + getField (TxBodyY (Memo m _)) = getField @"_txUpdateX" m + +instance HasField "mdHash" (TxBody era) (StrictMaybe (MetaDataHash era)) where + getField (TxBodyY (Memo m _)) = getField @"_mdHashX" m + +-- =============================================================== + -- | Proof/Witness that a transaction is authorized by the given key holder. data WitVKey kr era = WitVKey' { wvkKey' :: !(VKey kr (Crypto era)), @@ -905,83 +1025,6 @@ instance where mkWitVKey k sig = WitVKey' k sig (asWitness $ hashKey k) -instance - (Era era) => - ToCBOR (TxBody era) - where - toCBOR = encodePreEncoded . BSL.toStrict . bodyBytes - -instance - ShelleyBased era => - FromCBOR (Annotator (TxBody era)) - where - fromCBOR = annotatorSlice $ do - mapParts <- - decodeMapContents $ - decodeWord >>= \case - 0 -> f 0 (decodeSet fromCBOR) $ \bytes x t -> - t - { _inputs' = x, - extraSize = extraSize t + BSL.length bytes - } - 1 -> f 1 (decodeStrictSeq fromCBOR) $ \bytes x t -> - t - { _outputs' = x, - extraSize = extraSize t + BSL.length bytes - } - 2 -> f 2 fromCBOR $ \bytes x t -> - t - { _txfee' = x, - extraSize = extraSize t + BSL.length bytes - } - 3 -> f 3 fromCBOR $ \_ x t -> t {_ttl' = x} - 4 -> f 4 (decodeStrictSeq fromCBOR) $ \_ x t -> t {_certs' = x} - 5 -> f 5 fromCBOR $ \_ x t -> t {_wdrls' = x} - 6 -> f 6 fromCBOR $ \_ x t -> t {_txUpdate' = SJust x} - 7 -> f 7 fromCBOR $ \_ x t -> t {_mdHash' = SJust x} - k -> invalidKey k - let requiredFields :: Map Int String - requiredFields = - Map.fromList $ - [ (0, "inputs"), - (1, "outputs"), - (2, "fee"), - (3, "ttl") - ] - fields = fst <$> mapParts - missingFields = Map.filterWithKey (\k _ -> notElem k fields) requiredFields - unless - (null missingFields) - (fail $ "missing required transaction component(s): " <> show missingFields) - pure $ - Annotator $ - \fullbytes bytes -> - (foldr ($) basebody (flip runAnnotator fullbytes . snd <$> mapParts)) {bodyBytes = bytes} - where - f :: - Int -> - Decoder s a -> - (BSL.ByteString -> a -> TxBody era -> TxBody era) -> - Decoder s (Int, Annotator (TxBody era -> TxBody era)) - f key decoder updater = do - (x, annBytes) <- withSlice decoder - let result = Annotator $ \fullbytes txbody -> - updater (runAnnotator annBytes fullbytes) x txbody - pure (key, result) - basebody = - TxBody' - { _inputs' = Set.empty, - _outputs' = StrictSeq.empty, - _txfee' = Coin 0, - _ttl' = SlotNo 0, - _certs' = StrictSeq.empty, - _wdrls' = Wdrl Map.empty, - _txUpdate' = SNothing, - _mdHash' = SNothing, - bodyBytes = mempty, - extraSize = 0 - } - instance ToCBOR PoolMetaData where toCBOR (PoolMetaData u h) = encodeListLen 2 @@ -1076,6 +1119,8 @@ instance _poolMD = maybeToStrictMaybe md } +{- + instance Relation (StakeCreds era) where type Domain (StakeCreds era) = Credential 'Staking era type Range (StakeCreds era) = SlotNo @@ -1110,3 +1155,4 @@ instance Relation (StakeCreds era) where {-# INLINE removekey #-} removekey k (StakeCreds m) = StakeCreds (Map.delete k m) +-}