{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Mocked Peras certificates without crypto.
module Ouroboros.Consensus.Peras.Cert.Mock
  ( MockPerasCert (..)
  ) where

import Cardano.Binary
  ( FromCBOR (..)
  , ToCBOR (..)
  , decodeListLenOf
  , encodeListLen
  )
import Control.DeepSeq (NFData)
import Data.Containers.NonEmpty (NE)
import Data.Data (Proxy (..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Set (Set)
import qualified Data.Set.NonEmpty as NESet
import Data.Set.NonEmpty.Internal (NESet (..))
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block.Abstract
  ( ConvertRawHash
  , Point
  , StandardHash
  )
import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode (..))
import Ouroboros.Consensus.Peras.Cert.Class (IsPerasCert (..))
import Ouroboros.Consensus.Peras.Types
  ( BoostedBlock
  , PerasRoundNo
  , PerasSeatIndex
  )
import Ouroboros.Consensus.Util (ShowProxy)
import Ouroboros.Network.Util (ShowProxy (..))

-- | Mocked Peras certificates without crypto.
--
-- NOTE: this is parameterized around the concrete block type being certified.
data MockPerasCert blk
  = MockPerasCert
  { forall blk. MockPerasCert blk -> PerasRoundNo
mockCertRound :: PerasRoundNo
  , forall blk. MockPerasCert blk -> Point blk
mockCertBlock :: Point blk
  , forall blk. MockPerasCert blk -> NE (Set PerasSeatIndex)
mockCertVoters :: NE (Set PerasSeatIndex)
  }

deriving instance StandardHash blk => Show (MockPerasCert blk)
deriving instance StandardHash blk => Eq (MockPerasCert blk)
deriving instance StandardHash blk => Ord (MockPerasCert blk)
deriving instance StandardHash blk => NoThunks (MockPerasCert blk)
deriving instance StandardHash blk => NFData (MockPerasCert blk)
deriving instance Generic (MockPerasCert blk)

type instance BoostedBlock (MockPerasCert blk) = Point blk

instance IsPerasCert (MockPerasCert blk) blk where
  getPerasCertRound :: MockPerasCert blk -> PerasRoundNo
getPerasCertRound = MockPerasCert blk -> PerasRoundNo
forall blk. MockPerasCert blk -> PerasRoundNo
mockCertRound
  getPerasCertBlock :: MockPerasCert blk -> BoostedBlock (MockPerasCert blk)
getPerasCertBlock = MockPerasCert blk -> Point blk
MockPerasCert blk -> BoostedBlock (MockPerasCert blk)
forall blk. MockPerasCert blk -> Point blk
mockCertBlock

instance ShowProxy blk => ShowProxy (MockPerasCert blk) where
  showProxy :: Proxy (MockPerasCert blk) -> String
showProxy Proxy (MockPerasCert blk)
_ = String
"MockPerasCert(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Proxy blk -> String
forall {k} (p :: k). ShowProxy p => Proxy p -> String
showProxy (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"

instance
  ( Typeable blk
  , FromCBOR (Point blk)
  ) =>
  FromCBOR (MockPerasCert blk)
  where
  fromCBOR :: forall s. Decoder s (MockPerasCert blk)
fromCBOR = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
3
    mockCertRound <- Decoder s PerasRoundNo
forall s. Decoder s PerasRoundNo
forall a s. FromCBOR a => Decoder s a
fromCBOR
    mockCertBlock <- fromCBOR
    mockCertVoters <- decodeNonEmptySet
    pure
      MockPerasCert
        { mockCertRound
        , mockCertBlock
        , mockCertVoters
        }
   where
    decodeNonEmptySet :: Decoder s (NESet PerasSeatIndex)
decodeNonEmptySet = do
      xs <- Decoder s [PerasSeatIndex]
forall s. Decoder s [PerasSeatIndex]
forall a s. FromCBOR a => Decoder s a
fromCBOR
      case NonEmpty.nonEmpty xs of
        Maybe (NonEmpty PerasSeatIndex)
Nothing -> String -> Decoder s (NESet PerasSeatIndex)
forall a. HasCallStack => String -> Decoder s a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"Expected a non-empty set of PerasSeatIndex"
        Just NonEmpty PerasSeatIndex
neSet -> NESet PerasSeatIndex -> Decoder s (NESet PerasSeatIndex)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty PerasSeatIndex -> NESet PerasSeatIndex
forall a. Ord a => NonEmpty a -> NESet a
NESet.fromList NonEmpty PerasSeatIndex
neSet)

instance
  ( Typeable blk
  , ToCBOR (Point blk)
  ) =>
  ToCBOR (MockPerasCert blk)
  where
  toCBOR :: MockPerasCert blk -> Encoding
toCBOR
    MockPerasCert
      { PerasRoundNo
mockCertRound :: forall blk. MockPerasCert blk -> PerasRoundNo
mockCertRound :: PerasRoundNo
mockCertRound
      , Point blk
mockCertBlock :: forall blk. MockPerasCert blk -> Point blk
mockCertBlock :: Point blk
mockCertBlock
      , NE (Set PerasSeatIndex)
mockCertVoters :: forall blk. MockPerasCert blk -> NE (Set PerasSeatIndex)
mockCertVoters :: NE (Set PerasSeatIndex)
mockCertVoters
      } =
      Word -> Encoding
encodeListLen Word
3
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasRoundNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PerasRoundNo
mockCertRound
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Point blk -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Point blk
mockCertBlock
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [PerasSeatIndex] -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (NonEmpty PerasSeatIndex -> [PerasSeatIndex]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NESet PerasSeatIndex -> NonEmpty PerasSeatIndex
forall a. NESet a -> NonEmpty a
NESet.toList NESet PerasSeatIndex
NE (Set PerasSeatIndex)
mockCertVoters))

instance
  ConvertRawHash blk =>
  SerialiseNodeToNode blk (MockPerasCert blk)
  where
  encodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> MockPerasCert blk -> Encoding
encodeNodeToNode
    CodecConfig blk
ccfg
    BlockNodeToNodeVersion blk
version
    MockPerasCert
      { PerasRoundNo
mockCertRound :: forall blk. MockPerasCert blk -> PerasRoundNo
mockCertRound :: PerasRoundNo
mockCertRound
      , Point blk
mockCertBlock :: forall blk. MockPerasCert blk -> Point blk
mockCertBlock :: Point blk
mockCertBlock
      , NE (Set PerasSeatIndex)
mockCertVoters :: forall blk. MockPerasCert blk -> NE (Set PerasSeatIndex)
mockCertVoters :: NE (Set PerasSeatIndex)
mockCertVoters
      } =
      Word -> Encoding
encodeListLen Word
3
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CodecConfig blk
-> BlockNodeToNodeVersion blk -> PerasRoundNo -> Encoding
forall blk a.
SerialiseNodeToNode blk a =>
CodecConfig blk -> BlockNodeToNodeVersion blk -> a -> Encoding
encodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version PerasRoundNo
mockCertRound
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CodecConfig blk
-> BlockNodeToNodeVersion blk -> Point blk -> Encoding
forall blk a.
SerialiseNodeToNode blk a =>
CodecConfig blk -> BlockNodeToNodeVersion blk -> a -> Encoding
encodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version Point blk
mockCertBlock
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [PerasSeatIndex] -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (NonEmpty PerasSeatIndex -> [PerasSeatIndex]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NESet PerasSeatIndex -> NonEmpty PerasSeatIndex
forall a. NESet a -> NonEmpty a
NESet.toList NESet PerasSeatIndex
NE (Set PerasSeatIndex)
mockCertVoters))
  decodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk
-> forall s. Decoder s (MockPerasCert blk)
decodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
3
    mockCertRound <- CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s PerasRoundNo
forall blk a.
SerialiseNodeToNode blk a =>
CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s a
decodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version
    mockCertBlock <- decodeNodeToNode ccfg version
    mockCertVoters <- decodeNodeToNodeNonEmptySet ccfg version
    pure
      MockPerasCert
        { mockCertRound
        , mockCertBlock
        , mockCertVoters
        }
   where
    decodeNodeToNodeNonEmptySet :: p -> p -> Decoder s (NESet a)
decodeNodeToNodeNonEmptySet p
_ccfg p
_version = do
      xs <- Decoder s [a]
forall s. Decoder s [a]
forall a s. FromCBOR a => Decoder s a
fromCBOR
      case NonEmpty.nonEmpty xs of
        Maybe (NonEmpty a)
Nothing -> String -> Decoder s (NESet a)
forall a. HasCallStack => String -> Decoder s a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"Expected a non-empty set of PerasSeatIndex"
        Just NonEmpty a
neSet -> NESet a -> Decoder s (NESet a)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty a -> NESet a
forall a. Ord a => NonEmpty a -> NESet a
NESet.fromList NonEmpty a
neSet)

-- * Orphan instances

-- NOTE: we need this to be able to derive a couple of other classes for
-- 'NESet PerasSeatIndex'.
deriving instance Generic (NESet a)