Skip to content

Commit

Permalink
TxBody for ShelleMA (Mary and Allegra) eras
Browse files Browse the repository at this point in the history 
* "Added the TxBody type with validity intervals and forge fields. Tied this
together with the Timelocks scripts. TxBody is newtype wrapped around a MemoBytes.
It exports a set of HasField instances appropriate for a TxBody. Also created a
test file with a minumum number of test, testing the HasField use and roundtripp
CBOR properties. Cleaned up and extended Jareds idea of using EraIndependentTxBody.
Extended this to all types with a HashAnnotated instance, which now adds an
associated type family HashIndex. Made all uses consistent with this approach,
Removed the function eraIndTxBodyHash, which can be replaced hashAnnotated."

* Remove dead code in comments

Co-authored-by: Nicholas Clarke <nicholas.clarke@iohk.io>
  • Loading branch information
@TimSheard @nc6
TimSheard and nc6 committed Oct 26, 2020
1 parent 2289009 commit 05b708d
Show file tree
Hide file tree
Showing 31 changed files with 737 additions and 247 deletions.
27 changes: 14 additions & 13 deletions semantics/executable-spec/src/Data/Coders.hs
View file
Expand Up @@ -13,6 +13,9 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}

-- | 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.
Expand All @@ -27,6 +30,8 @@ module Data.Coders
Wrapped (..),
encode,
decode,
runE, -- Used in testing
decodeClosed, -- Used in testing
decodeList,
decodeSeq,
decodeStrictSeq,
Expand All @@ -35,8 +40,6 @@ module Data.Coders
encodeSeq,
encodeStrictSeq,
encodeSet,
runE, -- for testing
decodeClosed, -- for testing
decodeRecordNamed,
decodeRecordSum,
invalidKey,
Expand All @@ -45,13 +48,17 @@ module Data.Coders
decodeCollectionWithLen,
decodeCollection,
encodeFoldableEncoder,
roundTrip,
)
where

import Cardano.Prelude (cborError)
import Control.Monad (replicateM,unless)
import Codec.CBOR.Decoding (Decoder)
import Codec.CBOR.Encoding (Encoding)
import Codec.CBOR.Read(DeserialiseFailure,deserialiseFromBytes)
import Codec.CBOR.Write (toLazyByteString)
import qualified Data.ByteString.Lazy as Lazy
import Cardano.Binary
( FromCBOR (fromCBOR),
ToCBOR (toCBOR),
Expand All @@ -74,16 +81,7 @@ import Data.Sequence (Seq)
import Data.Set (Set)
import Data.Text (Text)
import Data.Foldable (foldl')


{-
import Shelley.Spec.Ledger.Serialization
(
encodeFoldable,
)
-}


import Prelude hiding (span)

decodeRecordNamed :: Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed name getRecordSize decoder = do
Expand Down Expand Up @@ -371,4 +369,7 @@ encodeSet = encodeFoldable

-- ===========================================
-- 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
-- cardano-ledger-specs/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/MemoBytes.hs

roundTrip :: (ToCBOR t,FromCBOR t) => t -> Either Codec.CBOR.Read.DeserialiseFailure (Lazy.ByteString, t)
roundTrip s = deserialiseFromBytes fromCBOR (toLazyByteString (toCBOR s))
21 changes: 16 additions & 5 deletions semantics/executable-spec/src/Data/MemoBytes.hs
View file
Expand Up @@ -12,6 +12,9 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}

-- | MemoBytes is an abstration for a datetype that encodes its own serialization.
-- The idea is to use a newtype around a MemoBytes non-memoizing version.
Expand All @@ -25,7 +28,7 @@ module Data.MemoBytes
shorten,
showMemo,
printMemo,

roundTripMemo,
)
where
import Cardano.Binary
Expand All @@ -37,18 +40,19 @@ import Cardano.Binary
)
import Data.ByteString.Short (ShortByteString, fromShort, toShort)
import qualified Data.ByteString.Lazy as Lazy
import Data.ByteString.Lazy (toStrict)
import Data.ByteString.Lazy (toStrict,fromStrict)
import Data.Typeable
import Data.Coders(runE, Encode, encode,)
import Codec.CBOR.Write (toLazyByteString)
import GHC.Generics (Generic)
import NoThunks.Class (AllowThunksIn (..), NoThunks (..))
import NoThunks.Class (NoThunks (..),AllowThunksIn(..))
import Prelude hiding (span)
import Codec.CBOR.Read(DeserialiseFailure,deserialiseFromBytes)

-- ========================================================================

data MemoBytes t = Memo {memotype :: !t, memobytes :: {-# UNPACK #-} !ShortByteString}
deriving (NoThunks) via AllowThunksIn '["memobytes"] (MemoBytes t)
data MemoBytes t = Memo {memotype :: !t, memobytes :: ShortByteString}
deriving (NoThunks) via AllowThunksIn '["memobytes"] (MemoBytes t)

deriving instance Generic (MemoBytes t)

Expand Down Expand Up @@ -82,3 +86,10 @@ printMemo x = putStrLn (showMemo x)

memoBytes :: Encode w t -> MemoBytes t
memoBytes t = Memo (runE t) (shorten (toLazyByteString (encode t)))


roundTripMemo:: (FromCBOR t) => MemoBytes t -> Either Codec.CBOR.Read.DeserialiseFailure (Lazy.ByteString, MemoBytes t)
roundTripMemo (Memo _t bytes) =
case deserialiseFromBytes fromCBOR (fromStrict (fromShort bytes)) of
Left err -> Left err
Right(leftover, newt) -> Right(leftover,Memo newt bytes)
51 changes: 50 additions & 1 deletion shelley-ma/impl/cardano-ledger-shelley-ma.cabal
View file
Expand Up @@ -26,6 +26,7 @@ library
Cardano.Ledger.Mary.Translation
Cardano.Ledger.ShelleyMA.Value
Cardano.Ledger.ShelleyMA.Timelocks
Cardano.Ledger.ShelleyMA.TxBody
other-modules:
Cardano.Ledger.ShelleyMA

Expand All @@ -35,6 +36,7 @@ library
bytestring,
cardano-binary,
cardano-crypto-class,
cardano-crypto-praos,
cardano-prelude,
cardano-slotting,
containers,
Expand All @@ -43,7 +45,7 @@ library
nothunks,
partial-order,
shelley-spec-ledger,
small-steps
small-steps,
hs-source-dirs: src
ghc-options:
-Wall
Expand All @@ -53,3 +55,50 @@ library
-Wredundant-constraints
-Wpartial-fields
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

hs-source-dirs: test
default-language: Haskell2010
ghc-options:
-threaded
-rtsopts
-with-rtsopts=-N
-Wall
-Wcompat
-Wincomplete-record-updates
-Wincomplete-uni-patterns
-Wredundant-constraints
-- We set a bound here so that we're alerted of potential space
-- leaks in our generators (or test) code.
--
-- The 4 megabytes stack bound and 200 megabytes heap bound were
-- determined ad-hoc.
"-with-rtsopts=-K4m -M250m"
build-depends:
cardano-ledger-shelley-ma,
base >=4.9 && <4.15,
bytestring,
cardano-binary,
cardano-crypto-class,
cardano-crypto-praos,
cardano-prelude,
cardano-slotting,
cborg,
containers,
deepseq,
groups,
nothunks,
partial-order,
shelley-spec-ledger,
small-steps,
tasty-hedgehog,
tasty-hunit,
tasty-quickcheck,
tasty,
81 changes: 52 additions & 29 deletions shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs
View file
Expand Up @@ -12,10 +12,12 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.ShelleyMA.Timelocks
Expand All @@ -24,13 +26,16 @@ module Cardano.Ledger.ShelleyMA.Timelocks
hashTimelockScript,
showTimelock,
validateTimelock,
ValidityInterval (..),
encodeVI,
decodeVI,
)
where

import Cardano.Binary
( Annotator (..),
FromCBOR (fromCBOR),
ToCBOR,
ToCBOR (toCBOR),
serialize',
)
import qualified Cardano.Crypto.Hash as Hash
Expand All @@ -39,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 (Encode (..), (!>))
import Data.Coders (Decode (..), Encode (..), Wrapped (..), decode, encode, (!>), (<!))
import Data.MemoBytes
( Mem,
MemoBytes (..),
Expand All @@ -49,6 +54,7 @@ import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import GHC.Records
import NoThunks.Class (NoThunks (..))
import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (SJust, SNothing), invalidKey)
import Shelley.Spec.Ledger.Keys (KeyHash (..), KeyRole (Witness))
Expand All @@ -71,6 +77,27 @@ import Shelley.Spec.Ledger.TxBody
( witKeyHash,
)

-- ================================================================
-- An pair of optional SlotNo.

data ValidityInterval = ValidityInterval
{ validFrom :: !(StrictMaybe SlotNo),
validTo :: !(StrictMaybe SlotNo)
}
deriving (Ord, Eq, Generic, Show, NoThunks)

encodeVI :: ValidityInterval -> Encode 'Closed ValidityInterval
encodeVI (ValidityInterval f t) = Rec ValidityInterval !> To f !> To t

instance ToCBOR ValidityInterval where
toCBOR vi = encode (encodeVI vi)

decodeVI :: Decode 'Closed ValidityInterval
decodeVI = RecD ValidityInterval <! From <! From

instance FromCBOR ValidityInterval where
fromCBOR = decode decodeVI

-- ================================================================
-- Timelock' and Timelock are mutually recursive. Timelock adds a
-- convenient place to hang the memoized serialized bytes by
Expand All @@ -79,7 +106,7 @@ import Shelley.Spec.Ledger.TxBody
-- 2) Serializer code (replaces ToCBOR instances) in the Patterns for Timelock

data Timelock' era
= Interval' !(StrictMaybe SlotNo) !(StrictMaybe SlotNo)
= Interval' !ValidityInterval
| Multi' !(MultiSig era)
| TimelockAnd' !(StrictSeq (Timelock era)) -- Note the hidden recursion of Timelock', through Timelock.
| TimelockOr' !(StrictSeq (Timelock era))
Expand All @@ -92,10 +119,9 @@ instance
fromCBOR = decodeRecordSum "Timelock" $
\case
0 -> do
left <- fromCBOR -- this: fromCBOR :: (Decoder s (StrictMaybe SlotNo))
right <- fromCBOR
pure $ (3, pure (Interval' left right)) -- Note the pure lifts from T to (Annotator T)
-- Possible because intervalpair has no memoized
interval <- fromCBOR -- this: fromCBOR :: (Decoder s ValidityInterval)
pure $ (2, pure (Interval' interval)) -- Note the pure lifts from T to (Annotator T)
-- Possible because ValidityInterval has no memoized
-- structures that remember their own bytes.
1 -> do
multi <- fromCBOR
Expand Down Expand Up @@ -127,13 +153,12 @@ deriving via

pattern Interval ::
Era era =>
StrictMaybe SlotNo ->
StrictMaybe SlotNo ->
ValidityInterval ->
Timelock era
pattern Interval left right <-
Timelock (Memo (Interval' left right) _)
pattern Interval valid <-
Timelock (Memo (Interval' valid) _)
where
Interval left right = Timelock $ memoBytes $ Sum Interval' 0 !> To left !> To right
Interval valid = Timelock $ memoBytes $ Sum Interval' 0 !> To valid

pattern Multi :: Era era => MultiSig era -> Timelock era
pattern Multi m <-
Expand Down Expand Up @@ -168,28 +193,23 @@ ininterval slot (SJust i_s, SJust i_f) = i_s <= slot && slot <= i_f

-- =======================================================
-- Validating timelock scripts
-- The following functions are stubs, since (TxBody era) does not currently
-- contain a validity interval. At somepoint txvld :: TxBody era -> ValidityInterval
-- will provide this operation. We will also need to correctly compute the witness
-- set for this new (TxBody era) as well.

type ValidityInterval = (StrictMaybe SlotNo, StrictMaybe SlotNo)

txvld :: Core.TxBody era -> ValidityInterval
txvld _ = (SNothing, SNothing)
-- We Assume that TxBody has field "vldt" that extracts a ValidityInterval
-- We still need to correctly compute the witness set for Core.TxBody as well.

evalFPS ::
forall era.
Era era =>
( Era era,
HasField "vldt" (Core.TxBody era) ValidityInterval
) =>
Timelock era ->
Set (KeyHash 'Witness (Crypto era)) ->
Core.TxBody era ->
Bool
evalFPS (TimelockAnd locks) vhks txb = all (\lock -> evalFPS lock vhks txb) locks
evalFPS (TimelockOr locks) vhks txb = any (\lock -> evalFPS lock vhks txb) locks
evalFPS (Multi msig) vhks _tx = evalNativeMultiSigScript msig vhks
evalFPS (Interval timeS timeF) _vhks txb =
let (bodyS, bodyF) = txvld @era txb -- THIS IS A STUB
evalFPS (Interval (ValidityInterval timeS timeF)) _vhks txb =
let (ValidityInterval bodyS bodyF) = getField @"vldt" txb -- THIS IS A STUB
in case (timeS, timeF) of
(SNothing, SNothing) -> True
(SNothing, SJust i_f) | SJust i'_f <- bodyF -> i'_f <= i_f
Expand All @@ -201,7 +221,10 @@ evalFPS (Interval timeS timeF) _vhks txb =
_ -> False

validateTimelock ::
Shelley.TxBodyConstraints era => Timelock era -> Tx era -> Bool
(Shelley.TxBodyConstraints era, HasField "vldt" (Core.TxBody era) ValidityInterval) =>
Timelock era ->
Tx era ->
Bool
validateTimelock lock tx = evalFPS lock vhks (_body tx)
where
-- THIS IS JUST A STUB. WHO KNOWS IF
Expand All @@ -225,10 +248,10 @@ hashTimelockScript =
. Hash.hashWith (\x -> nativeTimelockTag <> serialize' x)

showTimelock :: Era era => Timelock era -> String
showTimelock (Interval SNothing SNothing) = "(Interval -inf .. +inf)"
showTimelock (Interval (SJust (SlotNo x)) SNothing) = "(Interval " ++ show x ++ " .. +inf)"
showTimelock (Interval SNothing (SJust (SlotNo x))) = "(Interval -inf .. " ++ show x ++ ")"
showTimelock (Interval (SJust (SlotNo y)) (SJust (SlotNo x))) = "(Interval " ++ show y ++ " .. " ++ show x ++ ")"
showTimelock (Interval (ValidityInterval SNothing SNothing)) = "(Interval -inf .. +inf)"
showTimelock (Interval (ValidityInterval (SJust (SlotNo x)) SNothing)) = "(Interval " ++ show x ++ " .. +inf)"
showTimelock (Interval (ValidityInterval SNothing (SJust (SlotNo x)))) = "(Interval -inf .. " ++ show x ++ ")"
showTimelock (Interval (ValidityInterval (SJust (SlotNo y)) (SJust (SlotNo x)))) = "(Interval " ++ show y ++ " .. " ++ show x ++ ")"
showTimelock (TimelockAnd xs) = "(TimelockAnd " ++ foldl accum ")" xs where accum ans x = showTimelock x ++ " " ++ ans
showTimelock (TimelockOr xs) = "(TimelockOr " ++ foldl accum ")" xs where accum ans x = showTimelock x ++ " " ++ ans
showTimelock (Multi x) = show x

0 comments on commit 05b708d

Please sign in to comment.