{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE NumDecimals                #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# 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
  , tipFromHeader
  , encodeTip
  , decodeTip
  , ChainUpdate (..)
  , MaxSlotNo (..)
  , maxSlotNoFromMaybe
  , maxSlotNoToMaybe
  , maxSlotNoFromWithOrigin
  , genesisPoint
    -- * Serialisation
  , encodePoint
  , encodeChainHash
  , decodePoint
  , decodeChainHash
    -- * Serialised block/header
  , Serialised (..)
  , wrapCBORinCBOR
  , unwrapCBORinCBOR
  , mkSerialised
  , fromSerialised
  ) where

import Codec.CBOR.Decoding (Decoder)
import Codec.CBOR.Decoding qualified as Dec
import Codec.CBOR.Encoding (Encoding)
import Codec.CBOR.Encoding qualified as Enc
import Codec.CBOR.Read qualified as Read
import Codec.CBOR.Write qualified as Write
import Codec.Serialise (Serialise (..))
import Control.Monad (when)
import Data.ByteString.Base16.Lazy qualified as B16
import Data.ByteString.Lazy qualified as Lazy
import Data.ByteString.Lazy.Char8 qualified 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.Slotting.Block
import Cardano.Slotting.Slot (SlotNo (..))

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

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

-- | Header hash
type family HeaderHash (b :: k) :: 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 :: k) = HeaderFields {
      forall k (b :: k). HeaderFields b -> SlotNo
headerFieldSlot    :: SlotNo
    , forall k (b :: k). HeaderFields b -> BlockNo
headerFieldBlockNo :: BlockNo
    , forall k (b :: k). 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 k (b :: k) x. Rep (HeaderFields b) x -> HeaderFields b
forall k (b :: k) x. HeaderFields b -> Rep (HeaderFields b) x
$cfrom :: forall k (b :: k) x. HeaderFields b -> Rep (HeaderFields b) x
from :: forall x. HeaderFields b -> Rep (HeaderFields b) x
$cto :: forall k (b :: k) x. Rep (HeaderFields b) x -> HeaderFields b
to :: forall x. Rep (HeaderFields b) x -> HeaderFields b
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 :: forall {k} {k} (b :: k) (b' :: k).
(HeaderHash b ~ HeaderHash b') =>
HeaderFields b -> HeaderFields b'
castHeaderFields (HeaderFields SlotNo
h BlockNo
s HeaderHash b
b) = SlotNo -> BlockNo -> HeaderHash b' -> HeaderFields b'
forall k (b :: k).
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, Typeable k) => HasHeader (HeaderFields (b :: k)) where
  getHeaderFields :: HeaderFields b -> HeaderFields (HeaderFields b)
getHeaderFields = HeaderFields b -> HeaderFields (HeaderFields b)
forall {k} {k} (b :: k) (b' :: k).
(HeaderHash b ~ HeaderHash b') =>
HeaderFields b -> HeaderFields b'
castHeaderFields

blockHash :: HasHeader b => b -> HeaderHash b
blockHash :: forall b. HasHeader b => b -> HeaderHash b
blockHash = HeaderFields b -> HeaderHash b
forall k (b :: k). 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 :: forall b. HasHeader b => b -> SlotNo
blockSlot = HeaderFields b -> SlotNo
forall k (b :: k). 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 :: forall b. HasHeader b => b -> BlockNo
blockNo = HeaderFields b -> BlockNo
forall k (b :: k). 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/exts/deriving_inferred.html>
--
-- 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 :: k)

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 k (b :: k) x. Rep (ChainHash b) x -> ChainHash b
forall k (b :: k) x. ChainHash b -> Rep (ChainHash b) x
$cfrom :: forall k (b :: k) x. ChainHash b -> Rep (ChainHash b) x
from :: forall x. ChainHash b -> Rep (ChainHash b) x
$cto :: forall k (b :: k) x. Rep (ChainHash b) x -> ChainHash b
to :: forall x. Rep (ChainHash b) x -> ChainHash b
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 :: forall {k} {k} (b :: k) (b' :: k).
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash ChainHash b
GenesisHash   = ChainHash b'
forall {k} (b :: k). ChainHash b
GenesisHash
castHash (BlockHash HeaderHash b
h) = HeaderHash b' -> ChainHash b'
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash (HeaderHash b -> HeaderHash b'
forall a b. Coercible a b => a -> 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
    { forall {k} (block :: k).
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 k (block :: k) x. Rep (Point block) x -> Point block
forall k (block :: k) x. Point block -> Rep (Point block) x
$cfrom :: forall k (block :: k) x. Point block -> Rep (Point block) x
from :: forall x. Point block -> Rep (Point block) x
$cto :: forall k (block :: k) x. Rep (Point block) x -> Point block
to :: forall x. Rep (Point block) x -> Point block
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 :: forall {k} (block :: k). Point block
$mGenesisPoint :: forall {r} {k} {block :: k}.
Point block -> ((# #) -> r) -> ((# #) -> r) -> r
GenesisPoint = Point Origin

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

{-# COMPLETE GenesisPoint, BlockPoint #-}

pointSlot :: Point block -> WithOrigin SlotNo
pointSlot :: forall {k} (block :: k). 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 a b. (a -> b) -> WithOrigin a -> WithOrigin b
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 :: forall {k} (block :: k). 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 {k} (b :: k). ChainHash b
GenesisHash
    At Block SlotNo (HeaderHash block)
blk -> HeaderHash block -> ChainHash block
forall {k} (b :: k). 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 :: forall {k} {k} (b :: k) (b' :: k).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point b
GenesisPoint           = Point b'
forall {k} (block :: k). Point block
GenesisPoint
castPoint (BlockPoint SlotNo
slot HeaderHash b
hash) = SlotNo -> HeaderHash b' -> Point b'
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
slot (HeaderHash b -> HeaderHash b'
forall a b. Coercible a b => a -> b
coerce HeaderHash b
hash)

blockPoint :: HasHeader block => block -> Point block
blockPoint :: forall block. HasHeader block => block -> Point block
blockPoint block
b = WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
forall {k} (block :: k).
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 k (b :: k). HeaderFields b -> SlotNo
headerFieldSlot = SlotNo
s, headerFieldHash :: forall k (b :: k). 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 k (b :: k) x. Rep (Tip b) x -> Tip b
forall k (b :: k) x. Tip b -> Rep (Tip b) x
$cfrom :: forall k (b :: k) x. Tip b -> Rep (Tip b) x
from :: forall x. Tip b -> Rep (Tip b) x
$cto :: forall k (b :: k) x. Rep (Tip b) x -> Tip b
to :: forall x. Rep (Tip b) x -> Tip b
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 :: forall {k} {k} (a :: k) (b :: k).
(HeaderHash a ~ HeaderHash b) =>
Tip a -> Tip b
castTip Tip a
TipGenesis  = Tip b
forall {k} (b :: k). Tip b
TipGenesis
castTip (Tip SlotNo
s HeaderHash a
h BlockNo
b) = SlotNo -> HeaderHash b -> BlockNo -> Tip b
forall {k} (b :: k). SlotNo -> HeaderHash b -> BlockNo -> Tip b
Tip SlotNo
s HeaderHash a
HeaderHash b
h BlockNo
b

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

getTipBlockNo :: Tip b -> WithOrigin BlockNo
getTipBlockNo :: forall {k} (b :: k). 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 :: forall {k} (b :: k). 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 :: forall a. HasHeader a => a -> Tip a
tipFromHeader a
a = SlotNo -> HeaderHash a -> BlockNo -> Tip a
forall {k} (b :: k). SlotNo -> HeaderHash b -> BlockNo -> Tip b
Tip SlotNo
headerFieldSlot HeaderHash a
headerFieldHash BlockNo
headerFieldBlockNo
  where
    HeaderFields { SlotNo
headerFieldSlot :: forall k (b :: k). HeaderFields b -> SlotNo
headerFieldSlot :: SlotNo
headerFieldSlot
                 , BlockNo
headerFieldBlockNo :: forall k (b :: k). HeaderFields b -> BlockNo
headerFieldBlockNo :: BlockNo
headerFieldBlockNo
                 , HeaderHash a
headerFieldHash :: forall k (b :: k). HeaderFields b -> HeaderHash b
headerFieldHash :: HeaderHash a
headerFieldHash
                 } = a -> HeaderFields a
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields a
a



encodeTip :: (HeaderHash blk -> Encoding)
          -> (Tip        blk -> Encoding)
encodeTip :: forall {k} (blk :: k).
(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 {k} (block :: k).
(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 {k} (b :: k). 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 {k} (b :: k). Tip b -> WithOrigin BlockNo
getTipBlockNo Tip blk
tip)

decodeTip :: forall blk.
             (forall s. Decoder s (HeaderHash blk))
          -> (forall s. Decoder s (Tip        blk))
decodeTip :: forall {k} (blk :: k).
(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
    tipPoint    <- (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Point blk)
forall {k} (block :: k).
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
decodePoint Decoder s (HeaderHash blk)
forall s. Decoder s (HeaderHash blk)
decodeHeaderHash
    tipBlockNo  <- decode
    return $ case tipPoint :: Point blk of
      Point blk
GenesisPoint   -> Tip blk
forall {k} (b :: k). Tip b
TipGenesis
      BlockPoint SlotNo
s HeaderHash blk
h -> SlotNo -> HeaderHash blk -> BlockNo -> Tip blk
forall {k} (b :: k). 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 k (block :: k) a.
(StandardHash block, Eq a) =>
ChainUpdate block a -> ChainUpdate block a -> Bool
$c== :: forall k (block :: k) a.
(StandardHash block, Eq a) =>
ChainUpdate block a -> ChainUpdate block a -> Bool
== :: ChainUpdate block a -> ChainUpdate block a -> Bool
$c/= :: forall k (block :: k) a.
(StandardHash block, Eq a) =>
ChainUpdate block a -> ChainUpdate block a -> Bool
/= :: 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 k (block :: k) a.
(StandardHash block, Show a) =>
Int -> ChainUpdate block a -> ShowS
forall k (block :: k) a.
(StandardHash block, Show a) =>
[ChainUpdate block a] -> ShowS
forall k (block :: k) a.
(StandardHash block, Show a) =>
ChainUpdate block a -> String
$cshowsPrec :: forall k (block :: k) a.
(StandardHash block, Show a) =>
Int -> ChainUpdate block a -> ShowS
showsPrec :: Int -> ChainUpdate block a -> ShowS
$cshow :: forall k (block :: k) a.
(StandardHash block, Show a) =>
ChainUpdate block a -> String
show :: ChainUpdate block a -> String
$cshowList :: forall k (block :: k) a.
(StandardHash block, Show a) =>
[ChainUpdate block a] -> ShowS
showList :: [ChainUpdate block a] -> ShowS
Show, (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 k (block :: k) a b.
a -> ChainUpdate block b -> ChainUpdate block a
forall k (block :: k) a b.
(a -> b) -> ChainUpdate block a -> ChainUpdate block b
forall a b. a -> ChainUpdate block b -> ChainUpdate block a
forall 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
$cfmap :: forall k (block :: k) a b.
(a -> b) -> ChainUpdate block a -> ChainUpdate block b
fmap :: forall a b. (a -> b) -> ChainUpdate block a -> ChainUpdate block b
$c<$ :: forall k (block :: k) a b.
a -> ChainUpdate block b -> ChainUpdate block a
<$ :: forall a b. a -> ChainUpdate block b -> ChainUpdate block a
Functor, (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 k (block :: k) a. Eq a => a -> ChainUpdate block a -> Bool
forall k (block :: k) a. Num a => ChainUpdate block a -> a
forall k (block :: k) a. Ord a => ChainUpdate block a -> a
forall k (block :: k) m. Monoid m => ChainUpdate block m -> m
forall k (block :: k) a. ChainUpdate block a -> Bool
forall k (block :: k) a. ChainUpdate block a -> Int
forall k (block :: k) a. ChainUpdate block a -> [a]
forall k (block :: k) a. (a -> a -> a) -> ChainUpdate block a -> a
forall k (block :: k) m a.
Monoid m =>
(a -> m) -> ChainUpdate block a -> m
forall k (block :: k) b a.
(b -> a -> b) -> b -> ChainUpdate block a -> b
forall k (block :: k) a b.
(a -> b -> b) -> b -> ChainUpdate block a -> b
forall m a. Monoid m => (a -> m) -> ChainUpdate block a -> m
forall b a. (b -> a -> b) -> b -> ChainUpdate block a -> b
forall 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
$cfold :: forall k (block :: k) m. Monoid m => ChainUpdate block m -> m
fold :: forall m. Monoid m => ChainUpdate block m -> m
$cfoldMap :: forall k (block :: k) m a.
Monoid m =>
(a -> m) -> ChainUpdate block a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ChainUpdate block a -> m
$cfoldMap' :: forall k (block :: k) m a.
Monoid m =>
(a -> m) -> ChainUpdate block a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> ChainUpdate block a -> m
$cfoldr :: forall k (block :: k) a b.
(a -> b -> b) -> b -> ChainUpdate block a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ChainUpdate block a -> b
$cfoldr' :: forall k (block :: k) a b.
(a -> b -> b) -> b -> ChainUpdate block a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ChainUpdate block a -> b
$cfoldl :: forall k (block :: k) b a.
(b -> a -> b) -> b -> ChainUpdate block a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ChainUpdate block a -> b
$cfoldl' :: forall k (block :: k) b a.
(b -> a -> b) -> b -> ChainUpdate block a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> ChainUpdate block a -> b
$cfoldr1 :: forall k (block :: k) a. (a -> a -> a) -> ChainUpdate block a -> a
foldr1 :: forall a. (a -> a -> a) -> ChainUpdate block a -> a
$cfoldl1 :: forall k (block :: k) a. (a -> a -> a) -> ChainUpdate block a -> a
foldl1 :: forall a. (a -> a -> a) -> ChainUpdate block a -> a
$ctoList :: forall k (block :: k) a. ChainUpdate block a -> [a]
toList :: forall a. ChainUpdate block a -> [a]
$cnull :: forall k (block :: k) a. ChainUpdate block a -> Bool
null :: forall a. ChainUpdate block a -> Bool
$clength :: forall k (block :: k) a. ChainUpdate block a -> Int
length :: forall a. ChainUpdate block a -> Int
$celem :: forall k (block :: k) a. Eq a => a -> ChainUpdate block a -> Bool
elem :: forall a. Eq a => a -> ChainUpdate block a -> Bool
$cmaximum :: forall k (block :: k) a. Ord a => ChainUpdate block a -> a
maximum :: forall a. Ord a => ChainUpdate block a -> a
$cminimum :: forall k (block :: k) a. Ord a => ChainUpdate block a -> a
minimum :: forall a. Ord a => ChainUpdate block a -> a
$csum :: forall k (block :: k) a. Num a => ChainUpdate block a -> a
sum :: forall a. Num a => ChainUpdate block a -> a
$cproduct :: forall k (block :: k) a. Num a => ChainUpdate block a -> a
product :: forall a. Num a => ChainUpdate block a -> a
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)
forall k (block :: k). Functor (ChainUpdate block)
forall k (block :: k). Foldable (ChainUpdate block)
forall k (block :: k) (m :: * -> *) a.
Monad m =>
ChainUpdate block (m a) -> m (ChainUpdate block a)
forall k (block :: k) (f :: * -> *) a.
Applicative f =>
ChainUpdate block (f a) -> f (ChainUpdate block a)
forall k (block :: k) (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ChainUpdate block a -> m (ChainUpdate block b)
forall k (block :: k) (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)
$ctraverse :: forall k (block :: k) (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ChainUpdate block a -> f (ChainUpdate block b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ChainUpdate block a -> f (ChainUpdate block b)
$csequenceA :: forall k (block :: k) (f :: * -> *) a.
Applicative f =>
ChainUpdate block (f a) -> f (ChainUpdate block a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
ChainUpdate block (f a) -> f (ChainUpdate block a)
$cmapM :: forall k (block :: k) (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ChainUpdate block a -> m (ChainUpdate block b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ChainUpdate block a -> m (ChainUpdate block b)
$csequence :: forall k (block :: k) (m :: * -> *) a.
Monad m =>
ChainUpdate block (m a) -> m (ChainUpdate block a)
sequence :: forall (m :: * -> *) a.
Monad m =>
ChainUpdate block (m a) -> m (ChainUpdate block a)
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
$c== :: MaxSlotNo -> MaxSlotNo -> Bool
== :: MaxSlotNo -> MaxSlotNo -> Bool
$c/= :: MaxSlotNo -> MaxSlotNo -> Bool
/= :: 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
$cshowsPrec :: Int -> MaxSlotNo -> ShowS
showsPrec :: Int -> MaxSlotNo -> ShowS
$cshow :: MaxSlotNo -> String
show :: MaxSlotNo -> String
$cshowList :: [MaxSlotNo] -> ShowS
showList :: [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
$cfrom :: forall x. MaxSlotNo -> Rep MaxSlotNo x
from :: forall x. MaxSlotNo -> Rep MaxSlotNo x
$cto :: forall x. Rep MaxSlotNo x -> MaxSlotNo
to :: forall x. Rep MaxSlotNo x -> MaxSlotNo
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
$cnoThunks :: Context -> MaxSlotNo -> IO (Maybe ThunkInfo)
noThunks :: Context -> MaxSlotNo -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> MaxSlotNo -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> MaxSlotNo -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy MaxSlotNo -> String
showTypeOf :: Proxy MaxSlotNo -> String
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 {k} (block :: k).
(HeaderHash block -> Encoding) -> ChainHash block -> Encoding
encodeChainHash HeaderHash b -> Encoding
forall a. Serialise a => a -> Encoding
encode
  decode :: forall s. Decoder s (ChainHash b)
decode = (forall s. Decoder s (HeaderHash b))
-> forall s. Decoder s (ChainHash b)
forall {k} (block :: k).
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (ChainHash block)
decodeChainHash Decoder s (HeaderHash b)
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 {k} (block :: k).
(HeaderHash block -> Encoding) -> Point block -> Encoding
encodePoint HeaderHash block -> Encoding
forall a. Serialise a => a -> Encoding
encode
  decode :: forall s. Decoder s (Point block)
decode = (forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
forall {k} (block :: k).
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
decodePoint Decoder s (HeaderHash block)
forall s. Decoder s (HeaderHash block)
forall a s. Serialise a => Decoder s a
decode

encodeChainHash :: (HeaderHash block -> Encoding)
                -> (ChainHash  block -> Encoding)
encodeChainHash :: forall {k} (block :: k).
(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 {k} (block :: k).
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (ChainHash block)
decodeChainHash forall s. Decoder s (HeaderHash block)
decodeHash = do
    tag <- Decoder s Int
forall s. Decoder s Int
Dec.decodeListLen
    case tag of
      Int
0 -> ChainHash block -> Decoder s (ChainHash block)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return ChainHash block
forall {k} (b :: k). ChainHash b
GenesisHash
      Int
1 -> HeaderHash block -> ChainHash block
forall {k} (b :: k). 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 a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"decodeChainHash: invalid tag"

encodePoint :: (HeaderHash block -> Encoding)
            -> (Point      block -> Encoding)
encodePoint :: forall {k} (block :: k).
(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)

decodePoint :: (forall s. Decoder s (HeaderHash block))
            -> (forall s. Decoder s (Point      block))
decodePoint :: forall {k} (block :: k).
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
decodePoint forall s. Decoder s (HeaderHash block)
decodeHash = do
    tag <- Decoder s Int
forall s. Decoder s Int
Dec.decodeListLen
    case tag of
      Int
0 -> Point block -> Decoder s (Point block)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
forall {k} (block :: k).
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point WithOrigin (Block SlotNo (HeaderHash block))
forall t. WithOrigin t
origin)
      Int
2 -> do
        slot <- Decoder s SlotNo
forall s. Decoder s SlotNo
forall a s. Serialise a => Decoder s a
decode
        hash <- decodeHash
        return (Point (block slot hash))
      Int
_ -> String -> Decoder s (Point block)
forall a. String -> Decoder s a
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
  { forall {k} (a :: k). 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. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (a :: k). Serialised a -> Serialised a -> Bool
$c== :: forall k (a :: k). Serialised a -> Serialised a -> Bool
== :: Serialised a -> Serialised a -> Bool
$c/= :: forall k (a :: k). Serialised a -> Serialised a -> Bool
/= :: 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 :: forall a. (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 a.
(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 Decoder s (ByteString -> a)
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 s. 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 :: forall a. (a -> Encoding) -> a -> Serialised a
mkSerialised a -> Encoding
enc = ByteString -> Serialised a
forall {k} (a :: k). 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 a.
(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 Decoder s (ByteString -> a)
forall s. Decoder s (ByteString -> a)
dec ByteString
payload of
      Left (Read.DeserialiseFailure ByteOffset
_ String
reason) -> String -> Decoder s a
forall a. 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 a. 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 a. 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 :: forall s. Decoder s (Serialised a)
decode = do
      tag <- Decoder s Word
forall s. Decoder s Word
Dec.decodeTag
      when (tag /= 24) $ fail "expected tag 24 (CBOR-in-CBOR)"
      Serialised . Lazy.fromStrict <$> Dec.decodeBytes