{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Block.RealPoint
  ( -- * Non-genesis points
    RealPoint (..)
  , decodeRealPoint
  , encodeRealPoint

    -- * Derived
  , blockRealPoint
  , castRealPoint
  , headerRealPoint
  , pointToWithOriginRealPoint
  , realPointHash
  , realPointSlot
  , realPointToPoint
  , withOriginRealPointToPoint

    -- * Bytes32RealPoint
  , Bytes32RealPoint
  , bytes32RealPointHash
  , bytes32RealPointSlot
  , decodeBytes32RealPoint
  , encodeBytes32RealPoint
  , fromBytes32RealPoint
  , toBytes32RealPoint
  ) where

import Cardano.Binary (enforceSize)
import Codec.CBOR.Decoding (Decoder)
import Codec.CBOR.Encoding (Encoding, encodeListLen)
import Codec.Serialise (decode, encode)
import Data.ByteString.Short (ShortByteString)
import qualified Data.ByteString.Short as ByteString
import Data.Coerce
import Data.Proxy
import Data.Typeable (Typeable, typeRep)
import GHC.Generics
import NoThunks.Class (NoThunks (..))
import Ouroboros.Consensus.Block.Abstract
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Consensus.Util.RedundantConstraints

{-------------------------------------------------------------------------------
  Non-genesis point
-------------------------------------------------------------------------------}

-- | Point of an actual block (i.e., not genesis)
data RealPoint blk = RealPoint !SlotNo !(HeaderHash blk)
  deriving (forall x. RealPoint blk -> Rep (RealPoint blk) x)
-> (forall x. Rep (RealPoint blk) x -> RealPoint blk)
-> Generic (RealPoint blk)
forall x. Rep (RealPoint blk) x -> RealPoint blk
forall x. RealPoint blk -> Rep (RealPoint blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (RealPoint blk) x -> RealPoint blk
forall blk x. RealPoint blk -> Rep (RealPoint blk) x
$cfrom :: forall blk x. RealPoint blk -> Rep (RealPoint blk) x
from :: forall x. RealPoint blk -> Rep (RealPoint blk) x
$cto :: forall blk x. Rep (RealPoint blk) x -> RealPoint blk
to :: forall x. Rep (RealPoint blk) x -> RealPoint blk
Generic

-- TODO: The Ord instance should go
-- <https://github.com/IntersectMBO/ouroboros-network/issues/1693>
deriving instance StandardHash blk => Eq (RealPoint blk)
deriving instance StandardHash blk => Ord (RealPoint blk)
deriving instance StandardHash blk => Show (RealPoint blk)

instance
  (StandardHash blk, Typeable blk) =>
  NoThunks (RealPoint blk)
  where
  showTypeOf :: Proxy (RealPoint blk) -> String
showTypeOf Proxy (RealPoint blk)
_ = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy (RealPoint blk) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(RealPoint blk))

instance Condense (HeaderHash blk) => Condense (RealPoint blk) where
  condense :: RealPoint blk -> String
condense (RealPoint SlotNo
s HeaderHash blk
h) = String
"(Point " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SlotNo -> String
forall a. Condense a => a -> String
condense SlotNo
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HeaderHash blk -> String
forall a. Condense a => a -> String
condense HeaderHash blk
h String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"

encodeRealPoint ::
  (HeaderHash blk -> Encoding) ->
  (RealPoint blk -> Encoding)
encodeRealPoint :: forall blk.
(HeaderHash blk -> Encoding) -> RealPoint blk -> Encoding
encodeRealPoint HeaderHash blk -> Encoding
encodeHash (RealPoint SlotNo
s HeaderHash blk
h) =
  [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
    [ Word -> Encoding
encodeListLen Word
2
    , SlotNo -> Encoding
forall a. Serialise a => a -> Encoding
encode SlotNo
s
    , HeaderHash blk -> Encoding
encodeHash HeaderHash blk
h
    ]

decodeRealPoint ::
  (forall s. Decoder s (HeaderHash blk)) ->
  (forall s. Decoder s (RealPoint blk))
decodeRealPoint :: forall blk.
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (RealPoint blk)
decodeRealPoint forall s. Decoder s (HeaderHash blk)
decodeHash = do
  Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"RealPoint" Int
2
  SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint (SlotNo -> HeaderHash blk -> RealPoint blk)
-> Decoder s SlotNo -> Decoder s (HeaderHash blk -> RealPoint blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s SlotNo
forall s. Decoder s SlotNo
forall a s. Serialise a => Decoder s a
decode Decoder s (HeaderHash blk -> RealPoint blk)
-> Decoder s (HeaderHash blk) -> Decoder s (RealPoint blk)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (HeaderHash blk)
forall s. Decoder s (HeaderHash blk)
decodeHash

{-------------------------------------------------------------------------------
  Derived
-------------------------------------------------------------------------------}

realPointSlot :: RealPoint blk -> SlotNo
realPointSlot :: forall blk. RealPoint blk -> SlotNo
realPointSlot (RealPoint SlotNo
s HeaderHash blk
_) = SlotNo
s

realPointHash :: RealPoint blk -> HeaderHash blk
realPointHash :: forall blk. RealPoint blk -> HeaderHash blk
realPointHash (RealPoint SlotNo
_ HeaderHash blk
h) = HeaderHash blk
h

blockRealPoint :: HasHeader blk => blk -> RealPoint blk
blockRealPoint :: forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
blk = SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
s HeaderHash blk
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 blk
h} = blk -> HeaderFields blk
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields blk
blk

headerRealPoint ::
  forall blk.
  HasHeader (Header blk) =>
  Header blk ->
  RealPoint blk
headerRealPoint :: forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint Header blk
hdr = SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
s HeaderHash blk
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 (Header blk)
h} = HeaderFields (Header blk)
hf

  hf :: HeaderFields (Header blk)
  hf :: HeaderFields (Header blk)
hf = Header blk -> HeaderFields (Header blk)
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields Header blk
hdr

realPointToPoint :: RealPoint blk -> Point blk
realPointToPoint :: forall blk. RealPoint blk -> Point blk
realPointToPoint (RealPoint SlotNo
s HeaderHash blk
h) = SlotNo -> HeaderHash blk -> Point blk
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
s HeaderHash blk
h

withOriginRealPointToPoint :: WithOrigin (RealPoint blk) -> Point blk
withOriginRealPointToPoint :: forall blk. WithOrigin (RealPoint blk) -> Point blk
withOriginRealPointToPoint WithOrigin (RealPoint blk)
Origin = Point blk
forall {k} (block :: k). Point block
GenesisPoint
withOriginRealPointToPoint (NotOrigin RealPoint blk
p) = RealPoint blk -> Point blk
forall blk. RealPoint blk -> Point blk
realPointToPoint RealPoint blk
p

pointToWithOriginRealPoint :: Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint :: forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint Point blk
GenesisPoint = WithOrigin (RealPoint blk)
forall t. WithOrigin t
Origin
pointToWithOriginRealPoint (BlockPoint SlotNo
s HeaderHash blk
h) = RealPoint blk -> WithOrigin (RealPoint blk)
forall t. t -> WithOrigin t
NotOrigin (RealPoint blk -> WithOrigin (RealPoint blk))
-> RealPoint blk -> WithOrigin (RealPoint blk)
forall a b. (a -> b) -> a -> b
$ SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
s HeaderHash blk
h

castRealPoint ::
  forall blk blk'.
  Coercible (HeaderHash blk) (HeaderHash blk') =>
  RealPoint blk ->
  RealPoint blk'
castRealPoint :: forall blk blk'.
Coercible (HeaderHash blk) (HeaderHash blk') =>
RealPoint blk -> RealPoint blk'
castRealPoint (RealPoint SlotNo
s HeaderHash blk
h) = SlotNo -> HeaderHash blk' -> RealPoint blk'
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
s (HeaderHash blk -> HeaderHash blk'
forall a b. Coercible a b => a -> b
coerce HeaderHash blk
h)

{-------------------------------------------------------------------------------
  Bytes32RealPoint
-------------------------------------------------------------------------------}

-- | A 'RealPoint' where the hash is always 32 bytes.
--
-- The length of the hash is enforced during decoding.
data Bytes32RealPoint = Bytes32RealPoint !SlotNo !ShortByteString
  deriving (Int -> Bytes32RealPoint -> ShowS
[Bytes32RealPoint] -> ShowS
Bytes32RealPoint -> String
(Int -> Bytes32RealPoint -> ShowS)
-> (Bytes32RealPoint -> String)
-> ([Bytes32RealPoint] -> ShowS)
-> Show Bytes32RealPoint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Bytes32RealPoint -> ShowS
showsPrec :: Int -> Bytes32RealPoint -> ShowS
$cshow :: Bytes32RealPoint -> String
show :: Bytes32RealPoint -> String
$cshowList :: [Bytes32RealPoint] -> ShowS
showList :: [Bytes32RealPoint] -> ShowS
Show, Bytes32RealPoint -> Bytes32RealPoint -> Bool
(Bytes32RealPoint -> Bytes32RealPoint -> Bool)
-> (Bytes32RealPoint -> Bytes32RealPoint -> Bool)
-> Eq Bytes32RealPoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Bytes32RealPoint -> Bytes32RealPoint -> Bool
== :: Bytes32RealPoint -> Bytes32RealPoint -> Bool
$c/= :: Bytes32RealPoint -> Bytes32RealPoint -> Bool
/= :: Bytes32RealPoint -> Bytes32RealPoint -> Bool
Eq, (forall x. Bytes32RealPoint -> Rep Bytes32RealPoint x)
-> (forall x. Rep Bytes32RealPoint x -> Bytes32RealPoint)
-> Generic Bytes32RealPoint
forall x. Rep Bytes32RealPoint x -> Bytes32RealPoint
forall x. Bytes32RealPoint -> Rep Bytes32RealPoint x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Bytes32RealPoint -> Rep Bytes32RealPoint x
from :: forall x. Bytes32RealPoint -> Rep Bytes32RealPoint x
$cto :: forall x. Rep Bytes32RealPoint x -> Bytes32RealPoint
to :: forall x. Rep Bytes32RealPoint x -> Bytes32RealPoint
Generic, Context -> Bytes32RealPoint -> IO (Maybe ThunkInfo)
Proxy Bytes32RealPoint -> String
(Context -> Bytes32RealPoint -> IO (Maybe ThunkInfo))
-> (Context -> Bytes32RealPoint -> IO (Maybe ThunkInfo))
-> (Proxy Bytes32RealPoint -> String)
-> NoThunks Bytes32RealPoint
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Bytes32RealPoint -> IO (Maybe ThunkInfo)
noThunks :: Context -> Bytes32RealPoint -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Bytes32RealPoint -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Bytes32RealPoint -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Bytes32RealPoint -> String
showTypeOf :: Proxy Bytes32RealPoint -> String
NoThunks)

bytes32RealPointSlot :: Bytes32RealPoint -> SlotNo
bytes32RealPointSlot :: Bytes32RealPoint -> SlotNo
bytes32RealPointSlot (Bytes32RealPoint SlotNo
s ShortByteString
_) = SlotNo
s

bytes32RealPointHash :: Bytes32RealPoint -> ShortByteString
bytes32RealPointHash :: Bytes32RealPoint -> ShortByteString
bytes32RealPointHash (Bytes32RealPoint SlotNo
_ ShortByteString
h) = ShortByteString
h

encodeBytes32RealPoint :: Bytes32RealPoint -> Encoding
encodeBytes32RealPoint :: Bytes32RealPoint -> Encoding
encodeBytes32RealPoint (Bytes32RealPoint SlotNo
s ShortByteString
h) =
  [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
    [ Word -> Encoding
encodeListLen Word
2
    , SlotNo -> Encoding
forall a. Serialise a => a -> Encoding
encode SlotNo
s
    , ShortByteString -> Encoding
forall a. Serialise a => a -> Encoding
encode ShortByteString
h
    ]

decodeBytes32RealPoint :: forall s. Decoder s Bytes32RealPoint
decodeBytes32RealPoint :: forall s. Decoder s Bytes32RealPoint
decodeBytes32RealPoint = do
  Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"Bytes32RealPoint" Int
2
  s <- Decoder s SlotNo
forall s. Decoder s SlotNo
forall a s. Serialise a => Decoder s a
decode
  h <- decode
  case ByteString.length h of
    Int
32 -> Bytes32RealPoint -> Decoder s Bytes32RealPoint
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo -> ShortByteString -> Bytes32RealPoint
Bytes32RealPoint SlotNo
s ShortByteString
h)
    Int
len -> String -> Decoder s Bytes32RealPoint
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s Bytes32RealPoint)
-> String -> Decoder s Bytes32RealPoint
forall a b. (a -> b) -> a -> b
$ String
"decodeBytes32RealPoint: expected 32 bytes, got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
len

fromBytes32RealPoint ::
  forall blk.
  (ConvertRawHash blk, HashSize blk ~ 32) =>
  Bytes32RealPoint ->
  RealPoint blk
fromBytes32RealPoint :: forall blk.
(ConvertRawHash blk, HashSize blk ~ 32) =>
Bytes32RealPoint -> RealPoint blk
fromBytes32RealPoint (Bytes32RealPoint SlotNo
s ShortByteString
h) =
  SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
s (Proxy blk -> ShortByteString -> HeaderHash blk
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> ShortByteString -> HeaderHash blk
forall (proxy :: * -> *).
proxy blk -> ShortByteString -> HeaderHash blk
unsafeFromShortRawHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) ShortByteString
h)
 where
  -- This constraint ensures we are allowed to call 'unsafeFromShortRawHash'.
  ()
_ = Proxy (HashSize blk ~ 32) -> ()
forall (c :: Constraint) (proxy :: Constraint -> *).
c =>
proxy c -> ()
keepRedundantConstraint (forall {k} (t :: k). Proxy t
forall (t :: Constraint). Proxy t
Proxy @(HashSize blk ~ 32))

toBytes32RealPoint ::
  forall blk.
  (ConvertRawHash blk, HashSize blk ~ 32) =>
  RealPoint blk ->
  Bytes32RealPoint
toBytes32RealPoint :: forall blk.
(ConvertRawHash blk, HashSize blk ~ 32) =>
RealPoint blk -> Bytes32RealPoint
toBytes32RealPoint (RealPoint SlotNo
s HeaderHash blk
h) =
  SlotNo -> ShortByteString -> Bytes32RealPoint
Bytes32RealPoint SlotNo
s (Proxy blk -> HeaderHash blk -> ShortByteString
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> ShortByteString
forall (proxy :: * -> *).
proxy blk -> HeaderHash blk -> ShortByteString
toShortRawHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) HeaderHash blk
h)
 where
  -- This constraint ensures the hash we are wrapping in 'Bytes32RealPoint' is
  -- indeed 32 bytes long.
  ()
_ = Proxy (HashSize blk ~ 32) -> ()
forall (c :: Constraint) (proxy :: Constraint -> *).
c =>
proxy c -> ()
keepRedundantConstraint (forall {k} (t :: k). Proxy t
forall (t :: Constraint). Proxy t
Proxy @(HashSize blk ~ 32))