Replace anachronisticLedgerView with Forecast

Closes #1933
Closes #998

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/DelegationHistory.hs

@@ -23,7 +23,6 @@ import           Codec.CBOR.Encoding (Encoding, encodeListLen)
 import           Codec.Serialise (decode, encode)
 import           Data.Coerce (coerce)
 import qualified Data.Foldable as Foldable
-import           Data.Sequence.Strict (StrictSeq)
 import qualified Data.Sequence.Strict as Seq
 
 import           Cardano.Binary (enforceSize)
@@ -59,19 +58,6 @@ newtype DelegationHistory = DH (History Delegation.Map)
   deriving stock (Show, Eq)
   deriving newtype (NoUnexpectedThunks)
 
--- | Snapshots strictly after genesis
---
--- More recent snapshots are stored at the end of the sequence.
---
--- Invariant: the (exclusive) upper bound of each snapshot must equal the
--- (inclusive) lower bound of the next.
-type Snapshots = StrictSeq Snapshot
-
--- | Historical snapshot of the delegation state
---
--- See 'DelegationHistory' for details
-type Snapshot = SlotBounded 'IX Delegation.Map
-
 -- | Empty (genesis) delegation history
 empty :: DelegationHistory
 empty = DH History.empty
@@ -93,12 +79,12 @@ find = coerce (History.find @Delegation.Map)
   instance.
 -------------------------------------------------------------------------------}
 
-toLedgerViews :: Snapshots
+toLedgerViews :: History.Snapshots Delegation.Map
               -> [SlotBounded 'IX (PBftLedgerView PBftByronCrypto)]
 toLedgerViews = map (fmap toPBftLedgerView) . Foldable.toList
 
 fromLedgerViews :: [SlotBounded 'IX (PBftLedgerView PBftByronCrypto)]
-                -> Snapshots
+                -> History.Snapshots Delegation.Map
 fromLedgerViews = Seq.fromList . map (fmap fromPBftLedgerView)
 
 encodeDelegationHistory :: DelegationHistory -> Encoding

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs

@@ -42,7 +42,7 @@ import           Data.Type.Equality ((:~:) (Refl))
 import           GHC.Generics (Generic)
 
 import           Cardano.Prelude (NoUnexpectedThunks)
-import           Cardano.Slotting.Slot
+import           Cardano.Slotting.Slot hiding (at)
 
 import           Cardano.Binary (fromCBOR, toCBOR)
 import qualified Cardano.Chain.Block as CC
@@ -58,6 +58,7 @@ import qualified Ouroboros.Network.Point as Point
 import           Ouroboros.Network.Protocol.LocalStateQuery.Codec (Some (..))
 
 import           Ouroboros.Consensus.BlockchainTime
+import           Ouroboros.Consensus.Forecast
 import qualified Ouroboros.Consensus.HardFork.History as HardFork
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
@@ -197,40 +198,47 @@ instance LedgerSupportsProtocol ByronBlock where
   -- D. ([3], [4])
   --
   -- Then take the delegation state from in current ledger state, and apply the
-  -- updates that should be applied. The resulting delegation state must be
-  -- given the following validity bounds:
+  -- updates that should be applied.
   --
-  -- * The lower bound will be the slot number of the last update that was
-  --   applied, or the upper bound of the last historical snapshot if no
-  --   updates needed to be applied. If there are no historical snapshots,
-  --   then the lower bound is genesis (the history is only empty if the
-  --   delegation state never changed).
-  -- * The upper bound will be the slot number of the first update that was
-  --   not yet applied; if no such update is known, it will be set to the
-  --   the maximum upper bound @(NOW + 2k)@.
-  --
-  -- TODO: verify that the sdSlot of ScheduledDelegation is the slot at which
-  -- it becomes active (i.e., that delegation should be applied /in/ that slot)
-  -- i.e., that delegate is allowed to issue a block in that very same slot.
-  anachronisticProtocolLedgerView_ cfg (ByronLedgerState ls ss) slot =
-      case History.find slot ss of
-        Just sb -> return $ toPBftLedgerView sb -- Case (A)
+  -- NOTE: These forecasts are used to make validate headers from blocks that
+  -- potentially live on different chains. We can do this, because the
+  -- delegation state (delegation map and scheduled delegations) at the
+  -- intersection point A between our chain and that chain applies equally to
+  -- /any/ chain starting at that intersection point (only slot numbers are
+  -- relevant). It does however mean that we must limit the range of the
+  -- forecast to @2k@ slots /from the intersection/ point; if we don't, there
+  -- could be delegation certificates present on the other chain that we do not
+  -- know about and that could have taken effect.
+  ledgerViewForecastAt_ cfg (ByronLedgerState ls ss) at = Forecast at $ \for ->
+      case History.find (At for) ss of
+        Just sb -> return $ toPBftLedgerView sb -- Case (A) -- should bounds?
         Nothing -- Case (B), (C) or (D)
-          | slot <  At maxLo -> throwError TooFarBehind -- lower bound is inclusive
-          | slot >= At maxHi -> throwError TooFarAhead  -- upper bound is exclusive
-          | otherwise        -> case slot of
-              Origin -> throwError TooFarBehind -- this should be unreachable
-              At s -> return $ toPBftLedgerView $
-                CC.previewDelegationMap (toByronSlotNo s) ls
+          | at  <  minLo -> error preconditionViolation
+          | for >= maxHi -> throwError $ OutsideForecastRange at for
+          | otherwise    -> return $ toPBftLedgerView $
+                              CC.previewDelegationMap (toByronSlotNo for) ls
     where
       SecurityParam k = genesisSecurityParam (unByronLedgerConfig cfg)
-
-      now, maxHi, maxLo :: SlotNo
-      now   = fromByronSlotNo $ CC.cvsLastSlot ls
-      maxLo = SlotNo $ if (2 * k) > unSlotNo now
-                        then 0
-                        else unSlotNo now - (2 * k)
-      maxHi = SlotNo $ unSlotNo now + (2 * k)
+      now             = fromByronSlotNo $ CC.cvsLastSlot ls
+
+      -- The lower bound is inclusive
+      minLo :: WithOrigin SlotNo
+      minLo = if (2 * k) > unSlotNo now
+                then Origin
+                else At (SlotNo $ unSlotNo now - (2 * k))
+
+      -- The upper bound is exclusive
+      maxHi :: SlotNo
+      maxHi = case at of
+                Origin -> SlotNo $ 2 * k
+                At s   -> SlotNo $ unSlotNo s + 1 + (2 * k)
+
+      preconditionViolation :: String
+      preconditionViolation = concat [
+            "Byron ledgerViewForecastAt precondition violated: slot "
+          , show at
+          , " more than 2k slots away from the tip"
+          ]
 
 instance HasHardForkHistory ByronBlock where
   type HardForkIndices ByronBlock = '[()]

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

@@ -45,21 +45,20 @@ import           Codec.Serialise (Serialise, decode, encode)
 import           Control.Monad.Except
 import           Data.Kind (Type)
 import           Data.Map.Strict (Map)
-import           Data.Proxy (Proxy (..))
 import           Data.Set (Set)
 import           Data.Type.Equality ((:~:) (Refl))
 import           GHC.Generics (Generic)
 
 import           Cardano.Binary (enforceSize, fromCBOR, toCBOR)
 import           Cardano.Prelude (Natural, NoUnexpectedThunks (..),
                      OnlyCheckIsWHNF (..))
-import           Cardano.Slotting.Slot (EpochNo, WithOrigin (..),
-                     fromWithOrigin)
+import           Cardano.Slotting.Slot (EpochNo, WithOrigin (..))
 
 import           Ouroboros.Network.Block
 import           Ouroboros.Network.Protocol.LocalStateQuery.Codec (Some (..))
 
 import           Ouroboros.Consensus.BlockchainTime (singletonSlotLengths)
+import           Ouroboros.Consensus.Forecast
 import qualified Ouroboros.Consensus.HardFork.History as HardFork
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
@@ -191,42 +190,42 @@ instance TPraosCrypto c => UpdateLedger (ShelleyBlock c) where
 instance TPraosCrypto c => LedgerSupportsProtocol (ShelleyBlock c) where
   protocolLedgerView _cfg = SL.currentLedgerView . shelleyState
 
-  anachronisticProtocolLedgerView_ cfg ledgerState slot =
-      case History.find slot history of
+  ledgerViewForecastAt_ cfg ledgerState at = Forecast at $ \for ->
+      case History.find (At for) history of
         Just lv -> return lv
         Nothing
-          | slot <  At maxLo
-          -> throwError TooFarBehind -- lower bound is inclusive
-          | slot >= At maxHi
-          -> throwError TooFarAhead  -- upper bound is exclusive
+          | at < minLo
+          -> error preconditionViolation
+          | for >= maxHi
+          -> throwError $ OutsideForecastRange at for
           | otherwise
           -> -- If 'futureLedgerView' fails, it is a bug
              return $ either (error "futureLedgerView failed") id $
-             SL.futureLedgerView globals shelleyState forSlot
+             SL.futureLedgerView globals shelleyState for
     where
-      ShelleyLedgerState { ledgerTip , history , shelleyState } =
-        ledgerState
-
+      ShelleyLedgerState {history , shelleyState} = ledgerState
       ShelleyLedgerConfig globals = cfg
-
-      k = SL.securityParameter globals
-
-      now, maxHi, maxLo :: SlotNo
-      maxLo = SlotNo $ if (2 * k) > unSlotNo now
-                        then 0
-                        else unSlotNo now - (2 * k)
-      maxHi = SlotNo $ unSlotNo now + (2 * k)
-      -- The slot of the last block last applied to the ledger, /now/
-      -- according to the ledger.
-      now   = fromWithOrigin
-        (minimumPossibleSlotNo (Proxy @(ShelleyBlock c)))
-        (pointSlot ledgerTip)
-
-      -- The slot for which we want to get a 'ProtocolLedgerView'
-      forSlot :: SlotNo
-      forSlot = fromWithOrigin
-        (minimumPossibleSlotNo (Proxy @(ShelleyBlock c)))
-        slot
+      k   = SL.securityParameter globals
+      now = ledgerTipSlot ledgerState
+
+      -- Inclusive lower bound
+      minLo :: WithOrigin SlotNo
+      minLo = case now of
+                At (SlotNo s) | (2 * k) > s -> At (SlotNo (s - (2 * k)))
+                _otherwise                  -> Origin
+
+      -- Exclusive upper bound
+      maxHi :: SlotNo
+      maxHi = case at of
+                Origin -> SlotNo $ 2 * k
+                At s   -> SlotNo $ unSlotNo s + 1 + (2 * k)
+
+      preconditionViolation :: String
+      preconditionViolation = concat [
+            "Shelley ledgerViewForecastAt precondition violated: slot "
+          , show at
+          , " more than 2k slots away from the tip"
+          ]
 
 instance HasHardForkHistory (ShelleyBlock c) where
   type HardForkIndices (ShelleyBlock c) = '[()]

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/BFT.hs

@@ -28,6 +28,7 @@ import           Cardano.Prelude (NoUnexpectedThunks)
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
+import           Ouroboros.Consensus.Forecast
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Mock.Ledger.Block
 import           Ouroboros.Consensus.Mock.Node.Abstract
@@ -118,10 +119,8 @@ instance ( SimpleCrypto c
          , BftCrypto c'
          , Signable (BftDSIGN c') (SignedSimpleBft c c')
          ) => LedgerSupportsProtocol (SimpleBftBlock c c') where
-  protocolLedgerView _ _ =
-      ()
-  anachronisticProtocolLedgerView_ _ _ _ =
-      return ()
+  protocolLedgerView _ _ = ()
+  ledgerViewForecastAt_ _ _ = trivialForecast
 
 {-------------------------------------------------------------------------------
   Serialisation

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs

@@ -31,6 +31,7 @@ import           Ouroboros.Network.Block (HasHeader (..))
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
+import           Ouroboros.Consensus.Forecast
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Mock.Ledger.Block
 import           Ouroboros.Consensus.Mock.Node.Abstract
@@ -133,8 +134,8 @@ instance ( SimpleCrypto c
 instance ( SimpleCrypto c
          , Signable MockDSIGN (SignedSimplePBft c PBftMockCrypto)
          ) => LedgerSupportsProtocol (SimplePBftBlock c PBftMockCrypto) where
-  protocolLedgerView               cfg _   =          simpleMockLedgerConfig cfg
-  anachronisticProtocolLedgerView_ cfg _ _ = return $ simpleMockLedgerConfig cfg
+  protocolLedgerView    cfg _ =                     simpleMockLedgerConfig cfg
+  ledgerViewForecastAt_ cfg _ = constantForecastOf (simpleMockLedgerConfig cfg)
 
 {-------------------------------------------------------------------------------
   Serialisation

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs

@@ -32,6 +32,7 @@ import           Cardano.Prelude (NoUnexpectedThunks)
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
+import           Ouroboros.Consensus.Forecast
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Mock.Ledger.Address
 import           Ouroboros.Consensus.Mock.Ledger.Block
@@ -151,8 +152,8 @@ instance ( SimpleCrypto c
          , PraosCrypto c'
          , Signable (PraosKES c') (SignedSimplePraos c c')
          ) => LedgerSupportsProtocol (SimplePraosBlock c c') where
-  protocolLedgerView               cfg _   =          stakeDist cfg
-  anachronisticProtocolLedgerView_ cfg _ _ = return $ stakeDist cfg
+  protocolLedgerView    cfg _ =                     stakeDist cfg
+  ledgerViewForecastAt_ cfg _ = constantForecastOf (stakeDist cfg)
 
 -- | Praos needs a ledger that can give it the "active stake distribution"
 --

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs

@@ -28,6 +28,7 @@ import           Cardano.Prelude (NoUnexpectedThunks)
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
+import           Ouroboros.Consensus.Forecast
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Mock.Ledger.Block
 import           Ouroboros.Consensus.Mock.Node.Abstract
@@ -102,8 +103,8 @@ instance SimpleCrypto c
   validateView _ _ = ()
 
 instance SimpleCrypto c => LedgerSupportsProtocol (SimplePraosRuleBlock c) where
-  protocolLedgerView               _ _   = ()
-  anachronisticProtocolLedgerView_ _ _ _ = return ()
+  protocolLedgerView _ _ = ()
+  ledgerViewForecastAt_ _ _ = trivialForecast
 
 {-------------------------------------------------------------------------------
   We don't need crypto for this protocol

ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/TestBlock.hs

@@ -85,6 +85,7 @@ import qualified Ouroboros.Network.MockChain.Chain as Chain
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.BlockchainTime
 import           Ouroboros.Consensus.Config
+import           Ouroboros.Consensus.Forecast
 import qualified Ouroboros.Consensus.HardFork.History as HardFork
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
@@ -334,7 +335,7 @@ instance ValidateEnvelope TestBlock where
 
 instance LedgerSupportsProtocol TestBlock where
   protocolLedgerView _ _ = ()
-  anachronisticProtocolLedgerView_ _ _ _ = return ()
+  ledgerViewForecastAt_ _ _ = trivialForecast
 
 instance HasHardForkHistory TestBlock where
   type HardForkIndices TestBlock = '[()]

ouroboros-consensus/ouroboros-consensus.cabal

@@ -43,6 +43,7 @@ library
                        Ouroboros.Consensus.BlockchainTime.SlotLengths
                        Ouroboros.Consensus.BlockchainTime.WallClock
                        Ouroboros.Consensus.Config
+                       Ouroboros.Consensus.Forecast
                        Ouroboros.Consensus.HardFork.History
                        Ouroboros.Consensus.HeaderValidation
                        Ouroboros.Consensus.Ledger.Abstract

ouroboros-consensus/src/Ouroboros/Consensus/Forecast.hs

@@ -0,0 +1,49 @@
+module Ouroboros.Consensus.Forecast (
+    Forecast(..)
+  , trivialForecast
+  , constantForecastOf
+  , OutsideForecastRange(..)
+  ) where
+
+import           Control.Exception (Exception)
+import           Control.Monad.Except
+
+import           Cardano.Slotting.Slot hiding (at)
+
+data Forecast a = Forecast {
+      forecastAt  :: WithOrigin SlotNo
+
+      -- Precondition: @At s >= forecastAt@
+    , forecastFor :: SlotNo -> Except OutsideForecastRange a
+    }
+
+-- | Trivial forecast of values of type @()@
+--
+-- Specialization of 'constantForecast'.
+trivialForecast :: WithOrigin SlotNo -> Forecast ()
+trivialForecast = constantForecastOf ()
+
+-- | Forecast where the values are never changing
+--
+-- This is primarily useful for tests; the forecast range is infinite, but we
+-- do still check the precondition, to catch any bugs.
+constantForecastOf :: a -> WithOrigin SlotNo -> Forecast a
+constantForecastOf a at = Forecast {
+      forecastAt  = at
+    , forecastFor = \for ->
+                      if At for >= at
+                        then return a
+                        else error "trivialForecast: precondition violated"
+    }
+
+data OutsideForecastRange =
+    OutsideForecastRange {
+        -- | The slot for which the forecast was obtained
+        outsideForecastAt  :: !(WithOrigin SlotNo)
+
+        -- | The slot for which we requested a value
+      , outsideForecastFor :: !SlotNo
+      }
+  deriving (Show, Eq)
+
+instance Exception OutsideForecastRange

ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs

@@ -380,8 +380,8 @@ instance Bridge m a => LedgerSupportsProtocol (DualBlock m a) where
         (dualLedgerConfigMain cfg)
         (dualLedgerStateMain  state)
 
-  anachronisticProtocolLedgerView_ cfg state =
-      anachronisticProtocolLedgerView_
+  ledgerViewForecastAt_ cfg state =
+      ledgerViewForecastAt_
         (dualLedgerConfigMain cfg)
         (dualLedgerStateMain  state)