Block authentication

chainweb.cabal

@@ -118,6 +118,7 @@ library
     c-sources: c/shathree.c
     exposed-modules:
           Chainweb.Backup
+        , Chainweb.BlockAuthentication
         , Chainweb.BlockCreationTime
         , Chainweb.BlockHash
         , Chainweb.BlockHeader
@@ -352,6 +353,7 @@ library
         , filepath >= 1.4
         , ghc-compact >= 0.1
         , hashable >= 1.3
+        , hashes >= 0.2.3
         , heaps >= 0.3
         , hourglass >=0.2
         , http-client >= 0.5

src/Chainweb/BlockAuthentication.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- |
+-- Module: Chainweb.BlockAuthentication
+-- Copyright: Copyright © 2023 Kadena LLC.
+-- License: MIT
+-- Maintainer: Lars Kuhtz <[email protected]>
+-- Stability: experimental
+--
+module Chainweb.BlockAuthentication
+( BlockAuthenticationHash
+, blockAuthenticationHashAsWord64
+, BlockAuthenticationKey
+, blockAuthenticationHash
+) where
+
+import Control.DeepSeq
+import Control.Monad.Catch
+
+import Data.Aeson
+import Data.Aeson.Encoding hiding (int)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Builder as BB
+import Data.Hash.SipHash
+import Data.Hashable
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TB
+import qualified Data.Text.Lazy.Builder.Int as TB
+import qualified Data.Text.Read as T
+import Data.Word
+
+import GHC.Generics
+
+-- internal modules
+
+import Chainweb.Utils
+
+-- -------------------------------------------------------------------------- --
+-- BlockAuthenticationHash
+
+newtype BlockAuthenticationHash = BlockAuthenticationHash Word64
+    deriving stock (Show, Eq, Ord, Generic)
+    deriving anyclass (NFData)
+    deriving newtype (Hashable, Enum)
+
+blockAuthenticationHashAsWord64 :: BlockAuthenticationHash -> Word64
+blockAuthenticationHashAsWord64 (BlockAuthenticationHash w) = w
+{-# INLINE blockAuthenticationHashAsWord64 #-}
+
+-- -------------------------------------------------------------------------- --
+-- Block Authentication Key
+--
+-- If configured the nonce is a SipHash of chainweb version + chainid +
+-- blockHeight + creationTime. This is used by non-PoW miners and the CPU miner.
+--
+
+data BlockAuthenticationKey = BlockAuthenticationKey !Word64 !Word64
+    deriving (Eq, Ord, Generic)
+
+blockAuthenticationKeyToText :: BlockAuthenticationKey -> T.Text
+blockAuthenticationKeyToText (BlockAuthenticationKey a b)
+    = TL.toStrict . TB.toLazyText $ TB.hexadecimal a <> TB.hexadecimal b
+{-# INLINE blockAuthenticationKeyToText #-}
+
+blockAuthenticationKeyFromText :: MonadThrow m => T.Text -> m BlockAuthenticationKey
+blockAuthenticationKeyFromText t
+    | T.length t /= 32 = throwM . TextFormatException
+        $ "failed to read hex digits: expected 32 digits but got " <> sshow (T.length t)
+    | otherwise = case T.splitAt 16 t of
+        (a, b) -> BlockAuthenticationKey <$> word64Hex a <*> word64Hex b
+  where
+    word64Hex t' = case T.hexadecimal t' of
+        Right (n, "") -> return n
+        Right (n, x) ->
+            throwM . TextFormatException
+                $ "failed to parse hex digits: pending characters after reading " <> sshow n <> ": " <> x
+        Left e -> throwM . TextFormatException
+            $ "failed to read hex digits: " <> sshow e
+
+instance Show BlockAuthenticationKey where
+    show = T.unpack . blockAuthenticationKeyToText
+    {-# INLINE show #-}
+
+instance HasTextRepresentation BlockAuthenticationKey where
+    toText = blockAuthenticationKeyToText
+    {-# INLINE toText #-}
+    fromText = blockAuthenticationKeyFromText
+    {-# INLINE fromText #-}
+
+instance ToJSON BlockAuthenticationKey where
+    toEncoding (BlockAuthenticationKey a b)
+        = unsafeToEncoding $ "\"" <> BB.wordHex (int a) <> BB.wordHex (int b) <> "\""
+    toJSON = toJSON . blockAuthenticationKeyToText
+    {-# INLINE toEncoding #-}
+    {-# INLINE toJSON #-}
+
+instance FromJSON BlockAuthenticationKey where
+    parseJSON = parseJsonFromText "BlockAuthenticationKey"
+    {-# INLINE parseJSON #-}
+
+blockAuthenticationHash :: BlockAuthenticationKey -> B.ByteString -> BlockAuthenticationHash
+blockAuthenticationHash (BlockAuthenticationKey a b) s = BlockAuthenticationHash n
+  where
+    SipHash n = hashByteString @(SipHash 2 4) (SipHashKey a b) s
+

src/Chainweb/BlockHeader.hs

@@ -81,6 +81,8 @@ module Chainweb.BlockHeader
 , blockFlags
 , _blockPow
 , blockPow
+, _blockAuth
+, blockAuth
 , _blockAdjacentChainIds
 , blockAdjacentChainIds
 , encodeBlockHeader
@@ -129,6 +131,7 @@ import GHC.Generics (Generic)
 
 -- Internal imports
 
+import Chainweb.BlockAuthentication
 import Chainweb.BlockCreationTime
 import Chainweb.BlockHash
 import Chainweb.BlockHeight
@@ -824,6 +827,14 @@ blockPow :: Getter BlockHeader PowHash
 blockPow = to _blockPow
 {-# INLINE blockPow #-}
 
+_blockAuth :: BlockAuthenticationKey -> BlockHeader -> BlockAuthenticationHash
+_blockAuth k h = blockAuthenticationHash k
+    $ runPutS $ encodeBlockHeaderWithoutHash h
+
+blockAuth :: BlockAuthenticationKey -> Getter BlockHeader BlockAuthenticationHash
+blockAuth k = to (_blockAuth k)
+{-# INLINE blockAuth #-}
+
 -- | The number of microseconds between the creation time of two `BlockHeader`s.
 --
 timeBetween :: BlockCreationTime -> BlockCreationTime -> Micros

src/Chainweb/BlockHeader/Validation.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- |
 -- Module: Chainweb.BlockHeader.Validation
@@ -73,6 +74,7 @@ module Chainweb.BlockHeader.Validation
 
 -- * Intrinsic BlockHeader Properties
 , prop_block_pow
+, prop_block_auth
 , prop_block_hash
 , prop_block_genesis_parent
 , prop_block_genesis_target
@@ -108,6 +110,7 @@ import System.IO.Unsafe
 
 -- internal modules
 
+import Chainweb.BlockAuthentication
 import Chainweb.BlockCreationTime
 import Chainweb.BlockHash
 import Chainweb.BlockHeader
@@ -305,6 +308,7 @@ instance Show ValidationFailure where
             AdjacentParentChainMismatch -> "An adjacent parent hash references a block on the wrong chain"
             IncorrectHash -> "The hash of the block header does not match the one given"
             IncorrectPow -> "The POW hash does not match the POW target of the block"
+            IncorrectAuth -> "The block authentication hash of the header does not match the the nonce of the header"
             IncorrectEpoch -> "The epoch start time of the block is incorrect"
             IncorrectHeight -> "The given height is not one more than the parent height"
             IncorrectWeight -> "The given weight is not the sum of the difficulty target and the parent's weight"
@@ -342,6 +346,10 @@ data ValidationFailureType
     | IncorrectPow
         -- ^ The POW hash of the header does not match the POW target of the
         -- block.
+    | IncorrectAuth
+        -- ^ [Only applicable for networks that support it and if the BLOCK_AUTHENTICATION_KEY
+        -- environment variable is set] The block authentication hash of the header does not match
+        -- the the nonce of the header.
     | IncorrectHeight
         -- ^ The given height is not one more than the parent height.
     | IncorrectWeight
@@ -396,6 +404,7 @@ definiteValidationFailures =
     , ChainMismatch
     , IncorrectHash
     , IncorrectPow
+    , IncorrectAuth
     , IncorrectHeight
     , IncorrectWeight
     , IncorrectTarget
@@ -627,6 +636,7 @@ validateIntrinsic
         -- ^ A list of ways in which the block header isn't valid
 validateIntrinsic t b = concat
     [ [ IncorrectHash | not (prop_block_hash b) ]
+    , [ IncorrectAuth | not (prop_block_auth b) ]
     , [ IncorrectPow | not (prop_block_pow b) ]
     , [ IncorrectGenesisParent | not (prop_block_genesis_parent b)]
     , [ IncorrectGenesisTarget | not (prop_block_genesis_target b)]
@@ -675,6 +685,24 @@ validateInductiveWebStep s = concat
 -- Intrinsic BlockHeader properties
 -- -------------------------------------------------------------------------- --
 
+blockAuthenticationKey :: Maybe BlockAuthenticationKey
+blockAuthenticationKey = fmap (unsafeFromText . T.pack)
+    $ unsafeDupablePerformIO
+    $ lookupEnv "BLOCK_AUTHENTICATION_KEY"
+{-# NOINLINE blockAuthenticationKey #-}
+
+prop_block_auth :: BlockHeader -> Bool
+prop_block_auth b
+    -- Genesis block headers are not mined. So there's not need for Auth
+    | isGenesisBlockHeader b = True
+
+    -- Mainnet: no support for block authentication
+    | _blockChainwebVersion b == Mainnet01 = True
+
+    | otherwise = case blockAuthenticationKey of
+        Just k -> blockAuthenticationHashAsWord64 (_blockAuth k b) == encodeNonceToWord64 (_blockNonce b)
+        Nothing -> True
+
 powDisabled :: Bool
 powDisabled = case unsafeDupablePerformIO $ lookupEnv "DISABLE_POW_VALIDATION" of
   Nothing -> False
@@ -683,8 +711,8 @@ powDisabled = case unsafeDupablePerformIO $ lookupEnv "DISABLE_POW_VALIDATION" o
 
 prop_block_pow :: BlockHeader -> Bool
 prop_block_pow b
+    -- Genesis block headers are not mined. So there's not need for POW
     | isGenesisBlockHeader b = True
-        -- Genesis block headers are not mined. So there's not need for POW
     | _blockChainwebVersion b == Development && powDisabled = True
     | otherwise = checkTarget (_blockTarget b) (_blockPow b)