Shelley interface

shelley/chain-and-ledger/executable-spec/delegation.cabal

@@ -86,6 +86,7 @@ library
     small-steps,
     microlens,
     microlens-th,
+    monad-stm,
     mtl,
     non-integer,
     stm,

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
   }
 

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

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

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

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

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

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