{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cardano.Api.LocalChainSync
( getLocalTip
) where
import Cardano.Prelude hiding (atomically, catch)
import Cardano.Api.Typed
import Control.Concurrent.STM
import Ouroboros.Consensus.Ledger.Query (Query, ShowQuery)
import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx)
import Ouroboros.Network.Block (Point, Tip)
import Ouroboros.Network.Protocol.ChainSync.Client (ClientStIdle (..),
ClientStNext (..))
import Ouroboros.Network.Util.ShowProxy (ShowProxy)
getLocalTip :: (ShowProxy block, ShowProxy (ApplyTxErr block),
ShowProxy (Query block), ShowProxy (GenTx block),
ShowQuery (Query block))
=> LocalNodeConnectInfo mode block -> IO (Tip block)
getLocalTip :: LocalNodeConnectInfo mode block -> IO (Tip block)
getLocalTip LocalNodeConnectInfo mode block
connctInfo = do
TMVar (Tip block)
resultVar <- IO (TMVar (Tip block))
forall a. IO (TMVar a)
newEmptyTMVarIO
LocalNodeConnectInfo mode block
-> LocalNodeClientProtocols block -> IO ()
forall mode block.
(ShowProxy block, ShowProxy (ApplyTxErr block),
ShowProxy (Query block), ShowProxy (GenTx block),
ShowQuery (Query block)) =>
LocalNodeConnectInfo mode block
-> LocalNodeClientProtocols block -> IO ()
connectToLocalNode
LocalNodeConnectInfo mode block
connctInfo
LocalNodeClientProtocols block
forall block. LocalNodeClientProtocols block
nullLocalNodeClientProtocols {
localChainSyncClient :: Maybe (ChainSyncClient block (Point block) (Tip block) IO ())
localChainSyncClient = ChainSyncClient block (Point block) (Tip block) IO ()
-> Maybe (ChainSyncClient block (Point block) (Tip block) IO ())
forall a. a -> Maybe a
Just (TMVar (Tip block)
-> ChainSyncClient block (Point block) (Tip block) IO ()
forall blk.
TMVar (Tip blk) -> ChainSyncClient blk (Point blk) (Tip blk) IO ()
chainSyncGetCurrentTip TMVar (Tip block)
resultVar)
}
STM (Tip block) -> IO (Tip block)
forall a. STM a -> IO a
atomically (TMVar (Tip block) -> STM (Tip block)
forall a. TMVar a -> STM a
takeTMVar TMVar (Tip block)
resultVar)
chainSyncGetCurrentTip :: forall blk.
TMVar (Tip blk)
-> ChainSyncClient blk (Point blk) (Tip blk) IO ()
chainSyncGetCurrentTip :: TMVar (Tip blk) -> ChainSyncClient blk (Point blk) (Tip blk) IO ()
chainSyncGetCurrentTip TMVar (Tip blk)
tipVar =
IO (ClientStIdle blk (Point blk) (Tip blk) IO ())
-> ChainSyncClient blk (Point blk) (Tip blk) IO ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (ClientStIdle blk (Point blk) (Tip blk) IO ()
-> IO (ClientStIdle blk (Point blk) (Tip blk) IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle blk (Point blk) (Tip blk) IO ()
clientStIdle)
where
clientStIdle :: ClientStIdle blk (Point blk) (Tip blk) IO ()
clientStIdle :: ClientStIdle blk (Point blk) (Tip blk) IO ()
clientStIdle =
ClientStNext blk (Point blk) (Tip blk) IO ()
-> IO (ClientStNext blk (Point blk) (Tip blk) IO ())
-> ClientStIdle blk (Point blk) (Tip blk) IO ()
forall header point tip (m :: * -> *) a.
ClientStNext header point tip m a
-> m (ClientStNext header point tip m a)
-> ClientStIdle header point tip m a
SendMsgRequestNext ClientStNext blk (Point blk) (Tip blk) IO ()
clientStNext (ClientStNext blk (Point blk) (Tip blk) IO ()
-> IO (ClientStNext blk (Point blk) (Tip blk) IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStNext blk (Point blk) (Tip blk) IO ()
clientStNext)
clientStNext :: ClientStNext blk (Point blk) (Tip blk) IO ()
clientStNext :: ClientStNext blk (Point blk) (Tip blk) IO ()
clientStNext = ClientStNext :: forall header point tip (m :: * -> *) a.
(header -> tip -> ChainSyncClient header point tip m a)
-> (point -> tip -> ChainSyncClient header point tip m a)
-> ClientStNext header point tip m a
ClientStNext
{ recvMsgRollForward :: blk -> Tip blk -> ChainSyncClient blk (Point blk) (Tip blk) IO ()
recvMsgRollForward = \blk
_blk Tip blk
tip -> IO (ClientStIdle blk (Point blk) (Tip blk) IO ())
-> ChainSyncClient blk (Point blk) (Tip blk) IO ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (IO (ClientStIdle blk (Point blk) (Tip blk) IO ())
-> ChainSyncClient blk (Point blk) (Tip blk) IO ())
-> IO (ClientStIdle blk (Point blk) (Tip blk) IO ())
-> ChainSyncClient blk (Point blk) (Tip blk) IO ()
forall a b. (a -> b) -> a -> b
$ do
IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar (Tip blk) -> Tip blk -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Tip blk)
tipVar Tip blk
tip
ClientStIdle blk (Point blk) (Tip blk) IO ()
-> IO (ClientStIdle blk (Point blk) (Tip blk) IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStIdle blk (Point blk) (Tip blk) IO ()
-> IO (ClientStIdle blk (Point blk) (Tip blk) IO ()))
-> ClientStIdle blk (Point blk) (Tip blk) IO ()
-> IO (ClientStIdle blk (Point blk) (Tip blk) IO ())
forall a b. (a -> b) -> a -> b
$ () -> ClientStIdle blk (Point blk) (Tip blk) IO ()
forall a header point tip (m :: * -> *).
a -> ClientStIdle header point tip m a
SendMsgDone ()
, recvMsgRollBackward :: Point blk
-> Tip blk -> ChainSyncClient blk (Point blk) (Tip blk) IO ()
recvMsgRollBackward = \Point blk
_point Tip blk
tip -> IO (ClientStIdle blk (Point blk) (Tip blk) IO ())
-> ChainSyncClient blk (Point blk) (Tip blk) IO ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (IO (ClientStIdle blk (Point blk) (Tip blk) IO ())
-> ChainSyncClient blk (Point blk) (Tip blk) IO ())
-> IO (ClientStIdle blk (Point blk) (Tip blk) IO ())
-> ChainSyncClient blk (Point blk) (Tip blk) IO ()
forall a b. (a -> b) -> a -> b
$ do
IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar (Tip blk) -> Tip blk -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Tip blk)
tipVar Tip blk
tip
ClientStIdle blk (Point blk) (Tip blk) IO ()
-> IO (ClientStIdle blk (Point blk) (Tip blk) IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStIdle blk (Point blk) (Tip blk) IO ()
-> IO (ClientStIdle blk (Point blk) (Tip blk) IO ()))
-> ClientStIdle blk (Point blk) (Tip blk) IO ()
-> IO (ClientStIdle blk (Point blk) (Tip blk) IO ())
forall a b. (a -> b) -> a -> b
$ () -> ClientStIdle blk (Point blk) (Tip blk) IO ()
forall a header point tip (m :: * -> *).
a -> ClientStIdle header point tip m a
SendMsgDone ()
}