{-# 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.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.Ledger.Binary (
  Annotated (..),
  DecCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  byronProtVer,
  encodeListLen,
  enforceSize,
  fromByronCBOR,
  serialize',
  toByronCBOR,
 )
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
$c== :: Environment -> Environment -> Bool
== :: Environment -> Environment -> Bool
$c/= :: Environment -> Environment -> Bool
/= :: 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
$cshowsPrec :: Int -> Environment -> ShowS
showsPrec :: Int -> Environment -> ShowS
$cshow :: Environment -> String
show :: Environment -> String
$cshowList :: [Environment] -> ShowS
showList :: [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
$cfrom :: forall x. Environment -> Rep Environment x
from :: forall x. Environment -> Rep Environment x
$cto :: forall x. Rep Environment x -> Environment
to :: forall x. Rep Environment x -> Environment
Generic, Environment -> ()
(Environment -> ()) -> NFData Environment
forall a. (a -> ()) -> NFData a
$crnf :: Environment -> ()
rnf :: 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
$c== :: State -> State -> Bool
== :: State -> State -> Bool
$c/= :: State -> State -> Bool
/= :: 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
$cshowsPrec :: Int -> State -> ShowS
showsPrec :: Int -> State -> ShowS
$cshow :: State -> String
show :: State -> String
$cshowList :: [State] -> ShowS
showList :: [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
$cfrom :: forall x. State -> Rep State x
from :: forall x. State -> Rep State x
$cto :: forall x. Rep State x -> State
to :: forall x. Rep State x -> State
Generic, State -> ()
(State -> ()) -> NFData State
forall a. (a -> ()) -> NFData a
$crnf :: State -> ()
rnf :: 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
$cnoThunks :: Context -> State -> IO (Maybe ThunkInfo)
noThunks :: Context -> State -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> State -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> State -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy State -> String
showTypeOf :: Proxy State -> String
NoThunks)

instance ToCBOR State where
  toCBOR :: State -> Encoding
toCBOR = State -> Encoding
forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR State where
  fromCBOR :: forall s. Decoder s State
fromCBOR = Decoder s State
forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance DecCBOR State where
  decCBOR :: forall s. Decoder s State
decCBOR = 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 s. Decoder s State
forall a s. DecCBOR a => Decoder s a
decCBOR
      Decoder s (State -> State) -> Decoder s State -> Decoder s State
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 State
forall s. Decoder s State
forall a s. DecCBOR a => Decoder s a
decCBOR

instance EncCBOR State where
  encCBOR :: State -> Encoding
encCBOR State
s =
    Word -> Encoding
encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> State -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (State -> State
schedulingState State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> State -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (State -> State
activationState State
s)

delegationMap :: State -> Delegation.Map
delegationMap :: State -> Map
delegationMap = State -> Map
Activation.delegationMap (State -> Map) -> (State -> State) -> State -> Map
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 :: forall (m :: * -> *).
MonadError Error m =>
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 :: Environment -> Set KeyHash
allowedDelegators :: 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 0}

    is :: State
is =
      State
        { schedulingState :: State
schedulingState =
            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 =
            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 a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set KeyHash
allowedDelegators) (Set KeyHash -> [KeyHash]
forall a. Set a -> [a]
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 a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set KeyHash
allowedDelegators
              }
        }

    certificates :: [ACertificate ByteString]
certificates =
      (Certificate -> ACertificate ByteString)
-> [Certificate] -> [ACertificate ByteString]
forall a b. (a -> b) -> [a] -> [b]
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 b c a. (b -> c) -> (a -> b) -> a -> c
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
        { Delegation.aEpoch =
            Annotated
              (Delegation.epoch c)
              (serialize' byronProtVer $ Delegation.epoch c)
        , Delegation.annotation = serialize' byronProtVer 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 :: forall (m :: * -> *).
MonadError Error m =>
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 a. a -> m a
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 = ss'}
  where
    Environment {Annotated ProtocolMagicId ByteString
protocolMagic :: Environment -> Annotated ProtocolMagicId ByteString
protocolMagic :: Annotated ProtocolMagicId ByteString
protocolMagic, Set KeyHash
allowedDelegators :: Environment -> Set KeyHash
allowedDelegators :: Set KeyHash
allowedDelegators, BlockCount
k :: Environment -> BlockCount
k :: BlockCount
k, EpochNumber
currentEpoch :: Environment -> EpochNumber
currentEpoch :: EpochNumber
currentEpoch, SlotNumber
currentSlot :: Environment -> SlotNumber
currentSlot :: SlotNumber
currentSlot} =
      Environment
env

    schedulingEnv :: Environment
schedulingEnv =
      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 b c a. (b -> c) -> (a -> b) -> a -> c
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 = 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 b a. (b -> a -> b) -> b -> Seq a -> b
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 b c a. (b -> c) -> (a -> b) -> a -> c
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 = 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 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 b c a. (b -> c) -> (a -> b) -> a -> c
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 b c a. (b -> c) -> (a -> b) -> a -> c
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
        }