{-# 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
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
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. 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 -> ()
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
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
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. 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 -> ()
forall a. (a -> ()) -> NFData a
rnf :: State -> ()
$crnf :: State -> ()
NFData, Context -> State -> IO (Maybe ThunkInfo)
Proxy State -> String
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 ToCBOR State where
  toCBOR :: State -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

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

instance DecCBOR State where
  decCBOR :: forall s. Decoder s State
decCBOR = do
    forall s. Text -> Int -> Decoder s ()
enforceSize Text
"State" Int
2
    State -> State -> State
State
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR

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

delegationMap :: State -> Delegation.Map
delegationMap :: State -> Map
delegationMap = State -> Map
Activation.delegationMap 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 = 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
        { schedulingState :: State
schedulingState =
            Scheduling.State
              { scheduledDelegations :: Seq ScheduledDelegation
Scheduling.scheduledDelegations = forall a. Monoid a => a
mempty
              , keyEpochDelegations :: Set (EpochNumber, KeyHash)
Scheduling.keyEpochDelegations = forall a. Monoid a => a
mempty
              }
        , activationState :: State
activationState =
            Activation.State
              { delegationMap :: Map
Activation.delegationMap =
                  [(KeyHash, KeyHash)] -> Map
Delegation.fromList
                    forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set KeyHash
allowedDelegators) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set KeyHash
allowedDelegators)
              , delegationSlots :: Map KeyHash SlotNumber
Activation.delegationSlots =
                  forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                    forall a b. (a -> b) -> a -> b
$ (,Word64 -> SlotNumber
SlotNumber Word64
0)
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set KeyHash
allowedDelegators
              }
        }

    certificates :: [ACertificate ByteString]
certificates =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Certificate -> ACertificate ByteString
annotateCertificate forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k a. Map k a -> [a]
M.elems 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 =
            forall b a. b -> a -> Annotated b a
Annotated
              (forall a. ACertificate a -> EpochNumber
Delegation.epoch Certificate
c)
              (forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer forall a b. (a -> b) -> a -> b
$ forall a. ACertificate a -> EpochNumber
Delegation.epoch Certificate
c)
        , annotation :: ByteString
Delegation.annotation = forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer 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 :: 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' <-
    forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
      (forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> ACertificate ByteString -> m State
Scheduling.scheduleCertificate Environment
schedulingEnv)
      (State -> State
schedulingState State
is)
      [ACertificate ByteString]
certificates

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    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 =
      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 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' =
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
          State -> ScheduledDelegation -> State
Activation.activateDelegation
          State
as
          (forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter ((forall a. Ord a => a -> a -> Bool
<= SlotNumber
currentSlot) 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 Scheduling.State
        { scheduledDelegations :: Seq ScheduledDelegation
Scheduling.scheduledDelegations =
            forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter
              ((SlotNumber
currentSlot forall a. Num a => a -> a -> a
+ SlotNumber
1 forall a. Ord a => a -> a -> 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 =
            forall a. (a -> Bool) -> Set a -> Set a
Set.filter
              ((forall a. Ord a => a -> a -> Bool
>= EpochNumber
currentEpoch) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (a, b) -> a
fst)
              Set (EpochNumber, KeyHash)
keyEpochs
        }