Merge pull request #4809 from input-output-hk/newhoggy/introduce-Read…

…erT-into-LocalStateQueryExpr Add ReaderT of NodeToClientVersion to LocalStateQueryExpr
IntersectMBO · Jan 19, 2023 · 9665b3d · 9665b3d
2 parents b5c9f9b + b153ee2
commit 9665b3d
Show file tree

Hide file tree

Showing 3 changed files with 14 additions and 10 deletions.
diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal
@@ -140,6 +140,7 @@ library
                       , iproute
                       , memory
                       , microlens
+                      , mtl
                       , network
                       , nothunks
                       , optparse-applicative-fork

diff --git a/cardano-api/src/Cardano/Api/IPC/Monad.hs b/cardano-api/src/Cardano/Api/IPC/Monad.hs
@@ -13,6 +13,7 @@ import           Control.Applicative
 import           Control.Concurrent.STM
 import           Control.Monad
 import           Control.Monad.IO.Class
+import           Control.Monad.Reader
 import           Control.Monad.Trans.Cont
 import           Data.Bifunctor (first)
 import           Data.Either
@@ -45,14 +46,14 @@ import           Cardano.Api.Modes
 -- In order to make pipelining still possible we can explore the use of Selective Functors
 -- which would allow us to straddle both worlds.
 newtype LocalStateQueryExpr block point query r m a = LocalStateQueryExpr
-  { runLocalStateQueryExpr :: ContT (Net.Query.ClientStAcquired block point query m r) m a
-  } deriving (Functor, Applicative, Monad, MonadIO)
+  { runLocalStateQueryExpr :: ReaderT NodeToClientVersion (ContT (Net.Query.ClientStAcquired block point query m r) m) a
+  } deriving (Functor, Applicative, Monad, MonadReader NodeToClientVersion, MonadIO)
 
 -- | Execute a local state query expression.
 executeLocalStateQueryExpr
   :: LocalNodeConnectInfo mode
   -> Maybe ChainPoint
-  -> (NodeToClientVersion -> LocalStateQueryExpr (BlockInMode mode) ChainPoint (QueryInMode mode) () IO a)
+  -> LocalStateQueryExpr (BlockInMode mode) ChainPoint (QueryInMode mode) () IO a
   -> IO (Either AcquiringFailure a)
 executeLocalStateQueryExpr connectInfo mpoint f = do
   tmvResultLocalState <- newEmptyTMVarIO
@@ -63,7 +64,7 @@ executeLocalStateQueryExpr connectInfo mpoint f = do
     (\ntcVersion ->
       LocalNodeClientProtocols
       { localChainSyncClient    = NoLocalChainSyncClient
-      , localStateQueryClient   = Just $ setupLocalStateQueryExpr waitResult mpoint tmvResultLocalState (f ntcVersion)
+      , localStateQueryClient   = Just $ setupLocalStateQueryExpr waitResult mpoint tmvResultLocalState ntcVersion f
       , localTxSubmissionClient = Nothing
       , localTxMonitoringClient = Nothing
       }
@@ -79,12 +80,13 @@ setupLocalStateQueryExpr ::
      -- cause other incomplete protocols to abort which may lead to deadlock.
   -> Maybe ChainPoint
   -> TMVar (Either Net.Query.AcquireFailure a)
+  -> NodeToClientVersion
   -> LocalStateQueryExpr (BlockInMode mode) ChainPoint (QueryInMode mode) () IO a
   -> Net.Query.LocalStateQueryClient (BlockInMode mode) ChainPoint (QueryInMode mode) IO ()
-setupLocalStateQueryExpr waitDone mPointVar' resultVar' f =
+setupLocalStateQueryExpr waitDone mPointVar' resultVar' ntcVersion f =
   LocalStateQueryClient . pure . Net.Query.SendMsgAcquire mPointVar' $
     Net.Query.ClientStAcquiring
-    { Net.Query.recvMsgAcquired = runContT (runLocalStateQueryExpr f) $ \result -> do
+    { Net.Query.recvMsgAcquired = runContT (runReaderT (runLocalStateQueryExpr f) ntcVersion) $ \result -> do
         atomically $ putTMVar resultVar' (Right result)
         void $ atomically waitDone -- Wait for all protocols to complete before exiting.
         pure $ Net.Query.SendMsgRelease $ pure $ Net.Query.SendMsgDone ()
@@ -98,7 +100,7 @@ setupLocalStateQueryExpr waitDone mPointVar' resultVar' f =
 -- | Use 'queryExpr' in a do block to construct monadic local state queries.
 queryExpr :: QueryInMode mode a -> LocalStateQueryExpr block point (QueryInMode mode) r IO a
 queryExpr q =
-  LocalStateQueryExpr . ContT $ \f -> pure $
+  LocalStateQueryExpr . ReaderT $ \_ -> ContT $ \f -> pure $
     Net.Query.SendMsgQuery q $
       Net.Query.ClientStQuerying
       { Net.Query.recvMsgResult = f

diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs
@@ -209,7 +209,7 @@ runQueryProtocolParameters (AnyConsensusModeParams cModeParams) network mOutFile
                            $ newExceptT readEnvSocketPath
   let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
 
-  result <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ \_ntcVersion -> runExceptT $ do
+  result <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT $ do
     anyE@(AnyCardanoEra era) <- lift $ determineEraExpr cModeParams
 
     case cardanoEraStyle era of
@@ -284,7 +284,8 @@ runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do
     CardanoMode -> do
       let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
 
-      eLocalState <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ \ntcVersion -> do
+      eLocalState <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo Nothing $ do
+        ntcVersion <- ask
         era <- queryExpr (QueryCurrentEra CardanoModeIsMultiEra)
         eraHistory <- queryExpr (QueryEraHistory CardanoModeIsMultiEra)
         mChainBlockNo <- if ntcVersion >= NodeToClientV_10
@@ -1023,7 +1024,7 @@ runQueryStakePools (AnyConsensusModeParams cModeParams)
   let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
 
   result <- ExceptT . fmap (join . first ShelleyQueryCmdAcquireFailure) $
-    executeLocalStateQueryExpr localNodeConnInfo Nothing $ \_ntcVersion -> runExceptT @ShelleyQueryCmdError $ do
+    executeLocalStateQueryExpr localNodeConnInfo Nothing $ runExceptT @ShelleyQueryCmdError $ do
       anyE@(AnyCardanoEra era) <- case consensusModeOnly cModeParams of
         ByronMode -> return $ AnyCardanoEra ByronEra
         ShelleyMode -> return $ AnyCardanoEra ShelleyEra