{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}

module Cardano.Api.Internal.IPC.Monad
  ( LocalStateQueryExpr
  , executeLocalStateQueryExpr
  , queryExpr
  )
where

import Cardano.Api.Internal.Block
import Cardano.Api.Internal.IPC
import Cardano.Api.Internal.IPC.Version
import Cardano.Api.Internal.Query

import Cardano.Ledger.Shelley.Scripts ()
import Ouroboros.Network.Protocol.LocalStateQuery.Client qualified as Net.Query
import Ouroboros.Network.Protocol.LocalStateQuery.Type qualified as Net.Query

import Control.Concurrent.STM
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Trans.Cont

{- HLINT ignore "Use const" -}
{- HLINT ignore "Use let" -}

-- | Monadic type for constructing local state query expressions.
--
-- Use 'queryExpr' in a do block to construct queries of this type and convert
-- the expression to a 'Net.Query.LocalStateQueryClient' with 'setupLocalStateQueryExpr'.
--
-- Some consideration was made to use Applicative instead of Monad as the abstraction in
-- order to support pipelining, but we actually have a fair amount of code where the next
-- query depends on the result of the former and therefore actually need Monad.
--
-- 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
  { forall block point (query :: * -> *) r (m :: * -> *) a.
LocalStateQueryExpr block point query r m a
-> ReaderT
     NodeToClientVersion
     (ContT (ClientStAcquired block point query m r) m)
     a
runLocalStateQueryExpr
      :: ReaderT NodeToClientVersion (ContT (Net.Query.ClientStAcquired block point query m r) m) a
  }
  deriving ((forall a b.
 (a -> b)
 -> LocalStateQueryExpr block point query r m a
 -> LocalStateQueryExpr block point query r m b)
-> (forall a b.
    a
    -> LocalStateQueryExpr block point query r m b
    -> LocalStateQueryExpr block point query r m a)
-> Functor (LocalStateQueryExpr block point query r m)
forall a b.
a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m a
forall a b.
(a -> b)
-> LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
forall block point (query :: * -> *) r (m :: * -> *) a b.
a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m a
forall block point (query :: * -> *) r (m :: * -> *) a b.
(a -> b)
-> LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall block point (query :: * -> *) r (m :: * -> *) a b.
(a -> b)
-> LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
fmap :: forall a b.
(a -> b)
-> LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
$c<$ :: forall block point (query :: * -> *) r (m :: * -> *) a b.
a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m a
<$ :: forall a b.
a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m a
Functor, Functor (LocalStateQueryExpr block point query r m)
Functor (LocalStateQueryExpr block point query r m) =>
(forall a. a -> LocalStateQueryExpr block point query r m a)
-> (forall a b.
    LocalStateQueryExpr block point query r m (a -> b)
    -> LocalStateQueryExpr block point query r m a
    -> LocalStateQueryExpr block point query r m b)
-> (forall a b c.
    (a -> b -> c)
    -> LocalStateQueryExpr block point query r m a
    -> LocalStateQueryExpr block point query r m b
    -> LocalStateQueryExpr block point query r m c)
-> (forall a b.
    LocalStateQueryExpr block point query r m a
    -> LocalStateQueryExpr block point query r m b
    -> LocalStateQueryExpr block point query r m b)
-> (forall a b.
    LocalStateQueryExpr block point query r m a
    -> LocalStateQueryExpr block point query r m b
    -> LocalStateQueryExpr block point query r m a)
-> Applicative (LocalStateQueryExpr block point query r m)
forall a. a -> LocalStateQueryExpr block point query r m a
forall a b.
LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m a
forall a b.
LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m b
forall a b.
LocalStateQueryExpr block point query r m (a -> b)
-> LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
forall a b c.
(a -> b -> c)
-> LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m c
forall block point (query :: * -> *) r (m :: * -> *).
Functor (LocalStateQueryExpr block point query r m)
forall block point (query :: * -> *) r (m :: * -> *) a.
a -> LocalStateQueryExpr block point query r m a
forall block point (query :: * -> *) r (m :: * -> *) a b.
LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m a
forall block point (query :: * -> *) r (m :: * -> *) a b.
LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m b
forall block point (query :: * -> *) r (m :: * -> *) a b.
LocalStateQueryExpr block point query r m (a -> b)
-> LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
forall block point (query :: * -> *) r (m :: * -> *) a b c.
(a -> b -> c)
-> LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall block point (query :: * -> *) r (m :: * -> *) a.
a -> LocalStateQueryExpr block point query r m a
pure :: forall a. a -> LocalStateQueryExpr block point query r m a
$c<*> :: forall block point (query :: * -> *) r (m :: * -> *) a b.
LocalStateQueryExpr block point query r m (a -> b)
-> LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
<*> :: forall a b.
LocalStateQueryExpr block point query r m (a -> b)
-> LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
$cliftA2 :: forall block point (query :: * -> *) r (m :: * -> *) a b c.
(a -> b -> c)
-> LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m c
liftA2 :: forall a b c.
(a -> b -> c)
-> LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m c
$c*> :: forall block point (query :: * -> *) r (m :: * -> *) a b.
LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m b
*> :: forall a b.
LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m b
$c<* :: forall block point (query :: * -> *) r (m :: * -> *) a b.
LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m a
<* :: forall a b.
LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m a
Applicative, Applicative (LocalStateQueryExpr block point query r m)
Applicative (LocalStateQueryExpr block point query r m) =>
(forall a b.
 LocalStateQueryExpr block point query r m a
 -> (a -> LocalStateQueryExpr block point query r m b)
 -> LocalStateQueryExpr block point query r m b)
-> (forall a b.
    LocalStateQueryExpr block point query r m a
    -> LocalStateQueryExpr block point query r m b
    -> LocalStateQueryExpr block point query r m b)
-> (forall a. a -> LocalStateQueryExpr block point query r m a)
-> Monad (LocalStateQueryExpr block point query r m)
forall a. a -> LocalStateQueryExpr block point query r m a
forall a b.
LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m b
forall a b.
LocalStateQueryExpr block point query r m a
-> (a -> LocalStateQueryExpr block point query r m b)
-> LocalStateQueryExpr block point query r m b
forall block point (query :: * -> *) r (m :: * -> *).
Applicative (LocalStateQueryExpr block point query r m)
forall block point (query :: * -> *) r (m :: * -> *) a.
a -> LocalStateQueryExpr block point query r m a
forall block point (query :: * -> *) r (m :: * -> *) a b.
LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m b
forall block point (query :: * -> *) r (m :: * -> *) a b.
LocalStateQueryExpr block point query r m a
-> (a -> LocalStateQueryExpr block point query r m b)
-> LocalStateQueryExpr block point query r m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall block point (query :: * -> *) r (m :: * -> *) a b.
LocalStateQueryExpr block point query r m a
-> (a -> LocalStateQueryExpr block point query r m b)
-> LocalStateQueryExpr block point query r m b
>>= :: forall a b.
LocalStateQueryExpr block point query r m a
-> (a -> LocalStateQueryExpr block point query r m b)
-> LocalStateQueryExpr block point query r m b
$c>> :: forall block point (query :: * -> *) r (m :: * -> *) a b.
LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m b
>> :: forall a b.
LocalStateQueryExpr block point query r m a
-> LocalStateQueryExpr block point query r m b
-> LocalStateQueryExpr block point query r m b
$creturn :: forall block point (query :: * -> *) r (m :: * -> *) a.
a -> LocalStateQueryExpr block point query r m a
return :: forall a. a -> LocalStateQueryExpr block point query r m a
Monad, MonadReader NodeToClientVersion, Monad (LocalStateQueryExpr block point query r m)
Monad (LocalStateQueryExpr block point query r m) =>
(forall a. IO a -> LocalStateQueryExpr block point query r m a)
-> MonadIO (LocalStateQueryExpr block point query r m)
forall a. IO a -> LocalStateQueryExpr block point query r m a
forall block point (query :: * -> *) r (m :: * -> *).
MonadIO m =>
Monad (LocalStateQueryExpr block point query r m)
forall block point (query :: * -> *) r (m :: * -> *) a.
MonadIO m =>
IO a -> LocalStateQueryExpr block point query r m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall block point (query :: * -> *) r (m :: * -> *) a.
MonadIO m =>
IO a -> LocalStateQueryExpr block point query r m a
liftIO :: forall a. IO a -> LocalStateQueryExpr block point query r m a
MonadIO)

-- | Execute a local state query expression.
executeLocalStateQueryExpr
  :: ()
  => LocalNodeConnectInfo
  -> Net.Query.Target ChainPoint
  -> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
  -> IO (Either AcquiringFailure a)
executeLocalStateQueryExpr :: forall a.
LocalNodeConnectInfo
-> Target ChainPoint
-> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
-> IO (Either AcquiringFailure a)
executeLocalStateQueryExpr LocalNodeConnectInfo
connectInfo Target ChainPoint
target LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
f = do
  TMVar (Either AcquiringFailure a)
tmvResultLocalState <- IO (TMVar (Either AcquiringFailure a))
forall a. IO (TMVar a)
newEmptyTMVarIO
  let waitResult :: STM (Either AcquiringFailure a)
waitResult = TMVar (Either AcquiringFailure a)
-> STM (Either AcquiringFailure a)
forall a. TMVar a -> STM a
readTMVar TMVar (Either AcquiringFailure a)
tmvResultLocalState

  LocalNodeConnectInfo
-> (NodeToClientVersion -> LocalNodeClientProtocolsInMode) -> IO ()
forall (m :: * -> *).
MonadIO m =>
LocalNodeConnectInfo
-> (NodeToClientVersion -> LocalNodeClientProtocolsInMode) -> m ()
connectToLocalNodeWithVersion
    LocalNodeConnectInfo
connectInfo
    ( \NodeToClientVersion
ntcVersion ->
        LocalNodeClientProtocols
          { localChainSyncClient :: LocalChainSyncClient BlockInMode ChainPoint ChainTip IO
localChainSyncClient = LocalChainSyncClient BlockInMode ChainPoint ChainTip IO
forall block point tip (m :: * -> *).
LocalChainSyncClient block point tip m
NoLocalChainSyncClient
          , localStateQueryClient :: Maybe
  (LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ())
localStateQueryClient =
              LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ()
-> Maybe
     (LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ())
forall a. a -> Maybe a
Just (LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ()
 -> Maybe
      (LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ()))
-> LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ()
-> Maybe
     (LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ())
forall a b. (a -> b) -> a -> b
$ STM (Either AcquiringFailure a)
-> Target ChainPoint
-> TMVar (Either AcquiringFailure a)
-> NodeToClientVersion
-> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
-> LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ()
forall x a.
STM x
-> Target ChainPoint
-> TMVar (Either AcquiringFailure a)
-> NodeToClientVersion
-> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
-> LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ()
setupLocalStateQueryExpr STM (Either AcquiringFailure a)
waitResult Target ChainPoint
target TMVar (Either AcquiringFailure a)
tmvResultLocalState NodeToClientVersion
ntcVersion LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
f
          , localTxSubmissionClient :: Maybe
  (LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode IO ())
localTxSubmissionClient = Maybe
  (LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode IO ())
forall a. Maybe a
Nothing
          , localTxMonitoringClient :: Maybe (LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO ())
localTxMonitoringClient = Maybe (LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO ())
forall a. Maybe a
Nothing
          }
    )

  STM (Either AcquiringFailure a) -> IO (Either AcquiringFailure a)
forall a. STM a -> IO a
atomically STM (Either AcquiringFailure a)
waitResult

-- | Use 'queryExpr' in a do block to construct monadic local state queries.
setupLocalStateQueryExpr
  :: STM x
  -- ^ An STM expression that only returns when all protocols are complete.
  -- Protocols must wait until 'waitDone' returns because premature exit will
  -- cause other incomplete protocols to abort which may lead to deadlock.
  -> Net.Query.Target ChainPoint
  -> TMVar (Either AcquiringFailure a)
  -> NodeToClientVersion
  -> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
  -> Net.Query.LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ()
setupLocalStateQueryExpr :: forall x a.
STM x
-> Target ChainPoint
-> TMVar (Either AcquiringFailure a)
-> NodeToClientVersion
-> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
-> LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ()
setupLocalStateQueryExpr STM x
waitDone Target ChainPoint
mPointVar' TMVar (Either AcquiringFailure a)
resultVar' NodeToClientVersion
ntcVersion LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
f =
  IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ())
-> LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ()
forall block point (query :: * -> *) (m :: * -> *) a.
m (ClientStIdle block point query m a)
-> LocalStateQueryClient block point query m a
LocalStateQueryClient (IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ())
 -> LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ())
-> (ClientStAcquiring BlockInMode ChainPoint QueryInMode IO ()
    -> IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ()))
-> ClientStAcquiring BlockInMode ChainPoint QueryInMode IO ()
-> LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientStIdle BlockInMode ChainPoint QueryInMode IO ()
-> IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStIdle BlockInMode ChainPoint QueryInMode IO ()
 -> IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ()))
-> (ClientStAcquiring BlockInMode ChainPoint QueryInMode IO ()
    -> ClientStIdle BlockInMode ChainPoint QueryInMode IO ())
-> ClientStAcquiring BlockInMode ChainPoint QueryInMode IO ()
-> IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target ChainPoint
-> ClientStAcquiring BlockInMode ChainPoint QueryInMode IO ()
-> ClientStIdle BlockInMode ChainPoint QueryInMode IO ()
forall point block (query :: * -> *) (m :: * -> *) a.
Target point
-> ClientStAcquiring block point query m a
-> ClientStIdle block point query m a
Net.Query.SendMsgAcquire Target ChainPoint
mPointVar' (ClientStAcquiring BlockInMode ChainPoint QueryInMode IO ()
 -> LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ())
-> ClientStAcquiring BlockInMode ChainPoint QueryInMode IO ()
-> LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ()
forall a b. (a -> b) -> a -> b
$
    Net.Query.ClientStAcquiring
      { recvMsgAcquired :: IO (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ())
Net.Query.recvMsgAcquired =
          let allQueries :: ContT
  (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ()) IO a
allQueries = ReaderT
  NodeToClientVersion
  (ContT
     (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ()) IO)
  a
-> NodeToClientVersion
-> ContT
     (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ()) IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
-> ReaderT
     NodeToClientVersion
     (ContT
        (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ()) IO)
     a
forall block point (query :: * -> *) r (m :: * -> *) a.
LocalStateQueryExpr block point query r m a
-> ReaderT
     NodeToClientVersion
     (ContT (ClientStAcquired block point query m r) m)
     a
runLocalStateQueryExpr LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
f) NodeToClientVersion
ntcVersion
           in ContT
  (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ()) IO a
-> (a
    -> IO (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ()))
-> IO (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ())
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT ContT
  (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ()) IO a
allQueries a -> IO (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ())
finalContinuation
      , recvMsgFailure :: AcquireFailure
-> IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ())
Net.Query.recvMsgFailure = \AcquireFailure
failure -> do
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Either AcquiringFailure a)
-> Either AcquiringFailure a -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either AcquiringFailure a)
resultVar' (AcquiringFailure -> Either AcquiringFailure a
forall a b. a -> Either a b
Left (AcquireFailure -> AcquiringFailure
toAcquiringFailure AcquireFailure
failure))
          IO x -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO x -> IO ()) -> IO x -> IO ()
forall a b. (a -> b) -> a -> b
$ STM x -> IO x
forall a. STM a -> IO a
atomically STM x
waitDone -- Wait for all protocols to complete before exiting.
          ClientStIdle BlockInMode ChainPoint QueryInMode IO ()
-> IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStIdle BlockInMode ChainPoint QueryInMode IO ()
 -> IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ()))
-> ClientStIdle BlockInMode ChainPoint QueryInMode IO ()
-> IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ())
forall a b. (a -> b) -> a -> b
$ () -> ClientStIdle BlockInMode ChainPoint QueryInMode IO ()
forall a block point (query :: * -> *) (m :: * -> *).
a -> ClientStIdle block point query m a
Net.Query.SendMsgDone ()
      }
 where
  -- We wait for all queries to finish before exiting.
  finalContinuation :: a -> IO (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ())
finalContinuation a
result = do
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Either AcquiringFailure a)
-> Either AcquiringFailure a -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either AcquiringFailure a)
resultVar' (a -> Either AcquiringFailure a
forall a b. b -> Either a b
Right a
result)
    IO x -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO x -> IO ()) -> IO x -> IO ()
forall a b. (a -> b) -> a -> b
$ STM x -> IO x
forall a. STM a -> IO a
atomically STM x
waitDone -- Wait for all protocols to complete before exiting.
    ClientStAcquired BlockInMode ChainPoint QueryInMode IO ()
-> IO (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ()
 -> IO (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ()))
-> ClientStAcquired BlockInMode ChainPoint QueryInMode IO ()
-> IO (ClientStAcquired BlockInMode ChainPoint QueryInMode IO ())
forall a b. (a -> b) -> a -> b
$ IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ())
-> ClientStAcquired BlockInMode ChainPoint QueryInMode IO ()
forall (m :: * -> *) block point (query :: * -> *) a.
m (ClientStIdle block point query m a)
-> ClientStAcquired block point query m a
Net.Query.SendMsgRelease (IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ())
 -> ClientStAcquired BlockInMode ChainPoint QueryInMode IO ())
-> IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ())
-> ClientStAcquired BlockInMode ChainPoint QueryInMode IO ()
forall a b. (a -> b) -> a -> b
$ ClientStIdle BlockInMode ChainPoint QueryInMode IO ()
-> IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStIdle BlockInMode ChainPoint QueryInMode IO ()
 -> IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ()))
-> ClientStIdle BlockInMode ChainPoint QueryInMode IO ()
-> IO (ClientStIdle BlockInMode ChainPoint QueryInMode IO ())
forall a b. (a -> b) -> a -> b
$ () -> ClientStIdle BlockInMode ChainPoint QueryInMode IO ()
forall a block point (query :: * -> *) (m :: * -> *).
a -> ClientStIdle block point query m a
Net.Query.SendMsgDone ()

-- | Get the node server's Node-to-Client version.
getNtcVersion :: LocalStateQueryExpr block point QueryInMode r IO NodeToClientVersion
getNtcVersion :: forall block point r.
LocalStateQueryExpr
  block point QueryInMode r IO NodeToClientVersion
getNtcVersion = ReaderT
  NodeToClientVersion
  (ContT (ClientStAcquired block point QueryInMode IO r) IO)
  NodeToClientVersion
-> LocalStateQueryExpr
     block point QueryInMode r IO NodeToClientVersion
forall block point (query :: * -> *) r (m :: * -> *) a.
ReaderT
  NodeToClientVersion
  (ContT (ClientStAcquired block point query m r) m)
  a
-> LocalStateQueryExpr block point query r m a
LocalStateQueryExpr ReaderT
  NodeToClientVersion
  (ContT (ClientStAcquired block point QueryInMode IO r) IO)
  NodeToClientVersion
forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Use 'queryExpr' in a do block to construct monadic local state queries.
queryExpr
  :: QueryInMode a
  -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError a)
queryExpr :: forall a block point r.
QueryInMode a
-> LocalStateQueryExpr
     block point QueryInMode r IO (Either UnsupportedNtcVersionError a)
queryExpr QueryInMode a
q = do
  NodeToClientVersion
ntcVersion <- LocalStateQueryExpr
  block point QueryInMode r IO NodeToClientVersion
forall block point r.
LocalStateQueryExpr
  block point QueryInMode r IO NodeToClientVersion
getNtcVersion
  case Some (Query (CardanoBlock StandardCrypto))
-> NodeToClientVersion -> Either UnsupportedNtcVersionError ()
isQuerySupportedInNtcVersion (QueryInMode a -> Some (Query (CardanoBlock StandardCrypto))
forall block result.
(CardanoBlock StandardCrypto ~ block) =>
QueryInMode result -> Some (Query block)
toConsensusQuery QueryInMode a
q) NodeToClientVersion
ntcVersion of
    Right () ->
      (a -> Either UnsupportedNtcVersionError a)
-> LocalStateQueryExpr block point QueryInMode r IO a
-> LocalStateQueryExpr
     block point QueryInMode r IO (Either UnsupportedNtcVersionError a)
forall a b.
(a -> b)
-> LocalStateQueryExpr block point QueryInMode r IO a
-> LocalStateQueryExpr block point QueryInMode r IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either UnsupportedNtcVersionError a
forall a b. b -> Either a b
Right (LocalStateQueryExpr block point QueryInMode r IO a
 -> LocalStateQueryExpr
      block point QueryInMode r IO (Either UnsupportedNtcVersionError a))
-> ((NodeToClientVersion
     -> ContT (ClientStAcquired block point QueryInMode IO r) IO a)
    -> LocalStateQueryExpr block point QueryInMode r IO a)
-> (NodeToClientVersion
    -> ContT (ClientStAcquired block point QueryInMode IO r) IO a)
-> LocalStateQueryExpr
     block point QueryInMode r IO (Either UnsupportedNtcVersionError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT
  NodeToClientVersion
  (ContT (ClientStAcquired block point QueryInMode IO r) IO)
  a
-> LocalStateQueryExpr block point QueryInMode r IO a
forall block point (query :: * -> *) r (m :: * -> *) a.
ReaderT
  NodeToClientVersion
  (ContT (ClientStAcquired block point query m r) m)
  a
-> LocalStateQueryExpr block point query r m a
LocalStateQueryExpr (ReaderT
   NodeToClientVersion
   (ContT (ClientStAcquired block point QueryInMode IO r) IO)
   a
 -> LocalStateQueryExpr block point QueryInMode r IO a)
-> ((NodeToClientVersion
     -> ContT (ClientStAcquired block point QueryInMode IO r) IO a)
    -> ReaderT
         NodeToClientVersion
         (ContT (ClientStAcquired block point QueryInMode IO r) IO)
         a)
-> (NodeToClientVersion
    -> ContT (ClientStAcquired block point QueryInMode IO r) IO a)
-> LocalStateQueryExpr block point QueryInMode r IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeToClientVersion
 -> ContT (ClientStAcquired block point QueryInMode IO r) IO a)
-> ReaderT
     NodeToClientVersion
     (ContT (ClientStAcquired block point QueryInMode IO r) IO)
     a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((NodeToClientVersion
  -> ContT (ClientStAcquired block point QueryInMode IO r) IO a)
 -> LocalStateQueryExpr
      block point QueryInMode r IO (Either UnsupportedNtcVersionError a))
-> (NodeToClientVersion
    -> ContT (ClientStAcquired block point QueryInMode IO r) IO a)
-> LocalStateQueryExpr
     block point QueryInMode r IO (Either UnsupportedNtcVersionError a)
forall a b. (a -> b) -> a -> b
$ \NodeToClientVersion
_ -> QueryInMode a
-> ContT (ClientStAcquired block point QueryInMode IO r) IO a
forall (m :: * -> *) result block point a.
Applicative m =>
QueryInMode result
-> ContT (ClientStAcquired block point QueryInMode m a) m result
constructQueryContinuation QueryInMode a
q
    Left UnsupportedNtcVersionError
err -> Either UnsupportedNtcVersionError a
-> LocalStateQueryExpr
     block point QueryInMode r IO (Either UnsupportedNtcVersionError a)
forall a. a -> LocalStateQueryExpr block point QueryInMode r IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either UnsupportedNtcVersionError a
 -> LocalStateQueryExpr
      block point QueryInMode r IO (Either UnsupportedNtcVersionError a))
-> Either UnsupportedNtcVersionError a
-> LocalStateQueryExpr
     block point QueryInMode r IO (Either UnsupportedNtcVersionError a)
forall a b. (a -> b) -> a -> b
$ UnsupportedNtcVersionError -> Either UnsupportedNtcVersionError a
forall a b. a -> Either a b
Left UnsupportedNtcVersionError
err

{-  The client sends a query with the following data constructor:

data ClientStAcquired block point query m a where
  SendMsgQuery     :: query result
                   -> ClientStQuerying block point query m a result
                   -> ClientStAcquired block point query m a

The client is then awaiting a result from the server which is represented by:

data ClientStQuerying block point query m a result = ClientStQuerying {
      recvMsgResult :: result -> m (ClientStAcquired block point query m a)
    }

When constructing the `ClientStQuerying` value we can send another query (`SendMsgQuery`) or
release (`SendMsgRelease`) and this recursion is nicely modelled with the `ContT` monad transformer.

The final continuation in our case is waiting for all the queries to be returned and then returning
`SendMsgRelease`.
-}
constructQueryContinuation
  :: Applicative m
  => QueryInMode result
  -> ContT
       (Net.Query.ClientStAcquired block point QueryInMode m a)
       m
       result
constructQueryContinuation :: forall (m :: * -> *) result block point a.
Applicative m =>
QueryInMode result
-> ContT (ClientStAcquired block point QueryInMode m a) m result
constructQueryContinuation QueryInMode result
q = do
  ((result -> m (ClientStAcquired block point QueryInMode m a))
 -> m (ClientStAcquired block point QueryInMode m a))
-> ContT (ClientStAcquired block point QueryInMode m a) m result
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((result -> m (ClientStAcquired block point QueryInMode m a))
  -> m (ClientStAcquired block point QueryInMode m a))
 -> ContT (ClientStAcquired block point QueryInMode m a) m result)
-> ((result -> m (ClientStAcquired block point QueryInMode m a))
    -> m (ClientStAcquired block point QueryInMode m a))
-> ContT (ClientStAcquired block point QueryInMode m a) m result
forall a b. (a -> b) -> a -> b
$ \result -> m (ClientStAcquired block point QueryInMode m a)
final ->
    ClientStAcquired block point QueryInMode m a
-> m (ClientStAcquired block point QueryInMode m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStAcquired block point QueryInMode m a
 -> m (ClientStAcquired block point QueryInMode m a))
-> ClientStAcquired block point QueryInMode m a
-> m (ClientStAcquired block point QueryInMode m a)
forall a b. (a -> b) -> a -> b
$
      QueryInMode result
-> ClientStQuerying block point QueryInMode m a result
-> ClientStAcquired block point QueryInMode m a
forall (query :: * -> *) result block point (m :: * -> *) a.
query result
-> ClientStQuerying block point query m a result
-> ClientStAcquired block point query m a
Net.Query.SendMsgQuery QueryInMode result
q (ClientStQuerying block point QueryInMode m a result
 -> ClientStAcquired block point QueryInMode m a)
-> ClientStQuerying block point QueryInMode m a result
-> ClientStAcquired block point QueryInMode m a
forall a b. (a -> b) -> a -> b
$
        Net.Query.ClientStQuerying
          { recvMsgResult :: result -> m (ClientStAcquired block point QueryInMode m a)
Net.Query.recvMsgResult = result -> m (ClientStAcquired block point QueryInMode m a)
final
          }