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) +-}