allow shelley to start from genesis or bryon

shelley/chain-and-ledger/executable-spec/cddl-files/shelley.cddl

@@ -19,7 +19,7 @@ header =
   )
 
 header_body =
-  ( prev_hash        : $hash
+  ( prev_hash        : ($hash / null)
   , issuer_vkey      : $vkey
   , vrf_vkey         : $vrf_vkey
   , slot             : uint

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

@@ -15,6 +15,9 @@
 
 module Shelley.Spec.Ledger.BlockChain
   ( HashHeader(..)
+  , PrevHash(..)
+  , LastAppliedBlock(..)
+  , lastAppliedHash
   , BHBody(..)
   , BHeader(..)
   , Block(..)
@@ -54,13 +57,15 @@ import           GHC.Generics (Generic)
 import           Numeric.Natural (Natural)
 import           Shelley.Spec.Ledger.MetaData (MetaData)
 
-import           Cardano.Binary (Decoder, FromCBOR (fromCBOR), ToCBOR (toCBOR), decodeListLen,
-                     encodeListLen, matchSize, serializeEncoding')
+import           Cardano.Binary (Decoder, FromCBOR (fromCBOR), ToCBOR (toCBOR),
+                     TokenType (TypeNull), decodeListLen, decodeListLenOf, decodeNull,
+                     encodeListLen, encodeNull, matchSize, peekTokenType, serializeEncoding')
 import           Cardano.Crypto.Hash (SHA256)
 import qualified Cardano.Crypto.Hash.Class as Hash
 import qualified Cardano.Crypto.VRF.Class as VRF
 import           Cardano.Ledger.Shelley.Crypto
 import           Cardano.Prelude (NoUnexpectedThunks (..))
+import           Cardano.Slotting.Slot (WithOrigin (..))
 import           Control.Monad (unless)
 import           Shelley.Spec.Ledger.BaseTypes (Nonce (..), Seed (..), UnitInterval, intervalValue,
                      mkNonce)
@@ -163,9 +168,55 @@ instance Crypto crypto
      sig <- fromCBOR
      pure $ BHeader bhb sig
 
+-- |The previous hash of a block
+data PrevHash crypto = GenesisHash | BlockHash !(HashHeader crypto)
+  deriving (Show, Eq, Generic, Ord)
+
+instance Crypto crypto => NoUnexpectedThunks (PrevHash crypto)
+
+instance Crypto crypto
+  => ToCBOR (PrevHash crypto)
+  where
+    toCBOR GenesisHash = encodeNull
+    toCBOR (BlockHash h) = toCBOR h
+
+instance Crypto crypto
+  => FromCBOR (PrevHash crypto)
+ where
+   fromCBOR = do
+     peekTokenType >>= \case
+       TypeNull -> do
+         decodeNull
+         pure GenesisHash
+       _ -> BlockHash <$> fromCBOR
+
+data LastAppliedBlock crypto = LastAppliedBlock {
+     labBlockNo :: !BlockNo
+   , labSlotNo  :: !SlotNo
+   , labHash    :: !(HashHeader crypto)
+   }
+  deriving (Show, Eq, Generic)
+
+instance Crypto crypto => NoUnexpectedThunks (LastAppliedBlock crypto)
+
+instance Crypto crypto => ToCBOR (LastAppliedBlock crypto) where
+  toCBOR (LastAppliedBlock b s h) =
+      encodeListLen 3 <> toCBOR b <> toCBOR s <> toCBOR h
+
+instance Crypto crypto => FromCBOR (LastAppliedBlock crypto) where
+  fromCBOR = decodeListLenOf 3 >>
+    LastAppliedBlock
+      <$> fromCBOR
+      <*> fromCBOR
+      <*> fromCBOR
+
+lastAppliedHash :: WithOrigin (LastAppliedBlock crypto) -> PrevHash crypto
+lastAppliedHash Origin   = GenesisHash
+lastAppliedHash (At lab) = BlockHash $ labHash lab
+
 data BHBody crypto = BHBody
   { -- | Hash of the previous block header
-    bheaderPrev           :: HashHeader crypto
+    bheaderPrev           :: PrevHash crypto
     -- | verification key of block issuer
   , bheaderVk             :: VKey crypto
     -- | VRF verification key for block issuer
@@ -366,9 +417,10 @@ vrfChecks
   -> Bool
 vrfChecks eta0 (PoolDistr pd) f bhb =
   let sigma' = Map.lookup hk pd
-  in  case sigma' of
-        Nothing -> False
-        Just (sigma, vrfHK) ->
+  in  case (sigma', bheaderPrev bhb) of
+        (_, GenesisHash) -> True
+        (Nothing, _) -> False
+        (Just (sigma, vrfHK), (BlockHash prevHash)) ->
           vrfHK == hashKeyVRF @crypto vrfK
             && VRF.verifyCertified () vrfK
                          (mkSeed seedEta slot eta0 prevHash)
@@ -380,7 +432,6 @@ vrfChecks eta0 (PoolDistr pd) f bhb =
  where
   hk = hashKey $ bheaderVk bhb
   vrfK = bheaderVrfVk bhb
-  prevHash = bheaderPrev bhb
   slot = bheaderSlotNo bhb
 
 -- | Check that the certified input natural is valid for being slot leader. This

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

@@ -20,9 +20,10 @@ import qualified Data.Map.Strict as Map
 import           Numeric.Natural (Natural)
 
 import           Cardano.Prelude (asks)
+import           Cardano.Slotting.Slot (WithOrigin (..))
 import           Shelley.Spec.Ledger.BaseTypes (Globals (..), Nonce (..), Seed (..), ShelleyBase)
-import           Shelley.Spec.Ledger.BlockChain (BHBody, Block (..), HashHeader, bHeaderSize,
-                     bhbody, bheaderSlotNo, hBbsize, hashHeaderToNonce)
+import           Shelley.Spec.Ledger.BlockChain (BHBody, Block (..), LastAppliedBlock (..),
+                     bHeaderSize, bhbody, bheaderSlotNo, hBbsize)
 import           Shelley.Spec.Ledger.Coin (Coin (..))
 import           Shelley.Spec.Ledger.Delegation.Certificates (PoolDistr (..))
 import           Shelley.Spec.Ledger.EpochBoundary (BlocksMade (..), emptySnapShots)
@@ -35,7 +36,7 @@ import           Shelley.Spec.Ledger.OCert (KESPeriod)
 import           Shelley.Spec.Ledger.PParams (PParams, ProtVer (..), _maxBBSize, _maxBHSize,
                      _protocolVersion)
 import           Shelley.Spec.Ledger.Rewards (emptyNonMyopic)
-import           Shelley.Spec.Ledger.Slot (BlockNo, EpochNo, SlotNo)
+import           Shelley.Spec.Ledger.Slot (EpochNo, SlotNo)
 import           Shelley.Spec.Ledger.Tx (TxBody)
 import           Shelley.Spec.Ledger.Updates (AVUpdate (..), Applications, PPUpdate (..),
                      UpdateState (..))
@@ -53,32 +54,29 @@ data CHAIN crypto
 
 data ChainState crypto
   = ChainState
-    { chainNes            :: NewEpochState crypto
-    , chainOCertIssue     :: Map.Map (KeyHash crypto) Natural
-    , chainEpochNonce     :: Nonce
-    , chainEvolvingNonce  :: Nonce
-    , chainCandidateNonce :: Nonce
-    , chainPrevEpochNonce :: Nonce
-    , chainHashHeader     :: HashHeader crypto
-    , chainSlotNo         :: SlotNo
-    , chainBlockNo        :: BlockNo
+    { chainNes              :: NewEpochState crypto
+    , chainOCertIssue       :: Map.Map (KeyHash crypto) Natural
+    , chainEpochNonce       :: Nonce
+    , chainEvolvingNonce    :: Nonce
+    , chainCandidateNonce   :: Nonce
+    , chainPrevEpochNonce   :: Nonce
+    , chainLastAppliedBlock :: WithOrigin (LastAppliedBlock crypto)
     }
   deriving (Show, Eq)
 
 -- |Creates a valid initial chain state
 initialShelleyState
-  :: SlotNo
-  -> BlockNo
+  :: WithOrigin (LastAppliedBlock crypto)
   -> EpochNo
-  -> HashHeader crypto
   -> UTxO crypto
   -> Coin
   -> Map (GenKeyHash crypto) (KeyHash crypto)
   -> Map SlotNo (Maybe (GenKeyHash crypto))
   -> Applications crypto
   -> PParams
+  -> Nonce
   -> ChainState crypto
-initialShelleyState s b e h utxo reserves genDelegs os apps pp =
+initialShelleyState lab e utxo reserves genDelegs os apps pp initNonce =
   ChainState
     (NewEpochState
        e
@@ -104,13 +102,11 @@ initialShelleyState s b e h utxo reserves genDelegs os apps pp =
        os
     )
     cs
-    (hashHeaderToNonce h)
-    (hashHeaderToNonce h)
-    (hashHeaderToNonce h)
+    initNonce
+    initNonce
+    initNonce
     NeutralNonce
-    h
-    s
-    b
+    lab
   where
     cs = Map.fromList (fmap (\hk -> (hk,0)) (Map.elems genDelegs))
 
@@ -154,7 +150,7 @@ chainTransition
      )
   => TransitionRule (CHAIN crypto)
 chainTransition = do
-  TRC (sNow, ChainState nes cs eta0 etaV etaC etaH h sL bL, block@(Block bh _)) <- judgmentContext
+  TRC (sNow, ChainState nes cs eta0 etaV etaC etaH lab, block@(Block bh _)) <- judgmentContext
 
 
   let NewEpochState _ _ _ (EpochState _ _ _ pp _) _ _ _ = nes
@@ -177,17 +173,17 @@ chainTransition = do
   let EpochState (AccountState _ _reserves) _ ls pp' _                       = es
   let LedgerState _ (DPState (DState _ _ _ _ _ _genDelegs _) (PState _ _ _)) = ls
 
-  PrtclState cs' h' sL' bL' eta0' etaV' etaC' etaH' <- trans @(PRTCL crypto)
+  PrtclState cs' lab' eta0' etaV' etaC' etaH' <- trans @(PRTCL crypto)
     $ TRC ( PrtclEnv pp' osched _pd _genDelegs sNow (e1 /= e2)
-          , PrtclState cs h sL bL eta0 etaV etaC etaH
+          , PrtclState cs lab eta0 etaV etaC etaH
           , bh)
 
   BbodyState ls' bcur' <- trans @(BBODY crypto)
     $ TRC (BbodyEnv (Map.keysSet osched) pp' _reserves, BbodyState ls bcur, block)
 
   let nes'' = updateNES nes' bcur' ls'
 
-  pure $ ChainState nes'' cs' eta0' etaV' etaC' etaH' h' sL' bL'
+  pure $ ChainState nes'' cs' eta0' etaV' etaC' etaH' lab'
 
 instance
   ( Crypto crypto
@@ -224,7 +220,7 @@ instance
 
 -- |Calculate the total ada in the chain state
 totalAda :: ChainState crypto -> Coin
-totalAda (ChainState nes _ _ _ _ _ _ _ _) =
+totalAda (ChainState nes _ _ _ _ _ _) =
   treasury_ + reserves_ + rewards_ + circulation + deposits + fees_
   where
     (EpochState (AccountState treasury_ reserves_) _ ls _ _) = nesEs nes

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

@@ -37,48 +37,43 @@ import           Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR), decodeLis
 import qualified Cardano.Crypto.VRF as VRF
 import           Cardano.Ledger.Shelley.Crypto
 import           Cardano.Prelude (NoUnexpectedThunks (..))
+import           Cardano.Slotting.Slot (WithOrigin (..), withOriginFromMaybe, withOriginToMaybe)
 import           Control.State.Transition
 
 data PRTCL crypto
 
 data PrtclState crypto
   = PrtclState
       (Map (KeyHash crypto) Natural)
-      (HashHeader crypto)
-      SlotNo
-      BlockNo
+      (WithOrigin (LastAppliedBlock crypto))
       Nonce -- ^ Current epoch nonce
       Nonce -- ^ Evolving nonce
       Nonce -- ^ Candidate nonce
       Nonce -- ^ Prev epoch hash nonce
   deriving (Generic, Show, Eq)
 
 instance Crypto crypto => ToCBOR (PrtclState crypto) where
-  toCBOR (PrtclState m hh sn bn n1 n2 n3 n4) = mconcat
-    [ encodeListLen 8
+  toCBOR (PrtclState m lab n1 n2 n3 n4) = mconcat
+    [ encodeListLen 6
     , toCBOR m
-    , toCBOR hh
-    , toCBOR sn
-    , toCBOR bn
+    , toCBOR $ withOriginToMaybe lab
     , toCBOR n1
     , toCBOR n2
     , toCBOR n3
     , toCBOR n4
     ]
 
 instance Crypto crypto => FromCBOR (PrtclState crypto) where
-  fromCBOR = decodeListLenOf 8 >>
+  fromCBOR = decodeListLenOf 6 >>
     PrtclState
       <$> fromCBOR
-      <*> fromCBOR
-      <*> fromCBOR
-      <*> fromCBOR
+      <*> (withOriginFromMaybe <$> fromCBOR)
       <*> fromCBOR
       <*> fromCBOR
       <*> fromCBOR
       <*> fromCBOR
 
-instance NoUnexpectedThunks (PrtclState crypto)
+instance Crypto crypto => NoUnexpectedThunks (PrtclState crypto)
 
 data PrtclEnv crypto
   = PrtclEnv
@@ -113,7 +108,7 @@ instance
 
   data PredicateFailure (PRTCL crypto)
     = WrongSlotIntervalPRTCL
-    | WrongBlockNoPRTCL BlockNo BlockNo
+    | WrongBlockNoPRTCL (WithOrigin (LastAppliedBlock crypto)) BlockNo
     | WrongBlockSequencePRTCL
     | OverlayFailure (PredicateFailure (OVERLAY crypto))
     | UpdnFailure (PredicateFailure (UPDN crypto))
@@ -133,25 +128,42 @@ prtclTransition
   => TransitionRule (PRTCL crypto)
 prtclTransition = do
   TRC ( PrtclEnv pp osched pd dms sNow ne
-      , PrtclState cs h sL bL eta0 etaV etaC etaH
+      , PrtclState cs lab eta0 etaV etaC etaH
       , bh) <- judgmentContext
   let bhb  = bhbody bh
       bn = bheaderBlockNo bhb
       slot = bheaderSlotNo bhb
       eta  = fromNatural . VRF.certifiedNatural $ bheaderEta bhb
-  sL < slot && slot <= sNow ?! WrongSlotIntervalPRTCL
-  bL + 1 == bn ?! WrongBlockNoPRTCL bL bn
-  h == bheaderPrev bhb ?! WrongBlockSequencePRTCL
+      ph = lastAppliedHash lab
+
+  case lab of
+    Origin -> pure ()
+    At (LastAppliedBlock bL sL _) -> do
+      sL < slot && slot <= sNow ?! WrongSlotIntervalPRTCL
+      bL + 1 == bn ?! WrongBlockNoPRTCL lab bn
+  ph == bheaderPrev bhb ?! WrongBlockSequencePRTCL
 
   UpdnState eta0' etaV' etaC' etaH'
-    <- trans @(UPDN crypto) $ TRC (UpdnEnv eta pp h ne, UpdnState eta0 etaV etaC etaH, slot)
+    <- trans @(UPDN crypto) $ TRC ( UpdnEnv eta pp ph ne
+                                  , UpdnState eta0 etaV etaC etaH
+                                  , slot)
   cs'
     <- trans @(OVERLAY crypto)
         $ TRC (OverlayEnv pp osched eta0' pd dms, cs, bh)
 
-  pure $ PrtclState cs' (bhHash bh) slot bn eta0' etaV' etaC' etaH'
-
-instance NoUnexpectedThunks (PredicateFailure (PRTCL crypto))
+  pure $ PrtclState
+           cs'
+           (At $ LastAppliedBlock
+                   bn
+                   slot
+                   (bhHash bh)
+           )
+           eta0'
+           etaV'
+           etaC'
+           etaH'
+
+instance (Crypto crypto) => NoUnexpectedThunks (PredicateFailure (PRTCL crypto))
 
 instance
   ( Crypto crypto

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

@@ -2,6 +2,8 @@
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE EmptyDataDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Shelley.Spec.Ledger.STS.Updn
@@ -23,7 +25,7 @@ import           Shelley.Spec.Ledger.Slot
 
 data UPDN crypto
 
-data UpdnEnv crypto = UpdnEnv Nonce PParams (HashHeader crypto) Bool
+data UpdnEnv crypto = UpdnEnv Nonce PParams (PrevHash crypto) Bool
 data UpdnState = UpdnState Nonce Nonce Nonce Nonce
   deriving (Show, Eq)
 
@@ -41,9 +43,18 @@ instance
 
 instance NoUnexpectedThunks (PredicateFailure (UPDN crypto))
 
+prevHashToNonce
+  :: Nonce
+  -> PrevHash crypto
+  -> Nonce
+prevHashToNonce n = \case
+  GenesisHash -> n -- This case is impossible. The function is only called on a new epoch,
+                   -- but the GenesisHash can only occur as the first block.
+  BlockHash ph -> hashHeaderToNonce ph
+
 updTransition :: Crypto crypto => TransitionRule (UPDN crypto)
 updTransition = do
-  TRC (UpdnEnv eta pp h ne, UpdnState eta_0 eta_v eta_c eta_h, s) <- judgmentContext
+  TRC (UpdnEnv eta pp ph ne, UpdnState eta_0 eta_v eta_c eta_h, s) <- judgmentContext
   ei <- liftSTS $ asks epochInfo
   sp <- liftSTS $ asks slotsPrior
   EpochNo e <- liftSTS $ epochInfoEpoch ei s
@@ -55,4 +66,4 @@ updTransition = do
       then eta_v ⭒ eta
       else eta_c
     )
-    (if ne then (hashHeaderToNonce h) else eta_h)
+    (if ne then (prevHashToNonce eta_h ph) else eta_h)