{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Cardano.Ledger.Shelley.API.Validation (
ApplyBlock (..),
applyBlock,
applyTick,
TickTransitionError (..),
BlockTransitionError (..),
chainChecks,
)
where
import Cardano.Ledger.BHeaderView (BHeaderView)
import Cardano.Ledger.BaseTypes (Globals (..), ShelleyBase, Version)
import Cardano.Ledger.Binary (EncCBORGroup)
import Cardano.Ledger.Block (Block)
import qualified Cardano.Ledger.Chain as STS
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.Keys (DSignable, Hash)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Core (EraGov)
import Cardano.Ledger.Shelley.LedgerState (LedgerState (..), NewEpochState, curPParamsEpochStateL)
import qualified Cardano.Ledger.Shelley.LedgerState as LedgerState
import Cardano.Ledger.Shelley.PParams ()
import Cardano.Ledger.Shelley.Rules ()
import qualified Cardano.Ledger.Shelley.Rules as STS
import Cardano.Ledger.Slot (SlotNo)
import Control.Arrow (left, right)
import Control.Monad.Except
import Control.Monad.Trans.Reader (runReader)
import Control.State.Transition.Extended
import Data.List.NonEmpty (NonEmpty)
import GHC.Generics (Generic)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks (..))
class
( STS (EraRule "TICK" era)
, BaseM (EraRule "TICK" era) ~ ShelleyBase
, Environment (EraRule "TICK" era) ~ ()
, State (EraRule "TICK" era) ~ NewEpochState era
, Signal (EraRule "TICK" era) ~ SlotNo
, STS (EraRule "BBODY" era)
, BaseM (EraRule "BBODY" era) ~ ShelleyBase
, Environment (EraRule "BBODY" era) ~ STS.BbodyEnv era
, State (EraRule "BBODY" era) ~ STS.ShelleyBbodyState era
, Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era
, EncCBORGroup (TxSeq era)
, State (EraRule "LEDGERS" era) ~ LedgerState era
) =>
ApplyBlock era
where
applyTickOpts ::
ApplySTSOpts ep ->
Globals ->
NewEpochState era ->
SlotNo ->
EventReturnType ep (EraRule "TICK" era) (NewEpochState era)
applyTickOpts ApplySTSOpts ep
opts Globals
globals NewEpochState era
state SlotNo
hdr =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a b. Show a => a -> b
err forall a. a -> a
id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Globals
globals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType) (ep :: EventPolicy).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
ApplySTSOpts ep
-> RuleContext rtype s
-> m (Either
(NonEmpty (PredicateFailure s)) (EventReturnType ep s (State s)))
applySTSOptsEither @(EraRule "TICK" era) ApplySTSOpts ep
opts
forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), NewEpochState era
state, SlotNo
hdr)
where
err :: Show a => a -> b
err :: forall a b. Show a => a -> b
err a
msg = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Panic! applyTick failed: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show a
msg
applyBlockOpts ::
forall ep m.
(EventReturnTypeRep ep, MonadError (BlockTransitionError era) m) =>
ApplySTSOpts ep ->
Globals ->
NewEpochState era ->
Block (BHeaderView (EraCrypto era)) era ->
m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
default applyBlockOpts ::
forall ep m.
(EventReturnTypeRep ep, MonadError (BlockTransitionError era) m, EraGov era) =>
ApplySTSOpts ep ->
Globals ->
NewEpochState era ->
Block (BHeaderView (EraCrypto era)) era ->
m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
applyBlockOpts ApplySTSOpts ep
opts Globals
globals NewEpochState era
state Block (BHeaderView (EraCrypto era)) era
blk =
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left forall era.
NonEmpty (PredicateFailure (EraRule "BBODY" era))
-> BlockTransitionError era
BlockTransitionError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right
( forall (ep :: EventPolicy) sts a b.
EventReturnTypeRep ep =>
(a -> b) -> EventReturnType ep sts a -> EventReturnType ep sts b
mapEventReturn @ep @(EraRule "BBODY" era) forall a b. (a -> b) -> a -> b
$
forall era.
(LedgerState era ~ State (EraRule "LEDGERS" era), EraGov era) =>
NewEpochState era -> ShelleyBbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
state
)
forall a b. (a -> b) -> a -> b
$ Either
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
(EventReturnType ep (EraRule "BBODY" era) (ShelleyBbodyState era))
res
where
res :: Either
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
(EventReturnType ep (EraRule "BBODY" era) (ShelleyBbodyState era))
res =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Globals
globals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType) (ep :: EventPolicy).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
ApplySTSOpts ep
-> RuleContext rtype s
-> m (Either
(NonEmpty (PredicateFailure s)) (EventReturnType ep s (State s)))
applySTSOptsEither @(EraRule "BBODY" era)
ApplySTSOpts ep
opts
forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (forall era. EraGov era => NewEpochState era -> BbodyEnv era
mkBbodyEnv NewEpochState era
state, ShelleyBbodyState era
bbs, Block (BHeaderView (EraCrypto era)) era
blk)
bbs :: ShelleyBbodyState era
bbs =
forall era.
State (EraRule "LEDGERS" era)
-> BlocksMade (EraCrypto era) -> ShelleyBbodyState era
STS.BbodyState
(forall era. EpochState era -> LedgerState era
LedgerState.esLState forall a b. (a -> b) -> a -> b
$ forall era. NewEpochState era -> EpochState era
LedgerState.nesEs NewEpochState era
state)
(forall era. NewEpochState era -> BlocksMade (EraCrypto era)
LedgerState.nesBcur NewEpochState era
state)
reapplyBlock ::
Globals ->
NewEpochState era ->
Block (BHeaderView (EraCrypto era)) era ->
NewEpochState era
default reapplyBlock ::
EraGov era =>
Globals ->
NewEpochState era ->
Block (BHeaderView (EraCrypto era)) era ->
NewEpochState era
reapplyBlock Globals
globals NewEpochState era
state Block (BHeaderView (EraCrypto era)) era
blk =
forall era.
(LedgerState era ~ State (EraRule "LEDGERS" era), EraGov era) =>
NewEpochState era -> ShelleyBbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
state ShelleyBbodyState era
res
where
res :: ShelleyBbodyState era
res =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Globals
globals 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)
reapplySTS @(EraRule "BBODY" era) forall a b. (a -> b) -> a -> b
$
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (forall era. EraGov era => NewEpochState era -> BbodyEnv era
mkBbodyEnv NewEpochState era
state, ShelleyBbodyState era
bbs, Block (BHeaderView (EraCrypto era)) era
blk)
bbs :: ShelleyBbodyState era
bbs =
forall era.
State (EraRule "LEDGERS" era)
-> BlocksMade (EraCrypto era) -> ShelleyBbodyState era
STS.BbodyState
(forall era. EpochState era -> LedgerState era
LedgerState.esLState forall a b. (a -> b) -> a -> b
$ forall era. NewEpochState era -> EpochState era
LedgerState.nesEs NewEpochState era
state)
(forall era. NewEpochState era -> BlocksMade (EraCrypto era)
LedgerState.nesBcur NewEpochState era
state)
applyTick ::
ApplyBlock era =>
Globals ->
NewEpochState era ->
SlotNo ->
NewEpochState era
applyTick :: forall era.
ApplyBlock era =>
Globals -> NewEpochState era -> SlotNo -> NewEpochState era
applyTick =
forall era (ep :: EventPolicy).
ApplyBlock era =>
ApplySTSOpts ep
-> Globals
-> NewEpochState era
-> SlotNo
-> EventReturnType ep (EraRule "TICK" era) (NewEpochState era)
applyTickOpts forall a b. (a -> b) -> a -> b
$
ApplySTSOpts
{ asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
globalAssertionPolicy
, asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
ValidateAll
, asoEvents :: SingEP 'EventPolicyDiscard
asoEvents = SingEP 'EventPolicyDiscard
EPDiscard
}
applyBlock ::
( ApplyBlock era
, MonadError (BlockTransitionError era) m
) =>
Globals ->
NewEpochState era ->
Block (BHeaderView (EraCrypto era)) era ->
m (NewEpochState era)
applyBlock :: forall era (m :: * -> *).
(ApplyBlock era, MonadError (BlockTransitionError era) m) =>
Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> m (NewEpochState era)
applyBlock =
forall era (ep :: EventPolicy) (m :: * -> *).
(ApplyBlock era, EventReturnTypeRep ep,
MonadError (BlockTransitionError era) m) =>
ApplySTSOpts ep
-> Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
applyBlockOpts forall a b. (a -> b) -> a -> b
$
ApplySTSOpts
{ asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
globalAssertionPolicy
, asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
ValidateAll
, asoEvents :: SingEP 'EventPolicyDiscard
asoEvents = SingEP 'EventPolicyDiscard
EPDiscard
}
instance
( Crypto c
, DSignable c (Hash c EraIndependentTxBody)
) =>
ApplyBlock (ShelleyEra c)
chainChecks ::
forall c m.
MonadError STS.ChainPredicateFailure m =>
Version ->
STS.ChainChecksPParams ->
BHeaderView c ->
m ()
chainChecks :: forall c (m :: * -> *).
MonadError ChainPredicateFailure m =>
Version -> ChainChecksPParams -> BHeaderView c -> m ()
chainChecks = forall (m :: * -> *) c.
MonadError ChainPredicateFailure m =>
Version -> ChainChecksPParams -> BHeaderView c -> m ()
STS.chainChecks
mkBbodyEnv ::
EraGov era =>
NewEpochState era ->
STS.BbodyEnv era
mkBbodyEnv :: forall era. EraGov era => NewEpochState era -> BbodyEnv era
mkBbodyEnv
LedgerState.NewEpochState
{ EpochState era
nesEs :: EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
LedgerState.nesEs
} =
STS.BbodyEnv
{ bbodyPp :: PParams era
STS.bbodyPp = EpochState era
nesEs forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
, bbodyAccount :: AccountState
STS.bbodyAccount = forall era. EpochState era -> AccountState
LedgerState.esAccountState EpochState era
nesEs
}
updateNewEpochState ::
(LedgerState era ~ State (EraRule "LEDGERS" era), EraGov era) =>
NewEpochState era ->
STS.ShelleyBbodyState era ->
NewEpochState era
updateNewEpochState :: forall era.
(LedgerState era ~ State (EraRule "LEDGERS" era), EraGov era) =>
NewEpochState era -> ShelleyBbodyState era -> NewEpochState era
updateNewEpochState NewEpochState era
ss (STS.BbodyState State (EraRule "LEDGERS" era)
ls BlocksMade (EraCrypto era)
bcur) =
forall era.
EraGov era =>
NewEpochState era
-> BlocksMade (EraCrypto era)
-> LedgerState era
-> NewEpochState era
LedgerState.updateNES NewEpochState era
ss BlocksMade (EraCrypto era)
bcur State (EraRule "LEDGERS" era)
ls
newtype TickTransitionError era
= TickTransitionError (NonEmpty (STS.PredicateFailure (EraRule "TICK" era)))
deriving (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 (EraRule "TICK" era)) =>
NoThunks (TickTransitionError era)
deriving stock instance
Eq (STS.PredicateFailure (EraRule "TICK" era)) =>
Eq (TickTransitionError era)
deriving stock instance
Show (STS.PredicateFailure (EraRule "TICK" era)) =>
Show (TickTransitionError era)
newtype BlockTransitionError era
= BlockTransitionError (NonEmpty (STS.PredicateFailure (EraRule "BBODY" era)))
deriving (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 (EraRule "BBODY" era)) =>
Eq (BlockTransitionError era)
deriving stock instance
Show (STS.PredicateFailure (EraRule "BBODY" era)) =>
Show (BlockTransitionError era)
instance
NoThunks (STS.PredicateFailure (EraRule "BBODY" era)) =>
NoThunks (BlockTransitionError era)