serialization for ShelleyGenesis

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Genesis.hs

@@ -27,6 +27,7 @@ module Shelley.Spec.Ledger.Genesis
  )
 where
 
+import Cardano.Binary (FromCBOR (..), ToCBOR (..), encodeListLen)
 import qualified Cardano.Crypto.Hash.Class as Crypto
 import Cardano.Crypto.KES.Class (totalPeriodsKES)
 import qualified Cardano.Ledger.Core as Core
@@ -57,6 +58,13 @@ import Shelley.Spec.Ledger.BaseTypes
 import Shelley.Spec.Ledger.Coin
 import Shelley.Spec.Ledger.Keys
 import Shelley.Spec.Ledger.PParams
+import Shelley.Spec.Ledger.Serialization
+ ( decodeRecordNamed,
+ mapFromCBOR,
+ mapToCBOR,
+ utcTimeFromCBOR,
+ utcTimeToCBOR,
+ )
 import Shelley.Spec.Ledger.StabilityWindow
 import Shelley.Spec.Ledger.TxBody
 import Shelley.Spec.Ledger.UTxO
@@ -88,6 +96,17 @@ data ShelleyGenesisStaking era = ShelleyGenesisStaking
 
 instance NoThunks (ShelleyGenesisStaking era)
 
+instance Era era => ToCBOR (ShelleyGenesisStaking era) where
+ toCBOR (ShelleyGenesisStaking pools stake) =
+ encodeListLen 2 <> mapToCBOR pools <> mapToCBOR stake
+
+instance Era era => FromCBOR (ShelleyGenesisStaking era) where
+ fromCBOR = do
+ decodeRecordNamed "ShelleyGenesisStaking" (const 2) $ do
+ pools <- mapFromCBOR
+ stake <- mapFromCBOR
+ pure $ ShelleyGenesisStaking pools stake
+
 -- | Empty genesis staking
 emptyGenesisStaking :: ShelleyGenesisStaking era
 emptyGenesisStaking =
@@ -190,6 +209,78 @@ instance Era era => FromJSON (ShelleyGenesisStaking era) where
  <$> (forceElemsToWHNF <$> obj .: "pools")
  <*> (forceElemsToWHNF <$> obj .: "stake")
 
+instance Era era => ToCBOR (ShelleyGenesis era) where
+ toCBOR
+ ShelleyGenesis
+ { sgSystemStart,
+ sgNetworkMagic,
+ sgNetworkId,
+ sgActiveSlotsCoeff,
+ sgSecurityParam,
+ sgEpochLength,
+ sgSlotsPerKESPeriod,
+ sgMaxKESEvolutions,
+ sgSlotLength,
+ sgUpdateQuorum,
+ sgMaxLovelaceSupply,
+ sgProtocolParams,
+ sgGenDelegs,
+ sgInitialFunds,
+ sgStaking
+ } =
+ encodeListLen 15
+ <> utcTimeToCBOR sgSystemStart
+ <> toCBOR sgNetworkMagic
+ <> toCBOR sgNetworkId
+ <> toCBOR sgActiveSlotsCoeff
+ <> toCBOR sgSecurityParam
+ <> toCBOR (unEpochSize sgEpochLength)
+ <> toCBOR sgSlotsPerKESPeriod
+ <> toCBOR sgMaxKESEvolutions
+ <> toCBOR sgSlotLength
+ <> toCBOR sgUpdateQuorum
+ <> toCBOR sgMaxLovelaceSupply
+ <> toCBOR sgProtocolParams
+ <> mapToCBOR sgGenDelegs
+ <> mapToCBOR sgInitialFunds
+ <> toCBOR sgStaking
+
+instance Era era => FromCBOR (ShelleyGenesis era) where
+ fromCBOR = do
+ decodeRecordNamed "ShelleyGenesis" (const 15) $ do
+ sgSystemStart <- utcTimeFromCBOR
+ sgNetworkMagic <- fromCBOR
+ sgNetworkId <- fromCBOR
+ sgActiveSlotsCoeff <- fromCBOR
+ sgSecurityParam <- fromCBOR
+ sgEpochLength <- fromCBOR
+ sgSlotsPerKESPeriod <- fromCBOR
+ sgMaxKESEvolutions <- fromCBOR
+ sgSlotLength <- fromCBOR
+ sgUpdateQuorum <- fromCBOR
+ sgMaxLovelaceSupply <- fromCBOR
+ sgProtocolParams <- fromCBOR
+ sgGenDelegs <- mapFromCBOR
+ sgInitialFunds <- mapFromCBOR
+ sgStaking <- fromCBOR
+ pure $
+ ShelleyGenesis
+ sgSystemStart
+ sgNetworkMagic
+ sgNetworkId
+ sgActiveSlotsCoeff
+ sgSecurityParam
+ (EpochSize sgEpochLength)
+ sgSlotsPerKESPeriod
+ sgMaxKESEvolutions
+ sgSlotLength
+ sgUpdateQuorum
+ sgMaxLovelaceSupply
+ sgProtocolParams
+ sgGenDelegs
+ sgInitialFunds
+ sgStaking
+
 {-------------------------------------------------------------------------------
  Genesis UTxO
 -------------------------------------------------------------------------------}

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Serialization.hs

@@ -45,6 +45,9 @@ module Shelley.Spec.Ledger.Serialization
  -- Raw
  listLenInt,
  runByteBuilder,
+ -- UTC Time
+ utcTimeToCBOR,
+ utcTimeFromCBOR,
  )
 where
 
@@ -107,6 +110,9 @@ import Data.Sequence (Seq)
 import qualified Data.Sequence as Seq
 import Data.Text (Text)
 import qualified Data.Text as Text
+import Data.Time (UTCTime (..))
+import Data.Time.Calendar.OrdinalDate (fromOrdinalDate, toOrdinalDate)
+import Data.Time.Clock (diffTimeToPicoseconds, picosecondsToDiffTime)
 import Data.Typeable
 import Network.Socket (HostAddress6)
 import Prelude
@@ -310,3 +316,23 @@ runByteBuilder !sizeHint =
  (BS.safeStrategy sizeHint (2 * sizeHint))
  mempty
 {-# NOINLINE runByteBuilder #-}
+
+utcTimeToCBOR :: UTCTime -> Encoding
+utcTimeToCBOR t =
+ encodeListLen 3
+ <> toCBOR year
+ <> toCBOR dayOfYear
+ <> (toCBOR . diffTimeToPicoseconds . utctDayTime) t
+ where
+ (year, dayOfYear) = toOrdinalDate . utctDay $ t
+
+utcTimeFromCBOR :: Decoder s UTCTime
+utcTimeFromCBOR = do
+ decodeRecordNamed "UTCTime" (const 3) $ do
+ year <- fromCBOR
+ dayOfYear <- fromCBOR
+ diff <- fromCBOR
+ pure $
+ UTCTime
+ (fromOrdinalDate year dayOfYear)
+ (picosecondsToDiffTime diff)

shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/Generators.hs

@@ -40,7 +40,7 @@ import Cardano.Ledger.Crypto (DSIGN)
 import Cardano.Ledger.Era (Crypto, Era)
 import qualified Cardano.Ledger.Shelley as Shelley
 import Cardano.Slotting.Block (BlockNo (..))
-import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..))
+import Cardano.Slotting.Slot (EpochNo (..), EpochSize (..), SlotNo (..))
 import Control.SetAlgebra (biMapFromList)
 import qualified Data.ByteString.Char8 as BS
 import Data.Coerce (coerce)
@@ -51,6 +51,8 @@ import Data.Proxy (Proxy (..))
 import Data.Ratio ((%))
 import Data.Sequence.Strict (StrictSeq)
 import qualified Data.Sequence.Strict as StrictSeq
+import qualified Data.Time as Time
+import qualified Data.Time.Calendar.OrdinalDate as Time
 import qualified Data.Text as T
 import Data.Typeable (Typeable)
 import Data.Word (Word64, Word8)
@@ -708,3 +710,31 @@ genByteString :: Int -> Gen BS.ByteString
 genByteString size = do
  ws <- vectorOf size (chooseAny @Char)
  return $ BS.pack ws
+
+genUTCTime :: Gen Time.UTCTime
+genUTCTime = do
+ year <- arbitrary
+ dayOfYear <- arbitrary
+ diff <- arbitrary
+ pure $ Time.UTCTime
+ (Time.fromOrdinalDate year dayOfYear)
+ (Time.picosecondsToDiffTime diff)
+
+instance (ShelleyTest era, Mock (Crypto era)) => Arbitrary (ShelleyGenesis era) where
+ arbitrary =
+ ShelleyGenesis
+ <$> genUTCTime -- sgSystemStart
+ <*> arbitrary -- sgNetworkMagic
+ <*> arbitrary -- sgNetworkId
+ <*> arbitrary -- sgActiveSlotsCoeff
+ <*> arbitrary -- sgSecurityParam
+ <*> (EpochSize <$> arbitrary) -- sgEpochLength
+ <*> arbitrary -- sgSlotsPerKESPeriod
+ <*> arbitrary -- sgMaxKESEvolutions
+ <*> (fromInteger <$> arbitrary) -- sgSlotLength
+ <*> arbitrary -- sgUpdateQuorum
+ <*> arbitrary -- sgMaxLovelaceSupply
+ <*> genPParams (Proxy @era) -- sgProtocolParams
+ <*> arbitrary -- sgGenDelegs
+ <*> arbitrary -- sgInitialFunds
+ <*> (ShelleyGenesisStaking <$> arbitrary <*> arbitrary) -- sgStaking

shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Golden/Genesis.hs

@@ -9,10 +9,12 @@ module Test.Shelley.Spec.Ledger.Serialisation.Golden.Genesis
  ( tests,
 
  -- * Individual properties
- prop_golden_ShelleyGenesis,
+ prop_golden_json_ShelleyGenesis,
+ prop_golden_cbor_ShelleyGenesis,
  )
 where
 
+import Cardano.Binary (Encoding (..), ToCBOR (..), Tokens (..), serializeEncoding)
 import qualified Cardano.Crypto.Hash as Hash
 import Cardano.Ledger.Crypto (HASH)
 import Cardano.Ledger.Era (Crypto (..))
@@ -39,19 +41,106 @@ import Test.Shelley.Spec.Ledger.Utils
  unsafeMkUnitInterval,
  )
 import Test.Tasty
+import Test.Tasty.HUnit (Assertion, assertFailure, testCase)
 import Test.Tasty.Hedgehog
 
-prop_golden_ShelleyGenesis :: Property
-prop_golden_ShelleyGenesis = goldenTestJSONPretty example "test/Golden/ShelleyGenesis"
+prop_golden_json_ShelleyGenesis :: Property
+prop_golden_json_ShelleyGenesis = goldenTestJSONPretty example "test/Golden/ShelleyGenesis"
  where
  example :: ShelleyGenesis C
  example = exampleShelleyGenesis
 
+prop_golden_cbor_ShelleyGenesis :: Assertion
+prop_golden_cbor_ShelleyGenesis =
+ if serializeEncoding received /= serializeEncoding expected
+ then
+ assertFailure $
+ mconcat
+ [ "\nexpected:\n",
+ show expected,
+ "\nexpected:\n",
+ show received,
+ "\n"
+ ]
+ else return ()
+ where
+ example :: ShelleyGenesis C
+ example = exampleShelleyGenesis
+
+ received = Encoding expectedTokens
+ expected = toCBOR example
+
+ expectedTokens =
+ TkListLen 15
+ . TkListLen 3 . TkInt 2009 . TkInt 44 . TkInt 83589000000000000 -- sgSystemStart
+ . TkInt 4036000900 -- sgNetworkMagic
+ . TkInt 0 -- sgNetworkId
+ . TkListLen 2 . TkInt 6259 . TkInt 1000 -- sgActiveSlotsCoeff
+ . TkInt 120842 -- sgSecurityParam
+ . TkInt 1215 -- sgEpochLength
+ . TkInt 8541 -- sgSlotsPerKESPeriod
+ . TkInt 28899 -- sgMaxKESEvolutions
+ . TkInt 8000000 -- sgSlotLength
+ . TkInt 16991 -- sgUpdateQuorum
+ . TkInt 71 -- sgMaxLovelaceSupply
+ . TkListLen 18 -- sgProtocolParams
+ . TkInt 0
+ . TkInt 0
+ . TkInt 239857
+ . TkInt 2048
+ . TkInt 217569
+ . TkInt 0
+ . TkInt 0
+ . TkInt 0
+ . TkInt 100
+ . TkTag 30 . TkListLen 2 . TkInt 0 . TkInt 1
+ . TkTag 30 . TkListLen 2 . TkInt 0 . TkInt 1
+ . TkTag 30 . TkListLen 2 . TkInt 0 . TkInt 1
+ . TkTag 30 . TkListLen 2 . TkInt 19 . TkInt 1000
+ . TkListLen 1 . TkInt 0
+ . TkInt 0
+ . TkInt 0
+ . TkInt 0
+ . TkInt 0
+ . TkMapLen 1 -- sgGenDelegs
+ . TkBytes "#\213\RS\145#\213\RS\145"
+ . TkListLen 2
+ . TkBytes "\131\155\EOT\DEL\131\155\EOT\DEL"
+ . TkBytes "#\DC3\145\231#\DC3\145\231\SOH#"
+ . TkMapLen 1 -- sgInitialFunds
+ . TkBytes "\NUL\FS\DC4\238\142\FS\DC4\238\142\227ze\234\227ze\234"
+ . TkInt 12157196
+ . TkListLen 2 -- sgStaking
+ . TkMapLen 1 -- sgsPools
+ . TkBytes "=\190\NUL\161=\190\NUL\161"
+ . TkListLen 9 -- PoolParams
+ . TkBytes "\160\132\186\143l\131\193\165"
+ . TkBytes "\237\201\a\154O7\FS\172\&1\SI"
+ . TkInt 1
+ . TkInt 5
+ . TkTag 30 . TkListLen 2 . TkInt 1 . TkInt 4
+ . TkBytes "\224\248h\161\150\n?\160C"
+ . TkListLen 1 . TkBytes "\248h\161\150\n?\160C"
+ . TkListLen 3
+ . TkListLen 4
+ . TkInt 0
+ . TkInt 1234
+ . TkBytes "\NUL\NUL\NUL\NUL"
+ . TkBytes "\184\r\SOH \NUL\NUL\n\NUL\NUL\NUL\NUL\NUL#\SOH\NUL\NUL"
+ . TkListLen 3 . TkInt 1 . TkNull . TkString "cool.domain.com"
+ . TkListLen 2 . TkInt 2 . TkString "cool.domain.com"
+ . TkListLen 2 . TkString "best.pool.com" . TkBytes "100ab{}100ab{}"
+ . TkMapLen 1 -- sgsStake
+ . TkBytes "\FS\DC4\238\142\FS\DC4\238\142"
+ . TkBytes "\FS\DC4\238\142\FS\DC4\238\142"
+ -- TODO - return a CBOR diff in the case of failure
+
 tests :: TestTree
 tests =
  testGroup
  "Shelley Genesis golden tests"
- [ testProperty "ShelleyGenesis golden test" prop_golden_ShelleyGenesis
+ [ testProperty "ShelleyGenesis JSON golden test" prop_golden_json_ShelleyGenesis
+ , testCase "ShelleyGenesis CBOR golden test" prop_golden_cbor_ShelleyGenesis
  ]
 
 exampleShelleyGenesis ::

shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Tripping/CBOR.hs

@@ -30,6 +30,7 @@ module Test.Shelley.Spec.Ledger.Serialisation.Tripping.CBOR
  prop_roundtrip_LedgerState,
  prop_roundtrip_NewEpochState,
  prop_roundtrip_Script,
+ prop_roundtrip_ShelleyGenesis,
  )
 where
 
@@ -46,6 +47,7 @@ import Codec.CBOR.Read (deserialiseFromBytes)
 import Codec.CBOR.Write (toLazyByteString)
 import qualified Data.ByteString.Lazy as Lazy
 import qualified Shelley.Spec.Ledger.API as Ledger
+import Shelley.Spec.Ledger.Genesis (ShelleyGenesis)
 import qualified Shelley.Spec.Ledger.STS.Ledgers as STS
 import qualified Shelley.Spec.Ledger.STS.Prtcl as STS (PrtclState)
 import qualified Test.Shelley.Spec.Ledger.ConcreteCryptoTypes as Mock
@@ -144,6 +146,9 @@ prop_roundtrip_Script = roundtrip' toCBOR ((. Full) . runAnnotator <$> fromCBOR)
 prop_roundtrip_metadata :: Ledger.MetaData -> Property
 prop_roundtrip_metadata = roundtrip' toCBOR ((. Full) . runAnnotator <$> fromCBOR)
 
+prop_roundtrip_ShelleyGenesis :: ShelleyGenesis Mock.C -> Property
+prop_roundtrip_ShelleyGenesis = roundtrip toCBOR fromCBOR
+
 -- TODO
 
 -- roundTripIpv4 :: Property
@@ -184,5 +189,6 @@ tests =
  testProperty "roundtrip NewEpoch State" prop_roundtrip_NewEpochState,
  testProperty "roundtrip MultiSig" prop_roundtrip_MultiSig,
  testProperty "roundtrip Script" prop_roundtrip_Script,
- testProperty "roundtrip MetaData" prop_roundtrip_metadata
+ testProperty "roundtrip MetaData" prop_roundtrip_metadata,
+ testProperty "roundtrip Shelley Genesis" prop_roundtrip_ShelleyGenesis
  ]