diff --git a/shelley/chain-and-ledger/executable-spec/delegation.cabal b/shelley/chain-and-ledger/executable-spec/delegation.cabal index c5467cb87b4..4d228097631 100644 --- a/shelley/chain-and-ledger/executable-spec/delegation.cabal +++ b/shelley/chain-and-ledger/executable-spec/delegation.cabal @@ -86,6 +86,7 @@ library small-steps, microlens, microlens-th, + monad-stm, mtl, non-integer, stm, diff --git a/shelley/chain-and-ledger/executable-spec/src/BaseTypes.hs b/shelley/chain-and-ledger/executable-spec/src/BaseTypes.hs index cb984258dfd..b499c063d5a 100644 --- a/shelley/chain-and-ledger/executable-spec/src/BaseTypes.hs +++ b/shelley/chain-and-ledger/executable-spec/src/BaseTypes.hs @@ -123,7 +123,7 @@ infix 1 ==> -------------------------------------------------------------------------------- data Globals = Globals - { epochInfo :: EpochInfo ShelleyBase + { epochInfo :: EpochInfo STM , slotsPerKESPeriod :: Word64 } diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/API/Mempool.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/API/Mempool.hs index caf90256e05..ee31b378fe9 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/API/Mempool.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/API/Mempool.hs @@ -15,12 +15,15 @@ module Cardano.Ledger.Shelley.API.Mempool ) where +import BaseTypes (Globals) import qualified Cardano.Crypto.DSIGN as DSIGN import Cardano.Ledger.Shelley.API.Validation import Cardano.Ledger.Shelley.Crypto import Control.Arrow (left) import Control.Monad.Except -import Control.State.Transition (PredicateFailure, TRC (..), applySTS) +import Control.Monad.Reader.Class +import Control.Monad.STM.Class +import Control.State.Transition.Extended (PredicateFailure, TRC (..), applySTS) import Data.Sequence (Seq) import qualified LedgerState import STS.Ledgers (LEDGERS) @@ -78,14 +81,18 @@ applyTxs :: forall crypto m. ( Crypto crypto, MonadError (ApplyTxError crypto) m, - DSIGN.Signable (DSIGN crypto) (Tx.TxBody crypto) + DSIGN.Signable (DSIGN crypto) (Tx.TxBody crypto), + MonadReader Globals m, + MonadSTM m ) => MempoolEnv -> MempoolState crypto -> Seq (Tx crypto) -> m (MempoolState crypto) -applyTxs env state txs = +applyTxs env state txs = do + res <- + liftShelleyBase . applySTS @(LEDGERS crypto) $ + TRC (env, state, txs) liftEither . left (ApplyTxError . join) - . applySTS @(LEDGERS crypto) - $ TRC (env, state, txs) + $ res diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/API/Protocol.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/API/Protocol.hs index 00ed49d6d9d..73e5591574c 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/API/Protocol.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/API/Protocol.hs @@ -19,11 +19,14 @@ module Cardano.Ledger.Shelley.API.Protocol ) where +import BaseTypes (Globals (epochInfo)) import Cardano.Ledger.Shelley.API.Validation import Cardano.Ledger.Shelley.Crypto import Control.Arrow (left, right) import Control.Monad.Except -import Control.State.Transition (PredicateFailure, TRC (..), applySTS) +import Control.Monad.Reader.Class +import Control.Monad.STM.Class +import Control.State.Transition.Extended (PredicateFailure, TRC (..), applySTS) import Data.Map.Strict (Map) import Delegation.Certificates (PoolDistr) import GHC.Generics (Generic) @@ -40,7 +43,8 @@ import LedgerState import PParams (PParams) import STS.NewEpoch (NEWEPOCH) import qualified STS.Prtcl -import Slot (SlotNo, epochFromSlotNo) +import Slot (SlotNo) +import Cardano.Slotting.EpochInfo (epochInfoEpoch) -- | Data required by the Transitional Praos protocol from the Shelley ledger. data LedgerView crypto @@ -291,17 +295,25 @@ newtype FutureLedgerViewError crypto futureLedgerView :: forall crypto m. ( Crypto crypto, - MonadError (FutureLedgerViewError crypto) m + MonadError (FutureLedgerViewError crypto) m, + MonadReader Globals m, + MonadSTM m ) => ShelleyState crypto -> SlotNo -> m (LedgerView crypto) -futureLedgerView ss slot = +futureLedgerView ss slot = do + epoch <- do + ei <- asks epochInfo + liftSTM $ epochInfoEpoch ei slot + res <- + liftShelleyBase . + applySTS @(NEWEPOCH crypto) + $ TRC (mkNewEpochEnv, ss, epoch) liftEither . right view . left (FutureLedgerViewError . join) - . applySTS @(NEWEPOCH crypto) - $ TRC (mkNewEpochEnv, ss, epochFromSlotNo slot) + $ res where mkNewEpochEnv = NewEpochEnv diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/API/Validation.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/API/Validation.hs index 83260bdfe45..0b0eed68c67 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/API/Validation.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley/API/Validation.hs @@ -9,14 +9,19 @@ module Cardano.Ledger.Shelley.API.Validation ( ShelleyState, applyHeaderTransition, applyBlockTransition, + liftShelleyBase, ) where +import BaseTypes (Globals, ShelleyBase) import BlockChain import qualified Cardano.Crypto.DSIGN as DSIGN import Cardano.Ledger.Shelley.Crypto import Control.Arrow (left, right) import Control.Monad.Except +import Control.Monad.Reader.Class +import Control.Monad.Trans.Reader (runReaderT) +import Control.Monad.STM.Class import Control.State.Transition.Extended (TRC (..), applySTS) import Ledger.Core (Relation (..)) import qualified LedgerState @@ -27,6 +32,14 @@ import qualified TxData as Tx -- | Type alias for the state updated by BHEAD and BBODY rules type ShelleyState = LedgerState.NewEpochState +liftShelleyBase :: + (MonadReader Globals m, MonadSTM m) => + ShelleyBase a -> + m a +liftShelleyBase act = do + globs <- ask + liftSTM $ runReaderT act globs + {------------------------------------------------------------------------------- Applying blocks -------------------------------------------------------------------------------} @@ -63,16 +76,20 @@ newtype HeaderTransitionError crypto applyHeaderTransition :: forall crypto m. ( Crypto crypto, - MonadError (HeaderTransitionError crypto) m + MonadError (HeaderTransitionError crypto) m, + MonadReader Globals m, + MonadSTM m ) => ShelleyState crypto -> BHeader crypto -> m (ShelleyState crypto) -applyHeaderTransition state hdr = +applyHeaderTransition state hdr = do + res <- + liftShelleyBase . applySTS @(STS.BHEAD crypto) $ + TRC (mkBheadEnv state, state, hdr) liftEither . left (HeaderTransitionError . join) - . applySTS @(STS.BHEAD crypto) - $ TRC (mkBheadEnv state, state, hdr) + $ res newtype BlockTransitionError crypto = BlockTransitionError [STS.PredicateFailure (STS.BBODY crypto)] @@ -83,17 +100,21 @@ applyBlockTransition :: forall crypto m. ( Crypto crypto, MonadError (BlockTransitionError crypto) m, + MonadReader Globals m, + MonadSTM m, DSIGN.Signable (DSIGN crypto) (Tx.TxBody crypto) ) => ShelleyState crypto -> Block crypto -> m (ShelleyState crypto) -applyBlockTransition state blk = +applyBlockTransition state blk = do + res <- + liftShelleyBase . applySTS @(STS.BBODY crypto) $ + TRC (mkBbodyEnv state, bbs, blk) liftEither . right (updateShelleyState state) . left (BlockTransitionError . join) - . applySTS @(STS.BBODY crypto) - $ TRC (mkBbodyEnv state, bbs, blk) + $ res where updateShelleyState :: ShelleyState crypto -> diff --git a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs index c5b791d1ec9..a1bff807630 100644 --- a/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/LedgerState.hs @@ -120,7 +120,7 @@ import Lens.Micro.TH (makeLenses) import Numeric.Natural (Natural) import PParams (PParams (..), activeSlotCoeff, d, emptyPParams, keyDecayRate, keyDeposit, keyMinRefund, minfeeA, minfeeB) -import Slot (Duration (..), EpochNo (..), SlotNo (..), (+*), (-*)) +import Slot (Duration (..), EpochNo (..), SlotNo (..), (+*), (-*), epochInfoFirst, epochInfoSize, epochInfoEpoch) import Tx (extractKeyHash) import TxData (Addr (..), Credential (..), Ix, PoolParams, Ptr (..), RewardAcnt (..), StakeCredential, Tx (..), TxBody (..), TxId (..), TxIn (..), TxOut (..), body, @@ -136,7 +136,6 @@ import Delegation.Certificates (DCert (..), PoolDistr (..), StakeCreds import Delegation.PoolParams (poolSpec) import BaseTypes (ShelleyBase, Globals(..), UnitInterval, intervalValue, mkUnitInterval) -import Cardano.Slotting.EpochInfo import Ledger.Core (dom, (∪), (∪+), (⋪), (▷), (◁)) -- | Representation of a list of pairs of key pairs, e.g., pay and stake keys diff --git a/shelley/chain-and-ledger/executable-spec/src/Slot.hs b/shelley/chain-and-ledger/executable-spec/src/Slot.hs index 3fc7f3752e9..b9ea2754f79 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Slot.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Slot.hs @@ -10,21 +10,28 @@ module Slot , (+*) , (*-) , EpochNo(..) - , EpochInfo(..) + , EpochSize(..) + , EpochInfo -- conversion between Byron / Shelley , slotByronToShelley , slotShelleyToByron -- Block number , BlockNo(..) + , epochInfoEpoch + , epochInfoFirst + , epochInfoSize ) where +import BaseTypes ( ShelleyBase ) import Data.Word ( Word64 ) import Cardano.Prelude ( NoUnexpectedThunks(..) ) import Cardano.Slotting.Block ( BlockNo(..) ) -import Cardano.Slotting.Slot ( SlotNo(..), EpochNo(..) ) -import Cardano.Slotting.EpochInfo ( EpochInfo(..)) - +import Cardano.Slotting.Slot ( SlotNo(..), EpochNo(..), EpochSize(..) ) +import Cardano.Slotting.EpochInfo ( EpochInfo ) +import qualified Cardano.Slotting.EpochInfo as EI +import Control.Monad.STM +import Control.Monad.Trans (lift) import qualified Ledger.Core as Byron ( Slot(..) ) @@ -54,3 +61,12 @@ slotByronToShelley (Byron.Slot s) = SlotNo s slotShelleyToByron :: SlotNo -> Byron.Slot slotShelleyToByron (SlotNo s) = Byron.Slot s + +epochInfoEpoch :: EpochInfo STM -> SlotNo -> ShelleyBase EpochNo +epochInfoEpoch ei = lift . EI.epochInfoEpoch ei + +epochInfoFirst :: EpochInfo STM -> EpochNo -> ShelleyBase SlotNo +epochInfoFirst ei = lift . EI.epochInfoFirst ei + +epochInfoSize :: EpochInfo STM -> EpochNo -> ShelleyBase EpochSize +epochInfoSize ei = lift . EI.epochInfoSize ei diff --git a/stack.yaml b/stack.yaml index fa59241dbf0..c07faa007cb 100644 --- a/stack.yaml +++ b/stack.yaml @@ -12,6 +12,7 @@ extra-deps: - tasty-hedgehog-1.0.0.1 # Needed due to https://github.com/qfpl/tasty-hedgehog/issues/30 - Unique-0.4.7.6 - bimap-0.4.0 +- monad-stm-0.1.0.2 - git: https://github.com/input-output-hk/cardano-prelude commit: 7a8755b6988a9dd137f3f61a77c6d51e4eafa781