Factor out HeaderState

This is needed for the header/body split in the consensus layer. We also take this opportunity to do less in the 'updateBlock' rule, which is only really used for testing.

src/Cardano/Chain/Block/Header.hs

@@ -23,6 +23,7 @@ module Cardano.Chain.Block.Header
   -- * Accessors
   , headerSlot
   , headerLeaderKey
+  , headerHashAnnotated
   , headerIssuer
   , headerLength
   , headerDifficulty
@@ -119,6 +120,7 @@ import Cardano.Crypto
   , PublicKey
   , SecretKey
   , SignTag(..)
+  , hashDecoded
   , hashHexF
   , proxySign
   , proxyVerifyDecoded
@@ -333,6 +335,9 @@ headerToSign epochSlots h = ToSign
   (headerDifficulty h)
   (headerExtraData h)
 
+headerHashAnnotated :: AHeader ByteString -> HeaderHash
+headerHashAnnotated = hashDecoded . fmap wrapHeaderBytes
+
 headerLength :: AHeader ByteString -> Natural
 headerLength = fromIntegral . BS.length . headerAnnotation
 

src/Cardano/Chain/Block/Validation.hs

@@ -19,6 +19,9 @@ module Cardano.Chain.Block.Validation
   , BodyState(..)
   , BodyEnvironment(..)
   , ChainValidationState(..)
+  , cvsLastSlot
+  , cvsPreviousHash
+  , HeaderState(..)
   , initialChainValidationState
   , ChainValidationError
   , HeaderEnvironment(..)
@@ -53,7 +56,6 @@ import Cardano.Chain.Block.Block
   , BoundaryValidationData(..)
   , blockAttributes
   , blockDlgPayload
-  , blockHashAnnotated
   , blockHeader
   , blockIssuer
   , blockLength
@@ -67,6 +69,7 @@ import Cardano.Chain.Block.Header
   ( AHeader
   , BlockSignature(..)
   , HeaderHash
+  , headerHashAnnotated
   , headerAttributes
   , headerLength
   , headerSlot
@@ -162,17 +165,27 @@ updateSigningHistory pk sh
 -- ChainValidationState
 --------------------------------------------------------------------------------
 
+data HeaderState = HeaderState
+  { hsLastSlot :: !FlatSlotId
+  , hsSigningHistory :: !SigningHistory
+  , hsPreviousHash :: !(Either GenesisHash HeaderHash)
+  , hsUPIState :: !UPI.State
+  } deriving (Eq, Show, Generic, NFData)
+
 data ChainValidationState = ChainValidationState
-  { cvsLastSlot        :: !FlatSlotId
-  , cvsSigningHistory  :: !SigningHistory
-  , cvsPreviousHash    :: !(Either GenesisHash HeaderHash)
+  { cvsHeaderState     :: !HeaderState
   -- ^ GenesisHash for the previous hash of the zeroth boundary block and
   --   HeaderHash for all others.
   , cvsUtxo            :: !UTxO
-  , cvsUpdateState     :: !UPI.State
   , cvsDelegationState :: !DI.State
   } deriving (Eq, Show, Generic, NFData)
 
+cvsLastSlot :: ChainValidationState -> FlatSlotId
+cvsLastSlot = hsLastSlot . cvsHeaderState
+
+cvsPreviousHash :: ChainValidationState -> Either GenesisHash HeaderHash
+cvsPreviousHash = hsPreviousHash . cvsHeaderState
+
 -- | Create the state needed to validate the zeroth epoch of the chain. The
 --   zeroth epoch starts with a boundary block where the previous hash is the
 --   genesis hash.
@@ -183,19 +196,21 @@ initialChainValidationState
 initialChainValidationState config = do
   delegationState <- DI.initialState delegationEnv genesisDelegation
   pure $ ChainValidationState
-    { cvsLastSlot       = 0
-    , cvsSigningHistory = SigningHistory
-      { shK = configK config
-      , shStakeholderCounts = M.fromList
-        . map (, BlockCount 0)
-        . M.keys
-        . unGenesisWStakeholders
-        $ configBootStakeholders config
-      , shSigningQueue = Empty
+    { cvsHeaderState = HeaderState {
+        hsLastSlot       = 0
+      , hsSigningHistory = SigningHistory
+        { shK = configK config
+        , shStakeholderCounts = M.fromList
+          . map (, BlockCount 0)
+          . M.keys
+          . unGenesisWStakeholders
+          $ configBootStakeholders config
+        , shSigningQueue = Empty
+        }
+      , hsPreviousHash   = Left $ configGenesisHash config
+      , hsUPIState = UPI.initialState config
       }
-    , cvsPreviousHash   = Left $ configGenesisHash config
     , cvsUtxo           = genesisUtxo config
-    , cvsUpdateState    = UPI.initialState config
     , cvsDelegationState = delegationState
     }
  where
@@ -308,7 +323,7 @@ updateChainBoundary
   -> BoundaryValidationData ByteString
   -> m ChainValidationState
 updateChainBoundary cvs bvd = do
-  case (cvsPreviousHash cvs, boundaryPrevHash bvd) of
+  case (hsPreviousHash . cvsHeaderState $ cvs, boundaryPrevHash bvd) of
     (Left expected, Left actual) ->
         (expected == actual)
           `orThrowError` ChainValidationGenesisHashMismatch expected actual
@@ -327,13 +342,15 @@ updateChainBoundary cvs bvd = do
 
   -- Update the previous hash
   pure $ cvs
-    { cvsPreviousHash =
-      Right
-      . coerce
-      . hashRaw
-      . BSL.fromStrict
-      . wrapBoundaryBytes
-      $ boundaryHeaderBytes bvd
+    { cvsHeaderState = (cvsHeaderState cvs) 
+      { hsPreviousHash =
+        Right
+        . coerce
+        . hashRaw
+        . BSL.fromStrict
+        . wrapBoundaryBytes
+        $ boundaryHeaderBytes bvd
+      }
     }
 
 
@@ -463,9 +480,9 @@ data HeaderEnvironment = HeaderEnvironment
 updateHeader
   :: MonadError ChainValidationError m
   => HeaderEnvironment
-  -> UPI.State
+  -> HeaderState
   -> AHeader ByteString
-  -> m UPI.State
+  -> m HeaderState
 updateHeader env st h = do
   -- Validate the header size
   headerLength h <= maxHeaderSize `orThrowError` ChainValidationHeaderTooLarge
@@ -474,9 +491,15 @@ updateHeader env st h = do
   length attributes == 0 `orThrowError` ChainValidationHeaderAttributesTooLarge
 
   -- Perform epoch transition
-  epochTransition epochEnv st (headerSlot h)
+  us <- epochTransition epochEnv (hsUPIState st) (headerSlot h)
+
+  pure $ st
+    { hsLastSlot = headerSlot h
+    , hsPreviousHash = Right $ headerHashAnnotated h
+    , hsUPIState = us
+    }
  where
-  maxHeaderSize = Update.ppMaxHeaderSize $ UPI.adoptedProtocolParameters st
+  maxHeaderSize = Update.ppMaxHeaderSize . UPI.adoptedProtocolParameters $ hsUPIState st
 
   UnparsedFields attributes = attrRemain $ headerAttributes h
 
@@ -549,30 +572,28 @@ updateBlock
 updateBlock config cvs b = do
 
   -- Update the header
-  updateState' <- updateHeader headerEnv (cvsUpdateState cvs) (blockHeader b)
+  headerState' <- updateHeader headerEnv (cvsHeaderState cvs) (blockHeader b)
 
   let
     bodyEnv = BodyEnvironment
       { protocolMagic = configProtocolMagic config
       , k = configK config
       , numGenKeys
-      , protocolParameters = UPI.adoptedProtocolParameters updateState'
+      , protocolParameters = UPI.adoptedProtocolParameters $ hsUPIState headerState'
       , currentEpoch = slotNumberEpoch (configEpochSlots config) (blockSlot b)
       }
 
     bs = BodyState
       { utxo        = cvsUtxo cvs
-      , updateState = updateState'
+      , updateState = hsUPIState headerState'
       , delegationState = cvsDelegationState cvs
       }
 
   BodyState { utxo, updateState, delegationState } <- updateBody bodyEnv bs b
 
   pure $ cvs
-    { cvsLastSlot     = blockSlot b
-    , cvsPreviousHash = Right $ blockHashAnnotated b
+    { cvsHeaderState = headerState' { hsUPIState = updateState }
     , cvsUtxo         = utxo
-    , cvsUpdateState  = updateState
     , cvsDelegationState = delegationState
     }
  where

src/Cardano/Chain/Epoch/Validation.hs

@@ -28,6 +28,7 @@ import Cardano.Chain.Block
   , UTxOSize
   , blockSlot
   , calcUTxOSize
+  , cvsLastSlot
   , updateChainBlockOrBoundary
   )
 import Cardano.Chain.Epoch.File