Support ticking the Shelley ledger state.

The current method is a little dirty, in that we insert a partially
updated state into the history during chain tick (which will be
subsequently fixed during block update).

This should also fix the VRF problems.

cabal.project

@@ -170,71 +170,71 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: b508ad54209ae3b46f15810bf9e5cf42b76c7486
-  --sha256: 1vj44ppxrk3vnwkfpap3kvmz4fp9b9abvc3c21dfns34abvkajq6
+  tag: b3111673d6564985a999ecb494b68364fd1c0489
+  --sha256: 1vz7dwp9a43w0z0gm3kcqaxhnrd3fqdyvw8cpxasx915wqhh4x60
   subdir: semantics/executable-spec
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: b508ad54209ae3b46f15810bf9e5cf42b76c7486
-  --sha256: 1vj44ppxrk3vnwkfpap3kvmz4fp9b9abvc3c21dfns34abvkajq6
+  tag: b3111673d6564985a999ecb494b68364fd1c0489
+  --sha256: 1vz7dwp9a43w0z0gm3kcqaxhnrd3fqdyvw8cpxasx915wqhh4x60
   subdir: byron/ledger/executable-spec
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: b508ad54209ae3b46f15810bf9e5cf42b76c7486
-  --sha256: 1vj44ppxrk3vnwkfpap3kvmz4fp9b9abvc3c21dfns34abvkajq6
+  tag: b3111673d6564985a999ecb494b68364fd1c0489
+  --sha256: 1vz7dwp9a43w0z0gm3kcqaxhnrd3fqdyvw8cpxasx915wqhh4x60
   subdir: byron/ledger/impl
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: b508ad54209ae3b46f15810bf9e5cf42b76c7486
-  --sha256: 1vj44ppxrk3vnwkfpap3kvmz4fp9b9abvc3c21dfns34abvkajq6
+  tag: b3111673d6564985a999ecb494b68364fd1c0489
+  --sha256: 1vz7dwp9a43w0z0gm3kcqaxhnrd3fqdyvw8cpxasx915wqhh4x60
   subdir: byron/ledger/impl/test
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: b508ad54209ae3b46f15810bf9e5cf42b76c7486
-  --sha256: 1vj44ppxrk3vnwkfpap3kvmz4fp9b9abvc3c21dfns34abvkajq6
+  tag: b3111673d6564985a999ecb494b68364fd1c0489
+  --sha256: 1vz7dwp9a43w0z0gm3kcqaxhnrd3fqdyvw8cpxasx915wqhh4x60
   subdir: byron/crypto
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: b508ad54209ae3b46f15810bf9e5cf42b76c7486
-  --sha256: 1vj44ppxrk3vnwkfpap3kvmz4fp9b9abvc3c21dfns34abvkajq6
+  tag: b3111673d6564985a999ecb494b68364fd1c0489
+  --sha256: 1vz7dwp9a43w0z0gm3kcqaxhnrd3fqdyvw8cpxasx915wqhh4x60
   subdir: byron/crypto/test
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: b508ad54209ae3b46f15810bf9e5cf42b76c7486
-  --sha256: 1vj44ppxrk3vnwkfpap3kvmz4fp9b9abvc3c21dfns34abvkajq6
+  tag: b3111673d6564985a999ecb494b68364fd1c0489
+  --sha256: 1vz7dwp9a43w0z0gm3kcqaxhnrd3fqdyvw8cpxasx915wqhh4x60
   subdir: byron/chain/executable-spec
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: b508ad54209ae3b46f15810bf9e5cf42b76c7486
-  --sha256: 1vj44ppxrk3vnwkfpap3kvmz4fp9b9abvc3c21dfns34abvkajq6
+  tag: b3111673d6564985a999ecb494b68364fd1c0489
+  --sha256: 1vz7dwp9a43w0z0gm3kcqaxhnrd3fqdyvw8cpxasx915wqhh4x60
   subdir: shelley/chain-and-ledger/dependencies/non-integer
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: b508ad54209ae3b46f15810bf9e5cf42b76c7486
-  --sha256: 1vj44ppxrk3vnwkfpap3kvmz4fp9b9abvc3c21dfns34abvkajq6
+  tag: b3111673d6564985a999ecb494b68364fd1c0489
+  --sha256: 1vz7dwp9a43w0z0gm3kcqaxhnrd3fqdyvw8cpxasx915wqhh4x60
   subdir: shelley/chain-and-ledger/executable-spec
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: b508ad54209ae3b46f15810bf9e5cf42b76c7486
-  --sha256: 1vj44ppxrk3vnwkfpap3kvmz4fp9b9abvc3c21dfns34abvkajq6
+  tag: b3111673d6564985a999ecb494b68364fd1c0489
+  --sha256: 1vz7dwp9a43w0z0gm3kcqaxhnrd3fqdyvw8cpxasx915wqhh4x60
   subdir: shelley/chain-and-ledger/executable-spec/test
 
 source-repository-package

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs

@@ -49,6 +49,7 @@ import           Ouroboros.Consensus.Util.Assert
 import           Ouroboros.Consensus.Util.IOLike
 
 import qualified Shelley.Spec.Ledger.Address as SL
+import qualified Shelley.Spec.Ledger.API as SL
 import qualified Shelley.Spec.Ledger.BaseTypes as SL
 import qualified Shelley.Spec.Ledger.BlockChain as SL
 import qualified Shelley.Spec.Ledger.Credential as SL
@@ -61,6 +62,7 @@ import qualified Shelley.Spec.Ledger.PParams as SL
 import qualified Shelley.Spec.Ledger.STS.Chain as SL
 import qualified Shelley.Spec.Ledger.STS.NewEpoch as SL
 import qualified Shelley.Spec.Ledger.STS.Prtcl as SL
+import qualified Shelley.Spec.Ledger.STS.Tickn as SL
 import qualified Shelley.Spec.Ledger.UTxO as SL
 
 import           Ouroboros.Consensus.Shelley.Ledger
@@ -202,12 +204,18 @@ protocolInfoShelley genesis initialNonce maxMajorPV protVer mbCredentials =
 
     initChainDepState :: State.TPraosState c
     initChainDepState = State.empty Origin $
-      SL.PrtclState
-         (SL.chainOCertIssue     initShelleyState)
-         (SL.chainEpochNonce     initShelleyState)
-         (SL.chainEvolvingNonce  initShelleyState)
-         (SL.chainCandidateNonce initShelleyState)
-         (SL.chainPrevEpochNonce initShelleyState)
+      SL.ChainDepState
+        {
+          SL.csProtocol = SL.PrtclState
+            (SL.chainOCertIssue     initShelleyState)
+            (SL.chainEvolvingNonce  initShelleyState)
+            (SL.chainCandidateNonce initShelleyState)
+        , SL.csTickn = SL.TicknState
+            (SL.chainEpochNonce     initShelleyState)
+            (SL.chainPrevEpochNonce initShelleyState)
+        , SL.csLabNonce =
+            (SL.chainPrevEpochNonce initShelleyState)
+        }
 
     initialEpochNo :: EpochNo
     initialEpochNo = 0

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs

@@ -39,8 +39,6 @@ module Ouroboros.Consensus.Shelley.Protocol (
   , ConsensusConfig (..)
   ) where
 
-import           Control.Monad.Reader (runReader)
-import           Control.Monad.Trans.Except (except)
 import           Data.Coerce (coerce)
 import           Data.Function (on)
 import           Data.Functor.Identity (Identity)
@@ -64,8 +62,6 @@ import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Ticked
 import           Ouroboros.Consensus.Util.Condense
 
-import           Control.State.Transition.Extended (applySTS)
-import qualified Control.State.Transition.Extended as STS
 import qualified Shelley.Spec.Ledger.API as SL
 import qualified Shelley.Spec.Ledger.BaseTypes as SL
 import qualified Shelley.Spec.Ledger.BlockChain as SL
@@ -75,7 +71,7 @@ import qualified Shelley.Spec.Ledger.Genesis as SL
 import qualified Shelley.Spec.Ledger.Keys as SL
 import qualified Shelley.Spec.Ledger.LedgerState as SL
 import qualified Shelley.Spec.Ledger.OCert as SL
-import qualified Shelley.Spec.Ledger.STS.Prtcl as STS
+import qualified Shelley.Spec.Ledger.STS.Tickn as STS
 
 import           Ouroboros.Consensus.Shelley.Protocol.Crypto
 import           Ouroboros.Consensus.Shelley.Protocol.Crypto.HotKey
@@ -376,7 +372,7 @@ instance TPraosCrypto c => ConsensusProtocol (TPraos c) where
   type CanBeLeader   (TPraos c) = TPraosIsCoreNode c
   type CannotLead    (TPraos c) = TPraosCannotLead c
   type LedgerView    (TPraos c) = SL.LedgerView c
-  type ValidationErr (TPraos c) = [[STS.PredicateFailure (STS.PRTCL c)]]
+  type ValidationErr (TPraos c) = SL.ChainTransitionError c
   type ValidateView  (TPraos c) = TPraosValidateView c
 
   protocolSecurityParam = tpraosSecurityParam . tpraosParams
@@ -434,42 +430,41 @@ instance TPraosCrypto c => ConsensusProtocol (TPraos c) where
         , tpraosIsCoreNodeSignKeyVRF
         } = icn
 
-      prtclState = State.currentPRTCLState cs
-      eta0       = prtclStateEta0 prtclState
+      chainState = State.currentState cs
+      eta0       = tickEta0 $ SL.csTickn chainState
       vkhCold    = SL.hashKey tpraosIsCoreNodeColdVerKey
       rho'       = SL.mkSeed SL.seedEta slot eta0
       y'         = SL.mkSeed SL.seedL   slot eta0
 
+      tickEta0 (STS.TicknState _ x) = x
+
       -- The current wallclock KES period
       wallclockPeriod :: SL.KESPeriod
       wallclockPeriod = SL.KESPeriod $ fromIntegral $
           unSlotNo slot `div` tpraosSlotsPerKESPeriod tpraosParams
 
-  tickChainDepState _ (Ticked slot _lv) = Ticked slot -- TODO (@nc6)
+  tickChainDepState TPraosConfig{..} (Ticked slot lv) cds = Ticked slot cds'
+    where
+      cds' = State.append slot cs' cds
+      cs' = SL.tickChainDepState
+              shelleyGlobals
+              lv
+              (isNewEpoch tpraosEpochInfo slot (State.lastSlot cds))
+              (State.currentState cds)
+      shelleyGlobals = mkShelleyGlobals tpraosEpochInfo tpraosParams
 
   updateChainDepState TPraosConfig{..}
                       b
                       (Ticked _ lv)
                       (Ticked _ cs) = do
-      newCS <- except . flip runReader shelleyGlobals $
-        applySTS @(STS.PRTCL c) $ STS.TRC (prtclEnv, prtclState, b)
+      newCS <- SL.updateChainDepState shelleyGlobals lv b (State.currentState cs)
       return
         $ State.prune (fromIntegral k)
-        $ State.append slot newCS cs
+        $ State.updateLast newCS cs
     where
-      slot = SL.bheaderSlotNo $ SL.bhbody b
-      prevHash = SL.bheaderPrev $ SL.bhbody b
       SecurityParam k = tpraosSecurityParam tpraosParams
       shelleyGlobals = mkShelleyGlobals tpraosEpochInfo tpraosParams
 
-      prtclEnv :: STS.PrtclEnv c
-      prtclEnv = SL.mkPrtclEnv
-        lv
-        (isNewEpoch tpraosEpochInfo slot (State.lastSlot cs))
-        (SL.prevHashToNonce prevHash)
-
-      prtclState :: STS.PrtclState c
-      prtclState = State.currentPRTCLState cs
 
   -- Rewind the chain state
   --

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/State.hs

@@ -6,13 +6,14 @@
 -- | Consensus state for Transitional Praos
 module Ouroboros.Consensus.Shelley.Protocol.State (
     TPraosState -- opaque
-  , currentPRTCLState
+  , currentState
   , empty
   , lastSlot
   , append
   , rewind
   , prune
   , size
+  , updateLast
   ) where
 
 import qualified Codec.CBOR.Encoding as CBOR
@@ -29,8 +30,8 @@ import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Util.Assert
 import           Ouroboros.Consensus.Util.Versioned
 
+import qualified Shelley.Spec.Ledger.API as SL
 import           Shelley.Spec.Ledger.Crypto
-import qualified Shelley.Spec.Ledger.STS.Prtcl as STS
 
 -- | Praos consensus state.
 --
@@ -53,7 +54,7 @@ data TPraosState c = TPraosState {
       anchor           :: !(WithOrigin SlotNo)
 
       -- | Historical state snapshots.
-    , historicalStates :: !(Map (WithOrigin SlotNo) (STS.State (STS.PRTCL c)))
+    , historicalStates :: !(Map (WithOrigin SlotNo) (SL.ChainDepState c))
     }
   deriving (Generic, Show, Eq)
 
@@ -76,10 +77,10 @@ assertInvariants :: HasCallStack => TPraosState c -> TPraosState c
 assertInvariants st = assertWithMsg (checkInvariants st) st
 
 -- | Extract the current state
-currentPRTCLState :: HasCallStack => TPraosState c -> STS.State (STS.PRTCL c)
-currentPRTCLState st
-    | Just (currentState, _) <- Map.maxView (historicalStates st)
-    = currentState
+currentState :: HasCallStack => TPraosState c -> SL.ChainDepState c
+currentState st
+    | Just (cs, _) <- Map.maxView (historicalStates st)
+    = cs
     | otherwise
     = error "Empty state"
 
@@ -97,13 +98,25 @@ lastSlot st
 -- calling this to have a state containing more history than needed.
 append
   :: SlotNo
-  -> STS.State (STS.PRTCL c)
+  -> (SL.ChainDepState c)
   -> TPraosState c
   -> TPraosState c
 append slot prtclState st = st {
       historicalStates = Map.insert (NotOrigin slot) prtclState (historicalStates st)
     }
 
+-- | Update the last entry in the history.
+--
+--   This function is used to 'tick' the chain state. We expect it to be removed
+--   when we update the Ticked family.
+updateLast
+  :: SL.ChainDepState c
+  -> TPraosState c
+  -> TPraosState c
+updateLast prtclState st = st {
+    historicalStates = Map.insert (lastSlot st) prtclState (historicalStates st)
+  }
+
 -- | Prune the state to a given maximum size
 prune
   :: Int -- ^ Size (in terms of number of blocks) to prune the state to.
@@ -154,7 +167,7 @@ rewind toSlot st
         Nothing      -> older
         Just current -> Map.insert toSlot current older
 
-empty :: WithOrigin SlotNo -> STS.State (STS.PRTCL c) -> TPraosState c
+empty :: WithOrigin SlotNo -> (SL.ChainDepState c) -> TPraosState c
 empty slot prtclState = TPraosState {
       anchor           = slot
     , historicalStates = Map.singleton slot prtclState

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Util.hs

@@ -4,17 +4,13 @@
 -- package from cardano-ledger-specs.
 module Ouroboros.Consensus.Shelley.Protocol.Util (
     isNewEpoch
-  , prtclStateEta0
   ) where
 
 import           Cardano.Slotting.EpochInfo
 import           Data.Functor.Identity (Identity (..))
 
 import           Ouroboros.Consensus.Block
 
-import qualified Shelley.Spec.Ledger.BaseTypes as SL
-import qualified Shelley.Spec.Ledger.STS.Prtcl as STS
-
 -- | Verify whether a slot represents a change to a new epoch with regard to
 -- some other slot.
 isNewEpoch
@@ -32,8 +28,3 @@ isNewEpoch ei newSlot referenceWO = runIdentity $ do
     reference = fromWithOrigin genesisSlotNo referenceWO
     -- TODO
     genesisSlotNo = SlotNo 0
-
-prtclStateEta0
-  :: STS.State (STS.PRTCL c)
-  -> SL.Nonce
-prtclStateEta0 (STS.PrtclState _ eta0 _ _ _) = eta0

stack.yaml

@@ -50,7 +50,7 @@ extra-deps:
       - slotting
 
   - git: https://github.com/input-output-hk/cardano-ledger-specs
-    commit: b508ad54209ae3b46f15810bf9e5cf42b76c7486
+    commit: b3111673d6564985a999ecb494b68364fd1c0489
     subdirs:
       - byron/chain/executable-spec
       - byron/ledger/executable-spec