Infrastructure for changing the hash function

chainweb.cabal

@@ -141,6 +141,7 @@ library
         , Chainweb.BlockHeaderDB.RestAPI.Client
         , Chainweb.BlockHeaderDB.RestAPI.Server
         , Chainweb.BlockHeaderDB.Types
+        , Chainweb.BlockHeight
         , Chainweb.ChainId
         , Chainweb.Chainweb
         , Chainweb.Chainweb.ChainResources

src/Chainweb/BlockHeader.hs

@@ -42,13 +42,6 @@ module Chainweb.BlockHeader
 -- $guards
 , slowEpochGuard
 
--- * Block Height
-, BlockHeight(..)
-, encodeBlockHeight
-, decodeBlockHeight
-, encodeBlockHeightBe
-, decodeBlockHeightBe
-
 -- * Block Weight
 , BlockWeight(..)
 , encodeBlockWeight
@@ -80,9 +73,12 @@ module Chainweb.BlockHeader
 , epochStart
 
 -- * FeatureFlags
-, FeatureFlags(..)
+, FeatureFlags
+, mkFeatureFlags
 , encodeFeatureFlags
 , decodeFeatureFlags
+, featureFlagsGetPowHash
+, featureFlagsSetPowHash
 
 -- * POW Target
 , powTarget
@@ -104,6 +100,10 @@ module Chainweb.BlockHeader
 , blockFlags
 , _blockPow
 , blockPow
+, _blockPowHashAlg
+, blockPowHashAlg
+, _blockPowMultiplyer
+, blockPowMultiplyer
 , _blockAdjacentChainIds
 , blockAdjacentChainIds
 , encodeBlockHeader
@@ -145,15 +145,19 @@ import Control.Monad.Catch
 
 import Data.Aeson
 import Data.Aeson.Types (Parser)
+import Data.Bits
 import Data.Bytes.Get
 import Data.Bytes.Put
 import Data.ByteString.Char8 (ByteString)
+import Data.Foldable
 import Data.Function (on)
 import Data.Hashable
 import qualified Data.HashMap.Strict as HM
 import qualified Data.HashSet as HS
 import Data.Kind
 import Data.List (unfoldr)
+import qualified Data.List.NonEmpty as NE
+import Data.Maybe
 import qualified Data.Memory.Endian as BA
 import Data.MerkleLog hiding (Actual, Expected, MerkleHash)
 import Data.Serialize (Serialize(..))
@@ -162,9 +166,12 @@ import Data.Word
 
 import GHC.Generics (Generic)
 
+import Numeric.Natural
+
 -- Internal imports
 
 import Chainweb.BlockHash
+import Chainweb.BlockHeight
 import Chainweb.ChainId
 import Chainweb.Crypto.MerkleLog
 import Chainweb.Difficulty
@@ -232,38 +239,6 @@ slowEpochGuard (ParentHeader p)
     | otherwise = False
 {-# INLINE slowEpochGuard #-}
 
--- -------------------------------------------------------------------------- --
--- | BlockHeight
---
-newtype BlockHeight = BlockHeight { _height :: Word64 }
-    deriving (Eq, Ord, Generic)
-    deriving anyclass (NFData)
-    deriving newtype
-        ( Hashable, ToJSON, FromJSON
-        , AdditiveSemigroup, AdditiveAbelianSemigroup, AdditiveMonoid
-        , Num, Integral, Real, Enum
-        )
-instance Show BlockHeight where show (BlockHeight b) = show b
-
-instance IsMerkleLogEntry ChainwebHashTag BlockHeight where
-    type Tag BlockHeight = 'BlockHeightTag
-    toMerkleNode = encodeMerkleInputNode encodeBlockHeight
-    fromMerkleNode = decodeMerkleInputNode decodeBlockHeight
-    {-# INLINE toMerkleNode #-}
-    {-# INLINE fromMerkleNode #-}
-
-encodeBlockHeight :: MonadPut m => BlockHeight -> m ()
-encodeBlockHeight (BlockHeight h) = putWord64le h
-
-decodeBlockHeight :: MonadGet m => m BlockHeight
-decodeBlockHeight = BlockHeight <$> getWord64le
-
-encodeBlockHeightBe :: MonadPut m => BlockHeight -> m ()
-encodeBlockHeightBe (BlockHeight r) = putWord64be r
-
-decodeBlockHeightBe :: MonadGet m => m BlockHeight
-decodeBlockHeightBe = BlockHeight <$> getWord64be
-
 -- -------------------------------------------------------------------------- --
 -- Block Weight
 --
@@ -407,6 +382,10 @@ isLastInEpoch h = case effectiveWindow h of
 -- network. Thus we must perform Emergency Difficulty Adjustment to avoid
 -- stalling the chain.
 --
+-- NOTE: emergency DAs are now regarded a misfeature and have been disabled in
+-- all chainweb version. Emergency DAs are enabled (and have occured) only on
+-- mainnet01 for cut heights smaller than 80,000.
+--
 slowEpoch :: BlockHeader -> BlockCreationTime -> Bool
 slowEpoch p (BlockCreationTime ct) = actual > (expected * 5)
   where
@@ -460,7 +439,7 @@ epochStart p (BlockCreationTime bt)
 -- Feature Flags
 
 newtype FeatureFlags = FeatureFlags Word64
-    deriving stock (Show, Generic)
+    deriving stock (Show, Eq, Generic)
     deriving anyclass (NFData)
     deriving newtype (ToJSON, FromJSON)
 
@@ -477,6 +456,16 @@ instance IsMerkleLogEntry ChainwebHashTag FeatureFlags where
     {-# INLINE toMerkleNode #-}
     {-# INLINE fromMerkleNode #-}
 
+mkFeatureFlags :: PowHashAlg -> FeatureFlags
+mkFeatureFlags alg = featureFlagsSetPowHash alg $ FeatureFlags 0x0
+
+featureFlagsGetPowHash :: FeatureFlags -> PowHashAlg
+featureFlagsGetPowHash (FeatureFlags f) = toEnum . int $ (f .&. 0xff)
+
+featureFlagsSetPowHash :: PowHashAlg -> FeatureFlags -> FeatureFlags
+featureFlagsSetPowHash alg (FeatureFlags f) = FeatureFlags
+    $ f .|. (0xff .&. int (fromEnum alg))
+
 -- -------------------------------------------------------------------------- --
 -- Newtype wrappers for function parameters
 
@@ -488,6 +477,10 @@ newtype ParentHeader = ParentHeader BlockHeader
 
 -- | BlockHeader
 --
+-- Values of this type should never be constructed directly by external code.
+-- Instead the 'newBlockHeader' smart constructor should be used. Once
+-- constructed 'BlockHeader' values must not be modified.
+--
 -- Some redundant, aggregated information is included in the block and the block
 -- hash. This enables nodes to be checked inductively with respect to existing
 -- blocks without recalculating the aggregated value from the genesis block
@@ -831,16 +824,42 @@ isGenesisBlockHeader b = _blockHeight b == BlockHeight 0
 
 -- | The Proof-Of-Work hash includes all data in the block except for the
 -- '_blockHash'. The value (interpreted as 'BlockHashNat' must be smaller than
--- the value of '_blockTarget' (interpreted as 'BlockHashNat').
+-- the value of '_blockTarget' (interpreted as 'BlockHashNat'), subject to the
+-- POW hash multiplier for the respective chainweb version and block height
+-- (cf. 'powHashAlg').
 --
 _blockPow :: BlockHeader -> PowHash
-_blockPow h = powHash (_blockChainwebVersion h)
-    $ runPutS $ encodeBlockHeaderWithoutHash h
+_blockPow h
+    = powHash (_blockPowHashAlg h) $ runPutS $ encodeBlockHeaderWithoutHash h
 
 blockPow :: Getter BlockHeader PowHash
 blockPow = to _blockPow
 {-# INLINE blockPow #-}
 
+-- | The POW Hash that was used for the block
+--
+_blockPowHashAlg :: BlockHeader -> PowHashAlg
+_blockPowHashAlg = featureFlagsGetPowHash . _blockFlags
+{-# INLINE _blockPowHashAlg #-}
+
+blockPowHashAlg :: Getter BlockHeader PowHashAlg
+blockPowHashAlg = to _blockPowHashAlg
+{-# INLINE blockPowHashAlg #-}
+
+-- | The multiplyer for the POW hash when checking the target.
+--
+_blockPowMultiplyer :: BlockHeader -> Natural
+_blockPowMultiplyer h = fromMaybe 1 $ lookup alg $ toList $ powHashAlg v bh
+  where
+    v = _blockChainwebVersion h
+    bh = _blockHeight h
+    alg = _blockPowHashAlg h
+{-# INLINE _blockPowMultiplyer #-}
+
+blockPowMultiplyer :: Getter BlockHeader Natural
+blockPowMultiplyer = to _blockPowMultiplyer
+{-# INLINE blockPowMultiplyer #-}
+
 -- | The number of microseconds between the creation time of two `BlockHeader`s.
 --
 timeBetween :: BlockCreationTime -> BlockCreationTime -> Micros
@@ -923,19 +942,27 @@ hashPayload v cid b = BlockPayloadHash $ MerkleLogHash
 -- -------------------------------------------------------------------------- --
 -- Create new BlockHeader
 
+-- | Creates a new block header. No validation of the input parameters is
+-- performaned.
+--
 newBlockHeader
     :: BlockHashRecord
         -- ^ Adjacent parent hashes
     -> BlockPayloadHash
         -- ^ payload hash
+    -> PowHashAlg
+        -- ^ The POW hash algorithm that is used for the block. It is not
+        -- checked. whether the hash is legal for the chainweb version and the
+        -- block height.
     -> Nonce
-        -- ^ Randomness to affect the block hash
+        -- ^ Randomness to affect the block hash. It is not verified that the
+        -- nonce is valid with respect to the target and the POW hash algorithm.
     -> BlockCreationTime
-        -- ^ Creation time of the block
+        -- ^ Creation time of the block.
     -> ParentHeader
         -- ^ parent block header
     -> BlockHeader
-newBlockHeader adj pay nonce t (ParentHeader b) = fromLog $ newMerkleLog
+newBlockHeader adj pay alg nonce t (ParentHeader b) = fromLog $ newMerkleLog
     $ nonce
     :+: t
     :+: _blockHash b
@@ -946,7 +973,7 @@ newBlockHeader adj pay nonce t (ParentHeader b) = fromLog $ newMerkleLog
     :+: _blockHeight b + 1
     :+: v
     :+: epochStart b t
-    :+: FeatureFlags 0
+    :+: mkFeatureFlags alg
     :+: MerkleLogBody (blockHashRecordToVector adj)
   where
     cid = _chainId b
@@ -979,9 +1006,10 @@ testBlockHeader
         -- ^ parent block header
     -> BlockHeader
 testBlockHeader adj nonce p@(ParentHeader b) =
-    newBlockHeader adj (testBlockPayload b) nonce (BlockCreationTime $ add second t) p
+    newBlockHeader adj (testBlockPayload b) alg nonce (BlockCreationTime $ add second t) p
   where
     BlockCreationTime t = _blockCreationTime b
+    alg = fst . NE.head $ powHashAlg (_chainwebVersion b) (_blockHeight b + 1)
 
 -- | Given a `BlockHeader` of some initial parent, generate an infinite stream
 -- of `BlockHeader`s which form a legal chain.

src/Chainweb/BlockHeader/Genesis.hs

@@ -32,6 +32,7 @@ import Control.Arrow ((&&&))
 import Data.Foldable (toList)
 import qualified Data.HashMap.Strict as HM
 import qualified Data.HashSet as HS
+import qualified Data.List.NonEmpty as NE
 import Data.MerkleLog hiding (Actual, Expected, MerkleHash)
 
 import Pact.Types.Command (CommandResult)
@@ -41,6 +42,7 @@ import Pact.Types.Hash (Hash)
 
 import Chainweb.BlockHash
 import Chainweb.BlockHeader
+import Chainweb.BlockHeight
 import qualified Chainweb.BlockHeader.Genesis.Development0Payload as DN0
 import qualified Chainweb.BlockHeader.Genesis.DevelopmentNPayload as DNN
 import qualified Chainweb.BlockHeader.Genesis.FastTimedCPM0Payload as TN0
@@ -64,6 +66,7 @@ import Chainweb.MerkleLogHash
 import Chainweb.MerkleUniverse
 import Chainweb.Miner.Pact
 import Chainweb.Payload
+import Chainweb.PowHash
 import Chainweb.Time
 import Chainweb.Utils
 import Chainweb.Version
@@ -196,7 +199,7 @@ genesisBlockHeader' v p ct@(BlockCreationTime t) n = fromLog mlog
         :+: BlockHeight 0
         :+: v
         :+: EpochStartTime t
-        :+: FeatureFlags 0
+        :+: mkFeatureFlags (fst . NE.head $ powHashAlg v (BlockHeight 0))
         :+: MerkleLogBody (blockHashRecordToVector adjParents)
     adjParents = BlockHashRecord $ HM.fromList $
         (\c -> (c, genesisParentBlockHash v c)) <$> HS.toList (adjacentChainIds g p)

src/Chainweb/BlockHeader/Validation.hs

@@ -40,6 +40,8 @@ module Chainweb.BlockHeader.Validation
 , prop_block_genesis_parent
 , prop_block_genesis_target
 , prop_block_target
+, prop_block_featureFlags
+, prop_block_powHashAlg
 
 -- * Inductive BlockHeader Properties
 , prop_block_epoch
@@ -65,6 +67,7 @@ import Chainweb.BlockHeader
 import Chainweb.BlockHeader.Genesis (genesisBlockTarget, genesisParentBlockHash)
 import Chainweb.ChainId
 import Chainweb.Difficulty
+import Chainweb.PowHash
 import Chainweb.Time
 import Chainweb.Utils
 
@@ -102,6 +105,8 @@ instance Show ValidationFailure where
             BlockInTheFuture -> "The creation time of the block is in the future"
             IncorrectPayloadHash -> "The payload hash does not match the payload hash that results from payload validation"
             MissingPayload -> "The payload of the block is missing"
+            InvalidFeatureFlags -> "The block has an invalid feature flag value"
+            InvalidPowHashAlg -> "The block uses an POW hash that is invalid for the chainweb version and block height"
 
 -- | An enumeration of possible validation failures for a block header.
 --
@@ -148,6 +153,10 @@ data ValidationFailureType
         -- ^ The validation of the payload hash failed.
     | MissingPayload
         -- ^ The payload for the block is missing.
+    | InvalidFeatureFlags
+        -- ^ The block has an invalid feature flag setting
+    | InvalidPowHashAlg
+        -- ^ The block uses an invalid POW hash algorithm
   deriving (Show, Eq, Ord)
 
 instance Exception ValidationFailure
@@ -175,6 +184,8 @@ definiteValidationFailures =
     , IncorrectGenesisParent
     , IncorrectGenesisTarget
     , IncorrectPayloadHash
+    , InvalidFeatureFlags
+    , InvalidPowHashAlg
     ]
 
 -- | Predicate that checks whether a validation failure is definite.
@@ -311,6 +322,8 @@ validateIntrinsic t b = concat
     , [ IncorrectGenesisParent | not (prop_block_genesis_parent b)]
     , [ IncorrectGenesisTarget | not (prop_block_genesis_target b)]
     , [ BlockInTheFuture | not (prop_block_current t b)]
+    , [ InvalidFeatureFlags | not (prop_block_featureFlags b)]
+    , [ InvalidPowHashAlg | not (prop_block_powHashAlg b)]
     ]
 
 -- | Validate properties of a block with respect to a given parent.
@@ -376,7 +389,7 @@ validateBlocksM t lookupParent as
 -- Intrinsic BlockHeader properties
 
 prop_block_pow :: BlockHeader -> Bool
-prop_block_pow b = checkTarget (_blockTarget b) (_blockPow b)
+prop_block_pow b = checkTarget (_blockTarget b) (_blockPow b) (_blockPowMultiplyer b)
 
 prop_block_hash :: BlockHeader -> Bool
 prop_block_hash b = _blockHash b == computeBlockHash b
@@ -396,6 +409,14 @@ prop_block_genesis_target b = isGenesisBlockHeader b
 prop_block_current :: Time Micros -> BlockHeader -> Bool
 prop_block_current t b = BlockCreationTime t >= _blockCreationTime b
 
+prop_block_powHashAlg :: BlockHeader -> Bool
+prop_block_powHashAlg b = _blockPowHashAlg b `elem` (toList algs)
+  where
+    algs = fst <$> powHashAlg (_blockChainwebVersion b) (int $ _blockHeight b)
+
+prop_block_featureFlags :: BlockHeader -> Bool
+prop_block_featureFlags b = _blockFlags b == mkFeatureFlags (_blockPowHashAlg b)
+
 -- -------------------------------------------------------------------------- --
 -- Inductive BlockHeader Properties
 

src/Chainweb/BlockHeaderDB.hs

@@ -76,6 +76,7 @@ import Chainweb.BlockHash
 import Chainweb.BlockHeader
 import Chainweb.BlockHeaderDB.Types
 import Chainweb.BlockHeader.Genesis (genesisBlockHeader)
+import Chainweb.BlockHeight
 import Chainweb.ChainId
 import Chainweb.Logger
 import Chainweb.TreeDB

src/Chainweb/BlockHeaderDB/Types.hs

@@ -33,6 +33,7 @@ import Prelude hiding (lookup)
 
 import Chainweb.BlockHash
 import Chainweb.BlockHeader
+import Chainweb.BlockHeight
 import Chainweb.ChainId
 import Chainweb.Version