{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE NumDecimals                #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

-- | Abstract view over blocks
--
-- The network layer does not make any concrete assumptions about what blocks
-- look like.
module Ouroboros.Network.Block
  ( SlotNo (..)
  , BlockNo (..)
  , HeaderHash
  , HeaderFields (..)
  , castHeaderFields
  , HasHeader (..)
  , blockNo
  , blockSlot
  , blockHash
  , HasFullHeader (..)
  , StandardHash
  , ChainHash (..)
  , castHash
  , Point (..)
  , pointSlot
  , pointHash
  , castPoint
  , blockPoint
  , pattern GenesisPoint
  , pattern BlockPoint
  , atSlot
  , withHash
  , Tip (..)
  , castTip
  , getTipPoint
  , getTipBlockNo
  , getTipSlotNo
  , getLegacyTipBlockNo
  , tipFromHeader
  , legacyTip
  , toLegacyTip
  , encodeTip
  , encodedTipSize
  , decodeTip
  , ChainUpdate (..)
  , MaxSlotNo (..)
  , maxSlotNoFromMaybe
  , maxSlotNoToMaybe
  , maxSlotNoFromWithOrigin
  , genesisPoint
    -- * Serialisation
  , encodePoint
  , encodedPointSize
  , encodeChainHash
  , decodePoint
  , decodeChainHash
    -- * Serialised block/header
  , Serialised (..)
  , wrapCBORinCBOR
  , unwrapCBORinCBOR
  , mkSerialised
  , fromSerialised
  ) where

import           Codec.CBOR.Decoding (Decoder)
import qualified Codec.CBOR.Decoding as Dec
import           Codec.CBOR.Encoding (Encoding)
import qualified Codec.CBOR.Encoding as Enc
import qualified Codec.CBOR.Read as Read
import qualified Codec.CBOR.Write as Write
import           Codec.Serialise (Serialise (..))
import           Control.Monad (when)
import           Control.Tracer (contramap)
import qualified Data.ByteString.Base16.Lazy as B16
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString.Lazy.Char8 as BSC
import           Data.Coerce (Coercible, coerce)
import           Data.Kind (Type)
import           Data.Typeable (Typeable)
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)

import           Cardano.Binary (Case (..), Size, szCases, szGreedy)
import           Cardano.Slotting.Block
import           Cardano.Slotting.Slot (SlotNo (..))

import           Ouroboros.Network.Point (WithOrigin (..), block,
                     fromWithOrigin, origin, withOriginToMaybe)
import qualified Ouroboros.Network.Point as Point (Block (..))
import           Ouroboros.Network.Util.ShowProxy

genesisPoint :: Point block
genesisPoint :: Point block
genesisPoint = WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
forall block.
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point WithOrigin (Block SlotNo (HeaderHash block))
forall t. WithOrigin t
origin

-- | Header hash
type family HeaderHash b :: Type

-- | Header fields we expect to be present in a block
--
-- These fields are lazy because they are extracted from a block or block
-- header; this type is not intended for storage.
data HeaderFields b = HeaderFields {
      HeaderFields b -> SlotNo
headerFieldSlot    :: SlotNo
    , HeaderFields b -> BlockNo
headerFieldBlockNo :: BlockNo
    , HeaderFields b -> HeaderHash b
headerFieldHash    :: HeaderHash b
      -- ^ NOTE: this field is last so that the derived 'Eq' and 'Ord'
      -- instances first compare the slot and block numbers, which is cheaper
      -- than comparing hashes.
    }
  deriving ((forall x. HeaderFields b -> Rep (HeaderFields b) x)
-> (forall x. Rep (HeaderFields b) x -> HeaderFields b)
-> Generic (HeaderFields b)
forall x. Rep (HeaderFields b) x -> HeaderFields b
forall x. HeaderFields b -> Rep (HeaderFields b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall b x. Rep (HeaderFields b) x -> HeaderFields b
forall b x. HeaderFields b -> Rep (HeaderFields b) x
$cto :: forall b x. Rep (HeaderFields b) x -> HeaderFields b
$cfrom :: forall b x. HeaderFields b -> Rep (HeaderFields b) x
Generic)

deriving instance StandardHash b => Show (HeaderFields b)
deriving instance StandardHash b => Eq   (HeaderFields b)
deriving instance StandardHash b => Ord  (HeaderFields b)

-- Serialise instance only for the benefit of tests
deriving instance Serialise (HeaderHash b) => Serialise (HeaderFields b)

type instance HeaderHash (HeaderFields b) = HeaderHash b

castHeaderFields :: HeaderHash b ~ HeaderHash b'
                 => HeaderFields b -> HeaderFields b'
castHeaderFields :: HeaderFields b -> HeaderFields b'
castHeaderFields (HeaderFields SlotNo
h BlockNo
s HeaderHash b
b) = SlotNo -> BlockNo -> HeaderHash b' -> HeaderFields b'
forall b. SlotNo -> BlockNo -> HeaderHash b -> HeaderFields b
HeaderFields SlotNo
h BlockNo
s HeaderHash b
HeaderHash b'
b

instance StandardHash b => StandardHash (HeaderFields b)

-- | Abstract over the shape of blocks (or indeed just block headers)
class (StandardHash b, Typeable b) => HasHeader b where
  getHeaderFields :: b -> HeaderFields b

instance (StandardHash b, Typeable b) => HasHeader (HeaderFields b) where
  getHeaderFields :: HeaderFields b -> HeaderFields (HeaderFields b)
getHeaderFields = HeaderFields b -> HeaderFields (HeaderFields b)
forall b b'.
(HeaderHash b ~ HeaderHash b') =>
HeaderFields b -> HeaderFields b'
castHeaderFields

blockHash :: HasHeader b => b -> HeaderHash b
blockHash :: b -> HeaderHash b
blockHash = HeaderFields b -> HeaderHash b
forall b. HeaderFields b -> HeaderHash b
headerFieldHash (HeaderFields b -> HeaderHash b)
-> (b -> HeaderFields b) -> b -> HeaderHash b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> HeaderFields b
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields

blockSlot :: HasHeader b => b -> SlotNo
blockSlot :: b -> SlotNo
blockSlot = HeaderFields b -> SlotNo
forall b. HeaderFields b -> SlotNo
headerFieldSlot (HeaderFields b -> SlotNo) -> (b -> HeaderFields b) -> b -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> HeaderFields b
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields

blockNo   :: HasHeader b => b -> BlockNo
blockNo :: b -> BlockNo
blockNo = HeaderFields b -> BlockNo
forall b. HeaderFields b -> BlockNo
headerFieldBlockNo (HeaderFields b -> BlockNo)
-> (b -> HeaderFields b) -> b -> BlockNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> HeaderFields b
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields

-- | Extension of 'HasHeader' with some additional information
--
-- Used in tests and assertions only.
class HasHeader b => HasFullHeader b where
    blockPrevHash  :: b -> ChainHash b
    blockInvariant :: b -> Bool

-- | 'StandardHash' summarises the constraints we want header hashes to have
--
-- Without this class we would need to write
--
-- > deriving instance Eq (HeaderHash block) => Eq (ChainHash block)`
--
-- That requires @UndecidableInstances@; not a problem by itself, but it also
-- means that we can then not use @deriving Eq@ anywhere else for datatypes
-- that reference 'Hash', which is very frustrating; see
--
-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#inferred-context-for-deriving-clauses>
--
-- Introducing the 'StandardHash' class avoids this problem.
--
-- Having these constraints directly as part of the 'HasHeader' class is
-- possible but libraries that /use/ the networking layer may wish to be able to
-- talk about 'StandardHash' independently of 'HasHeader' since the latter may
-- impose yet further constraints.
class ( Eq       (HeaderHash b)
      , Ord      (HeaderHash b)
      , Show     (HeaderHash b)
      , Typeable (HeaderHash b)
      , NoThunks (HeaderHash b)
      ) => StandardHash b

data ChainHash b = GenesisHash | BlockHash !(HeaderHash b)
  deriving ((forall x. ChainHash b -> Rep (ChainHash b) x)
-> (forall x. Rep (ChainHash b) x -> ChainHash b)
-> Generic (ChainHash b)
forall x. Rep (ChainHash b) x -> ChainHash b
forall x. ChainHash b -> Rep (ChainHash b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall b x. Rep (ChainHash b) x -> ChainHash b
forall b x. ChainHash b -> Rep (ChainHash b) x
$cto :: forall b x. Rep (ChainHash b) x -> ChainHash b
$cfrom :: forall b x. ChainHash b -> Rep (ChainHash b) x
Generic)

deriving instance StandardHash block => Eq   (ChainHash block)
deriving instance StandardHash block => Ord  (ChainHash block)
deriving instance StandardHash block => Show (ChainHash block)

instance (StandardHash block, Typeable block) => NoThunks (ChainHash block)
  -- use generic instance

castHash :: Coercible (HeaderHash b) (HeaderHash b') => ChainHash b -> ChainHash b'
castHash :: ChainHash b -> ChainHash b'
castHash ChainHash b
GenesisHash   = ChainHash b'
forall b. ChainHash b
GenesisHash
castHash (BlockHash HeaderHash b
h) = HeaderHash b' -> ChainHash b'
forall b. HeaderHash b -> ChainHash b
BlockHash (HeaderHash b -> HeaderHash b'
coerce HeaderHash b
h)

{-------------------------------------------------------------------------------
  Point on a chain
-------------------------------------------------------------------------------}

-- | A point on the chain is identified by its 'Slot' and 'HeaderHash'.
--
-- The 'Slot' tells us where to look and the 'HeaderHash' either simply serves
-- as a check, or in some contexts it disambiguates blocks from different forks
-- that were in the same slot.
--
-- It's a newtype rather than a type synonym, because using a type synonym
-- would lead to ambiguity, since HeaderHash is a non-injective type family.
newtype Point block = Point
    { Point block -> WithOrigin (Block SlotNo (HeaderHash block))
getPoint :: WithOrigin (Point.Block SlotNo (HeaderHash block))
    }
  deriving ((forall x. Point block -> Rep (Point block) x)
-> (forall x. Rep (Point block) x -> Point block)
-> Generic (Point block)
forall x. Rep (Point block) x -> Point block
forall x. Point block -> Rep (Point block) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall block x. Rep (Point block) x -> Point block
forall block x. Point block -> Rep (Point block) x
$cto :: forall block x. Rep (Point block) x -> Point block
$cfrom :: forall block x. Point block -> Rep (Point block) x
Generic)

deriving newtype instance StandardHash block => Eq       (Point block)
deriving newtype instance StandardHash block => Ord      (Point block)
deriving newtype instance StandardHash block => Show     (Point block)
deriving newtype instance StandardHash block => NoThunks (Point block)

instance ShowProxy block => ShowProxy (Point block) where
    showProxy :: Proxy (Point block) -> String
showProxy Proxy (Point block)
_ = String
"Point " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Proxy block -> String
forall k (p :: k). ShowProxy p => Proxy p -> String
showProxy (Proxy block
forall k (t :: k). Proxy t
Proxy :: Proxy block)

pattern GenesisPoint :: Point block
pattern $bGenesisPoint :: Point block
$mGenesisPoint :: forall r block. Point block -> (Void# -> r) -> (Void# -> r) -> r
GenesisPoint = Point Origin

pattern BlockPoint :: SlotNo -> HeaderHash block -> Point block
pattern $bBlockPoint :: SlotNo -> HeaderHash block -> Point block
$mBlockPoint :: forall r block.
Point block
-> (SlotNo -> HeaderHash block -> r) -> (Void# -> r) -> r
BlockPoint { Point block -> SlotNo
atSlot, Point block -> HeaderHash block
withHash } = Point (At (Point.Block atSlot withHash))

{-# COMPLETE GenesisPoint, BlockPoint #-}

pointSlot :: Point block -> WithOrigin SlotNo
pointSlot :: Point block -> WithOrigin SlotNo
pointSlot (Point WithOrigin (Block SlotNo (HeaderHash block))
pt) = (Block SlotNo (HeaderHash block) -> SlotNo)
-> WithOrigin (Block SlotNo (HeaderHash block))
-> WithOrigin SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Block SlotNo (HeaderHash block) -> SlotNo
forall slot hash. Block slot hash -> slot
Point.blockPointSlot WithOrigin (Block SlotNo (HeaderHash block))
pt

pointHash :: Point block -> ChainHash block
pointHash :: Point block -> ChainHash block
pointHash (Point WithOrigin (Block SlotNo (HeaderHash block))
pt) = case WithOrigin (Block SlotNo (HeaderHash block))
pt of
    WithOrigin (Block SlotNo (HeaderHash block))
Origin -> ChainHash block
forall b. ChainHash b
GenesisHash
    At Block SlotNo (HeaderHash block)
blk -> HeaderHash block -> ChainHash block
forall b. HeaderHash b -> ChainHash b
BlockHash (Block SlotNo (HeaderHash block) -> HeaderHash block
forall slot hash. Block slot hash -> hash
Point.blockPointHash Block SlotNo (HeaderHash block)
blk)

castPoint :: Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b'
castPoint :: Point b -> Point b'
castPoint Point b
GenesisPoint           = Point b'
forall block. Point block
GenesisPoint
castPoint (BlockPoint SlotNo
slot HeaderHash b
hash) = SlotNo -> HeaderHash b' -> Point b'
forall block. SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
slot (HeaderHash b -> HeaderHash b'
coerce HeaderHash b
hash)

blockPoint :: HasHeader block => block -> Point block
blockPoint :: block -> Point block
blockPoint block
b = WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
forall block.
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point (SlotNo
-> HeaderHash block -> WithOrigin (Block SlotNo (HeaderHash block))
forall slot hash. slot -> hash -> WithOrigin (Block slot hash)
block SlotNo
s HeaderHash block
h)
  where
    HeaderFields { headerFieldSlot :: forall b. HeaderFields b -> SlotNo
headerFieldSlot = SlotNo
s, headerFieldHash :: forall b. HeaderFields b -> HeaderHash b
headerFieldHash = HeaderHash block
h } = block -> HeaderFields block
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields block
b

{-------------------------------------------------------------------------------
  Tip of a chain
-------------------------------------------------------------------------------}

-- | Used in chain-sync protocol to advertise the tip of the server's chain.
--
data Tip b =
    -- | The tip is genesis
    TipGenesis

    -- | The tip is not genesis
  | Tip !SlotNo !(HeaderHash b) !BlockNo
  deriving ((forall x. Tip b -> Rep (Tip b) x)
-> (forall x. Rep (Tip b) x -> Tip b) -> Generic (Tip b)
forall x. Rep (Tip b) x -> Tip b
forall x. Tip b -> Rep (Tip b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall b x. Rep (Tip b) x -> Tip b
forall b x. Tip b -> Rep (Tip b) x
$cto :: forall b x. Rep (Tip b) x -> Tip b
$cfrom :: forall b x. Tip b -> Rep (Tip b) x
Generic)

deriving instance StandardHash b => Eq       (Tip b)
deriving instance StandardHash b => Show     (Tip b)
deriving instance StandardHash b => NoThunks (Tip b)
instance ShowProxy b => ShowProxy (Tip b) where
    showProxy :: Proxy (Tip b) -> String
showProxy Proxy (Tip b)
_ = String
"Tip " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Proxy b -> String
forall k (p :: k). ShowProxy p => Proxy p -> String
showProxy (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b)

-- | The equivalent of 'castPoint' for 'Tip'
castTip :: (HeaderHash a ~ HeaderHash b) => Tip a -> Tip b
castTip :: Tip a -> Tip b
castTip Tip a
TipGenesis  = Tip b
forall b. Tip b
TipGenesis
castTip (Tip SlotNo
s HeaderHash a
h BlockNo
b) = SlotNo -> HeaderHash b -> BlockNo -> Tip b
forall b. SlotNo -> HeaderHash b -> BlockNo -> Tip b
Tip SlotNo
s HeaderHash a
HeaderHash b
h BlockNo
b

getTipPoint :: Tip b -> Point b
getTipPoint :: Tip b -> Point b
getTipPoint Tip b
TipGenesis  = Point b
forall block. Point block
GenesisPoint
getTipPoint (Tip SlotNo
s HeaderHash b
h BlockNo
_) = SlotNo -> HeaderHash b -> Point b
forall block. SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
s HeaderHash b
h

getTipBlockNo :: Tip b -> WithOrigin BlockNo
getTipBlockNo :: Tip b -> WithOrigin BlockNo
getTipBlockNo Tip b
TipGenesis  = WithOrigin BlockNo
forall t. WithOrigin t
Origin
getTipBlockNo (Tip SlotNo
_ HeaderHash b
_ BlockNo
b) = BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At BlockNo
b

getTipSlotNo :: Tip b -> WithOrigin SlotNo
getTipSlotNo :: Tip b -> WithOrigin SlotNo
getTipSlotNo Tip b
TipGenesis  = WithOrigin SlotNo
forall t. WithOrigin t
Origin
getTipSlotNo (Tip SlotNo
s HeaderHash b
_ BlockNo
_) = SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At SlotNo
s

tipFromHeader ::  HasHeader a => a -> Tip a
tipFromHeader :: a -> Tip a
tipFromHeader a
a = SlotNo -> HeaderHash a -> BlockNo -> Tip a
forall b. SlotNo -> HeaderHash b -> BlockNo -> Tip b
Tip SlotNo
headerFieldSlot HeaderHash a
headerFieldHash BlockNo
headerFieldBlockNo
  where
    HeaderFields { SlotNo
headerFieldSlot :: SlotNo
headerFieldSlot :: forall b. HeaderFields b -> SlotNo
headerFieldSlot
                 , BlockNo
headerFieldBlockNo :: BlockNo
headerFieldBlockNo :: forall b. HeaderFields b -> BlockNo
headerFieldBlockNo
                 , HeaderHash a
headerFieldHash :: HeaderHash a
headerFieldHash :: forall b. HeaderFields b -> HeaderHash b
headerFieldHash
                 } = a -> HeaderFields a
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields a
a


-- | Get the block number associated with a 'Tip', or 'genesisBlockNo' otherwise
--
-- TODO: This is /wrong/. There /is/ no block number if we are at genesis
-- ('genesisBlockNo' is the block number of the first block on the chain).
-- Usage of this function should be phased out.
getLegacyTipBlockNo :: Tip b -> BlockNo
getLegacyTipBlockNo :: Tip b -> BlockNo
getLegacyTipBlockNo = BlockNo -> WithOrigin BlockNo -> BlockNo
forall t. t -> WithOrigin t -> t
fromWithOrigin BlockNo
genesisBlockNo (WithOrigin BlockNo -> BlockNo)
-> (Tip b -> WithOrigin BlockNo) -> Tip b -> BlockNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tip b -> WithOrigin BlockNo
forall b. Tip b -> WithOrigin BlockNo
getTipBlockNo
  where
    genesisBlockNo :: BlockNo
genesisBlockNo = Word64 -> BlockNo
BlockNo Word64
0
{-# DEPRECATED getLegacyTipBlockNo "Use getTipBlockNo" #-}

-- | Translate to the format it was before (to maintain binary compatibility)
toLegacyTip :: Tip b -> (Point b, BlockNo)
toLegacyTip :: Tip b -> (Point b, BlockNo)
toLegacyTip Tip b
tip = (Tip b -> Point b
forall b. Tip b -> Point b
getTipPoint Tip b
tip, Tip b -> BlockNo
forall b. Tip b -> BlockNo
getLegacyTipBlockNo Tip b
tip)
{-# DEPRECATED toLegacyTip "Use getTipPoint and getTipBlockNo" #-}

-- | Inverse of 'toLegacyTip'
--
-- TODO: This should be phased out, since it makes no sense to have a
-- 'BlockNo' for the genesis point.
legacyTip :: Point b -> BlockNo -> Tip b
legacyTip :: Point b -> BlockNo -> Tip b
legacyTip Point b
GenesisPoint     BlockNo
_ = Tip b
forall b. Tip b
TipGenesis -- Ignore block number
legacyTip (BlockPoint SlotNo
s HeaderHash b
h) BlockNo
b = SlotNo -> HeaderHash b -> BlockNo -> Tip b
forall b. SlotNo -> HeaderHash b -> BlockNo -> Tip b
Tip SlotNo
s HeaderHash b
h BlockNo
b
{-# DEPRECATED legacyTip "Use tipFromHeader instead" #-}

encodeTip :: (HeaderHash blk -> Encoding)
          -> (Tip        blk -> Encoding)
encodeTip :: (HeaderHash blk -> Encoding) -> Tip blk -> Encoding
encodeTip HeaderHash blk -> Encoding
encodeHeaderHash Tip blk
tip = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
    [ Word -> Encoding
Enc.encodeListLen Word
2
    , (HeaderHash blk -> Encoding) -> Point blk -> Encoding
forall block.
(HeaderHash block -> Encoding) -> Point block -> Encoding
encodePoint HeaderHash blk -> Encoding
encodeHeaderHash Point blk
tipPoint
    , BlockNo -> Encoding
forall a. Serialise a => a -> Encoding
encode                       BlockNo
tipBlockNo
    ]
  where
    tipPoint :: Point blk
tipPoint   = Tip blk -> Point blk
forall b. Tip b -> Point b
getTipPoint Tip blk
tip
    -- note: 'encodePoint' would encode 'Origin' differently than @'Block' 0@,
    -- we keep the encoding backward compatible.
    tipBlockNo :: BlockNo
tipBlockNo = BlockNo -> WithOrigin BlockNo -> BlockNo
forall t. t -> WithOrigin t -> t
fromWithOrigin (Word64 -> BlockNo
BlockNo Word64
0)
                                (Tip blk -> WithOrigin BlockNo
forall b. Tip b -> WithOrigin BlockNo
getTipBlockNo Tip blk
tip)

-- TODO: add a test, which should compare with 'encodedTip', including various
-- instantiations of 'blk', e.g. 'ByronBlock, etc.  Thus this test should live
-- in 'ourobors-consensus'.
encodedTipSize :: (Proxy (HeaderHash blk) -> Size)
               -> (Proxy (Tip        blk) -> Size)
encodedTipSize :: (Proxy (HeaderHash blk) -> Size) -> Proxy (Tip blk) -> Size
encodedTipSize Proxy (HeaderHash blk) -> Size
encodedHeaderHashSize Proxy (Tip blk)
tipProxy =
    Size
1
  Size -> Size -> Size
forall a. Num a => a -> a -> a
+ (Proxy (HeaderHash blk) -> Size) -> Proxy (Point blk) -> Size
forall block.
(Proxy (HeaderHash block) -> Size) -> Proxy (Point block) -> Size
encodedPointSize Proxy (HeaderHash blk) -> Size
encodedHeaderHashSize ((Point blk, BlockNo) -> Point blk
forall a b. (a, b) -> a
fst ((Point blk, BlockNo) -> Point blk)
-> (Tip blk -> (Point blk, BlockNo)) -> Tip blk -> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tip blk -> (Point blk, BlockNo)
forall b. Tip b -> (Point b, BlockNo)
toLegacyTip (Tip blk -> Point blk) -> Proxy (Tip blk) -> Proxy (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (Tip blk)
tipProxy)
  -- TODO: remove 'unBlockNo' when 'BlockNo' 'ToCBOR' instance will implement
  -- 'encodedSizeExpr', also include a test in `cardano-ledger-byron`.
  Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Proxy Word64 -> Size
forall a. ToCBOR a => Proxy a -> Size
szGreedy (BlockNo -> Word64
unBlockNo (BlockNo -> Word64) -> (Tip blk -> BlockNo) -> Tip blk -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point blk, BlockNo) -> BlockNo
forall a b. (a, b) -> b
snd ((Point blk, BlockNo) -> BlockNo)
-> (Tip blk -> (Point blk, BlockNo)) -> Tip blk -> BlockNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tip blk -> (Point blk, BlockNo)
forall b. Tip b -> (Point b, BlockNo)
toLegacyTip (Tip blk -> Word64) -> Proxy (Tip blk) -> Proxy Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (Tip blk)
tipProxy)

decodeTip :: forall blk.
             (forall s. Decoder s (HeaderHash blk))
          -> (forall s. Decoder s (Tip        blk))
decodeTip :: (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Tip blk)
decodeTip forall s. Decoder s (HeaderHash blk)
decodeHeaderHash = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
Dec.decodeListLenOf Int
2
    Point blk
tipPoint    <- (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Point blk)
forall block.
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
decodePoint forall s. Decoder s (HeaderHash blk)
decodeHeaderHash
    BlockNo
tipBlockNo  <- Decoder s BlockNo
forall a s. Serialise a => Decoder s a
decode
    Tip blk -> Decoder s (Tip blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tip blk -> Decoder s (Tip blk)) -> Tip blk -> Decoder s (Tip blk)
forall a b. (a -> b) -> a -> b
$ case Point blk
tipPoint :: Point blk of
      Point blk
GenesisPoint   -> Tip blk
forall b. Tip b
TipGenesis
      BlockPoint SlotNo
s HeaderHash blk
h -> SlotNo -> HeaderHash blk -> BlockNo -> Tip blk
forall b. SlotNo -> HeaderHash b -> BlockNo -> Tip b
Tip SlotNo
s HeaderHash blk
h BlockNo
tipBlockNo


{-------------------------------------------------------------------------------
  ChainUpdate type
-------------------------------------------------------------------------------}

-- | A representation of two actions to update a chain: add a block or roll
-- back to a previous point.
--
-- The type parameter @a@ is there to allow a 'Functor' instance. Typically,
-- it will be instantiated with @block@ itself.
data ChainUpdate block a = AddBlock a
                         | RollBack (Point block)
  deriving (ChainUpdate block a -> ChainUpdate block a -> Bool
(ChainUpdate block a -> ChainUpdate block a -> Bool)
-> (ChainUpdate block a -> ChainUpdate block a -> Bool)
-> Eq (ChainUpdate block a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall block a.
(StandardHash block, Eq a) =>
ChainUpdate block a -> ChainUpdate block a -> Bool
/= :: ChainUpdate block a -> ChainUpdate block a -> Bool
$c/= :: forall block a.
(StandardHash block, Eq a) =>
ChainUpdate block a -> ChainUpdate block a -> Bool
== :: ChainUpdate block a -> ChainUpdate block a -> Bool
$c== :: forall block a.
(StandardHash block, Eq a) =>
ChainUpdate block a -> ChainUpdate block a -> Bool
Eq, Int -> ChainUpdate block a -> ShowS
[ChainUpdate block a] -> ShowS
ChainUpdate block a -> String
(Int -> ChainUpdate block a -> ShowS)
-> (ChainUpdate block a -> String)
-> ([ChainUpdate block a] -> ShowS)
-> Show (ChainUpdate block a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall block a.
(StandardHash block, Show a) =>
Int -> ChainUpdate block a -> ShowS
forall block a.
(StandardHash block, Show a) =>
[ChainUpdate block a] -> ShowS
forall block a.
(StandardHash block, Show a) =>
ChainUpdate block a -> String
showList :: [ChainUpdate block a] -> ShowS
$cshowList :: forall block a.
(StandardHash block, Show a) =>
[ChainUpdate block a] -> ShowS
show :: ChainUpdate block a -> String
$cshow :: forall block a.
(StandardHash block, Show a) =>
ChainUpdate block a -> String
showsPrec :: Int -> ChainUpdate block a -> ShowS
$cshowsPrec :: forall block a.
(StandardHash block, Show a) =>
Int -> ChainUpdate block a -> ShowS
Show, a -> ChainUpdate block b -> ChainUpdate block a
(a -> b) -> ChainUpdate block a -> ChainUpdate block b
(forall a b.
 (a -> b) -> ChainUpdate block a -> ChainUpdate block b)
-> (forall a b. a -> ChainUpdate block b -> ChainUpdate block a)
-> Functor (ChainUpdate block)
forall a b. a -> ChainUpdate block b -> ChainUpdate block a
forall a b. (a -> b) -> ChainUpdate block a -> ChainUpdate block b
forall block a b. a -> ChainUpdate block b -> ChainUpdate block a
forall block a b.
(a -> b) -> ChainUpdate block a -> ChainUpdate block b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ChainUpdate block b -> ChainUpdate block a
$c<$ :: forall block a b. a -> ChainUpdate block b -> ChainUpdate block a
fmap :: (a -> b) -> ChainUpdate block a -> ChainUpdate block b
$cfmap :: forall block a b.
(a -> b) -> ChainUpdate block a -> ChainUpdate block b
Functor, ChainUpdate block a -> Bool
(a -> m) -> ChainUpdate block a -> m
(a -> b -> b) -> b -> ChainUpdate block a -> b
(forall m. Monoid m => ChainUpdate block m -> m)
-> (forall m a. Monoid m => (a -> m) -> ChainUpdate block a -> m)
-> (forall m a. Monoid m => (a -> m) -> ChainUpdate block a -> m)
-> (forall a b. (a -> b -> b) -> b -> ChainUpdate block a -> b)
-> (forall a b. (a -> b -> b) -> b -> ChainUpdate block a -> b)
-> (forall b a. (b -> a -> b) -> b -> ChainUpdate block a -> b)
-> (forall b a. (b -> a -> b) -> b -> ChainUpdate block a -> b)
-> (forall a. (a -> a -> a) -> ChainUpdate block a -> a)
-> (forall a. (a -> a -> a) -> ChainUpdate block a -> a)
-> (forall a. ChainUpdate block a -> [a])
-> (forall a. ChainUpdate block a -> Bool)
-> (forall a. ChainUpdate block a -> Int)
-> (forall a. Eq a => a -> ChainUpdate block a -> Bool)
-> (forall a. Ord a => ChainUpdate block a -> a)
-> (forall a. Ord a => ChainUpdate block a -> a)
-> (forall a. Num a => ChainUpdate block a -> a)
-> (forall a. Num a => ChainUpdate block a -> a)
-> Foldable (ChainUpdate block)
forall a. Eq a => a -> ChainUpdate block a -> Bool
forall a. Num a => ChainUpdate block a -> a
forall a. Ord a => ChainUpdate block a -> a
forall m. Monoid m => ChainUpdate block m -> m
forall a. ChainUpdate block a -> Bool
forall a. ChainUpdate block a -> Int
forall a. ChainUpdate block a -> [a]
forall a. (a -> a -> a) -> ChainUpdate block a -> a
forall block a. Eq a => a -> ChainUpdate block a -> Bool
forall block a. Num a => ChainUpdate block a -> a
forall block a. Ord a => ChainUpdate block a -> a
forall m a. Monoid m => (a -> m) -> ChainUpdate block a -> m
forall block m. Monoid m => ChainUpdate block m -> m
forall block a. ChainUpdate block a -> Bool
forall block a. ChainUpdate block a -> Int
forall block a. ChainUpdate block a -> [a]
forall b a. (b -> a -> b) -> b -> ChainUpdate block a -> b
forall a b. (a -> b -> b) -> b -> ChainUpdate block a -> b
forall block a. (a -> a -> a) -> ChainUpdate block a -> a
forall block m a. Monoid m => (a -> m) -> ChainUpdate block a -> m
forall block b a. (b -> a -> b) -> b -> ChainUpdate block a -> b
forall block a b. (a -> b -> b) -> b -> ChainUpdate block a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: ChainUpdate block a -> a
$cproduct :: forall block a. Num a => ChainUpdate block a -> a
sum :: ChainUpdate block a -> a
$csum :: forall block a. Num a => ChainUpdate block a -> a
minimum :: ChainUpdate block a -> a
$cminimum :: forall block a. Ord a => ChainUpdate block a -> a
maximum :: ChainUpdate block a -> a
$cmaximum :: forall block a. Ord a => ChainUpdate block a -> a
elem :: a -> ChainUpdate block a -> Bool
$celem :: forall block a. Eq a => a -> ChainUpdate block a -> Bool
length :: ChainUpdate block a -> Int
$clength :: forall block a. ChainUpdate block a -> Int
null :: ChainUpdate block a -> Bool
$cnull :: forall block a. ChainUpdate block a -> Bool
toList :: ChainUpdate block a -> [a]
$ctoList :: forall block a. ChainUpdate block a -> [a]
foldl1 :: (a -> a -> a) -> ChainUpdate block a -> a
$cfoldl1 :: forall block a. (a -> a -> a) -> ChainUpdate block a -> a
foldr1 :: (a -> a -> a) -> ChainUpdate block a -> a
$cfoldr1 :: forall block a. (a -> a -> a) -> ChainUpdate block a -> a
foldl' :: (b -> a -> b) -> b -> ChainUpdate block a -> b
$cfoldl' :: forall block b a. (b -> a -> b) -> b -> ChainUpdate block a -> b
foldl :: (b -> a -> b) -> b -> ChainUpdate block a -> b
$cfoldl :: forall block b a. (b -> a -> b) -> b -> ChainUpdate block a -> b
foldr' :: (a -> b -> b) -> b -> ChainUpdate block a -> b
$cfoldr' :: forall block a b. (a -> b -> b) -> b -> ChainUpdate block a -> b
foldr :: (a -> b -> b) -> b -> ChainUpdate block a -> b
$cfoldr :: forall block a b. (a -> b -> b) -> b -> ChainUpdate block a -> b
foldMap' :: (a -> m) -> ChainUpdate block a -> m
$cfoldMap' :: forall block m a. Monoid m => (a -> m) -> ChainUpdate block a -> m
foldMap :: (a -> m) -> ChainUpdate block a -> m
$cfoldMap :: forall block m a. Monoid m => (a -> m) -> ChainUpdate block a -> m
fold :: ChainUpdate block m -> m
$cfold :: forall block m. Monoid m => ChainUpdate block m -> m
Foldable, Functor (ChainUpdate block)
Foldable (ChainUpdate block)
Functor (ChainUpdate block)
-> Foldable (ChainUpdate block)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> ChainUpdate block a -> f (ChainUpdate block b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    ChainUpdate block (f a) -> f (ChainUpdate block a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> ChainUpdate block a -> m (ChainUpdate block b))
-> (forall (m :: * -> *) a.
    Monad m =>
    ChainUpdate block (m a) -> m (ChainUpdate block a))
-> Traversable (ChainUpdate block)
(a -> f b) -> ChainUpdate block a -> f (ChainUpdate block b)
forall block. Functor (ChainUpdate block)
forall block. Foldable (ChainUpdate block)
forall block (m :: * -> *) a.
Monad m =>
ChainUpdate block (m a) -> m (ChainUpdate block a)
forall block (f :: * -> *) a.
Applicative f =>
ChainUpdate block (f a) -> f (ChainUpdate block a)
forall block (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ChainUpdate block a -> m (ChainUpdate block b)
forall block (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ChainUpdate block a -> f (ChainUpdate block b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
ChainUpdate block (m a) -> m (ChainUpdate block a)
forall (f :: * -> *) a.
Applicative f =>
ChainUpdate block (f a) -> f (ChainUpdate block a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ChainUpdate block a -> m (ChainUpdate block b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ChainUpdate block a -> f (ChainUpdate block b)
sequence :: ChainUpdate block (m a) -> m (ChainUpdate block a)
$csequence :: forall block (m :: * -> *) a.
Monad m =>
ChainUpdate block (m a) -> m (ChainUpdate block a)
mapM :: (a -> m b) -> ChainUpdate block a -> m (ChainUpdate block b)
$cmapM :: forall block (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ChainUpdate block a -> m (ChainUpdate block b)
sequenceA :: ChainUpdate block (f a) -> f (ChainUpdate block a)
$csequenceA :: forall block (f :: * -> *) a.
Applicative f =>
ChainUpdate block (f a) -> f (ChainUpdate block a)
traverse :: (a -> f b) -> ChainUpdate block a -> f (ChainUpdate block b)
$ctraverse :: forall block (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ChainUpdate block a -> f (ChainUpdate block b)
$cp2Traversable :: forall block. Foldable (ChainUpdate block)
$cp1Traversable :: forall block. Functor (ChainUpdate block)
Traversable)

{-------------------------------------------------------------------------------
  MaxSlotNo
-------------------------------------------------------------------------------}

-- | The highest slot number seen.
data MaxSlotNo
  = NoMaxSlotNo
    -- ^ No block/header has been seen yet, so we don't have a highest slot
    -- number.
  | MaxSlotNo !SlotNo
    -- ^ The highest slot number seen.
  deriving (MaxSlotNo -> MaxSlotNo -> Bool
(MaxSlotNo -> MaxSlotNo -> Bool)
-> (MaxSlotNo -> MaxSlotNo -> Bool) -> Eq MaxSlotNo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MaxSlotNo -> MaxSlotNo -> Bool
$c/= :: MaxSlotNo -> MaxSlotNo -> Bool
== :: MaxSlotNo -> MaxSlotNo -> Bool
$c== :: MaxSlotNo -> MaxSlotNo -> Bool
Eq, Int -> MaxSlotNo -> ShowS
[MaxSlotNo] -> ShowS
MaxSlotNo -> String
(Int -> MaxSlotNo -> ShowS)
-> (MaxSlotNo -> String)
-> ([MaxSlotNo] -> ShowS)
-> Show MaxSlotNo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MaxSlotNo] -> ShowS
$cshowList :: [MaxSlotNo] -> ShowS
show :: MaxSlotNo -> String
$cshow :: MaxSlotNo -> String
showsPrec :: Int -> MaxSlotNo -> ShowS
$cshowsPrec :: Int -> MaxSlotNo -> ShowS
Show, (forall x. MaxSlotNo -> Rep MaxSlotNo x)
-> (forall x. Rep MaxSlotNo x -> MaxSlotNo) -> Generic MaxSlotNo
forall x. Rep MaxSlotNo x -> MaxSlotNo
forall x. MaxSlotNo -> Rep MaxSlotNo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MaxSlotNo x -> MaxSlotNo
$cfrom :: forall x. MaxSlotNo -> Rep MaxSlotNo x
Generic, Context -> MaxSlotNo -> IO (Maybe ThunkInfo)
Proxy MaxSlotNo -> String
(Context -> MaxSlotNo -> IO (Maybe ThunkInfo))
-> (Context -> MaxSlotNo -> IO (Maybe ThunkInfo))
-> (Proxy MaxSlotNo -> String)
-> NoThunks MaxSlotNo
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy MaxSlotNo -> String
$cshowTypeOf :: Proxy MaxSlotNo -> String
wNoThunks :: Context -> MaxSlotNo -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> MaxSlotNo -> IO (Maybe ThunkInfo)
noThunks :: Context -> MaxSlotNo -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> MaxSlotNo -> IO (Maybe ThunkInfo)
NoThunks)

-- The derived instances would do the same, but for clarity, we write it out
-- explicitly.
instance Ord MaxSlotNo where
  compare :: MaxSlotNo -> MaxSlotNo -> Ordering
compare MaxSlotNo
NoMaxSlotNo       (MaxSlotNo SlotNo
_) = Ordering
LT
  compare MaxSlotNo
NoMaxSlotNo       MaxSlotNo
NoMaxSlotNo   = Ordering
EQ
  compare (MaxSlotNo SlotNo
_)  MaxSlotNo
NoMaxSlotNo      = Ordering
GT
  compare (MaxSlotNo SlotNo
s1) (MaxSlotNo SlotNo
s2)   = SlotNo -> SlotNo -> Ordering
forall a. Ord a => a -> a -> Ordering
compare SlotNo
s1 SlotNo
s2

maxSlotNoFromMaybe :: Maybe SlotNo -> MaxSlotNo
maxSlotNoFromMaybe :: Maybe SlotNo -> MaxSlotNo
maxSlotNoFromMaybe = MaxSlotNo -> (SlotNo -> MaxSlotNo) -> Maybe SlotNo -> MaxSlotNo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MaxSlotNo
NoMaxSlotNo SlotNo -> MaxSlotNo
MaxSlotNo

maxSlotNoToMaybe :: MaxSlotNo -> Maybe SlotNo
maxSlotNoToMaybe :: MaxSlotNo -> Maybe SlotNo
maxSlotNoToMaybe MaxSlotNo
NoMaxSlotNo   = Maybe SlotNo
forall a. Maybe a
Nothing
maxSlotNoToMaybe (MaxSlotNo SlotNo
s) = SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
Just SlotNo
s

maxSlotNoFromWithOrigin :: WithOrigin SlotNo -> MaxSlotNo
maxSlotNoFromWithOrigin :: WithOrigin SlotNo -> MaxSlotNo
maxSlotNoFromWithOrigin = Maybe SlotNo -> MaxSlotNo
maxSlotNoFromMaybe (Maybe SlotNo -> MaxSlotNo)
-> (WithOrigin SlotNo -> Maybe SlotNo)
-> WithOrigin SlotNo
-> MaxSlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithOrigin SlotNo -> Maybe SlotNo
forall t. WithOrigin t -> Maybe t
withOriginToMaybe

instance Semigroup MaxSlotNo where
  <> :: MaxSlotNo -> MaxSlotNo -> MaxSlotNo
(<>) = MaxSlotNo -> MaxSlotNo -> MaxSlotNo
forall a. Ord a => a -> a -> a
max

instance Monoid MaxSlotNo where
  mempty :: MaxSlotNo
mempty  = MaxSlotNo
NoMaxSlotNo
  mappend :: MaxSlotNo -> MaxSlotNo -> MaxSlotNo
mappend = MaxSlotNo -> MaxSlotNo -> MaxSlotNo
forall a. Semigroup a => a -> a -> a
(<>)

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

--TODO: these two instances require UndecidableInstances
instance Serialise (HeaderHash b) => Serialise (ChainHash b) where
  encode :: ChainHash b -> Encoding
encode = (HeaderHash b -> Encoding) -> ChainHash b -> Encoding
forall block.
(HeaderHash block -> Encoding) -> ChainHash block -> Encoding
encodeChainHash HeaderHash b -> Encoding
forall a. Serialise a => a -> Encoding
encode
  decode :: Decoder s (ChainHash b)
decode = (forall s. Decoder s (HeaderHash b))
-> forall s. Decoder s (ChainHash b)
forall block.
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (ChainHash block)
decodeChainHash forall s. Decoder s (HeaderHash b)
forall a s. Serialise a => Decoder s a
decode

instance Serialise (HeaderHash block) => Serialise (Point block) where
  encode :: Point block -> Encoding
encode = (HeaderHash block -> Encoding) -> Point block -> Encoding
forall block.
(HeaderHash block -> Encoding) -> Point block -> Encoding
encodePoint HeaderHash block -> Encoding
forall a. Serialise a => a -> Encoding
encode
  decode :: Decoder s (Point block)
decode = (forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
forall block.
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
decodePoint forall s. Decoder s (HeaderHash block)
forall a s. Serialise a => Decoder s a
decode

encodeChainHash :: (HeaderHash block -> Encoding)
                -> (ChainHash  block -> Encoding)
encodeChainHash :: (HeaderHash block -> Encoding) -> ChainHash block -> Encoding
encodeChainHash HeaderHash block -> Encoding
encodeHash ChainHash block
chainHash =
    case ChainHash block
chainHash of
      ChainHash block
GenesisHash -> Word -> Encoding
Enc.encodeListLen Word
0
      BlockHash HeaderHash block
h -> Word -> Encoding
Enc.encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> HeaderHash block -> Encoding
encodeHash HeaderHash block
h

decodeChainHash :: (forall s. Decoder s (HeaderHash block))
                -> (forall s. Decoder s (ChainHash  block))
decodeChainHash :: (forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (ChainHash block)
decodeChainHash forall s. Decoder s (HeaderHash block)
decodeHash = do
    Int
tag <- Decoder s Int
forall s. Decoder s Int
Dec.decodeListLen
    case Int
tag of
      Int
0 -> ChainHash block -> Decoder s (ChainHash block)
forall (m :: * -> *) a. Monad m => a -> m a
return ChainHash block
forall b. ChainHash b
GenesisHash
      Int
1 -> HeaderHash block -> ChainHash block
forall b. HeaderHash b -> ChainHash b
BlockHash (HeaderHash block -> ChainHash block)
-> Decoder s (HeaderHash block) -> Decoder s (ChainHash block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (HeaderHash block)
forall s. Decoder s (HeaderHash block)
decodeHash
      Int
_ -> String -> Decoder s (ChainHash block)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"decodeChainHash: invalid tag"

-- TODO: remove 'unSlotNo', add a test.  This should be moved to
-- 'cardano-consensus' where similar tests exists (and all the infrastructure
-- to run them is in place).
encodedSlotNoSize :: Proxy SlotNo -> Size
encodedSlotNoSize :: Proxy SlotNo -> Size
encodedSlotNoSize = Proxy Word64 -> Size
forall a. ToCBOR a => Proxy a -> Size
szGreedy (Proxy Word64 -> Size)
-> (Proxy SlotNo -> Proxy Word64) -> Proxy SlotNo -> Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotNo -> Word64) -> Proxy SlotNo -> Proxy Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SlotNo -> Word64
unSlotNo

encodePoint :: (HeaderHash block -> Encoding)
            -> (Point      block -> Encoding)
encodePoint :: (HeaderHash block -> Encoding) -> Point block -> Encoding
encodePoint HeaderHash block -> Encoding
encodeHash (Point WithOrigin (Block SlotNo (HeaderHash block))
pt) = case WithOrigin (Block SlotNo (HeaderHash block))
pt of
    WithOrigin (Block SlotNo (HeaderHash block))
Origin -> Word -> Encoding
Enc.encodeListLen Word
0
    At Block SlotNo (HeaderHash block)
blk ->
           Word -> Encoding
Enc.encodeListLen Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SlotNo -> Encoding
forall a. Serialise a => a -> Encoding
encode     (Block SlotNo (HeaderHash block) -> SlotNo
forall slot hash. Block slot hash -> slot
Point.blockPointSlot Block SlotNo (HeaderHash block)
blk)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> HeaderHash block -> Encoding
encodeHash (Block SlotNo (HeaderHash block) -> HeaderHash block
forall slot hash. Block slot hash -> hash
Point.blockPointHash Block SlotNo (HeaderHash block)
blk)

-- TODO: add a test (see 'encodedTipSize')
encodedPointSize :: (Proxy (HeaderHash block) -> Size)
                 -> (Proxy (Point      block) -> Size)
encodedPointSize :: (Proxy (HeaderHash block) -> Size) -> Proxy (Point block) -> Size
encodedPointSize Proxy (HeaderHash block) -> Size
encodedHeaderHashSize Proxy (Point block)
pointProxy =
    Size
1
    Size -> Size -> Size
forall a. Num a => a -> a -> a
+ [Case Size] -> Size
szCases
        [ Text -> Size -> Case Size
forall t. Text -> t -> Case t
Case Text
"Origin" Size
1
        , Text -> Size -> Case Size
forall t. Text -> t -> Case t
Case Text
"At" (Size -> Case Size) -> Size -> Case Size
forall a b. (a -> b) -> a -> b
$
              Size
1
            Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Proxy SlotNo -> Size
encodedSlotNoSize
                (Block SlotNo (HeaderHash block) -> SlotNo
forall slot hash. Block slot hash -> slot
Point.blockPointSlot (Block SlotNo (HeaderHash block) -> SlotNo)
-> Proxy (Block SlotNo (HeaderHash block)) -> Proxy SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (Block SlotNo (HeaderHash block))
blockProxy)
            Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Proxy (HeaderHash block) -> Size
encodedHeaderHashSize
                (Block SlotNo (HeaderHash block) -> HeaderHash block
forall slot hash. Block slot hash -> hash
Point.blockPointHash (Block SlotNo (HeaderHash block) -> HeaderHash block)
-> Proxy (Block SlotNo (HeaderHash block))
-> Proxy (HeaderHash block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (Block SlotNo (HeaderHash block))
blockProxy)
        ]
  where
    blockProxy :: Proxy (Block SlotNo (HeaderHash block))
blockProxy = Block SlotNo (HeaderHash block)
-> WithOrigin (Block SlotNo (HeaderHash block))
forall t. t -> WithOrigin t
At (Block SlotNo (HeaderHash block)
 -> WithOrigin (Block SlotNo (HeaderHash block)))
-> Proxy (WithOrigin (Block SlotNo (HeaderHash block)))
-> Proxy (Block SlotNo (HeaderHash block))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
`contramap` (Point block -> WithOrigin (Block SlotNo (HeaderHash block))
forall block.
Point block -> WithOrigin (Block SlotNo (HeaderHash block))
getPoint (Point block -> WithOrigin (Block SlotNo (HeaderHash block)))
-> Proxy (Point block)
-> Proxy (WithOrigin (Block SlotNo (HeaderHash block)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (Point block)
pointProxy)

decodePoint :: (forall s. Decoder s (HeaderHash block))
            -> (forall s. Decoder s (Point      block))
decodePoint :: (forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
decodePoint forall s. Decoder s (HeaderHash block)
decodeHash = do
    Int
tag <- Decoder s Int
forall s. Decoder s Int
Dec.decodeListLen
    case Int
tag of
      Int
0 -> Point block -> Decoder s (Point block)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
forall block.
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point WithOrigin (Block SlotNo (HeaderHash block))
forall t. WithOrigin t
origin)
      Int
2 -> do
        SlotNo
slot <- Decoder s SlotNo
forall a s. Serialise a => Decoder s a
decode
        HeaderHash block
hash <- Decoder s (HeaderHash block)
forall s. Decoder s (HeaderHash block)
decodeHash
        Point block -> Decoder s (Point block)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
forall block.
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point (SlotNo
-> HeaderHash block -> WithOrigin (Block SlotNo (HeaderHash block))
forall slot hash. slot -> hash -> WithOrigin (Block slot hash)
block SlotNo
slot HeaderHash block
hash))
      Int
_ -> String -> Decoder s (Point block)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"decodePoint: invalid tag"

{-------------------------------------------------------------------------------
  Serialised block/header
-------------------------------------------------------------------------------}

-- | An already serialised value
--
-- When streaming blocks/header from disk to the network, there is often no
-- need to deserialise them, as we'll just end up serialising them again when
-- putting them on the wire.
newtype Serialised a = Serialised
  { Serialised a -> ByteString
unSerialised :: Lazy.ByteString }
  deriving (Serialised a -> Serialised a -> Bool
(Serialised a -> Serialised a -> Bool)
-> (Serialised a -> Serialised a -> Bool) -> Eq (Serialised a)
forall a. Serialised a -> Serialised a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Serialised a -> Serialised a -> Bool
$c/= :: forall a. Serialised a -> Serialised a -> Bool
== :: Serialised a -> Serialised a -> Bool
$c== :: forall a. Serialised a -> Serialised a -> Bool
Eq)

instance Show (Serialised a) where
  show :: Serialised a -> String
show (Serialised ByteString
bytes) = ByteString -> String
BSC.unpack (ByteString -> ByteString
B16.encode ByteString
bytes)

instance ShowProxy a => ShowProxy (Serialised a) where
    showProxy :: Proxy (Serialised a) -> String
showProxy Proxy (Serialised a)
_ = String
"Serialised " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Proxy a -> String
forall k (p :: k). ShowProxy p => Proxy p -> String
showProxy (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

type instance HeaderHash (Serialised block) = HeaderHash block
instance StandardHash block => StandardHash (Serialised block)

-- | Wrap CBOR-in-CBOR
--
-- This is primarily useful for the /decoder/; see 'unwrapCBORinCBOR'
wrapCBORinCBOR :: (a -> Encoding) -> a -> Encoding
wrapCBORinCBOR :: (a -> Encoding) -> a -> Encoding
wrapCBORinCBOR a -> Encoding
enc = Serialised a -> Encoding
forall a. Serialise a => a -> Encoding
encode (Serialised a -> Encoding) -> (a -> Serialised a) -> a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Encoding) -> a -> Serialised a
forall a. (a -> Encoding) -> a -> Serialised a
mkSerialised a -> Encoding
enc

-- | Unwrap CBOR-in-CBOR
--
-- The CBOR-in-CBOR encoding gives us the 'ByteString' we need in order to
-- to construct annotations.
unwrapCBORinCBOR :: (forall s. Decoder s (Lazy.ByteString -> a))
                 -> (forall s. Decoder s a)
unwrapCBORinCBOR :: (forall s. Decoder s (ByteString -> a)) -> forall s. Decoder s a
unwrapCBORinCBOR forall s. Decoder s (ByteString -> a)
dec = (forall s. Decoder s (ByteString -> a))
-> Serialised a -> forall s. Decoder s a
forall a.
(forall s. Decoder s (ByteString -> a))
-> Serialised a -> forall s. Decoder s a
fromSerialised forall s. Decoder s (ByteString -> a)
dec (Serialised a -> Decoder s a)
-> Decoder s (Serialised a) -> Decoder s a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Decoder s (Serialised a)
forall a s. Serialise a => Decoder s a
decode

-- | Construct 'Serialised' value from an unserialised value
mkSerialised :: (a -> Encoding) -> a -> Serialised a
mkSerialised :: (a -> Encoding) -> a -> Serialised a
mkSerialised a -> Encoding
enc = ByteString -> Serialised a
forall a. ByteString -> Serialised a
Serialised (ByteString -> Serialised a)
-> (a -> ByteString) -> a -> Serialised a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> ByteString
Write.toLazyByteString (Encoding -> ByteString) -> (a -> Encoding) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Encoding
enc

-- | Decode a 'Serialised' value
--
-- Unlike a regular 'Decoder', which has an implicit input stream,
-- 'fromSerialised' takes the 'Serialised' value as an argument.
fromSerialised :: (forall s. Decoder s (Lazy.ByteString -> a))
               -> Serialised a -> (forall s. Decoder s a)
fromSerialised :: (forall s. Decoder s (ByteString -> a))
-> Serialised a -> forall s. Decoder s a
fromSerialised forall s. Decoder s (ByteString -> a)
dec (Serialised ByteString
payload) =
    case (forall s. Decoder s (ByteString -> a))
-> ByteString
-> Either DeserialiseFailure (ByteString, ByteString -> a)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
Read.deserialiseFromBytes forall s. Decoder s (ByteString -> a)
dec ByteString
payload of
      Left (Read.DeserialiseFailure ByteOffset
_ String
reason) -> String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
reason
      Right (ByteString
trailing, ByteString -> a
mkA)
        | Bool -> Bool
not (ByteString -> Bool
Lazy.null ByteString
trailing) -> String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"trailing bytes in CBOR-in-CBOR"
        | Bool
otherwise                -> a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> a
mkA ByteString
payload)

-- | CBOR-in-CBOR
--
-- TODO: replace with encodeEmbeddedCBOR from cborg-0.2.4 once
-- it is available, since that will be faster.
--
-- TODO: Avoid converting to a strict ByteString, as that requires copying O(n)
-- in case the lazy ByteString consists of more than one chunks.
instance Serialise (Serialised a) where
  encode :: Serialised a -> Encoding
encode (Serialised ByteString
bs) = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
        Word -> Encoding
Enc.encodeTag Word
24
      , ByteString -> Encoding
Enc.encodeBytes (ByteString -> ByteString
Lazy.toStrict ByteString
bs)
      ]

  decode :: Decoder s (Serialised a)
decode = do
      Word
tag <- Decoder s Word
forall s. Decoder s Word
Dec.decodeTag
      Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
tag Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
/= Word
24) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ String -> Decoder s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected tag 24 (CBOR-in-CBOR)"
      ByteString -> Serialised a
forall a. ByteString -> Serialised a
Serialised (ByteString -> Serialised a)
-> (ByteString -> ByteString) -> ByteString -> Serialised a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Lazy.fromStrict (ByteString -> Serialised a)
-> Decoder s ByteString -> Decoder s (Serialised a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ByteString
forall s. Decoder s ByteString
Dec.decodeBytes