{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-missed-specialisations #-}

module Cardano.Chain.Genesis.Delegation
  ( GenesisDelegation (..),
    GenesisDelegationError,
    mkGenesisDelegation,
  )
where

import Cardano.Binary
import Cardano.Chain.Common (KeyHash, hashKey)
import Cardano.Chain.Delegation.Certificate
  ( ACertificate (delegateVK, issuerVK),
    Certificate,
  )
import Cardano.Prelude
import Data.List (nub)
import qualified Data.Map.Strict as M
import Formatting (bprint, build, formatToString)
import qualified Formatting.Buildable as B
import NoThunks.Class (NoThunks (..))
import Text.JSON.Canonical (FromJSON (..), ReportSchemaErrors (..), ToJSON (..))

-- | This type contains genesis state of heavyweight delegation. It wraps a map
--   where keys are issuers and values are delegation certificates. There are
--   some invariants:
--
--   1. In each pair delegate must differ from issuer, i. e. no revocations.
--   2. PSKs must be consistent with keys in the map, i. e. issuer's ID must be
--      equal to the key in the map.
--   3. Delegates can't be issuers, i. e. transitive delegation is not
--      supported. It's not needed in genesis, it can always be reduced.
newtype GenesisDelegation = UnsafeGenesisDelegation
  { GenesisDelegation -> Map KeyHash Certificate
unGenesisDelegation :: Map KeyHash Certificate
  }
  deriving (Int -> GenesisDelegation -> ShowS
[GenesisDelegation] -> ShowS
GenesisDelegation -> String
(Int -> GenesisDelegation -> ShowS)
-> (GenesisDelegation -> String)
-> ([GenesisDelegation] -> ShowS)
-> Show GenesisDelegation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenesisDelegation] -> ShowS
$cshowList :: [GenesisDelegation] -> ShowS
show :: GenesisDelegation -> String
$cshow :: GenesisDelegation -> String
showsPrec :: Int -> GenesisDelegation -> ShowS
$cshowsPrec :: Int -> GenesisDelegation -> ShowS
Show, GenesisDelegation -> GenesisDelegation -> Bool
(GenesisDelegation -> GenesisDelegation -> Bool)
-> (GenesisDelegation -> GenesisDelegation -> Bool)
-> Eq GenesisDelegation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenesisDelegation -> GenesisDelegation -> Bool
$c/= :: GenesisDelegation -> GenesisDelegation -> Bool
== :: GenesisDelegation -> GenesisDelegation -> Bool
$c== :: GenesisDelegation -> GenesisDelegation -> Bool
Eq, Context -> GenesisDelegation -> IO (Maybe ThunkInfo)
Proxy GenesisDelegation -> String
(Context -> GenesisDelegation -> IO (Maybe ThunkInfo))
-> (Context -> GenesisDelegation -> IO (Maybe ThunkInfo))
-> (Proxy GenesisDelegation -> String)
-> NoThunks GenesisDelegation
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy GenesisDelegation -> String
$cshowTypeOf :: Proxy GenesisDelegation -> String
wNoThunks :: Context -> GenesisDelegation -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> GenesisDelegation -> IO (Maybe ThunkInfo)
noThunks :: Context -> GenesisDelegation -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> GenesisDelegation -> IO (Maybe ThunkInfo)
NoThunks)

instance Monad m => ToJSON m GenesisDelegation where
  toJSON :: GenesisDelegation -> m JSValue
toJSON = Map KeyHash Certificate -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (Map KeyHash Certificate -> m JSValue)
-> (GenesisDelegation -> Map KeyHash Certificate)
-> GenesisDelegation
-> m JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. GenesisDelegation -> Map KeyHash Certificate
unGenesisDelegation

instance MonadError SchemaError m => FromJSON m GenesisDelegation where
  fromJSON :: JSValue -> m GenesisDelegation
fromJSON JSValue
val = do
    Map KeyHash Certificate
certs <- JSValue -> m (Map KeyHash Certificate)
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
val
    case Map KeyHash Certificate
-> Either GenesisDelegationError GenesisDelegation
forall (m :: * -> *).
MonadError GenesisDelegationError m =>
Map KeyHash Certificate -> m GenesisDelegation
recreateGenesisDelegation Map KeyHash Certificate
certs of
      Left GenesisDelegationError
err ->
        String -> Maybe String -> m GenesisDelegation
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected
          String
"GenesisDelegation"
          (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Format String (GenesisDelegationError -> String)
-> GenesisDelegationError -> String
forall a. Format String a -> a
formatToString Format String (GenesisDelegationError -> String)
forall a r. Buildable a => Format r (a -> r)
build GenesisDelegationError
err)
      Right GenesisDelegation
delegation -> GenesisDelegation -> m GenesisDelegation
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenesisDelegation
delegation

instance ToCBOR GenesisDelegation where
  toCBOR :: GenesisDelegation -> Encoding
toCBOR (UnsafeGenesisDelegation Map KeyHash Certificate
gd) =
    Word -> Encoding
encodeListLen Word
1
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map KeyHash Certificate -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR @(Map KeyHash Certificate) Map KeyHash Certificate
gd

instance FromCBOR GenesisDelegation where
  fromCBOR :: Decoder s GenesisDelegation
fromCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"GenesisDelegation" Int
1
    Map KeyHash Certificate -> GenesisDelegation
UnsafeGenesisDelegation (Map KeyHash Certificate -> GenesisDelegation)
-> Decoder s (Map KeyHash Certificate)
-> Decoder s GenesisDelegation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s.
FromCBOR (Map KeyHash Certificate) =>
Decoder s (Map KeyHash Certificate)
forall a s. FromCBOR a => Decoder s a
fromCBOR @(Map KeyHash Certificate)

data GenesisDelegationError
  = GenesisDelegationDuplicateIssuer
  | GenesisDelegationInvalidKey KeyHash KeyHash
  | GenesisDelegationMultiLayerDelegation KeyHash
  deriving (GenesisDelegationError -> GenesisDelegationError -> Bool
(GenesisDelegationError -> GenesisDelegationError -> Bool)
-> (GenesisDelegationError -> GenesisDelegationError -> Bool)
-> Eq GenesisDelegationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenesisDelegationError -> GenesisDelegationError -> Bool
$c/= :: GenesisDelegationError -> GenesisDelegationError -> Bool
== :: GenesisDelegationError -> GenesisDelegationError -> Bool
$c== :: GenesisDelegationError -> GenesisDelegationError -> Bool
Eq, Int -> GenesisDelegationError -> ShowS
[GenesisDelegationError] -> ShowS
GenesisDelegationError -> String
(Int -> GenesisDelegationError -> ShowS)
-> (GenesisDelegationError -> String)
-> ([GenesisDelegationError] -> ShowS)
-> Show GenesisDelegationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenesisDelegationError] -> ShowS
$cshowList :: [GenesisDelegationError] -> ShowS
show :: GenesisDelegationError -> String
$cshow :: GenesisDelegationError -> String
showsPrec :: Int -> GenesisDelegationError -> ShowS
$cshowsPrec :: Int -> GenesisDelegationError -> ShowS
Show)

instance B.Buildable GenesisDelegationError where
  build :: GenesisDelegationError -> Builder
build = \case
    GenesisDelegationError
GenesisDelegationDuplicateIssuer ->
      Format Builder Builder -> Builder
forall a. Format Builder a -> a
bprint
        Format Builder Builder
"Encountered duplicate issuer VerificationKey while constructing GenesisDelegation."
    GenesisDelegationInvalidKey KeyHash
k KeyHash
k' ->
      Format Builder (KeyHash -> KeyHash -> Builder)
-> KeyHash -> KeyHash -> Builder
forall a. Format Builder a -> a
bprint
        ( Format
  (KeyHash -> KeyHash -> Builder) (KeyHash -> KeyHash -> Builder)
"Invalid key in GenesisDelegation map.\nExpected: "
            Format
  (KeyHash -> KeyHash -> Builder) (KeyHash -> KeyHash -> Builder)
-> Format Builder (KeyHash -> KeyHash -> Builder)
-> Format Builder (KeyHash -> KeyHash -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (KeyHash -> Builder) (KeyHash -> KeyHash -> Builder)
forall a r. Buildable a => Format r (a -> r)
build
            Format (KeyHash -> Builder) (KeyHash -> KeyHash -> Builder)
-> Format Builder (KeyHash -> Builder)
-> Format Builder (KeyHash -> KeyHash -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (KeyHash -> Builder) (KeyHash -> Builder)
"\nGot: "
            Format (KeyHash -> Builder) (KeyHash -> Builder)
-> Format Builder (KeyHash -> Builder)
-> Format Builder (KeyHash -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (KeyHash -> Builder)
forall a r. Buildable a => Format r (a -> r)
build
        )
        KeyHash
k
        KeyHash
k'
    GenesisDelegationMultiLayerDelegation KeyHash
k ->
      Format Builder (KeyHash -> Builder) -> KeyHash -> Builder
forall a. Format Builder a -> a
bprint
        ( Format (KeyHash -> Builder) (KeyHash -> Builder)
"Encountered multi-layer delegation.\n"
            Format (KeyHash -> Builder) (KeyHash -> Builder)
-> Format Builder (KeyHash -> Builder)
-> Format Builder (KeyHash -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (KeyHash -> Builder)
forall a r. Buildable a => Format r (a -> r)
build
            Format Builder (KeyHash -> Builder)
-> Format Builder Builder -> Format Builder (KeyHash -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder Builder
" is a delegate and an issuer."
        )
        KeyHash
k

-- | Safe constructor of 'GenesisDelegation' from a list of 'Certificate's
mkGenesisDelegation ::
  MonadError GenesisDelegationError m => [Certificate] -> m GenesisDelegation
mkGenesisDelegation :: [Certificate] -> m GenesisDelegation
mkGenesisDelegation [Certificate]
certs = do
  (([VerificationKey] -> Int
forall a. HasLength a => a -> Int
length ([VerificationKey] -> Int)
-> ([VerificationKey] -> [VerificationKey])
-> [VerificationKey]
-> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [VerificationKey] -> [VerificationKey]
forall a. Eq a => [a] -> [a]
nub ([VerificationKey] -> Int) -> [VerificationKey] -> Int
forall a b. (a -> b) -> a -> b
$ Certificate -> VerificationKey
forall a. ACertificate a -> VerificationKey
issuerVK (Certificate -> VerificationKey)
-> [Certificate] -> [VerificationKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Certificate]
certs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Certificate] -> Int
forall a. HasLength a => a -> Int
length [Certificate]
certs)
    Bool -> GenesisDelegationError -> m ()
forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` GenesisDelegationError
GenesisDelegationDuplicateIssuer
  let res :: Map KeyHash Certificate
res = [(KeyHash, Certificate)] -> Map KeyHash Certificate
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(VerificationKey -> KeyHash
hashKey (VerificationKey -> KeyHash) -> VerificationKey -> KeyHash
forall a b. (a -> b) -> a -> b
$ Certificate -> VerificationKey
forall a. ACertificate a -> VerificationKey
issuerVK Certificate
cert, Certificate
cert) | Certificate
cert <- [Certificate]
certs]
  Map KeyHash Certificate -> m GenesisDelegation
forall (m :: * -> *).
MonadError GenesisDelegationError m =>
Map KeyHash Certificate -> m GenesisDelegation
recreateGenesisDelegation Map KeyHash Certificate
res

-- | Safe constructor of 'GenesisDelegation' from existing map
recreateGenesisDelegation ::
  MonadError GenesisDelegationError m =>
  Map KeyHash Certificate ->
  m GenesisDelegation
recreateGenesisDelegation :: Map KeyHash Certificate -> m GenesisDelegation
recreateGenesisDelegation Map KeyHash Certificate
certMap = do
  [(KeyHash, Certificate)]
-> ((KeyHash, Certificate) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map KeyHash Certificate -> [(KeyHash, Certificate)]
forall k a. Map k a -> [(k, a)]
M.toList Map KeyHash Certificate
certMap) (((KeyHash, Certificate) -> m ()) -> m ())
-> ((KeyHash, Certificate) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(KeyHash
k, Certificate
cert) -> do
    let k' :: KeyHash
k' = VerificationKey -> KeyHash
hashKey (VerificationKey -> KeyHash) -> VerificationKey -> KeyHash
forall a b. (a -> b) -> a -> b
$ Certificate -> VerificationKey
forall a. ACertificate a -> VerificationKey
issuerVK Certificate
cert
    (KeyHash
k KeyHash -> KeyHash -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash
k') Bool -> GenesisDelegationError -> m ()
forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` KeyHash -> KeyHash -> GenesisDelegationError
GenesisDelegationInvalidKey KeyHash
k KeyHash
k'

    let delegateId :: KeyHash
delegateId = VerificationKey -> KeyHash
hashKey (VerificationKey -> KeyHash) -> VerificationKey -> KeyHash
forall a b. (a -> b) -> a -> b
$ Certificate -> VerificationKey
forall a. ACertificate a -> VerificationKey
delegateVK Certificate
cert
    (KeyHash
delegateId KeyHash -> Map KeyHash Certificate -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.notMember` Map KeyHash Certificate
certMap)
      Bool -> GenesisDelegationError -> m ()
forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` KeyHash -> GenesisDelegationError
GenesisDelegationMultiLayerDelegation KeyHash
delegateId

  GenesisDelegation -> m GenesisDelegation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenesisDelegation -> m GenesisDelegation)
-> GenesisDelegation -> m GenesisDelegation
forall a b. (a -> b) -> a -> b
$ Map KeyHash Certificate -> GenesisDelegation
UnsafeGenesisDelegation Map KeyHash Certificate
certMap