The HardFork protocol combinator

This only introduces the protocol combinator, not yet the ledger
integration. We might still end up tweaking this a bit.

Co-authored-by: Rupert Horlick <rupert.horlick@iohk.io>

ouroboros-consensus/ouroboros-consensus.cabal

@@ -73,6 +73,14 @@ library
                        Ouroboros.Consensus.Protocol.Abstract
                        Ouroboros.Consensus.Protocol.BFT
                        Ouroboros.Consensus.Protocol.ExtNodeConfig
+                       Ouroboros.Consensus.Protocol.HardFork
+                       Ouroboros.Consensus.Protocol.HardFork.CanHardFork
+                       Ouroboros.Consensus.Protocol.HardFork.CanHardFork.MockPBftToPraos
+                       Ouroboros.Consensus.Protocol.HardFork.ChainState
+                       Ouroboros.Consensus.Protocol.HardFork.Config
+                       Ouroboros.Consensus.Protocol.HardFork.Forked
+                       Ouroboros.Consensus.Protocol.HardFork.OuroborosTag
+                       Ouroboros.Consensus.Protocol.HardFork.ProjectState
                        Ouroboros.Consensus.Protocol.LeaderSchedule
                        Ouroboros.Consensus.Protocol.MockChainSel
                        Ouroboros.Consensus.Protocol.ModChainSel

ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs

@@ -158,6 +158,10 @@ class ( Show (ChainState    p)
   compareCandidates _ = AF.compareHeadBlockNo
 
   -- | Check if a node is the leader
+  --
+  -- The 'LedgerView' and 'ChainState' passed to 'checkIsLeader' are the ledger
+  -- view and chain state for the /currently adopted chain/ (and must therefore
+  -- be consistent with each other).
   checkIsLeader :: (HasNodeState p m, MonadRandom m)
                 => NodeConfig p
                 -> SlotNo

ouroboros-consensus/src/Ouroboros/Consensus/Protocol/HardFork.hs

@@ -0,0 +1,8 @@
+module Ouroboros.Consensus.Protocol.HardFork (
+    module X
+  ) where
+
+import           Ouroboros.Consensus.Protocol.HardFork.CanHardFork as X
+import           Ouroboros.Consensus.Protocol.HardFork.CanHardFork.MockPBftToPraos as X
+                     ()
+import           Ouroboros.Consensus.Protocol.HardFork.OuroborosTag as X

ouroboros-consensus/src/Ouroboros/Consensus/Protocol/HardFork/CanHardFork.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators         #-}
+
+module Ouroboros.Consensus.Protocol.HardFork.CanHardFork (
+    CanHardFork(..)
+  ) where
+
+import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
+import           Ouroboros.Network.Block (HasHeader, SlotNo)
+
+import           Ouroboros.Consensus.Protocol.Abstract
+import           Ouroboros.Consensus.Protocol.HardFork.Config
+
+{-------------------------------------------------------------------------------
+  Class to hard fork between protocols
+-------------------------------------------------------------------------------}
+
+-- | Protocol specific functionality required to fork between protocols
+class (OuroborosTag p1, OuroborosTag p2) => CanHardFork p1 p2 where
+  -- | Should we fork (or already have forked) at this slot?
+  shouldFork
+    :: NodeConfig (p1 `HardForksTo` p2)
+    -> LedgerView p1 -> SlotNo -> Bool
+
+  -- | Convert the 'ChainState' from the old protocol to the new at the boundary
+  chainStateAfterFork
+    :: NodeConfig (p1 `HardForksTo` p2) -> ChainState p1 -> ChainState p2
+
+  -- | Convert the 'LedgerView' from the old protocol to the new at the boundary
+  ledgerViewAfterFork
+    :: NodeConfig (p1 `HardForksTo` p2) -> LedgerView p1 -> LedgerView p2
+
+  -- | Do we prefer this candidate?
+  --
+  -- We use this because it is tricky to define a generic version for any two
+  -- protocols.
+  --
+  -- TODO: Describe what the difficulty is.
+  hardForkPreferCandidate
+    :: HasHeader hdr
+    => NodeConfig (p1 `HardForksTo` p2)
+    -> AnchoredFragment hdr -- ^ Our chain
+    -> AnchoredFragment hdr -- ^ Candidate
+    -> Bool
+
+  -- | Which candidate do we prefer?
+  --
+  -- We use this because it is tricky to define a generic version for any two
+  -- protocols.
+  --
+  -- TODO: Describe what the difficulty is.
+  hardForkCompareCandidates
+    :: HasHeader hdr
+    => NodeConfig (p1 `HardForksTo` p2)
+    -> AnchoredFragment hdr
+    -> AnchoredFragment hdr
+    -> Ordering

ouroboros-consensus/src/Ouroboros/Consensus/Protocol/HardFork/CanHardFork/MockPBftToPraos.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Ouroboros.Consensus.Protocol.HardFork.CanHardFork.MockPBftToPraos () where
+
+import           Ouroboros.Consensus.Ledger.Mock
+import qualified Ouroboros.Consensus.Ledger.Mock.Stake as Stake
+import           Ouroboros.Consensus.Protocol.ExtNodeConfig
+import           Ouroboros.Consensus.Protocol.HardFork.CanHardFork
+import           Ouroboros.Consensus.Protocol.HardFork.Config
+import           Ouroboros.Consensus.Protocol.PBFT hiding (pbftParams)
+import           Ouroboros.Consensus.Protocol.Praos
+import qualified Ouroboros.Consensus.Util.AnchoredFragment as AF
+
+{-------------------------------------------------------------------------------
+  Simple Hard Fork Instance
+-------------------------------------------------------------------------------}
+
+type MockPBft  = ExtNodeConfig (PBftLedgerView PBftMockCrypto) (PBft PBftMockCrypto)
+type MockPraos = ExtNodeConfig AddrDist (Praos PraosMockCrypto)
+
+instance CanHardFork MockPBft MockPraos where
+
+  shouldFork _ _ _ = False -- TODO
+
+  chainStateAfterFork _ _ = []
+
+  ledgerViewAfterFork cfg _ = Stake.equalStakeDist addrDist
+    where
+      addrDist :: AddrDist
+      addrDist = encNodeConfigExt (nodeConfigAfterFork cfg)
+
+  -- We just use the defaults from OuroborosTag for chain selection
+
+  hardForkPreferCandidate _ ours cand = AF.compareHeadBlockNo cand ours == GT
+  hardForkCompareCandidates _ = AF.compareHeadBlockNo

ouroboros-consensus/src/Ouroboros/Consensus/Protocol/HardFork/ChainState.hs

@@ -0,0 +1,143 @@
+{-# LANGUAGE DeriveAnyClass       #-}
+{-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE RecordWildCards      #-}
+{-# LANGUAGE StandaloneDeriving   #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | Chain state for the hard fork combinator
+--
+-- Intended for qualified import.
+--
+-- > import Ouroboros.Consensus.Protocol.HardFork.ChainState (AfterForkChainState(..))
+-- > import qualified Ouroboros.Consensus.Protocol.HardFork.ChainState as AFCS
+module Ouroboros.Consensus.Protocol.HardFork.ChainState (
+    AfterForkChainState(..)
+  , init
+  , update
+  , dropSnapshotIfRedundant
+    -- * Serialisation
+  , encodeAfterForkChainState
+  , decodeAfterForkChainState
+  ) where
+
+import           Prelude hiding (init)
+
+import           Codec.Serialise (Serialise (..))
+import           Control.Monad (guard)
+import           Data.Word
+import           GHC.Generics (Generic)
+
+import           Cardano.Binary
+import           Cardano.Prelude (NoUnexpectedThunks)
+
+import           Ouroboros.Network.Block
+
+import           Ouroboros.Consensus.Protocol.Abstract
+import           Ouroboros.Consensus.Protocol.HardFork.CanHardFork
+import           Ouroboros.Consensus.Protocol.HardFork.Config
+
+{-------------------------------------------------------------------------------
+  ChainState for after the fork
+-------------------------------------------------------------------------------}
+
+-- | After the fork we need to keep track of when we forked and keep a snapshot
+--   of the old era 'ChainState' for k blocks
+data AfterForkChainState p1 p2 =
+    AfterForkChainState {
+        -- | The slot number of the block that initiated the hard fork
+        afcsSlotNo   :: SlotNo
+
+        -- | The block number of the block that initiated the hard fork
+      , afcsBlockNo  :: BlockNo
+
+        -- | Snapshot of the chain state before the hard fork
+        --
+        -- Will be set to 'Nothing' once this is no longer required (when we are
+        -- sure we cannot roll back anymore to before the hard fork).
+      , afcsSnapshot :: Maybe (ChainState p1)
+
+        -- | Current chain state
+      , afcsState    :: ChainState p2
+      }
+  deriving (Generic)
+
+deriving instance (OuroborosTag p1, OuroborosTag p2)
+               => Show (AfterForkChainState p1 p2)
+
+deriving instance (OuroborosTag p1, OuroborosTag p2)
+               => NoUnexpectedThunks (AfterForkChainState p1 p2)
+
+-- | Initial chain state (immediately after the fork)
+init :: (HasHeader hdr, CanHardFork p1 p2)
+     => NodeConfig (p1 `HardForksTo` p2)
+     -> hdr
+     -> ChainState p1
+     -> AfterForkChainState p1 p2
+init cfg hdr oldState = AfterForkChainState {
+      afcsSlotNo   = blockSlot hdr
+    , afcsBlockNo  = blockNo hdr
+    , afcsSnapshot = Just oldState
+    , afcsState    = chainStateAfterFork cfg oldState
+    }
+
+dropSnapshotIfRedundant :: (HasHeader hdr, OuroborosTag p2)
+                        => NodeConfig p2
+                        -> hdr            -- ^ Most recent applied header
+                        -> AfterForkChainState p1 p2
+                        -> AfterForkChainState p1 p2
+dropSnapshotIfRedundant cfg hdr afcs = afcs {
+      afcsSnapshot = guard (distance < k) >> afcsSnapshot afcs
+    }
+  where
+    k, atFork, now, distance :: Word64
+    k        = maxRollbacks (protocolSecurityParam cfg)
+    atFork   = unBlockNo (afcsBlockNo afcs)
+    now      = unBlockNo (blockNo hdr)
+    distance = if now >= atFork
+                 then now - atFork
+                 else error "apply: block from the past"
+
+-- | Update the chain state
+update :: Monad m
+       => AfterForkChainState p1 p2
+       -> (ChainState p2 -> m (ChainState p2))
+       -> m (AfterForkChainState p1 p2)
+update afcs f = do
+    newState <- f (afcsState afcs)
+    return $ afcs {
+        afcsState = newState
+      }
+
+{-------------------------------------------------------------------------------
+  Serialisation
+-------------------------------------------------------------------------------}
+
+encodeAfterForkChainState
+  :: (ChainState p1 -> Encoding)
+  -> (ChainState p2 -> Encoding)
+  -> AfterForkChainState p1 p2
+  -> Encoding
+encodeAfterForkChainState encodeBeforeFork
+                          encodeAfterFork
+                          AfterForkChainState{..} =
+    mconcat [
+        encodeListLen 4
+      , encode afcsSlotNo
+      , encode afcsBlockNo
+      , toCBORMaybe encodeBeforeFork afcsSnapshot
+      , encodeAfterFork afcsState
+      ]
+
+decodeAfterForkChainState
+  :: Decoder s (ChainState p1)
+  -> Decoder s (ChainState p2)
+  -> Decoder s (AfterForkChainState p1 p2)
+decodeAfterForkChainState decodeBeforeFork decodeAfterFork = do
+    decodeListLenOf 4
+    afcsSlotNo   <- decode
+    afcsBlockNo  <- decode
+    afcsSnapshot <- fromCBORMaybe decodeBeforeFork
+    afcsState    <- decodeAfterFork
+    return AfterForkChainState{..}

ouroboros-consensus/src/Ouroboros/Consensus/Protocol/HardFork/Config.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE TypeOperators      #-}
+
+module Ouroboros.Consensus.Protocol.HardFork.Config (
+    HardForksTo
+  , NodeConfig(..)
+  ) where
+
+import           Data.Typeable (typeRep)
+import           GHC.Generics (Generic)
+
+import           Cardano.Prelude (NoUnexpectedThunks (..))
+
+import           Ouroboros.Consensus.Protocol.Abstract
+
+-- | A protocol that acts as @p1@ until a hard fork switches to @p2@
+data HardForksTo p1 p2
+
+-- Store configuration for both protocols
+data instance NodeConfig (p1 `HardForksTo` p2) =
+    HardForkCfg {
+        nodeConfigBeforeFork :: NodeConfig p1
+      , nodeConfigAfterFork  :: NodeConfig p2
+      }
+  deriving (Generic)
+
+instance (OuroborosTag p1, OuroborosTag p2)
+      => NoUnexpectedThunks (NodeConfig (p1 `HardForksTo` p2)) where
+  showTypeOf = show . typeRep

ouroboros-consensus/src/Ouroboros/Consensus/Protocol/HardFork/Forked.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE UndecidableInstances       #-}
+
+module Ouroboros.Consensus.Protocol.HardFork.Forked (
+    -- * Forked data
+    Forked(..)
+  , forked
+  , forkedPair
+  , forkedTriple
+  , unsafeBeforeFork
+  , unsafeAfterFork
+  ) where
+
+import           Data.Bifoldable
+import           Data.Bifunctor
+import           Data.Bitraversable
+import           GHC.Generics (Generic)
+import           GHC.Stack (HasCallStack)
+
+import           Cardano.Prelude (NoUnexpectedThunks)
+
+import           Ouroboros.Consensus.Util.Condense
+
+{-------------------------------------------------------------------------------
+  Forked Data
+-------------------------------------------------------------------------------}
+
+-- | A sum type to represent values before and after a hard fork
+data Forked a b = BeforeFork a | AfterFork b
+  deriving (Eq, Ord, Show, Generic, NoUnexpectedThunks)
+
+instance Bifunctor Forked where
+  bimap f g = forked (BeforeFork . f) (AfterFork . g)
+
+instance Bifoldable Forked where
+  bifoldMap = forked
+
+instance Bitraversable Forked where
+  bitraverse f g = forked (fmap BeforeFork . f) (fmap AfterFork . g)
+
+instance (Condense a, Condense b) => Condense (Forked a b) where
+  condense (BeforeFork a) = condense a
+  condense (AfterFork b)  = condense b
+
+forked :: (a -> c) -> (b -> c) -> Forked a b -> c
+forked f _ (BeforeFork a) = f a
+forked _ g (AfterFork  b) = g b
+
+forkedPair :: Forked a  b
+           -> Forked a' b'
+           -> Maybe (Forked (a, a') (b, b'))
+forkedPair (BeforeFork a) (BeforeFork a') = Just $ BeforeFork (a, a')
+forkedPair (AfterFork  b) (AfterFork  b') = Just $ AfterFork  (b, b')
+forkedPair _              _               = Nothing
+
+forkedTriple :: Forked a   b
+             -> Forked a'  b'
+             -> Forked a'' b''
+             -> Maybe (Forked (a, a', a'') (b, b', b''))
+forkedTriple (BeforeFork a) (BeforeFork a') (BeforeFork a'') = Just $ BeforeFork (a, a', a'')
+forkedTriple (AfterFork  b) (AfterFork  b') (AfterFork  b'') = Just $ AfterFork  (b, b', b'')
+forkedTriple _              _               _                = Nothing
+
+unsafeBeforeFork :: HasCallStack => Forked a b -> a
+unsafeBeforeFork (BeforeFork a) = a
+unsafeBeforeFork _              = error "unsafeBeforeFork: Got AfterFork"
+
+unsafeAfterFork :: HasCallStack => Forked a b -> b
+unsafeAfterFork (AfterFork b) = b
+unsafeAfterFork _             = error "unsafeAfterFork: Got BeforeFork"