{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Protocol.TPraos.OCert (
  OCert (..),
  OCertEnv (..),
  OCertSignable (..),
  ocertToSignable,
  currentIssueNo,
  KESPeriod (..),
  slotsPerKESPeriod,
  kesPeriod,
) where

import qualified Cardano.Crypto.DSIGN as DSIGN
import Cardano.Crypto.KES (KESAlgorithm (..))
import qualified Cardano.Crypto.KES as KES
import Cardano.Crypto.Util (SignableRepresentation (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (
  CBORGroup (..),
  DecCBOR (..),
  DecCBORGroup (..),
  Decoder,
  EncCBOR (..),
  EncCBORGroup (..),
  Encoding,
  FixedSizeCodec (..),
  decodeFixedSized,
  encodeFixedSized,
  fixedSize,
  runByteBuilder,
 )
import Cardano.Ledger.Keys (
  DSIGN,
  KeyHash,
  KeyRole (..),
  coerceKeyRole,
 )
import Cardano.Protocol.Crypto (Crypto, KES)
import Control.Monad.Trans.Reader (asks)
import qualified Data.ByteString.Builder as BS
import qualified Data.ByteString.Builder.Extra as BS
import Data.Functor ((<&>))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (..))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word (Word64)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Quiet

data OCertEnv = OCertEnv
  { OCertEnv -> Set (KeyHash StakePool)
ocertEnvStPools :: Set (KeyHash StakePool)
  , OCertEnv -> Set (KeyHash GenesisDelegate)
ocertEnvGenDelegs :: Set (KeyHash GenesisDelegate)
  }
  deriving (Int -> OCertEnv -> ShowS
[OCertEnv] -> ShowS
OCertEnv -> String
(Int -> OCertEnv -> ShowS)
-> (OCertEnv -> String) -> ([OCertEnv] -> ShowS) -> Show OCertEnv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OCertEnv -> ShowS
showsPrec :: Int -> OCertEnv -> ShowS
$cshow :: OCertEnv -> String
show :: OCertEnv -> String
$cshowList :: [OCertEnv] -> ShowS
showList :: [OCertEnv] -> ShowS
Show, OCertEnv -> OCertEnv -> Bool
(OCertEnv -> OCertEnv -> Bool)
-> (OCertEnv -> OCertEnv -> Bool) -> Eq OCertEnv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OCertEnv -> OCertEnv -> Bool
== :: OCertEnv -> OCertEnv -> Bool
$c/= :: OCertEnv -> OCertEnv -> Bool
/= :: OCertEnv -> OCertEnv -> Bool
Eq)

currentIssueNo ::
  OCertEnv ->
  Map (KeyHash BlockIssuer) Word64 ->
  -- | Pool hash
  KeyHash BlockIssuer ->
  Maybe Word64
currentIssueNo :: OCertEnv
-> Map (KeyHash BlockIssuer) Word64
-> KeyHash BlockIssuer
-> Maybe Word64
currentIssueNo (OCertEnv Set (KeyHash StakePool)
stPools Set (KeyHash GenesisDelegate)
genDelegs) Map (KeyHash BlockIssuer) Word64
cs KeyHash BlockIssuer
hk
  | KeyHash BlockIssuer -> Map (KeyHash BlockIssuer) Word64 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member KeyHash BlockIssuer
hk Map (KeyHash BlockIssuer) Word64
cs = KeyHash BlockIssuer
-> Map (KeyHash BlockIssuer) Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash BlockIssuer
hk Map (KeyHash BlockIssuer) Word64
cs
  | KeyHash StakePool -> Set (KeyHash StakePool) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (KeyHash BlockIssuer -> KeyHash StakePool
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash BlockIssuer
hk) Set (KeyHash StakePool)
stPools = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
  | KeyHash GenesisDelegate -> Set (KeyHash GenesisDelegate) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (KeyHash BlockIssuer -> KeyHash GenesisDelegate
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash BlockIssuer
hk) Set (KeyHash GenesisDelegate)
genDelegs = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
  | Bool
otherwise = Maybe Word64
forall a. Maybe a
Nothing

newtype KESPeriod = KESPeriod {KESPeriod -> Word
unKESPeriod :: Word}
  deriving (KESPeriod -> KESPeriod -> Bool
(KESPeriod -> KESPeriod -> Bool)
-> (KESPeriod -> KESPeriod -> Bool) -> Eq KESPeriod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KESPeriod -> KESPeriod -> Bool
== :: KESPeriod -> KESPeriod -> Bool
$c/= :: KESPeriod -> KESPeriod -> Bool
/= :: KESPeriod -> KESPeriod -> Bool
Eq, (forall x. KESPeriod -> Rep KESPeriod x)
-> (forall x. Rep KESPeriod x -> KESPeriod) -> Generic KESPeriod
forall x. Rep KESPeriod x -> KESPeriod
forall x. KESPeriod -> Rep KESPeriod x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. KESPeriod -> Rep KESPeriod x
from :: forall x. KESPeriod -> Rep KESPeriod x
$cto :: forall x. Rep KESPeriod x -> KESPeriod
to :: forall x. Rep KESPeriod x -> KESPeriod
Generic, Eq KESPeriod
Eq KESPeriod =>
(KESPeriod -> KESPeriod -> Ordering)
-> (KESPeriod -> KESPeriod -> Bool)
-> (KESPeriod -> KESPeriod -> Bool)
-> (KESPeriod -> KESPeriod -> Bool)
-> (KESPeriod -> KESPeriod -> Bool)
-> (KESPeriod -> KESPeriod -> KESPeriod)
-> (KESPeriod -> KESPeriod -> KESPeriod)
-> Ord KESPeriod
KESPeriod -> KESPeriod -> Bool
KESPeriod -> KESPeriod -> Ordering
KESPeriod -> KESPeriod -> KESPeriod
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: KESPeriod -> KESPeriod -> Ordering
compare :: KESPeriod -> KESPeriod -> Ordering
$c< :: KESPeriod -> KESPeriod -> Bool
< :: KESPeriod -> KESPeriod -> Bool
$c<= :: KESPeriod -> KESPeriod -> Bool
<= :: KESPeriod -> KESPeriod -> Bool
$c> :: KESPeriod -> KESPeriod -> Bool
> :: KESPeriod -> KESPeriod -> Bool
$c>= :: KESPeriod -> KESPeriod -> Bool
>= :: KESPeriod -> KESPeriod -> Bool
$cmax :: KESPeriod -> KESPeriod -> KESPeriod
max :: KESPeriod -> KESPeriod -> KESPeriod
$cmin :: KESPeriod -> KESPeriod -> KESPeriod
min :: KESPeriod -> KESPeriod -> KESPeriod
Ord, Context -> KESPeriod -> IO (Maybe ThunkInfo)
Proxy KESPeriod -> String
(Context -> KESPeriod -> IO (Maybe ThunkInfo))
-> (Context -> KESPeriod -> IO (Maybe ThunkInfo))
-> (Proxy KESPeriod -> String)
-> NoThunks KESPeriod
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> KESPeriod -> IO (Maybe ThunkInfo)
noThunks :: Context -> KESPeriod -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> KESPeriod -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> KESPeriod -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy KESPeriod -> String
showTypeOf :: Proxy KESPeriod -> String
NoThunks, Typeable KESPeriod
Typeable KESPeriod =>
(forall s. Decoder s KESPeriod)
-> (forall s. Proxy KESPeriod -> Decoder s ())
-> (Proxy KESPeriod -> Text)
-> DecCBOR KESPeriod
Proxy KESPeriod -> Text
forall s. Decoder s KESPeriod
forall a.
Typeable a =>
(forall s. Decoder s a)
-> (forall s. Proxy a -> Decoder s ())
-> (Proxy a -> Text)
-> DecCBOR a
forall s. Proxy KESPeriod -> Decoder s ()
$cdecCBOR :: forall s. Decoder s KESPeriod
decCBOR :: forall s. Decoder s KESPeriod
$cdropCBOR :: forall s. Proxy KESPeriod -> Decoder s ()
dropCBOR :: forall s. Proxy KESPeriod -> Decoder s ()
$clabel :: Proxy KESPeriod -> Text
label :: Proxy KESPeriod -> Text
DecCBOR, KESPeriod -> Encoding
(KESPeriod -> Encoding) -> EncCBOR KESPeriod
forall a. (a -> Encoding) -> EncCBOR a
$cencCBOR :: KESPeriod -> Encoding
encCBOR :: KESPeriod -> Encoding
EncCBOR)
  deriving (Int -> KESPeriod -> ShowS
[KESPeriod] -> ShowS
KESPeriod -> String
(Int -> KESPeriod -> ShowS)
-> (KESPeriod -> String)
-> ([KESPeriod] -> ShowS)
-> Show KESPeriod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KESPeriod -> ShowS
showsPrec :: Int -> KESPeriod -> ShowS
$cshow :: KESPeriod -> String
show :: KESPeriod -> String
$cshowList :: [KESPeriod] -> ShowS
showList :: [KESPeriod] -> ShowS
Show) via Quiet KESPeriod

data OCert c = OCert
  { forall c. OCert c -> VerKeyKES (KES c)
ocertVkHot :: !(KES.VerKeyKES (KES c))
  -- ^ The operational hot key
  , forall c. OCert c -> Word64
ocertN :: !Word64
  -- ^ counter
  , forall c. OCert c -> KESPeriod
ocertKESPeriod :: !KESPeriod
  -- ^ Start of key evolving signature period
  , forall c. OCert c -> SignedDSIGN DSIGN (OCertSignable c)
ocertSigma :: !(DSIGN.SignedDSIGN DSIGN (OCertSignable c))
  -- ^ Signature of block operational certificate content
  }
  deriving ((forall x. OCert c -> Rep (OCert c) x)
-> (forall x. Rep (OCert c) x -> OCert c) -> Generic (OCert c)
forall x. Rep (OCert c) x -> OCert c
forall x. OCert c -> Rep (OCert c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (OCert c) x -> OCert c
forall c x. OCert c -> Rep (OCert c) x
$cfrom :: forall c x. OCert c -> Rep (OCert c) x
from :: forall x. OCert c -> Rep (OCert c) x
$cto :: forall c x. Rep (OCert c) x -> OCert c
to :: forall x. Rep (OCert c) x -> OCert c
Generic)
  deriving (OCert c -> Encoding
(OCert c -> Encoding) -> EncCBOR (OCert c)
forall c. Crypto c => OCert c -> Encoding
forall a. (a -> Encoding) -> EncCBOR a
$cencCBOR :: forall c. Crypto c => OCert c -> Encoding
encCBOR :: OCert c -> Encoding
EncCBOR) via (CBORGroup (OCert c))
  deriving (Typeable (OCert c)
Typeable (OCert c) =>
(forall s. Decoder s (OCert c))
-> (forall s. Proxy (OCert c) -> Decoder s ())
-> (Proxy (OCert c) -> Text)
-> DecCBOR (OCert c)
Proxy (OCert c) -> Text
forall s. Decoder s (OCert c)
forall a.
Typeable a =>
(forall s. Decoder s a)
-> (forall s. Proxy a -> Decoder s ())
-> (Proxy a -> Text)
-> DecCBOR a
forall s. Proxy (OCert c) -> Decoder s ()
forall c. Crypto c => Typeable (OCert c)
forall c. Crypto c => Proxy (OCert c) -> Text
forall c s. Crypto c => Decoder s (OCert c)
forall c s. Crypto c => Proxy (OCert c) -> Decoder s ()
$cdecCBOR :: forall c s. Crypto c => Decoder s (OCert c)
decCBOR :: forall s. Decoder s (OCert c)
$cdropCBOR :: forall c s. Crypto c => Proxy (OCert c) -> Decoder s ()
dropCBOR :: forall s. Proxy (OCert c) -> Decoder s ()
$clabel :: forall c. Crypto c => Proxy (OCert c) -> Text
label :: Proxy (OCert c) -> Text
DecCBOR) via (CBORGroup (OCert c))

deriving instance Crypto c => Eq (OCert c)

deriving instance Crypto c => Show (OCert c)

instance Crypto c => NoThunks (OCert c)

-- Serialization of OCerts cannot be versioned, unless it gets parameterized by era.
-- Therefore we use plain encoding for defining the versioned one, instead of the oppoit
-- approach how it is done for types with versioned serialization

instance Crypto c => EncCBORGroup (OCert c) where
  encCBORGroup :: OCert c -> Encoding
encCBORGroup = OCert c -> Encoding
forall c. Crypto c => OCert c -> Encoding
encodeOCertFields
  listLen :: Proxy (OCert c) -> Word
listLen Proxy (OCert c)
_ = Word
4

instance Crypto c => DecCBORGroup (OCert c) where
  decCBORGroup :: forall s. Decoder s (OCert c)
decCBORGroup = Decoder s (OCert c)
forall c s. Crypto c => Decoder s (OCert c)
decodeOCertFields

encodeOCertFields :: Crypto c => OCert c -> Encoding
encodeOCertFields :: forall c. Crypto c => OCert c -> Encoding
encodeOCertFields OCert c
ocert =
  VerKeyKES (KES c) -> Encoding
forall a. FixedSizeCodec a => a -> Encoding
encodeFixedSized (OCert c -> VerKeyKES (KES c)
forall c. OCert c -> VerKeyKES (KES c)
ocertVkHot OCert c
ocert)
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (OCert c -> Word64
forall c. OCert c -> Word64
ocertN OCert c
ocert)
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KESPeriod -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (OCert c -> KESPeriod
forall c. OCert c -> KESPeriod
ocertKESPeriod OCert c
ocert)
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SignedDSIGN DSIGN (OCertSignable c) -> Encoding
forall a. FixedSizeCodec a => a -> Encoding
encodeFixedSized (OCert c -> SignedDSIGN DSIGN (OCertSignable c)
forall c. OCert c -> SignedDSIGN DSIGN (OCertSignable c)
ocertSigma OCert c
ocert)

decodeOCertFields :: Crypto c => Decoder s (OCert c)
decodeOCertFields :: forall c s. Crypto c => Decoder s (OCert c)
decodeOCertFields =
  VerKeyKES (KES c)
-> Word64
-> KESPeriod
-> SignedDSIGN DSIGN (OCertSignable c)
-> OCert c
forall c.
VerKeyKES (KES c)
-> Word64
-> KESPeriod
-> SignedDSIGN DSIGN (OCertSignable c)
-> OCert c
OCert
    (VerKeyKES (KES c)
 -> Word64
 -> KESPeriod
 -> SignedDSIGN DSIGN (OCertSignable c)
 -> OCert c)
-> Decoder s (VerKeyKES (KES c))
-> Decoder
     s
     (Word64
      -> KESPeriod -> SignedDSIGN DSIGN (OCertSignable c) -> OCert c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (VerKeyKES (KES c))
forall a s. FixedSizeCodec a => Decoder s a
decodeFixedSized
    Decoder
  s
  (Word64
   -> KESPeriod -> SignedDSIGN DSIGN (OCertSignable c) -> OCert c)
-> Decoder s Word64
-> Decoder
     s (KESPeriod -> SignedDSIGN DSIGN (OCertSignable c) -> OCert c)
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 Word64
forall s. Decoder s Word64
forall a s. DecCBOR a => Decoder s a
decCBOR
    Decoder
  s (KESPeriod -> SignedDSIGN DSIGN (OCertSignable c) -> OCert c)
-> Decoder s KESPeriod
-> Decoder s (SignedDSIGN DSIGN (OCertSignable c) -> OCert c)
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
<*> (Word -> KESPeriod
KESPeriod (Word -> KESPeriod) -> Decoder s Word -> Decoder s KESPeriod
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word
forall s. Decoder s Word
forall a s. DecCBOR a => Decoder s a
decCBOR)
    Decoder s (SignedDSIGN DSIGN (OCertSignable c) -> OCert c)
-> Decoder s (SignedDSIGN DSIGN (OCertSignable c))
-> Decoder s (OCert c)
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 (SignedDSIGN DSIGN (OCertSignable c))
forall a s. FixedSizeCodec a => Decoder s a
decodeFixedSized

kesPeriod :: SlotNo -> ShelleyBase KESPeriod
kesPeriod :: SlotNo -> ShelleyBase KESPeriod
kesPeriod (SlotNo Word64
s) =
  (Globals -> Word64) -> ReaderT Globals Identity Word64
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Word64
slotsPerKESPeriod ReaderT Globals Identity Word64
-> (Word64 -> KESPeriod) -> ShelleyBase KESPeriod
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Word64
spkp ->
    if Word64
spkp Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
      then String -> KESPeriod
forall a. HasCallStack => String -> a
error String
"kesPeriod: slots per KES period was set to zero"
      else Word -> KESPeriod
KESPeriod (Word -> KESPeriod) -> (Word64 -> Word) -> Word64 -> KESPeriod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> KESPeriod) -> Word64 -> KESPeriod
forall a b. (a -> b) -> a -> b
$ Word64
s Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
spkp

-- | Signable part of an operational certificate
data OCertSignable c
  = OCertSignable !(KES.VerKeyKES (KES c)) !Word64 !KESPeriod

instance Crypto c => SignableRepresentation (OCertSignable c) where
  getSignableRepresentation :: OCertSignable c -> ByteString
getSignableRepresentation (OCertSignable VerKeyKES (KES c)
vk Word64
counter KESPeriod
period) =
    Int -> Builder -> ByteString
runByteBuilder
      ( Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$
          Proxy (VerKeyKES (KES c)) -> Word
forall a (proxy :: * -> *). FixedSizeCodec a => proxy a -> Word
fixedSize (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(VerKeyKES (KES c)))
            Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
8
            Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
8
      )
      (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
BS.byteStringCopy (VerKeyKES (KES c) -> ByteString
forall a. FixedSizeCodec a => a -> ByteString
rawEncodeFixedSized VerKeyKES (KES c)
vk)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
BS.word64BE Word64
counter
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
BS.word64BE (Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Word64) -> Word -> Word64
forall a b. (a -> b) -> a -> b
$ KESPeriod -> Word
unKESPeriod KESPeriod
period)

-- | Extract the signable part of an operational certificate (for verification)
ocertToSignable :: OCert c -> OCertSignable c
ocertToSignable :: forall c. OCert c -> OCertSignable c
ocertToSignable OCert {VerKeyKES (KES c)
ocertVkHot :: forall c. OCert c -> VerKeyKES (KES c)
ocertVkHot :: VerKeyKES (KES c)
ocertVkHot, Word64
ocertN :: forall c. OCert c -> Word64
ocertN :: Word64
ocertN, KESPeriod
ocertKESPeriod :: forall c. OCert c -> KESPeriod
ocertKESPeriod :: KESPeriod
ocertKESPeriod} =
  VerKeyKES (KES c) -> Word64 -> KESPeriod -> OCertSignable c
forall c.
VerKeyKES (KES c) -> Word64 -> KESPeriod -> OCertSignable c
OCertSignable VerKeyKES (KES c)
ocertVkHot Word64
ocertN KESPeriod
ocertKESPeriod