{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}

module Ouroboros.Consensus.Block.Abstract (
    -- * Protocol
    BlockProtocol
    -- * Configuration
  , BlockConfig
  , CodecConfig
  , StorageConfig
    -- * Previous hash
  , GetPrevHash (..)
  , blockPrevHash
    -- * Working with headers
  , GetHeader (..)
  , Header
  , blockIsEBB
  , blockToIsEBB
  , getBlockHeaderFields
  , headerHash
  , headerPoint
  , headerToIsEBB
    -- * Raw hash
  , ConvertRawHash (..)
  , decodeRawHash
  , encodeRawHash
    -- * Utilities for working with WithOrigin
  , succWithOrigin
    -- * Ouroboros Genesis window
  , GenesisWindow (..)
    -- * Re-export basic definitions from @ouroboros-network@
  , ChainHash (..)
  , HasHeader (..)
  , HeaderFields (..)
  , HeaderHash
  , Point (GenesisPoint, BlockPoint)
  , StandardHash
  , blockHash
  , blockNo
  , blockPoint
  , blockSlot
  , castHash
  , castHeaderFields
  , castPoint
  , pointHash
  , pointSlot
    -- * Re-export basic definitions from @cardano-base@
  , BlockNo (..)
  , EpochNo (..)
  , EpochSize (..)
  , SlotNo (..)
  , WithOrigin (Origin, NotOrigin)
  , fromWithOrigin
  , withOrigin
  , withOriginFromMaybe
  , withOriginToMaybe
  ) where

import           Cardano.Slotting.Block (BlockNo (..))
import           Cardano.Slotting.Slot (EpochNo (..), EpochSize (..),
                     SlotNo (..), WithOrigin (Origin), fromWithOrigin,
                     withOrigin, withOriginFromMaybe, withOriginToMaybe)
import qualified Cardano.Slotting.Slot as Cardano
import qualified Codec.Serialise as Serialise
import           Codec.Serialise.Decoding (Decoder)
import           Codec.Serialise.Encoding (Encoding)
import qualified Data.ByteString as Strict
import           Data.ByteString.Short (ShortByteString)
import qualified Data.ByteString.Short as Short
import           Data.Kind (Type)
import           Data.Maybe (isJust)
import           Data.Word (Word32, Word64)
import           NoThunks.Class (NoThunks)
import           Ouroboros.Consensus.Block.EBB
import           Ouroboros.Network.Block (ChainHash (..), HasHeader (..),
                     HeaderFields (..), HeaderHash, Point, StandardHash,
                     blockHash, blockNo, blockPoint, blockSlot, castHash,
                     castHeaderFields, castPoint, pattern BlockPoint,
                     pattern GenesisPoint, pointHash, pointSlot)

{-------------------------------------------------------------------------------
  Protocol
-------------------------------------------------------------------------------}

-- | Map block to consensus protocol
type family BlockProtocol blk :: Type

{-------------------------------------------------------------------------------
  Configuration
-------------------------------------------------------------------------------}

-- | Static configuration required to work with this type of blocks
data family BlockConfig blk :: Type

-- | Static configuration required for serialisation and deserialisation of
-- types pertaining to this type of block.
--
-- Data family instead of type family to get better type inference.
data family CodecConfig blk :: Type

-- | Config needed for the
-- 'Ouroboros.Consensus.Node.InitStorage.NodeInitStorage' class. Defined here to
-- avoid circular dependencies.
data family StorageConfig blk :: Type

{-------------------------------------------------------------------------------
  Get hash of previous block
-------------------------------------------------------------------------------}

class (HasHeader blk, GetHeader blk) => GetPrevHash blk where
  -- | Get the hash of the predecessor of this block
  headerPrevHash :: Header blk -> ChainHash blk

blockPrevHash :: GetPrevHash blk => blk -> ChainHash blk
blockPrevHash :: forall blk. GetPrevHash blk => blk -> ChainHash blk
blockPrevHash = ChainHash blk -> ChainHash blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (ChainHash blk -> ChainHash blk)
-> (blk -> ChainHash blk) -> blk -> ChainHash blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header blk -> ChainHash blk
forall blk. GetPrevHash blk => Header blk -> ChainHash blk
headerPrevHash (Header blk -> ChainHash blk)
-> (blk -> Header blk) -> blk -> ChainHash blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader

{-------------------------------------------------------------------------------
  Link block to its header
-------------------------------------------------------------------------------}

data family Header blk :: Type

class HasHeader (Header blk) => GetHeader blk where
  getHeader          :: blk -> Header blk
  -- | Check whether the header is the header of the block.
  --
  -- For example, by checking whether the hash of the body stored in the
  -- header matches that of the block.
  blockMatchesHeader :: Header blk -> blk -> Bool

  -- | When the given header is the header of an Epoch Boundary Block, returns
  -- its epoch number.
  headerIsEBB        :: Header blk -> Maybe EpochNo

headerToIsEBB :: GetHeader blk => Header blk -> IsEBB
headerToIsEBB :: forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB = Bool -> IsEBB
toIsEBB (Bool -> IsEBB) -> (Header blk -> Bool) -> Header blk -> IsEBB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe EpochNo -> Bool
forall a. Maybe a -> Bool
isJust (Maybe EpochNo -> Bool)
-> (Header blk -> Maybe EpochNo) -> Header blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header blk -> Maybe EpochNo
forall blk. GetHeader blk => Header blk -> Maybe EpochNo
headerIsEBB

blockIsEBB :: GetHeader blk => blk -> Maybe EpochNo
blockIsEBB :: forall blk. GetHeader blk => blk -> Maybe EpochNo
blockIsEBB = Header blk -> Maybe EpochNo
forall blk. GetHeader blk => Header blk -> Maybe EpochNo
headerIsEBB (Header blk -> Maybe EpochNo)
-> (blk -> Header blk) -> blk -> Maybe EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader

blockToIsEBB :: GetHeader blk => blk -> IsEBB
blockToIsEBB :: forall blk. GetHeader blk => blk -> IsEBB
blockToIsEBB = Header blk -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB (Header blk -> IsEBB) -> (blk -> Header blk) -> blk -> IsEBB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader

type instance BlockProtocol (Header blk) = BlockProtocol blk

{-------------------------------------------------------------------------------
  Some automatic instances for 'Header'
-------------------------------------------------------------------------------}

type instance HeaderHash (Header blk) = HeaderHash blk

instance HasHeader blk => StandardHash (Header blk)

-- | Get the 'HeaderFields' of a block, without requiring 'HasHeader blk'
--
-- This is primarily useful as a a simple definition of 'HasHeader' for
-- block types:
--
-- > instance HasHeader SomeBlock where
-- >   getHeaderFields = getBlockHeaderFields
--
-- provided that there is a 'HasHeader' instance for the header.
--
-- Unfortunately we cannot give a 'HasHeader' instance once and for all; if we
-- mapped from a header to a block instead we could do
--
-- > instance HasHeader hdr => HasHeader (Block hdr) where
-- >  ..
--
-- but we can't do that when we do things this way around.
getBlockHeaderFields :: GetHeader blk => blk -> HeaderFields blk
getBlockHeaderFields :: forall blk. GetHeader blk => blk -> HeaderFields blk
getBlockHeaderFields = HeaderFields (Header blk) -> HeaderFields blk
forall {k1} {k2} (b :: k1) (b' :: k2).
(HeaderHash b ~ HeaderHash b') =>
HeaderFields b -> HeaderFields b'
castHeaderFields (HeaderFields (Header blk) -> HeaderFields blk)
-> (blk -> HeaderFields (Header blk)) -> blk -> HeaderFields blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header blk -> HeaderFields (Header blk)
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields (Header blk -> HeaderFields (Header blk))
-> (blk -> Header blk) -> blk -> HeaderFields (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader

{-------------------------------------------------------------------------------
  Convenience wrappers around 'HasHeader' that avoids unnecessary casts
-------------------------------------------------------------------------------}

headerHash :: HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash :: forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash = Header blk -> HeaderHash blk
Header blk -> HeaderHash (Header blk)
forall b. HasHeader b => b -> HeaderHash b
blockHash

headerPoint :: HasHeader (Header blk) => Header blk -> Point blk
headerPoint :: forall blk. HasHeader (Header blk) => Header blk -> Point blk
headerPoint = Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> (Header blk -> Point (Header blk)) -> Header blk -> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header blk -> Point (Header blk)
forall block. HasHeader block => block -> Point block
blockPoint

{-------------------------------------------------------------------------------
  Raw hash
-------------------------------------------------------------------------------}

-- | Convert a hash from/to raw bytes
--
-- Variants of 'toRawHash' and 'fromRawHash' for 'ShortByteString' are
-- included. Override the default implementations to avoid an extra step in
-- case the 'HeaderHash' is a 'ShortByteString' under the hood.
class ConvertRawHash blk where
  -- | Get the raw bytes from a hash
  toRawHash :: proxy blk -> HeaderHash blk -> Strict.ByteString
  toRawHash proxy blk
p = ShortByteString -> ByteString
Short.fromShort (ShortByteString -> ByteString)
-> (HeaderHash blk -> ShortByteString)
-> HeaderHash blk
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. proxy blk -> HeaderHash blk -> ShortByteString
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> ShortByteString
forall (proxy :: * -> *).
proxy blk -> HeaderHash blk -> ShortByteString
toShortRawHash proxy blk
p

  -- | Construct the hash from a raw hash
  --
  -- PRECONDITION: the bytestring's size must match 'hashSize'
  fromRawHash :: proxy blk -> Strict.ByteString -> HeaderHash blk
  fromRawHash proxy blk
p = proxy blk -> ShortByteString -> HeaderHash blk
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> ShortByteString -> HeaderHash blk
forall (proxy :: * -> *).
proxy blk -> ShortByteString -> HeaderHash blk
fromShortRawHash proxy blk
p (ShortByteString -> HeaderHash blk)
-> (ByteString -> ShortByteString) -> ByteString -> HeaderHash blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShortByteString
Short.toShort

  -- | Variant of 'toRawHash' for 'ShortByteString'
  toShortRawHash :: proxy blk -> HeaderHash blk -> ShortByteString
  toShortRawHash proxy blk
p = ByteString -> ShortByteString
Short.toShort (ByteString -> ShortByteString)
-> (HeaderHash blk -> ByteString)
-> HeaderHash blk
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. proxy blk -> HeaderHash blk -> ByteString
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> ByteString
forall (proxy :: * -> *). proxy blk -> HeaderHash blk -> ByteString
toRawHash proxy blk
p

  -- | Variant of 'fromRawHash' for 'ShortByteString'
  fromShortRawHash :: proxy blk -> ShortByteString -> HeaderHash blk
  fromShortRawHash proxy blk
p = proxy blk -> ByteString -> HeaderHash blk
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> ByteString -> HeaderHash blk
forall (proxy :: * -> *). proxy blk -> ByteString -> HeaderHash blk
fromRawHash proxy blk
p (ByteString -> HeaderHash blk)
-> (ShortByteString -> ByteString)
-> ShortByteString
-> HeaderHash blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ByteString
Short.fromShort

  -- | The size of the hash in number of bytes
  hashSize :: proxy blk -> Word32

  {-# MINIMAL hashSize
            , (toRawHash | toShortRawHash)
            , (fromRawHash | fromShortRawHash) #-}

encodeRawHash :: ConvertRawHash blk
              => proxy blk -> HeaderHash blk -> Encoding
encodeRawHash :: forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Encoding
encodeRawHash proxy blk
p = ShortByteString -> Encoding
forall a. Serialise a => a -> Encoding
Serialise.encode (ShortByteString -> Encoding)
-> (HeaderHash blk -> ShortByteString)
-> HeaderHash blk
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. proxy blk -> HeaderHash blk -> ShortByteString
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> ShortByteString
forall (proxy :: * -> *).
proxy blk -> HeaderHash blk -> ShortByteString
toShortRawHash proxy blk
p

decodeRawHash :: ConvertRawHash blk
              => proxy blk -> forall s. Decoder s (HeaderHash blk)
decodeRawHash :: forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> forall s. Decoder s (HeaderHash blk)
decodeRawHash proxy blk
p = proxy blk -> ShortByteString -> HeaderHash blk
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> ShortByteString -> HeaderHash blk
forall (proxy :: * -> *).
proxy blk -> ShortByteString -> HeaderHash blk
fromShortRawHash proxy blk
p (ShortByteString -> HeaderHash blk)
-> Decoder s ShortByteString -> Decoder s (HeaderHash blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ShortByteString
forall s. Decoder s ShortByteString
forall a s. Serialise a => Decoder s a
Serialise.decode

{-------------------------------------------------------------------------------
  Utilities for working with WithOrigin
-------------------------------------------------------------------------------}

{-# COMPLETE Origin, NotOrigin #-}

-- | Custom pattern for 'WithOrigin'
--
-- This avoids clashing with our (extensive) use of 'At' for testing.
pattern NotOrigin :: t -> WithOrigin t
pattern $mNotOrigin :: forall {r} {t}. WithOrigin t -> (t -> r) -> ((# #) -> r) -> r
$bNotOrigin :: forall t. t -> WithOrigin t
NotOrigin t = Cardano.At t

-- | Return the successor of a 'WithOrigin' value. Useful in combination with
-- 'SlotNo' and 'BlockNo'.
succWithOrigin :: (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin :: forall t. (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin = t -> (t -> t) -> WithOrigin t -> t
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin t
forall a. Bounded a => a
minBound t -> t
forall a. Enum a => a -> a
succ

{-------------------------------------------------------------------------------
  Ouroboros Genesis window
-------------------------------------------------------------------------------}

-- | Size of the Genesis window, in number of slots.
--
-- This is the number of slots that the GDD Governor (Genesis Density
-- Disconnection Governor -- see 'Ouroboros.Consensus.Genesis.Governor') will
-- consider when deciding whether to disconnect from a peer. It has to be
-- smaller or equal to the stability window. For instance, for Shelley-based
-- eras, this will be equal to a stability window, that is @3k/f@.
newtype GenesisWindow = GenesisWindow { GenesisWindow -> Word64
unGenesisWindow :: Word64 }
  deriving stock (Int -> GenesisWindow -> ShowS
[GenesisWindow] -> ShowS
GenesisWindow -> String
(Int -> GenesisWindow -> ShowS)
-> (GenesisWindow -> String)
-> ([GenesisWindow] -> ShowS)
-> Show GenesisWindow
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GenesisWindow -> ShowS
showsPrec :: Int -> GenesisWindow -> ShowS
$cshow :: GenesisWindow -> String
show :: GenesisWindow -> String
$cshowList :: [GenesisWindow] -> ShowS
showList :: [GenesisWindow] -> ShowS
Show, GenesisWindow -> GenesisWindow -> Bool
(GenesisWindow -> GenesisWindow -> Bool)
-> (GenesisWindow -> GenesisWindow -> Bool) -> Eq GenesisWindow
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GenesisWindow -> GenesisWindow -> Bool
== :: GenesisWindow -> GenesisWindow -> Bool
$c/= :: GenesisWindow -> GenesisWindow -> Bool
/= :: GenesisWindow -> GenesisWindow -> Bool
Eq, Eq GenesisWindow
Eq GenesisWindow =>
(GenesisWindow -> GenesisWindow -> Ordering)
-> (GenesisWindow -> GenesisWindow -> Bool)
-> (GenesisWindow -> GenesisWindow -> Bool)
-> (GenesisWindow -> GenesisWindow -> Bool)
-> (GenesisWindow -> GenesisWindow -> Bool)
-> (GenesisWindow -> GenesisWindow -> GenesisWindow)
-> (GenesisWindow -> GenesisWindow -> GenesisWindow)
-> Ord GenesisWindow
GenesisWindow -> GenesisWindow -> Bool
GenesisWindow -> GenesisWindow -> Ordering
GenesisWindow -> GenesisWindow -> GenesisWindow
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: GenesisWindow -> GenesisWindow -> Ordering
compare :: GenesisWindow -> GenesisWindow -> Ordering
$c< :: GenesisWindow -> GenesisWindow -> Bool
< :: GenesisWindow -> GenesisWindow -> Bool
$c<= :: GenesisWindow -> GenesisWindow -> Bool
<= :: GenesisWindow -> GenesisWindow -> Bool
$c> :: GenesisWindow -> GenesisWindow -> Bool
> :: GenesisWindow -> GenesisWindow -> Bool
$c>= :: GenesisWindow -> GenesisWindow -> Bool
>= :: GenesisWindow -> GenesisWindow -> Bool
$cmax :: GenesisWindow -> GenesisWindow -> GenesisWindow
max :: GenesisWindow -> GenesisWindow -> GenesisWindow
$cmin :: GenesisWindow -> GenesisWindow -> GenesisWindow
min :: GenesisWindow -> GenesisWindow -> GenesisWindow
Ord)
  deriving newtype (Context -> GenesisWindow -> IO (Maybe ThunkInfo)
Proxy GenesisWindow -> String
(Context -> GenesisWindow -> IO (Maybe ThunkInfo))
-> (Context -> GenesisWindow -> IO (Maybe ThunkInfo))
-> (Proxy GenesisWindow -> String)
-> NoThunks GenesisWindow
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> GenesisWindow -> IO (Maybe ThunkInfo)
noThunks :: Context -> GenesisWindow -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> GenesisWindow -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> GenesisWindow -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy GenesisWindow -> String
showTypeOf :: Proxy GenesisWindow -> String
NoThunks, Integer -> GenesisWindow
GenesisWindow -> GenesisWindow
GenesisWindow -> GenesisWindow -> GenesisWindow
(GenesisWindow -> GenesisWindow -> GenesisWindow)
-> (GenesisWindow -> GenesisWindow -> GenesisWindow)
-> (GenesisWindow -> GenesisWindow -> GenesisWindow)
-> (GenesisWindow -> GenesisWindow)
-> (GenesisWindow -> GenesisWindow)
-> (GenesisWindow -> GenesisWindow)
-> (Integer -> GenesisWindow)
-> Num GenesisWindow
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: GenesisWindow -> GenesisWindow -> GenesisWindow
+ :: GenesisWindow -> GenesisWindow -> GenesisWindow
$c- :: GenesisWindow -> GenesisWindow -> GenesisWindow
- :: GenesisWindow -> GenesisWindow -> GenesisWindow
$c* :: GenesisWindow -> GenesisWindow -> GenesisWindow
* :: GenesisWindow -> GenesisWindow -> GenesisWindow
$cnegate :: GenesisWindow -> GenesisWindow
negate :: GenesisWindow -> GenesisWindow
$cabs :: GenesisWindow -> GenesisWindow
abs :: GenesisWindow -> GenesisWindow
$csignum :: GenesisWindow -> GenesisWindow
signum :: GenesisWindow -> GenesisWindow
$cfromInteger :: Integer -> GenesisWindow
fromInteger :: Integer -> GenesisWindow
Num)