{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Shelley.Spec.Ledger.API.Validation
( ApplyBlock (..),
TickTransitionError (..),
BlockTransitionError (..),
chainChecks,
)
where
import Cardano.Ledger.Core (AnnotatedData, ChainData, SerialisableData)
import Cardano.Ledger.Era (Crypto, Era)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Constraints (ShelleyBased)
import Control.Arrow (left, right)
import Control.Monad.Except
import Control.Monad.Trans.Reader (runReader)
import Control.State.Transition.Extended
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Shelley.Spec.Ledger.API.Protocol (PraosCrypto)
import Shelley.Spec.Ledger.BaseTypes (Globals (..))
import Shelley.Spec.Ledger.BlockChain
import Shelley.Spec.Ledger.LedgerState (NewEpochState)
import qualified Shelley.Spec.Ledger.LedgerState as LedgerState
import qualified Shelley.Spec.Ledger.STS.Bbody as STS
import qualified Shelley.Spec.Ledger.STS.Chain as STS
import qualified Shelley.Spec.Ledger.STS.Tick as STS
import Shelley.Spec.Ledger.Slot (SlotNo)
class
( ChainData (Block era),
AnnotatedData (Block era),
ChainData (BHeader (Crypto era)),
AnnotatedData (BHeader (Crypto era)),
ChainData (NewEpochState era),
SerialisableData (NewEpochState era),
ChainData (BlockTransitionError era),
ChainData (STS.PredicateFailure (STS.CHAIN era))
) =>
ApplyBlock era
where
applyTick ::
Globals ->
NewEpochState era ->
SlotNo ->
NewEpochState era
default applyTick ::
ShelleyBased era =>
Globals ->
NewEpochState era ->
SlotNo ->
NewEpochState era
applyTick Globals
globals NewEpochState era
state SlotNo
hdr =
(([[TickPredicateFailure era]] -> NewEpochState era)
-> (NewEpochState era -> NewEpochState era)
-> Either [[TickPredicateFailure era]] (NewEpochState era)
-> NewEpochState era
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [[TickPredicateFailure era]] -> NewEpochState era
forall a b. Show a => a -> b
err NewEpochState era -> NewEpochState era
forall a. a -> a
id) (Either [[TickPredicateFailure era]] (NewEpochState era)
-> NewEpochState era)
-> (TRC (TICK era)
-> Either [[TickPredicateFailure era]] (NewEpochState era))
-> TRC (TICK era)
-> NewEpochState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reader
Globals (Either [[TickPredicateFailure era]] (NewEpochState era))
-> Globals
-> Either [[TickPredicateFailure era]] (NewEpochState era))
-> Globals
-> Reader
Globals (Either [[TickPredicateFailure era]] (NewEpochState era))
-> Either [[TickPredicateFailure era]] (NewEpochState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
Globals (Either [[TickPredicateFailure era]] (NewEpochState era))
-> Globals
-> Either [[TickPredicateFailure era]] (NewEpochState era)
forall r a. Reader r a -> r -> a
runReader Globals
globals
(Reader
Globals (Either [[TickPredicateFailure era]] (NewEpochState era))
-> Either [[TickPredicateFailure era]] (NewEpochState era))
-> (TRC (TICK era)
-> Reader
Globals (Either [[TickPredicateFailure era]] (NewEpochState era)))
-> TRC (TICK era)
-> Either [[TickPredicateFailure era]] (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s -> m (Either [[PredicateFailure s]] (State s))
forall (m :: * -> *) (rtype :: RuleType).
(STS (TICK era), RuleTypeRep rtype, m ~ BaseM (TICK era)) =>
RuleContext rtype (TICK era)
-> m (Either [[PredicateFailure (TICK era)]] (State (TICK era)))
applySTS @(STS.TICK era)
(TRC (TICK era) -> NewEpochState era)
-> TRC (TICK era) -> NewEpochState era
forall a b. (a -> b) -> a -> b
$ (Environment (TICK era), State (TICK era), Signal (TICK era))
-> TRC (TICK era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (TICK era)
NewEpochState era
state, SlotNo
Signal (TICK era)
hdr)
where
err :: Show a => a -> b
err :: a -> b
err a
msg = [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char] -> b) -> [Char] -> b
forall a b. (a -> b) -> a -> b
$ [Char]
"Panic! applyTick failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (a -> [Char]
forall a. Show a => a -> [Char]
show a
msg)
applyBlock ::
MonadError (BlockTransitionError era) m =>
Globals ->
NewEpochState era ->
Block era ->
m (NewEpochState era)
default applyBlock ::
( STS (STS.BBODY era),
MonadError (BlockTransitionError era) m
) =>
Globals ->
NewEpochState era ->
Block era ->
m (NewEpochState era)
applyBlock Globals
globals NewEpochState era
state Block era
blk =
Either (BlockTransitionError era) (NewEpochState era)
-> m (NewEpochState era)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
(Either (BlockTransitionError era) (NewEpochState era)
-> m (NewEpochState era))
-> (Either [[BbodyPredicateFailure era]] (BbodyState era)
-> Either (BlockTransitionError era) (NewEpochState era))
-> Either [[BbodyPredicateFailure era]] (BbodyState era)
-> m (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BbodyState era -> NewEpochState era)
-> Either (BlockTransitionError era) (BbodyState era)
-> Either (BlockTransitionError era) (NewEpochState era)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right (NewEpochState era -> BbodyState era -> NewEpochState era
forall era.
NewEpochState era -> BbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
state)
(Either (BlockTransitionError era) (BbodyState era)
-> Either (BlockTransitionError era) (NewEpochState era))
-> (Either [[BbodyPredicateFailure era]] (BbodyState era)
-> Either (BlockTransitionError era) (BbodyState era))
-> Either [[BbodyPredicateFailure era]] (BbodyState era)
-> Either (BlockTransitionError era) (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[BbodyPredicateFailure era]] -> BlockTransitionError era)
-> Either [[BbodyPredicateFailure era]] (BbodyState era)
-> Either (BlockTransitionError era) (BbodyState era)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ([BbodyPredicateFailure era] -> BlockTransitionError era
forall era.
[PredicateFailure (BBODY era)] -> BlockTransitionError era
BlockTransitionError ([BbodyPredicateFailure era] -> BlockTransitionError era)
-> ([[BbodyPredicateFailure era]] -> [BbodyPredicateFailure era])
-> [[BbodyPredicateFailure era]]
-> BlockTransitionError era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[BbodyPredicateFailure era]] -> [BbodyPredicateFailure era]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join)
(Either [[BbodyPredicateFailure era]] (BbodyState era)
-> m (NewEpochState era))
-> Either [[BbodyPredicateFailure era]] (BbodyState era)
-> m (NewEpochState era)
forall a b. (a -> b) -> a -> b
$ Either [[BbodyPredicateFailure era]] (BbodyState era)
res
where
res :: Either [[BbodyPredicateFailure era]] (BbodyState era)
res =
(Reader
Globals (Either [[BbodyPredicateFailure era]] (BbodyState era))
-> Globals
-> Either [[BbodyPredicateFailure era]] (BbodyState era))
-> Globals
-> Reader
Globals (Either [[BbodyPredicateFailure era]] (BbodyState era))
-> Either [[BbodyPredicateFailure era]] (BbodyState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
Globals (Either [[BbodyPredicateFailure era]] (BbodyState era))
-> Globals -> Either [[BbodyPredicateFailure era]] (BbodyState era)
forall r a. Reader r a -> r -> a
runReader Globals
globals (Reader
Globals (Either [[BbodyPredicateFailure era]] (BbodyState era))
-> Either [[BbodyPredicateFailure era]] (BbodyState era))
-> (TRC (BBODY era)
-> Reader
Globals (Either [[BbodyPredicateFailure era]] (BbodyState era)))
-> TRC (BBODY era)
-> Either [[BbodyPredicateFailure era]] (BbodyState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s -> m (Either [[PredicateFailure s]] (State s))
forall (m :: * -> *) (rtype :: RuleType).
(STS (BBODY era), RuleTypeRep rtype, m ~ BaseM (BBODY era)) =>
RuleContext rtype (BBODY era)
-> m (Either [[PredicateFailure (BBODY era)]] (State (BBODY era)))
applySTS @(STS.BBODY era) (TRC (BBODY era)
-> Either [[BbodyPredicateFailure era]] (BbodyState era))
-> TRC (BBODY era)
-> Either [[BbodyPredicateFailure era]] (BbodyState era)
forall a b. (a -> b) -> a -> b
$
(Environment (BBODY era), State (BBODY era), Signal (BBODY era))
-> TRC (BBODY era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (NewEpochState era -> BbodyEnv era
forall era. NewEpochState era -> BbodyEnv era
mkBbodyEnv NewEpochState era
state, State (BBODY era)
BbodyState era
bbs, Signal (BBODY era)
Block era
blk)
bbs :: BbodyState era
bbs =
LedgerState era -> BlocksMade (Crypto era) -> BbodyState era
forall era.
LedgerState era -> BlocksMade (Crypto era) -> BbodyState era
STS.BbodyState
(EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
LedgerState.esLState (EpochState era -> LedgerState era)
-> EpochState era -> LedgerState era
forall a b. (a -> b) -> a -> b
$ NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
LedgerState.nesEs NewEpochState era
state)
(NewEpochState era -> BlocksMade (Crypto era)
forall era. NewEpochState era -> BlocksMade (Crypto era)
LedgerState.nesBcur NewEpochState era
state)
reapplyBlock ::
Globals ->
NewEpochState era ->
Block era ->
NewEpochState era
default reapplyBlock ::
STS (STS.BBODY era) =>
Globals ->
NewEpochState era ->
Block era ->
NewEpochState era
reapplyBlock Globals
globals NewEpochState era
state Block era
blk =
NewEpochState era -> BbodyState era -> NewEpochState era
forall era.
NewEpochState era -> BbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
state BbodyState era
res
where
res :: BbodyState era
res =
(Reader Globals (BbodyState era) -> Globals -> BbodyState era)
-> Globals -> Reader Globals (BbodyState era) -> BbodyState era
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader Globals (BbodyState era) -> Globals -> BbodyState era
forall r a. Reader r a -> r -> a
runReader Globals
globals (Reader Globals (BbodyState era) -> BbodyState era)
-> (TRC (BBODY era) -> Reader Globals (BbodyState era))
-> TRC (BBODY era)
-> BbodyState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s -> m (State s)
forall (m :: * -> *) (rtype :: RuleType).
(STS (BBODY era), RuleTypeRep rtype, m ~ BaseM (BBODY era)) =>
RuleContext rtype (BBODY era) -> m (State (BBODY era))
reapplySTS @(STS.BBODY era) (TRC (BBODY era) -> BbodyState era)
-> TRC (BBODY era) -> BbodyState era
forall a b. (a -> b) -> a -> b
$
(Environment (BBODY era), State (BBODY era), Signal (BBODY era))
-> TRC (BBODY era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (NewEpochState era -> BbodyEnv era
forall era. NewEpochState era -> BbodyEnv era
mkBbodyEnv NewEpochState era
state, State (BBODY era)
BbodyState era
bbs, Signal (BBODY era)
Block era
blk)
bbs :: BbodyState era
bbs =
LedgerState era -> BlocksMade (Crypto era) -> BbodyState era
forall era.
LedgerState era -> BlocksMade (Crypto era) -> BbodyState era
STS.BbodyState
(EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
LedgerState.esLState (EpochState era -> LedgerState era)
-> EpochState era -> LedgerState era
forall a b. (a -> b) -> a -> b
$ NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
LedgerState.nesEs NewEpochState era
state)
(NewEpochState era -> BlocksMade (Crypto era)
forall era. NewEpochState era -> BlocksMade (Crypto era)
LedgerState.nesBcur NewEpochState era
state)
instance PraosCrypto crypto => ApplyBlock (ShelleyEra crypto)
chainChecks ::
forall era m.
( Era era,
MonadError (STS.PredicateFailure (STS.CHAIN era)) m
) =>
Globals ->
STS.ChainChecksData ->
BHeader (Crypto era) ->
m ()
chainChecks :: Globals -> ChainChecksData -> BHeader (Crypto era) -> m ()
chainChecks Globals
globals ChainChecksData
ccd BHeader (Crypto era)
bh = Natural -> ChainChecksData -> BHeader (Crypto era) -> m ()
forall era (m :: * -> *).
(Era era, MonadError (PredicateFailure (CHAIN era)) m) =>
Natural -> ChainChecksData -> BHeader (Crypto era) -> m ()
STS.chainChecks (Globals -> Natural
maxMajorPV Globals
globals) ChainChecksData
ccd BHeader (Crypto era)
bh
mkBbodyEnv ::
NewEpochState era ->
STS.BbodyEnv era
mkBbodyEnv :: NewEpochState era -> BbodyEnv era
mkBbodyEnv
LedgerState.NewEpochState
{ EpochState era
nesEs :: EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
LedgerState.nesEs
} =
BbodyEnv :: forall era. PParams era -> AccountState -> BbodyEnv era
STS.BbodyEnv
{ bbodyPp :: PParams era
STS.bbodyPp = EpochState era -> PParams era
forall era. EpochState era -> PParams era
LedgerState.esPp EpochState era
nesEs,
bbodyAccount :: AccountState
STS.bbodyAccount = EpochState era -> AccountState
forall era. EpochState era -> AccountState
LedgerState.esAccountState EpochState era
nesEs
}
updateNewEpochState ::
NewEpochState era ->
STS.BbodyState era ->
NewEpochState era
updateNewEpochState :: NewEpochState era -> BbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
ss (STS.BbodyState LedgerState era
ls BlocksMade (Crypto era)
bcur) =
NewEpochState era
-> BlocksMade (Crypto era) -> LedgerState era -> NewEpochState era
forall era.
NewEpochState era
-> BlocksMade (Crypto era) -> LedgerState era -> NewEpochState era
LedgerState.updateNES NewEpochState era
ss BlocksMade (Crypto era)
bcur LedgerState era
ls
newtype TickTransitionError era
= TickTransitionError [STS.PredicateFailure (STS.TICK era)]
deriving ((forall x.
TickTransitionError era -> Rep (TickTransitionError era) x)
-> (forall x.
Rep (TickTransitionError era) x -> TickTransitionError era)
-> Generic (TickTransitionError era)
forall x.
Rep (TickTransitionError era) x -> TickTransitionError era
forall x.
TickTransitionError era -> Rep (TickTransitionError era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (TickTransitionError era) x -> TickTransitionError era
forall era x.
TickTransitionError era -> Rep (TickTransitionError era) x
$cto :: forall era x.
Rep (TickTransitionError era) x -> TickTransitionError era
$cfrom :: forall era x.
TickTransitionError era -> Rep (TickTransitionError era) x
Generic)
instance
(NoThunks (STS.PredicateFailure (STS.TICK era))) =>
NoThunks (TickTransitionError era)
deriving stock instance
(Eq (STS.PredicateFailure (STS.TICK era))) =>
Eq (TickTransitionError era)
deriving stock instance
(Show (STS.PredicateFailure (STS.TICK era))) =>
Show (TickTransitionError era)
newtype BlockTransitionError era
= BlockTransitionError [STS.PredicateFailure (STS.BBODY era)]
deriving ((forall x.
BlockTransitionError era -> Rep (BlockTransitionError era) x)
-> (forall x.
Rep (BlockTransitionError era) x -> BlockTransitionError era)
-> Generic (BlockTransitionError era)
forall x.
Rep (BlockTransitionError era) x -> BlockTransitionError era
forall x.
BlockTransitionError era -> Rep (BlockTransitionError era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (BlockTransitionError era) x -> BlockTransitionError era
forall era x.
BlockTransitionError era -> Rep (BlockTransitionError era) x
$cto :: forall era x.
Rep (BlockTransitionError era) x -> BlockTransitionError era
$cfrom :: forall era x.
BlockTransitionError era -> Rep (BlockTransitionError era) x
Generic)
deriving stock instance
(Eq (STS.PredicateFailure (STS.BBODY era))) =>
Eq (BlockTransitionError era)
deriving stock instance
(Show (STS.PredicateFailure (STS.BBODY era))) =>
Show (BlockTransitionError era)
instance
(NoThunks (STS.PredicateFailure (STS.BBODY era))) =>
NoThunks (BlockTransitionError era)