Make monadic queries easier to access

IntersectMBO · Jul 28, 2021 · 3eba38f · 3eba38f
1 parent 60a10bc
commit 3eba38f
Show file tree

Hide file tree

Showing 3 changed files with 100 additions and 76 deletions.
diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -584,9 +584,10 @@ module Cardano.Api (
     NodeToClientVersion(..),
 
     -- ** Monadic queries
-    LocalStateQueryScript,
+    LocalStateQueryExpr,
     sendMsgQuery,
-    setupLocalStateQueryScript
+    executeQueryLocalState,
+    executeQueryLocalStateWithChainSync
   ) where
 
 import           Cardano.Api.Address

diff --git a/cardano-api/src/Cardano/Api/IPC/Monad.hs b/cardano-api/src/Cardano/Api/IPC/Monad.hs
@@ -2,9 +2,10 @@
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
 
 module Cardano.Api.IPC.Monad
-  ( LocalStateQueryScript
+  ( LocalStateQueryExpr
   , sendMsgQuery
-  , setupLocalStateQueryScript
+  , executeQueryLocalState
+  , executeQueryLocalStateWithChainSync
   ) where
 
 import Cardano.Api.Block
@@ -21,40 +22,113 @@ import Data.Ord
 import Shelley.Spec.Ledger.Scripts ()
 import System.IO
 
+import qualified Ouroboros.Network.Protocol.ChainSync.Client as Net.Sync
 import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as Net.Query
 import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as Net.Query
 
 -- | Monadic type for constructing local state queries.
 --
 -- Use 'sendMsgQuery' in a do block to construct queries of this type and convert
--- the expression to a 'Net.Query.LocalStateQueryClient' with 'setupLocalStateQueryScript'.
-newtype LocalStateQueryScript block point query r m a = LocalStateQueryScript
-  { runLocalStateQueryScript :: ContT (Net.Query.ClientStAcquired block point query m r) m a
+-- the expression to a 'Net.Query.LocalStateQueryClient' with 'setupLocalStateQueryExpr'.
+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)
 
 -- | Use 'sendMsgQuery' in a do block to construct monadic local state queries.
-sendMsgQuery :: Monad m => query a -> LocalStateQueryScript block point query r m a
-sendMsgQuery q = LocalStateQueryScript . ContT $ \f -> pure $
+sendMsgQuery :: Monad m => query a -> LocalStateQueryExpr block point query r m a
+sendMsgQuery q = LocalStateQueryExpr . ContT $ \f -> pure $
   Net.Query.SendMsgQuery q $
     Net.Query.ClientStQuerying
     { Net.Query.recvMsgResult = f
     }
 
+-- | Execute a local state query expression.
+executeQueryLocalState
+  :: LocalNodeConnectInfo CardanoMode
+  -> Maybe ChainPoint
+  -> (NodeToClientVersion -> LocalStateQueryExpr (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) () IO a)
+  -> IO (Either AcquireFailure (Maybe a))
+executeQueryLocalState connectInfo mpoint f = do
+  resultVarQueryTipLocalState <- newEmptyTMVarIO
+  waitResult <- pure $ sequence <$> readTMVar resultVarQueryTipLocalState
+
+  connectToLocalNodeWithVersion
+    connectInfo
+    (\ntcVersion ->
+      LocalNodeClientProtocols
+      { localChainSyncClient    = NoLocalChainSyncClient
+      , localStateQueryClient   = Just $ setupLocalStateQueryExpr waitResult mpoint ntcVersion resultVarQueryTipLocalState (f ntcVersion)
+      , localTxSubmissionClient = Nothing
+      }
+    )
+
+  atomically waitResult
+
+-- | Execute a local state query expression concurrently with a chain sync.
+executeQueryLocalStateWithChainSync
+  :: LocalNodeConnectInfo CardanoMode
+  -> Maybe ChainPoint
+  -> (NodeToClientVersion -> LocalStateQueryExpr (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) () IO a)
+  -> IO (ChainTip, Either AcquireFailure (Maybe a))
+executeQueryLocalStateWithChainSync connectInfo mpoint f = do
+  resultVarQueryTipLocalState <- newEmptyTMVarIO
+  resultVarChainTip <- newEmptyTMVarIO
+
+  waitResult <- pure $ (,)
+    <$> readTMVar resultVarChainTip
+    <*> (sequence <$> readTMVar resultVarQueryTipLocalState)
+
+  connectToLocalNodeWithVersion
+    connectInfo
+    (\ntcVersion ->
+      LocalNodeClientProtocols
+      { localChainSyncClient    = LocalChainSyncClient $ chainSyncGetCurrentTip waitResult resultVarChainTip
+      , localStateQueryClient   = Just $ setupLocalStateQueryExpr waitResult mpoint ntcVersion resultVarQueryTipLocalState (f ntcVersion)
+      , localTxSubmissionClient = Nothing
+      }
+    )
+
+  atomically waitResult
+
+  where
+    chainSyncGetCurrentTip
+      :: STM b
+      -> TMVar  ChainTip
+      -> ChainSyncClient (BlockInMode mode) ChainPoint ChainTip IO ()
+    chainSyncGetCurrentTip waitDone tipVar =
+      ChainSyncClient $ pure clientStIdle
+      where
+        clientStIdle :: Net.Sync.ClientStIdle (BlockInMode mode) ChainPoint ChainTip IO ()
+        clientStIdle =
+          Net.Sync.SendMsgRequestNext clientStNext (pure clientStNext)
+
+        clientStNext :: Net.Sync.ClientStNext (BlockInMode mode) ChainPoint ChainTip IO ()
+        clientStNext = Net.Sync.ClientStNext
+          { Net.Sync.recvMsgRollForward = \_block tip -> ChainSyncClient $ do
+              void . atomically $ putTMVar tipVar tip
+              void $ atomically waitDone
+              pure $ Net.Sync.SendMsgDone ()
+          , Net.Sync.recvMsgRollBackward = \_point tip -> ChainSyncClient $ do
+              void . atomically $ putTMVar tipVar tip
+              void $ atomically waitDone
+              pure $ Net.Sync.SendMsgDone ()
+          }
+
 -- | Use 'sendMsgQuery' in a do block to construct monadic local state queries.
-setupLocalStateQueryScript ::
+setupLocalStateQueryExpr ::
      STM x
   -> Maybe ChainPoint
   -> NodeToClientVersion
   -> TMVar (Maybe (Either Net.Query.AcquireFailure a))
-  -> LocalStateQueryScript (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) () IO a
+  -> LocalStateQueryExpr (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) () IO a
   -> Net.Query.LocalStateQueryClient (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) IO ()
-setupLocalStateQueryScript waitDone mPointVar' ntcVersion resultVar' f =
+setupLocalStateQueryExpr waitDone mPointVar' ntcVersion resultVar' f =
   LocalStateQueryClient $
     if ntcVersion >= NodeToClientV_8
       then do
         pure . Net.Query.SendMsgAcquire mPointVar' $
           Net.Query.ClientStAcquiring
-          { Net.Query.recvMsgAcquired = runContT (runLocalStateQueryScript f) $ \result -> do
+          { Net.Query.recvMsgAcquired = runContT (runLocalStateQueryExpr f) $ \result -> do
               atomically $ putTMVar resultVar' (Just (Right result))
               void $ atomically waitDone
               pure $ Net.Query.SendMsgRelease $ pure $ Net.Query.SendMsgDone ()

diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs
@@ -35,7 +35,6 @@ import           Cardano.Ledger.Coin
 import           Cardano.Ledger.Crypto (StandardCrypto)
 import           Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
 import           Cardano.Prelude hiding (atomically)
-import           Control.Concurrent.STM
 import           Control.Monad.Trans.Except (except)
 import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistMaybe, left)
 import           Data.Aeson (ToJSON (..), (.=))
@@ -68,7 +67,6 @@ import qualified Data.Text.IO as T
 import qualified Data.Text.IO as Text
 import qualified Data.Vector as Vector
 import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry
-import qualified Ouroboros.Network.Protocol.ChainSync.Client as Net.Sync
 import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery
 import qualified Shelley.Spec.Ledger.API.Protocol as Ledger
 import qualified System.IO as IO
@@ -207,7 +205,18 @@ runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do
     CardanoMode -> do
       let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
 
-      (chainTip, emLocalState) <- liftIO $ queryQueryTip localNodeConnInfo Nothing
+      (chainTip, emLocalState) <- liftIO $
+        executeQueryLocalStateWithChainSync localNodeConnInfo Nothing $ \ntcVersion -> do
+          era <- sendMsgQuery (QueryCurrentEra CardanoModeIsMultiEra)
+          eraHistory <- sendMsgQuery (QueryEraHistory CardanoModeIsMultiEra)
+          mSystemStart <- if ntcVersion >= NodeToClientV_9
+            then Just <$> sendMsgQuery QuerySystemStart
+            else return Nothing
+          return O.QueryTipLocalState
+            { O.era = era
+            , O.eraHistory = eraHistory
+            , O.mSystemStart = mSystemStart
+            }
 
       mLocalState <- fmap join . hushM emLocalState $ \e -> do
         liftIO . T.hPutStrLn IO.stderr $
@@ -253,66 +262,6 @@ runQueryTip (AnyConsensusModeParams cModeParams) network mOutFile = do
 
     mode -> left (ShelleyQueryCmdUnsupportedMode (AnyConsensusMode mode))
 
-queryQueryTip
-  :: LocalNodeConnectInfo CardanoMode
-  -> Maybe ChainPoint
-  -> IO (ChainTip, Either AcquireFailure (Maybe O.QueryTipLocalState))
-queryQueryTip connectInfo mpoint = do
-  resultVarQueryTipLocalState <- newEmptyTMVarIO
-  resultVarChainTip <- newEmptyTMVarIO
-
-  waitResult <- pure $ (,)
-    <$> readTMVar resultVarChainTip
-    <*> (sequence <$> readTMVar resultVarQueryTipLocalState)
-
-  connectToLocalNodeWithVersion
-    connectInfo
-    (\ntcVersion ->
-      LocalNodeClientProtocols
-      { localChainSyncClient    = LocalChainSyncClient $ chainSyncGetCurrentTip waitResult resultVarChainTip
-      , localStateQueryClient   = Just $ setupLocalStateQueryScript waitResult mpoint ntcVersion resultVarQueryTipLocalState $ do
-          era <- sendMsgQuery (QueryCurrentEra CardanoModeIsMultiEra)
-          eraHistory <- sendMsgQuery (QueryEraHistory CardanoModeIsMultiEra)
-          mSystemStart <- if ntcVersion >= NodeToClientV_9
-            then Just <$> sendMsgQuery QuerySystemStart
-            else return Nothing
-          return O.QueryTipLocalState
-            { O.era = era
-            , O.eraHistory = eraHistory
-            , O.mSystemStart = mSystemStart
-            }
-
-      , localTxSubmissionClient = Nothing
-      }
-    )
-
-  atomically waitResult
-
-  where
-    chainSyncGetCurrentTip
-      :: forall mode a
-      .  STM a
-      -> TMVar  ChainTip
-      -> ChainSyncClient (BlockInMode mode) ChainPoint ChainTip IO ()
-    chainSyncGetCurrentTip waitDone tipVar =
-      ChainSyncClient $ pure clientStIdle
-      where
-        clientStIdle :: Net.Sync.ClientStIdle (BlockInMode mode) ChainPoint ChainTip IO ()
-        clientStIdle =
-          Net.Sync.SendMsgRequestNext clientStNext (pure clientStNext)
-
-        clientStNext :: Net.Sync.ClientStNext (BlockInMode mode) ChainPoint ChainTip IO ()
-        clientStNext = Net.Sync.ClientStNext
-          { Net.Sync.recvMsgRollForward = \_block tip -> ChainSyncClient $ do
-              void . atomically $ putTMVar tipVar tip
-              void $ atomically waitDone
-              pure $ Net.Sync.SendMsgDone ()
-          , Net.Sync.recvMsgRollBackward = \_point tip -> ChainSyncClient $ do
-              void . atomically $ putTMVar tipVar tip
-              void $ atomically waitDone
-              pure $ Net.Sync.SendMsgDone ()
-          }
-
 -- | Query the UTxO, filtered by a given set of addresses, from a Shelley node
 -- via the local state query protocol.
 --