{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Cardano.Chain.Delegation.Validation.Interface
  ( -- * Blockchain Interface
    Environment (..),
    State (..),
    activateDelegations,
    delegates,
    delegationMap,
    initialState,
    tickDelegation,
    updateDelegation,
  )
where

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)
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 (..))

--------------------------------------------------------------------------------
-- Blockchain Interface
--------------------------------------------------------------------------------

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)

-- | State shared between the blockchain and the ledger
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

-- | The initial state maps each genesis key to itself and overrides this using
--   certificates from the genesis block.
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
    -- We modify the environment here to allow the delegation certificates to
    -- be applied immediately. Since the environment is not propagated, this
    -- should be harmless.
    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
        }

-- | Check whether a delegation is valid in the 'State'
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

-- | Update the 'State' with a list of new 'Certificate's
--
--   This corresponds to the `DELEG` rule from the Byron ledger specification
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
  -- Schedule new certificates
  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
        }

-- | Perform delegation update without adding certificates
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'}

-- | Activate certificates up to this slot
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'}

-- | Remove stale values from 'Scheduling.State'
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
        }