Merge pull request #56 from mlabs-haskell/euonymos/fix-era-summaries

Last never-forking era, get chain points query

emulator/src/Cardano/Node/Socket/Emulator/Query.hs

@@ -18,13 +18,14 @@ import Cardano.Node.Socket.Emulator.Types (
   AppState (..),
   EmulatorMsg,
   clbState,
+  getChainPointTime,
   getTip,
   runClbInIO',
   socketEmulatorState,
  )
 import Cardano.Slotting.EpochInfo (epochInfoEpoch)
 import Cardano.Slotting.Slot (WithOrigin (..))
-import Cardano.Slotting.Time (RelativeTime (RelativeTime), SlotLength, mkSlotLength)
+import Cardano.Slotting.Time (SlotLength, mkSlotLength)
 import Clb (ClbT, chainState, clbConfig, getClbConfig, getCurrentSlot, getGlobals, getStakePools, getUtxosAt)
 import Clb qualified as E
 import Clb.Config (ClbConfig (..))
@@ -47,7 +48,7 @@ import Data.SOP.Counting qualified as Ouroboros
 import Data.SOP.NonEmpty qualified as Ouroboros
 import Data.SOP.Strict (NP (Nil, (:*)), NS (S, Z))
 import Data.Set qualified as Set
-import Ouroboros.Consensus.Block (EpochNo (EpochNo), EpochSize, GenesisWindow (..), SlotNo (SlotNo))
+import Ouroboros.Consensus.Block (EpochSize, GenesisWindow (..))
 import Ouroboros.Consensus.Cardano.Block (BlockQuery (..), CardanoBlock)
 import Ouroboros.Consensus.HardFork.Combinator (QueryHardFork (..))
 import Ouroboros.Consensus.HardFork.Combinator qualified as Consensus
@@ -57,6 +58,7 @@ import Ouroboros.Consensus.HardFork.History.Summary (
   Bound (..),
   EraSummary (..),
   Summary (..),
+  neverForksSummary,
  )
 import Ouroboros.Consensus.Ledger.Query (Query (..))
 import Ouroboros.Consensus.Protocol.Praos (Praos)
@@ -122,7 +124,11 @@ handleQueryConwayEra trace state q =
             let ret = At curBlockNo
             logInfo $ "Tip is: " <> show ret
             pure ret
-      GetChainPoint -> printError "Unimplemented GetChainPoint was received"
+      query@GetChainPoint -> do
+        logInfo $ "Query was received (5): " ++ show query
+        ret <- getChainPointTime state
+        logInfo $ "Chain point time is: " <> show ret
+        pure ret
 
 queryIfCurrentConway ::
   (block ~ Shelley.ShelleyBlock (Praos StandardCrypto) (ConwayEra StandardCrypto)) =>
@@ -176,7 +182,7 @@ emulatorEraHistory params = C.EraHistory (Ouroboros.mkInterpreter $ Ouroboros.su
     lastS =
       Ouroboros.nonEmptyHead $
         Ouroboros.getSummary $
-          skipSummary lastEndBound emulatorEpochSize (slotLength params) emulatorGenesisWindow
+          neverForksSummary emulatorEpochSize (slotLength params) emulatorGenesisWindow
     list = Ouroboros.Exactly $ K one :* K one :* K one :* K one :* K one :* K one :* K lastS :* Nil
 
 -- | 'Summary' for a ledger that never forks
@@ -196,14 +202,6 @@ skipSummary endBound epochSize slotLen genesisWindow =
               }
         }
 
-lastEndBound :: Bound
-lastEndBound =
-  Bound
-    { boundTime = RelativeTime 50
-    , boundSlot = SlotNo 1
-    , boundEpoch = EpochNo 500
-    }
-
 emulatorGenesisWindow :: GenesisWindow
 emulatorGenesisWindow = GenesisWindow window
   where

emulator/src/Cardano/Node/Socket/Emulator/Server.hs

@@ -88,11 +88,11 @@ import Cardano.Node.Socket.Emulator.Types (
   txSubmissionCodec,
  )
 import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..))
-import Clb (ValidationResult (..))
+import Clb (ValidationResult (..), chainState)
 import Clb qualified as E
 import Clb.EmulatedLedgerState qualified as E
 import Clb.Era (IsCardanoLedgerEra)
-import Clb.TimeSlot (Slot)
+import Clb.TimeSlot (Slot, fromSlot)
 import Clb.Tx (pattern CardanoEmulatorEraTx)
 import Clb.Tx qualified as E (getEmulatorEraTx)
 import Control.Monad.Freer.Extras (logInfo)
@@ -280,6 +280,14 @@ handleCommand trace CommandChannel {ccCommand, ccResponse} mvAppState = do
     atomically (readTQueue ccCommand) >>= \case
       ModifySlot f -> do
         s <- runClb trace mvAppState (E.modifySlot f)
+        -- FIXME: This is unfortunate we have to look after two ledger envs.
+        liftIO $ modifyMVar mvAppState $ \appState -> do
+          let newState =
+                over
+                  (socketEmulatorState . cachedState)
+                  (E.setSlot $ fromSlot s)
+                  appState
+          pure (newState, ())
         atomically $
           writeTQueue ccResponse (SlotChanged s)
       TryProduceBlock -> do
@@ -318,10 +326,13 @@ processBlock trace mvAppState =
           logInfo @EmulatorMsg $ "Block is: " <> show newBlock
           logInfo @EmulatorMsg "Updating chain state..."
           let s = appState ^. (socketEmulatorState . clbState)
+          let cachedState' = appState ^. (socketEmulatorState . cachedState)
+          let currentSlot =
+                E.getSlot (appState ^. socketEmulatorState . clbState . chainState)
           (_, s') <-
             runStateT
               ( modify $
-                  over E.chainState (const $ appState ^. (socketEmulatorState . cachedState))
+                  over E.chainState (const (E.setSlot currentSlot cachedState'))
                     . over E.knownDatums (`M.union` blockDatums)
               )
               s
@@ -489,8 +500,7 @@ nextState ::
         (m (ServerStNext block (Point block) Tip m ()))
     )
 nextState localChannel@(LocalChannel channel') = do
-  chainState <- ask
-  tip' <- getTip chainState
+  tip' <- getTip =<< ask
   (liftIO . atomically $ tryReadTChan channel') >>= \case
     Nothing -> do
       Right . pure <$> do

emulator/src/Cardano/Node/Socket/Emulator/Types.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
@@ -45,6 +46,7 @@ import Clb (
   ClbT,
   EmulatedLedgerState,
   OnChainTx (..),
+  chainState,
  )
 import Clb qualified as E
 import Clb.EmulatedLedgerState qualified as E (getSlot)
@@ -80,6 +82,7 @@ import Data.Foldable (toList, traverse_)
 import Data.Functor ((<&>))
 import Data.ListMap qualified as LM
 import Data.Map qualified as Map
+import Data.Maybe (listToMaybe)
 import Data.Text qualified as Text
 import Data.Time.Clock (UTCTime)
 import Data.Time.Format.ISO8601 qualified as F
@@ -106,7 +109,11 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion (
 import Ouroboros.Consensus.Protocol.Praos.Header qualified as Praos
 import Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
 import Ouroboros.Consensus.Shelley.Ledger qualified as Shelley
-import Ouroboros.Network.Block (Point)
+import Ouroboros.Network.Block (
+  Point,
+  pattern BlockPoint,
+  pattern GenesisPoint,
+ )
 import Ouroboros.Network.Block qualified as Ouroboros
 import Ouroboros.Network.NodeToClient (
   NodeToClientVersion (..),
@@ -255,6 +262,22 @@ getChannel mv = liftIO (readMVar mv) <&> view (socketEmulatorState . channel)
 getTip :: (MonadIO m) => MVar (AppState era) -> m Tip
 getTip mv = liftIO (readMVar mv) <&> view (socketEmulatorState . tip)
 
+-- Get so-called "chain point" time
+getChainPointTime ::
+  ( MonadIO m
+  , block ~ CardanoBlock StandardCrypto
+  , CBOR.ToCBOR (Core.Tx (CardanoLedgerEra era))
+  ) =>
+  MVar (AppState era) ->
+  m (Point block)
+getChainPointTime mv = do
+  st <- liftIO (readMVar mv)
+  case listToMaybe $ st ^. socketEmulatorState . chainNewestFirst of
+    Just newest -> do
+      let slot = E.getSlot $ st ^. socketEmulatorState . clbState . chainState
+      pure $ BlockPoint slot (coerce $ blockId newest)
+    Nothing -> pure GenesisPoint
+
 -- Set the new tip
 setTip :: (MonadIO m, CBOR.ToCBOR (Core.Tx (CardanoLedgerEra era))) => MVar (AppState era) -> Block era -> m ()
 setTip mv block = liftIO $ modifyMVar_ mv $ \oldState -> do