diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 37ef8d1753b..e1432c3ce7e 100644 --- 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 index 9a0c9f361f6..df222298200 100644 --- 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 index d7ac310331c..a09595f2923 100644 --- 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