{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Cardano.Chain.Delegation.Validation.Interface
(
Environment(..)
, State(..)
, activateDelegations
, delegates
, delegationMap
, initialState
, tickDelegation
, updateDelegation
)
where
import Cardano.Prelude hiding (State)
import qualified Data.Map.Strict as M
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import NoThunks.Class (NoThunks (..))
import Cardano.Binary
( Annotated(..)
, FromCBOR(..)
, ToCBOR(..)
, encodeListLen
, enforceSize
, serialize'
)
import Cardano.Chain.Common (BlockCount(..), KeyHash, hashKey)
import qualified Cardano.Chain.Delegation as Delegation
import Cardano.Chain.Delegation.Certificate (ACertificate, Certificate)
import qualified Cardano.Chain.Delegation.Validation.Activation as Activation
import qualified Cardano.Chain.Delegation.Validation.Scheduling as Scheduling
import Cardano.Chain.Genesis (GenesisDelegation(..))
import Cardano.Chain.Slotting
( EpochNumber
, SlotNumber(..)
)
import Cardano.Crypto (ProtocolMagicId, VerificationKey)
data Environment = Environment
{ Environment -> Annotated ProtocolMagicId ByteString
protocolMagic :: !(Annotated ProtocolMagicId ByteString)
, Environment -> Set KeyHash
allowedDelegators :: !(Set KeyHash)
, Environment -> BlockCount
k :: !BlockCount
, Environment -> EpochNumber
currentEpoch :: !EpochNumber
, Environment -> SlotNumber
currentSlot :: !SlotNumber
} deriving (Environment -> Environment -> Bool
(Environment -> Environment -> Bool)
-> (Environment -> Environment -> Bool) -> Eq Environment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Environment -> Environment -> Bool
$c/= :: Environment -> Environment -> Bool
== :: Environment -> Environment -> Bool
$c== :: Environment -> Environment -> Bool
Eq, Int -> Environment -> ShowS
[Environment] -> ShowS
Environment -> String
(Int -> Environment -> ShowS)
-> (Environment -> String)
-> ([Environment] -> ShowS)
-> Show Environment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Environment] -> ShowS
$cshowList :: [Environment] -> ShowS
show :: Environment -> String
$cshow :: Environment -> String
showsPrec :: Int -> Environment -> ShowS
$cshowsPrec :: Int -> Environment -> ShowS
Show, (forall x. Environment -> Rep Environment x)
-> (forall x. Rep Environment x -> Environment)
-> Generic Environment
forall x. Rep Environment x -> Environment
forall x. Environment -> Rep Environment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Environment x -> Environment
$cfrom :: forall x. Environment -> Rep Environment x
Generic, Environment -> ()
(Environment -> ()) -> NFData Environment
forall a. (a -> ()) -> NFData a
rnf :: Environment -> ()
$crnf :: Environment -> ()
NFData)
data State = State
{ State -> State
schedulingState :: !Scheduling.State
, State -> State
activationState :: !Activation.State
} deriving (State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: State -> State -> Bool
$c/= :: State -> State -> Bool
== :: State -> State -> Bool
$c== :: State -> State -> Bool
Eq, Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show, (forall x. State -> Rep State x)
-> (forall x. Rep State x -> State) -> Generic State
forall x. Rep State x -> State
forall x. State -> Rep State x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep State x -> State
$cfrom :: forall x. State -> Rep State x
Generic, State -> ()
(State -> ()) -> NFData State
forall a. (a -> ()) -> NFData a
rnf :: State -> ()
$crnf :: State -> ()
NFData, Context -> State -> IO (Maybe ThunkInfo)
Proxy State -> String
(Context -> State -> IO (Maybe ThunkInfo))
-> (Context -> State -> IO (Maybe ThunkInfo))
-> (Proxy State -> String)
-> NoThunks State
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy State -> String
$cshowTypeOf :: Proxy State -> String
wNoThunks :: Context -> State -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> State -> IO (Maybe ThunkInfo)
noThunks :: Context -> State -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> State -> IO (Maybe ThunkInfo)
NoThunks)
instance FromCBOR State where
fromCBOR :: Decoder s State
fromCBOR = do
Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"State" Int
2
State -> State -> State
State
(State -> State -> State)
-> Decoder s State -> Decoder s (State -> State)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s State
forall a s. FromCBOR a => Decoder s a
fromCBOR
Decoder s (State -> State) -> Decoder s State -> Decoder s State
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s State
forall a s. FromCBOR a => Decoder s a
fromCBOR
instance ToCBOR State where
toCBOR :: State -> Encoding
toCBOR State
s =
Word -> Encoding
encodeListLen Word
2
Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> State -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> State
schedulingState State
s)
Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> State -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> State
activationState State
s)
delegationMap :: State -> Delegation.Map
delegationMap :: State -> Map
delegationMap = State -> Map
Activation.delegationMap (State -> Map) -> (State -> State) -> State -> Map
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. State -> State
activationState
initialState
:: MonadError Scheduling.Error m
=> Environment
-> GenesisDelegation
-> m State
initialState :: Environment -> GenesisDelegation -> m State
initialState Environment
env GenesisDelegation
genesisDelegation = Environment -> State -> [ACertificate ByteString] -> m State
forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> [ACertificate ByteString] -> m State
updateDelegation Environment
env' State
is [ACertificate ByteString]
certificates
where
Environment { Set KeyHash
allowedDelegators :: Set KeyHash
allowedDelegators :: Environment -> Set KeyHash
allowedDelegators } = Environment
env
env' :: Environment
env' = Environment
env { k :: BlockCount
k = Word64 -> BlockCount
BlockCount Word64
0 }
is :: State
is = State :: State -> State -> State
State
{ schedulingState :: State
schedulingState = State :: Seq ScheduledDelegation -> Set (EpochNumber, KeyHash) -> State
Scheduling.State
{ scheduledDelegations :: Seq ScheduledDelegation
Scheduling.scheduledDelegations = Seq ScheduledDelegation
forall a. Monoid a => a
mempty
, keyEpochDelegations :: Set (EpochNumber, KeyHash)
Scheduling.keyEpochDelegations = Set (EpochNumber, KeyHash)
forall a. Monoid a => a
mempty
}
, activationState :: State
activationState = State :: Map -> Map KeyHash SlotNumber -> State
Activation.State
{ delegationMap :: Map
Activation.delegationMap = [(KeyHash, KeyHash)] -> Map
Delegation.fromList
([(KeyHash, KeyHash)] -> Map) -> [(KeyHash, KeyHash)] -> Map
forall a b. (a -> b) -> a -> b
$ [KeyHash] -> [KeyHash] -> [(KeyHash, KeyHash)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set KeyHash -> [KeyHash]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set KeyHash
allowedDelegators) (Set KeyHash -> [KeyHash]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set KeyHash
allowedDelegators)
, delegationSlots :: Map KeyHash SlotNumber
Activation.delegationSlots = [(KeyHash, SlotNumber)] -> Map KeyHash SlotNumber
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
([(KeyHash, SlotNumber)] -> Map KeyHash SlotNumber)
-> [(KeyHash, SlotNumber)] -> Map KeyHash SlotNumber
forall a b. (a -> b) -> a -> b
$ (, Word64 -> SlotNumber
SlotNumber Word64
0)
(KeyHash -> (KeyHash, SlotNumber))
-> [KeyHash] -> [(KeyHash, SlotNumber)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set KeyHash -> [KeyHash]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set KeyHash
allowedDelegators
}
}
certificates :: [ACertificate ByteString]
certificates =
(Certificate -> ACertificate ByteString)
-> [Certificate] -> [ACertificate ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Certificate -> ACertificate ByteString
annotateCertificate ([Certificate] -> [ACertificate ByteString])
-> (Map KeyHash Certificate -> [Certificate])
-> Map KeyHash Certificate
-> [ACertificate ByteString]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Map KeyHash Certificate -> [Certificate]
forall k a. Map k a -> [a]
M.elems (Map KeyHash Certificate -> [ACertificate ByteString])
-> Map KeyHash Certificate -> [ACertificate ByteString]
forall a b. (a -> b) -> a -> b
$ GenesisDelegation -> Map KeyHash Certificate
unGenesisDelegation GenesisDelegation
genesisDelegation
annotateCertificate :: Certificate -> ACertificate ByteString
annotateCertificate :: Certificate -> ACertificate ByteString
annotateCertificate Certificate
c = Certificate
c
{ aEpoch :: Annotated EpochNumber ByteString
Delegation.aEpoch = EpochNumber -> ByteString -> Annotated EpochNumber ByteString
forall b a. b -> a -> Annotated b a
Annotated
(Certificate -> EpochNumber
forall a. ACertificate a -> EpochNumber
Delegation.epoch Certificate
c)
(EpochNumber -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' (EpochNumber -> ByteString) -> EpochNumber -> ByteString
forall a b. (a -> b) -> a -> b
$ Certificate -> EpochNumber
forall a. ACertificate a -> EpochNumber
Delegation.epoch Certificate
c)
, annotation :: ByteString
Delegation.annotation = Certificate -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' Certificate
c
}
delegates :: State -> VerificationKey -> VerificationKey -> Bool
delegates :: State -> VerificationKey -> VerificationKey -> Bool
delegates State
is VerificationKey
delegator VerificationKey
delegate =
(VerificationKey -> KeyHash
hashKey VerificationKey
delegator, VerificationKey -> KeyHash
hashKey VerificationKey
delegate)
(KeyHash, KeyHash) -> Map -> Bool
`Delegation.pairMember` State -> Map
delegationMap State
is
updateDelegation
:: MonadError Scheduling.Error m
=> Environment
-> State
-> [ACertificate ByteString]
-> m State
updateDelegation :: Environment -> State -> [ACertificate ByteString] -> m State
updateDelegation Environment
env State
is [ACertificate ByteString]
certificates = do
State
ss' <- (State -> ACertificate ByteString -> m State)
-> State -> [ACertificate ByteString] -> m State
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
(Environment -> State -> ACertificate ByteString -> m State
forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> ACertificate ByteString -> m State
Scheduling.scheduleCertificate Environment
schedulingEnv)
(State -> State
schedulingState State
is)
[ACertificate ByteString]
certificates
State -> m State
forall (f :: * -> *) a. Applicative f => a -> f a
pure (State -> m State) -> State -> m State
forall a b. (a -> b) -> a -> b
$ EpochNumber -> SlotNumber -> State -> State
tickDelegation EpochNumber
currentEpoch SlotNumber
currentSlot
State
is { schedulingState :: State
schedulingState = State
ss' }
where
Environment { Annotated ProtocolMagicId ByteString
protocolMagic :: Annotated ProtocolMagicId ByteString
protocolMagic :: Environment -> Annotated ProtocolMagicId ByteString
protocolMagic, Set KeyHash
allowedDelegators :: Set KeyHash
allowedDelegators :: Environment -> Set KeyHash
allowedDelegators, BlockCount
k :: BlockCount
k :: Environment -> BlockCount
k, EpochNumber
currentEpoch :: EpochNumber
currentEpoch :: Environment -> EpochNumber
currentEpoch, SlotNumber
currentSlot :: SlotNumber
currentSlot :: Environment -> SlotNumber
currentSlot }
= Environment
env
schedulingEnv :: Environment
schedulingEnv = Environment :: Annotated ProtocolMagicId ByteString
-> Set KeyHash
-> EpochNumber
-> SlotNumber
-> BlockCount
-> Environment
Scheduling.Environment
{ protocolMagic :: Annotated ProtocolMagicId ByteString
Scheduling.protocolMagic = Annotated ProtocolMagicId ByteString
protocolMagic
, allowedDelegators :: Set KeyHash
Scheduling.allowedDelegators = Set KeyHash
allowedDelegators
, currentEpoch :: EpochNumber
Scheduling.currentEpoch = EpochNumber
currentEpoch
, currentSlot :: SlotNumber
Scheduling.currentSlot = SlotNumber
currentSlot
, k :: BlockCount
Scheduling.k = BlockCount
k
}
tickDelegation :: EpochNumber -> SlotNumber -> State -> State
tickDelegation :: EpochNumber -> SlotNumber -> State -> State
tickDelegation EpochNumber
currentEpoch SlotNumber
currentSlot =
State -> State
prune (State -> State) -> (State -> State) -> State -> State
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SlotNumber -> State -> State
activateDelegations SlotNumber
currentSlot
where
prune :: State -> State
prune State
s =
let ss' :: State
ss' = EpochNumber -> SlotNumber -> State -> State
pruneScheduledDelegations EpochNumber
currentEpoch SlotNumber
currentSlot (State -> State
schedulingState State
s)
in State
s{ schedulingState :: State
schedulingState = State
ss'}
activateDelegations :: SlotNumber -> State -> State
activateDelegations :: SlotNumber -> State -> State
activateDelegations SlotNumber
currentSlot s :: State
s@(State State
ss State
as) =
let Scheduling.State Seq ScheduledDelegation
delegations Set (EpochNumber, KeyHash)
_keyEpochs = State
ss
as' :: State
as' = (State -> ScheduledDelegation -> State)
-> State -> Seq ScheduledDelegation -> State
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl State -> ScheduledDelegation -> State
Activation.activateDelegation State
as
((ScheduledDelegation -> Bool)
-> Seq ScheduledDelegation -> Seq ScheduledDelegation
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter ((SlotNumber -> SlotNumber -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNumber
currentSlot) (SlotNumber -> Bool)
-> (ScheduledDelegation -> SlotNumber)
-> ScheduledDelegation
-> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ScheduledDelegation -> SlotNumber
Scheduling.sdSlot) Seq ScheduledDelegation
delegations)
in State
s { activationState :: State
activationState = State
as' }
pruneScheduledDelegations
:: EpochNumber
-> SlotNumber
-> Scheduling.State
-> Scheduling.State
pruneScheduledDelegations :: EpochNumber -> SlotNumber -> State -> State
pruneScheduledDelegations EpochNumber
currentEpoch SlotNumber
currentSlot State
ss =
let Scheduling.State Seq ScheduledDelegation
delegations Set (EpochNumber, KeyHash)
keyEpochs = State
ss
in State :: Seq ScheduledDelegation -> Set (EpochNumber, KeyHash) -> State
Scheduling.State
{ scheduledDelegations :: Seq ScheduledDelegation
Scheduling.scheduledDelegations = (ScheduledDelegation -> Bool)
-> Seq ScheduledDelegation -> Seq ScheduledDelegation
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter
((SlotNumber
currentSlot SlotNumber -> SlotNumber -> SlotNumber
forall a. Num a => a -> a -> a
+ SlotNumber
1 SlotNumber -> SlotNumber -> Bool
forall a. Ord a => a -> a -> Bool
<=) (SlotNumber -> Bool)
-> (ScheduledDelegation -> SlotNumber)
-> ScheduledDelegation
-> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ScheduledDelegation -> SlotNumber
Scheduling.sdSlot)
Seq ScheduledDelegation
delegations
, keyEpochDelegations :: Set (EpochNumber, KeyHash)
Scheduling.keyEpochDelegations = ((EpochNumber, KeyHash) -> Bool)
-> Set (EpochNumber, KeyHash) -> Set (EpochNumber, KeyHash)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter
((EpochNumber -> EpochNumber -> Bool
forall a. Ord a => a -> a -> Bool
>= EpochNumber
currentEpoch) (EpochNumber -> Bool)
-> ((EpochNumber, KeyHash) -> EpochNumber)
-> (EpochNumber, KeyHash)
-> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (EpochNumber, KeyHash) -> EpochNumber
forall a b. (a, b) -> a
fst)
Set (EpochNumber, KeyHash)
keyEpochs
}