{-# 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.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)


--------------------------------------------------------------------------------
-- 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
        }