{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE TypeFamilies      #-}

{-|
   This mock client has been used to test the PAB while we had no real node available.
   Since now we do, this will be phased out and eventually removed in favor of the
   `Cardano.Protocol.Socket.Client` module which connects to a real cardano node.
-}
module Cardano.Protocol.Socket.Mock.Client where

import Data.ByteString.Lazy qualified as LBS
import Data.Time.Units (Second, TimeUnit, toMicroseconds)
import Data.Void (Void)

import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad.Catch (catchAll)
import Control.Tracer

import Cardano.Api qualified as C

import Ouroboros.Network.Block (Point (..))
import Ouroboros.Network.Protocol.ChainSync.Client qualified as ChainSync
import Ouroboros.Network.Protocol.LocalTxSubmission.Client qualified as TxSubmission

import Cardano.Node.Emulator.TimeSlot (SlotConfig, currentSlot)
import Ouroboros.Network.IOManager
import Ouroboros.Network.Mux
import Ouroboros.Network.NodeToClient (NodeToClientProtocols (..), connectTo, versionedNodeToClientProtocols)
import Ouroboros.Network.Snocket
import Ouroboros.Network.Socket

import Cardano.Protocol.Socket.Client (ChainSyncHandle (..))
import Cardano.Protocol.Socket.Type
import Ledger (Block, Slot (..))

newtype TxSendHandle = TxSendHandle
    { TxSendHandle -> TQueue (Tx BabbageEra)
tshQueue :: TQueue (C.Tx C.BabbageEra) }

-- | Queue a transaction to be sent to the server.
queueTx ::
    TxSendHandle
 -> C.Tx C.BabbageEra
 -> IO ()
queueTx :: TxSendHandle -> Tx BabbageEra -> IO ()
queueTx TxSendHandle { TQueue (Tx BabbageEra)
tshQueue :: TQueue (Tx BabbageEra)
tshQueue :: TxSendHandle -> TQueue (Tx BabbageEra)
tshQueue } Tx BabbageEra
tx =
    STM () -> IO ()
forall a. STM a -> IO a
atomically (TQueue (Tx BabbageEra) -> Tx BabbageEra -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Tx BabbageEra)
tshQueue Tx BabbageEra
tx)

getCurrentSlot :: ChainSyncHandle Block -> IO Slot
getCurrentSlot :: ChainSyncHandle Block -> IO Slot
getCurrentSlot = ChainSyncHandle Block -> IO Slot
forall event. ChainSyncHandle event -> IO Slot
cshCurrentSlot

-- | Run the chain sync protocol to get access to the current slot number.
runChainSync' :: FilePath
              -> SlotConfig
              -> IO (ChainSyncHandle Block)
runChainSync' :: FilePath -> SlotConfig -> IO (ChainSyncHandle Block)
runChainSync' FilePath
socketPath SlotConfig
slotConfig =
  FilePath
-> SlotConfig
-> (Block -> Slot -> IO ())
-> IO (ChainSyncHandle Block)
runChainSync FilePath
socketPath SlotConfig
slotConfig (\Block
_ Slot
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

runChainSync :: FilePath
             -> SlotConfig
             -> (Block -> Slot -> IO ())
             -> IO (ChainSyncHandle Block)
runChainSync :: FilePath
-> SlotConfig
-> (Block -> Slot -> IO ())
-> IO (ChainSyncHandle Block)
runChainSync FilePath
socketPath SlotConfig
slotConfig Block -> Slot -> IO ()
onNewBlock = do
    let handle :: ChainSyncHandle Block
handle = ChainSyncHandle :: forall event.
IO Slot -> (event -> Slot -> IO ()) -> ChainSyncHandle event
ChainSyncHandle { cshCurrentSlot :: IO Slot
cshCurrentSlot = SlotConfig -> IO Slot
currentSlot SlotConfig
slotConfig
                                 , cshHandler :: Block -> Slot -> IO ()
cshHandler = Block -> Slot -> IO ()
onNewBlock
                                 }

    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (IOManager -> IO ()) -> IO ()
WithIOManager
withIOManager ((IOManager -> IO ()) -> IO ()) -> (IOManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Second -> ChainSyncHandle Block -> IOManager -> IO ()
forall a.
TimeUnit a =>
a -> ChainSyncHandle Block -> IOManager -> IO ()
loop (Second
1 :: Second) ChainSyncHandle Block
handle
    ChainSyncHandle Block -> IO (ChainSyncHandle Block)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainSyncHandle Block
handle
    where
      loop :: TimeUnit a => a -> ChainSyncHandle Block -> IOManager -> IO ()
      loop :: a -> ChainSyncHandle Block -> IOManager -> IO ()
loop a
timeout ch :: ChainSyncHandle Block
ch@ChainSyncHandle{ Block -> Slot -> IO ()
cshHandler :: Block -> Slot -> IO ()
cshHandler :: forall event. ChainSyncHandle event -> event -> Slot -> IO ()
cshHandler } IOManager
iocp = do
        IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchAll
          (LocalSnocket
-> NetworkConnectTracers LocalAddress NodeToClientVersion
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'InitiatorMode LocalAddress ByteString IO () Void)
-> FilePath
-> IO ()
forall a b.
LocalSnocket
-> NetworkConnectTracers LocalAddress NodeToClientVersion
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'InitiatorMode LocalAddress ByteString IO a b)
-> FilePath
-> IO ()
connectTo
            (IOManager -> LocalSnocket
localSnocket IOManager
iocp)
            NetworkConnectTracers LocalAddress NodeToClientVersion
forall addr vNumber. NetworkConnectTracers addr vNumber
nullNetworkConnectTracers
            (NodeToClientVersion
-> NodeToClientVersionData
-> (ConnectionId LocalAddress
    -> STM IO ControlMessage
    -> NodeToClientProtocols 'InitiatorMode ByteString IO () Void)
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'InitiatorMode LocalAddress ByteString IO () Void)
forall (m :: * -> *) (appType :: MuxMode) bytes a b.
NodeToClientVersion
-> NodeToClientVersionData
-> (ConnectionId LocalAddress
    -> STM m ControlMessage
    -> NodeToClientProtocols appType bytes m a b)
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication appType LocalAddress bytes m a b)
versionedNodeToClientProtocols
              NodeToClientVersion
nodeToClientVersion
              NodeToClientVersionData
nodeToClientVersionData
              (\ConnectionId LocalAddress
_ STM IO ControlMessage
_ -> (Block -> Slot -> IO ())
-> NodeToClientProtocols 'InitiatorMode ByteString IO () Void
nodeToClientProtocols Block -> Slot -> IO ()
cshHandler))
            FilePath
socketPath)
          {- If we receive any error or disconnect, try to reconnect.
             This happens a lot on startup, until the server starts. -}
          (\SomeException
_ -> do
               Int -> IO ()
threadDelay (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a. TimeUnit a => a -> Integer
toMicroseconds a
timeout)
               a -> ChainSyncHandle Block -> IOManager -> IO ()
forall a.
TimeUnit a =>
a -> ChainSyncHandle Block -> IOManager -> IO ()
loop a
timeout ChainSyncHandle Block
ch IOManager
iocp)

      nodeToClientProtocols
        :: (Block -> Slot -> IO ())
        -> NodeToClientProtocols 'InitiatorMode LBS.ByteString IO () Void
      nodeToClientProtocols :: (Block -> Slot -> IO ())
-> NodeToClientProtocols 'InitiatorMode ByteString IO () Void
nodeToClientProtocols Block -> Slot -> IO ()
blockHandler =
        NodeToClientProtocols :: forall (appType :: MuxMode) bytes (m :: * -> *) a b.
RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> NodeToClientProtocols appType bytes m a b
NodeToClientProtocols
          { localChainSyncProtocol :: RunMiniProtocol 'InitiatorMode ByteString IO () Void
localChainSyncProtocol = (Block -> Slot -> IO ())
-> RunMiniProtocol 'InitiatorMode ByteString IO () Void
chainSync Block -> Slot -> IO ()
blockHandler
          , localTxSubmissionProtocol :: RunMiniProtocol 'InitiatorMode ByteString IO () Void
localTxSubmissionProtocol = RunMiniProtocol 'InitiatorMode ByteString IO () Void
forall (m :: * -> *) a.
MonadTimer m =>
RunMiniProtocol 'InitiatorMode ByteString m a Void
doNothingInitiatorProtocol
          , localStateQueryProtocol :: RunMiniProtocol 'InitiatorMode ByteString IO () Void
localStateQueryProtocol = RunMiniProtocol 'InitiatorMode ByteString IO () Void
forall (m :: * -> *) a.
MonadTimer m =>
RunMiniProtocol 'InitiatorMode ByteString m a Void
doNothingInitiatorProtocol
          , localTxMonitorProtocol :: RunMiniProtocol 'InitiatorMode ByteString IO () Void
localTxMonitorProtocol = RunMiniProtocol 'InitiatorMode ByteString IO () Void
forall (m :: * -> *) a.
MonadTimer m =>
RunMiniProtocol 'InitiatorMode ByteString m a Void
doNothingInitiatorProtocol
          }

      chainSync :: (Block -> Slot -> IO ())
                -> RunMiniProtocol 'InitiatorMode LBS.ByteString IO () Void
      chainSync :: (Block -> Slot -> IO ())
-> RunMiniProtocol 'InitiatorMode ByteString IO () Void
chainSync Block -> Slot -> IO ()
onNewBlock' =
          MuxPeer ByteString IO ()
-> RunMiniProtocol 'InitiatorMode ByteString IO () Void
forall bytes (m :: * -> *) a.
MuxPeer bytes m a -> RunMiniProtocol 'InitiatorMode bytes m a Void
InitiatorProtocolOnly (MuxPeer ByteString IO ()
 -> RunMiniProtocol 'InitiatorMode ByteString IO () Void)
-> MuxPeer ByteString IO ()
-> RunMiniProtocol 'InitiatorMode ByteString IO () Void
forall a b. (a -> b) -> a -> b
$
          Tracer IO (TraceSendRecv (ChainSync Block (Point Block) Block))
-> Codec
     (ChainSync Block (Point Block) Block)
     DeserialiseFailure
     IO
     ByteString
-> Peer
     (ChainSync Block (Point Block) Block) 'AsClient 'StIdle IO ()
-> MuxPeer ByteString IO ()
forall (pr :: PeerRole) ps (st :: ps) failure bytes (m :: * -> *)
       a.
(Show failure, forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr st m a
-> MuxPeer bytes m a
MuxPeer
            Tracer IO (TraceSendRecv (ChainSync Block (Point Block) Block))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
            Codec
  (ChainSync Block (Point Block) Block)
  DeserialiseFailure
  IO
  ByteString
forall block.
(Serialise block, Serialise (HeaderHash block)) =>
Codec
  (ChainSync block (Point block) Block)
  DeserialiseFailure
  IO
  ByteString
chainSyncCodec
            (ChainSyncClient Block (Point Block) Block IO ()
-> Peer
     (ChainSync Block (Point Block) Block) 'AsClient 'StIdle IO ()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncClient header point tip m a
-> Peer (ChainSync header point tip) 'AsClient 'StIdle m a
ChainSync.chainSyncClientPeer
               (SlotConfig
-> (Block -> Slot -> IO ())
-> ChainSyncClient Block (Point Block) Block IO ()
chainSyncClient SlotConfig
slotConfig Block -> Slot -> IO ()
onNewBlock'))

-- | The client updates the application state when the protocol state changes.
chainSyncClient :: SlotConfig
                -> (Block -> Slot -> IO ())
                -> ChainSync.ChainSyncClient Block (Point Block) Tip IO ()
chainSyncClient :: SlotConfig
-> (Block -> Slot -> IO ())
-> ChainSyncClient Block (Point Block) Block IO ()
chainSyncClient SlotConfig
slotConfig Block -> Slot -> IO ()
onNewBlock =
    IO (ClientStIdle Block (Point Block) Block IO ())
-> ChainSyncClient Block (Point Block) Block IO ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSync.ChainSyncClient (IO (ClientStIdle Block (Point Block) Block IO ())
 -> ChainSyncClient Block (Point Block) Block IO ())
-> IO (ClientStIdle Block (Point Block) Block IO ())
-> ChainSyncClient Block (Point Block) Block IO ()
forall a b. (a -> b) -> a -> b
$ ClientStIdle Block (Point Block) Block IO ()
-> IO (ClientStIdle Block (Point Block) Block IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle Block (Point Block) Block IO ()
requestNext
    where
      requestNext :: ChainSync.ClientStIdle Block (Point Block) Tip IO ()
      requestNext :: ClientStIdle Block (Point Block) Block IO ()
requestNext =
        ClientStNext Block (Point Block) Block IO ()
-> IO (ClientStNext Block (Point Block) Block IO ())
-> ClientStIdle Block (Point Block) Block 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
ChainSync.SendMsgRequestNext
          ClientStNext Block (Point Block) Block IO ()
handleNext
          (ClientStNext Block (Point Block) Block IO ()
-> IO (ClientStNext Block (Point Block) Block IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ClientStNext Block (Point Block) Block IO ()
handleNext)

      handleNext :: ChainSync.ClientStNext Block (Point Block) Tip IO ()
      handleNext :: ClientStNext Block (Point Block) Block IO ()
handleNext =
        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
ChainSync.ClientStNext
        {
          recvMsgRollForward :: Block -> Block -> ChainSyncClient Block (Point Block) Block IO ()
ChainSync.recvMsgRollForward  = \Block
block Block
_ ->
            IO (ClientStIdle Block (Point Block) Block IO ())
-> ChainSyncClient Block (Point Block) Block IO ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSync.ChainSyncClient (IO (ClientStIdle Block (Point Block) Block IO ())
 -> ChainSyncClient Block (Point Block) Block IO ())
-> IO (ClientStIdle Block (Point Block) Block IO ())
-> ChainSyncClient Block (Point Block) Block IO ()
forall a b. (a -> b) -> a -> b
$ do
              Slot
slot <- SlotConfig -> IO Slot
currentSlot SlotConfig
slotConfig
              Block -> Slot -> IO ()
onNewBlock Block
block Slot
slot
              ClientStIdle Block (Point Block) Block IO ()
-> IO (ClientStIdle Block (Point Block) Block IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ClientStIdle Block (Point Block) Block IO ()
requestNext
        , recvMsgRollBackward :: Point Block
-> Block -> ChainSyncClient Block (Point Block) Block IO ()
ChainSync.recvMsgRollBackward = FilePath
-> Point Block
-> Block
-> ChainSyncClient Block (Point Block) Block IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"Not supported."
        }

runTxSender :: FilePath
            -> IO TxSendHandle
runTxSender :: FilePath -> IO TxSendHandle
runTxSender FilePath
socketPath = do
    TQueue (Tx BabbageEra)
inputQueue  <- IO (TQueue (Tx BabbageEra))
forall a. IO (TQueue a)
newTQueueIO
    let handle :: TxSendHandle
handle = TxSendHandle :: TQueue (Tx BabbageEra) -> TxSendHandle
TxSendHandle { tshQueue :: TQueue (Tx BabbageEra)
tshQueue = TQueue (Tx BabbageEra)
inputQueue }

    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (IOManager -> IO ()) -> IO ()
WithIOManager
withIOManager ((IOManager -> IO ()) -> IO ()) -> (IOManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Second -> TxSendHandle -> IOManager -> IO ()
forall a. TimeUnit a => a -> TxSendHandle -> IOManager -> IO ()
loop (Second
1 :: Second) TxSendHandle
handle
    TxSendHandle -> IO TxSendHandle
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxSendHandle
handle
    where
      loop :: TimeUnit a => a -> TxSendHandle -> IOManager -> IO ()
      loop :: a -> TxSendHandle -> IOManager -> IO ()
loop a
timeout ch :: TxSendHandle
ch@TxSendHandle{ TQueue (Tx BabbageEra)
tshQueue :: TQueue (Tx BabbageEra)
tshQueue :: TxSendHandle -> TQueue (Tx BabbageEra)
tshQueue } IOManager
iocp = do
        IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchAll
          (LocalSnocket
-> NetworkConnectTracers LocalAddress NodeToClientVersion
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'InitiatorMode LocalAddress ByteString IO () Void)
-> FilePath
-> IO ()
forall a b.
LocalSnocket
-> NetworkConnectTracers LocalAddress NodeToClientVersion
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'InitiatorMode LocalAddress ByteString IO a b)
-> FilePath
-> IO ()
connectTo
            (IOManager -> LocalSnocket
localSnocket IOManager
iocp)
            NetworkConnectTracers LocalAddress NodeToClientVersion
forall addr vNumber. NetworkConnectTracers addr vNumber
nullNetworkConnectTracers
            (NodeToClientVersion
-> NodeToClientVersionData
-> (ConnectionId LocalAddress
    -> STM IO ControlMessage
    -> NodeToClientProtocols 'InitiatorMode ByteString IO () Void)
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'InitiatorMode LocalAddress ByteString IO () Void)
forall (m :: * -> *) (appType :: MuxMode) bytes a b.
NodeToClientVersion
-> NodeToClientVersionData
-> (ConnectionId LocalAddress
    -> STM m ControlMessage
    -> NodeToClientProtocols appType bytes m a b)
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication appType LocalAddress bytes m a b)
versionedNodeToClientProtocols
              NodeToClientVersion
nodeToClientVersion
              NodeToClientVersionData
nodeToClientVersionData
              (\ConnectionId LocalAddress
_ STM IO ControlMessage
_ -> TQueue (Tx BabbageEra)
-> NodeToClientProtocols 'InitiatorMode ByteString IO () Void
nodeToClientProtocols TQueue (Tx BabbageEra)
tshQueue))
            FilePath
socketPath)
          {- If we receive any error or disconnect, try to reconnect.
             This happens a lot on startup, until the server starts. -}
          (\SomeException
_ -> do
               Int -> IO ()
threadDelay (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a. TimeUnit a => a -> Integer
toMicroseconds a
timeout)
               a -> TxSendHandle -> IOManager -> IO ()
forall a. TimeUnit a => a -> TxSendHandle -> IOManager -> IO ()
loop a
timeout TxSendHandle
ch IOManager
iocp)

      nodeToClientProtocols
        :: TQueue (C.Tx C.BabbageEra)
        -> NodeToClientProtocols 'InitiatorMode LBS.ByteString IO () Void
      nodeToClientProtocols :: TQueue (Tx BabbageEra)
-> NodeToClientProtocols 'InitiatorMode ByteString IO () Void
nodeToClientProtocols TQueue (Tx BabbageEra)
sendQueue =
        NodeToClientProtocols :: forall (appType :: MuxMode) bytes (m :: * -> *) a b.
RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> NodeToClientProtocols appType bytes m a b
NodeToClientProtocols
          { localChainSyncProtocol :: RunMiniProtocol 'InitiatorMode ByteString IO () Void
localChainSyncProtocol = RunMiniProtocol 'InitiatorMode ByteString IO () Void
forall (m :: * -> *) a.
MonadTimer m =>
RunMiniProtocol 'InitiatorMode ByteString m a Void
doNothingInitiatorProtocol
          , localTxSubmissionProtocol :: RunMiniProtocol 'InitiatorMode ByteString IO () Void
localTxSubmissionProtocol = TQueue (Tx BabbageEra)
-> RunMiniProtocol 'InitiatorMode ByteString IO () Void
txSubmission TQueue (Tx BabbageEra)
sendQueue
          , localStateQueryProtocol :: RunMiniProtocol 'InitiatorMode ByteString IO () Void
localStateQueryProtocol = RunMiniProtocol 'InitiatorMode ByteString IO () Void
forall (m :: * -> *) a.
MonadTimer m =>
RunMiniProtocol 'InitiatorMode ByteString m a Void
doNothingInitiatorProtocol
          , localTxMonitorProtocol :: RunMiniProtocol 'InitiatorMode ByteString IO () Void
localTxMonitorProtocol = RunMiniProtocol 'InitiatorMode ByteString IO () Void
forall (m :: * -> *) a.
MonadTimer m =>
RunMiniProtocol 'InitiatorMode ByteString m a Void
doNothingInitiatorProtocol
          }

      txSubmission :: TQueue (C.Tx C.BabbageEra)
                   -> RunMiniProtocol 'InitiatorMode LBS.ByteString IO () Void
      txSubmission :: TQueue (Tx BabbageEra)
-> RunMiniProtocol 'InitiatorMode ByteString IO () Void
txSubmission TQueue (Tx BabbageEra)
inputQueue =
          MuxPeer ByteString IO ()
-> RunMiniProtocol 'InitiatorMode ByteString IO () Void
forall bytes (m :: * -> *) a.
MuxPeer bytes m a -> RunMiniProtocol 'InitiatorMode bytes m a Void
InitiatorProtocolOnly (MuxPeer ByteString IO ()
 -> RunMiniProtocol 'InitiatorMode ByteString IO () Void)
-> MuxPeer ByteString IO ()
-> RunMiniProtocol 'InitiatorMode ByteString IO () Void
forall a b. (a -> b) -> a -> b
$
          Tracer
  IO (TraceSendRecv (LocalTxSubmission (Tx BabbageEra) FilePath))
-> Codec
     (LocalTxSubmission (Tx BabbageEra) FilePath)
     DeserialiseFailure
     IO
     ByteString
-> Peer
     (LocalTxSubmission (Tx BabbageEra) FilePath)
     'AsClient
     'StIdle
     IO
     ()
-> MuxPeer ByteString IO ()
forall (pr :: PeerRole) ps (st :: ps) failure bytes (m :: * -> *)
       a.
(Show failure, forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr st m a
-> MuxPeer bytes m a
MuxPeer
            Tracer
  IO (TraceSendRecv (LocalTxSubmission (Tx BabbageEra) FilePath))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
            Codec
  (LocalTxSubmission (Tx BabbageEra) FilePath)
  DeserialiseFailure
  IO
  ByteString
txSubmissionCodec
            (LocalTxSubmissionClient (Tx BabbageEra) FilePath IO ()
-> Peer
     (LocalTxSubmission (Tx BabbageEra) FilePath)
     'AsClient
     'StIdle
     IO
     ()
forall tx reject (m :: * -> *) a.
Monad m =>
LocalTxSubmissionClient tx reject m a
-> Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a
TxSubmission.localTxSubmissionClientPeer
               (TQueue (Tx BabbageEra)
-> LocalTxSubmissionClient (Tx BabbageEra) FilePath IO ()
txSubmissionClient TQueue (Tx BabbageEra)
inputQueue))

-- | The client updates the application state when the protocol state changes.
txSubmissionClient :: TQueue (C.Tx C.BabbageEra)
                   -> TxSubmission.LocalTxSubmissionClient (C.Tx C.BabbageEra) String IO ()
txSubmissionClient :: TQueue (Tx BabbageEra)
-> LocalTxSubmissionClient (Tx BabbageEra) FilePath IO ()
txSubmissionClient TQueue (Tx BabbageEra)
txQueue =
    IO (LocalTxClientStIdle (Tx BabbageEra) FilePath IO ())
-> LocalTxSubmissionClient (Tx BabbageEra) FilePath IO ()
forall tx reject (m :: * -> *) a.
m (LocalTxClientStIdle tx reject m a)
-> LocalTxSubmissionClient tx reject m a
TxSubmission.LocalTxSubmissionClient IO (LocalTxClientStIdle (Tx BabbageEra) FilePath IO ())
pushTxs
    where
      pushTxs :: IO (TxSubmission.LocalTxClientStIdle (C.Tx C.BabbageEra) String IO ())
      pushTxs :: IO (LocalTxClientStIdle (Tx BabbageEra) FilePath IO ())
pushTxs = do
        Tx BabbageEra
header <- STM (Tx BabbageEra) -> IO (Tx BabbageEra)
forall a. STM a -> IO a
atomically (STM (Tx BabbageEra) -> IO (Tx BabbageEra))
-> STM (Tx BabbageEra) -> IO (Tx BabbageEra)
forall a b. (a -> b) -> a -> b
$ TQueue (Tx BabbageEra) -> STM (Tx BabbageEra)
forall a. TQueue a -> STM a
readTQueue TQueue (Tx BabbageEra)
txQueue
        LocalTxClientStIdle (Tx BabbageEra) FilePath IO ()
-> IO (LocalTxClientStIdle (Tx BabbageEra) FilePath IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalTxClientStIdle (Tx BabbageEra) FilePath IO ()
 -> IO (LocalTxClientStIdle (Tx BabbageEra) FilePath IO ()))
-> LocalTxClientStIdle (Tx BabbageEra) FilePath IO ()
-> IO (LocalTxClientStIdle (Tx BabbageEra) FilePath IO ())
forall a b. (a -> b) -> a -> b
$ Tx BabbageEra
-> (SubmitResult FilePath
    -> IO (LocalTxClientStIdle (Tx BabbageEra) FilePath IO ()))
-> LocalTxClientStIdle (Tx BabbageEra) FilePath IO ()
forall tx reject (m :: * -> *) a.
tx
-> (SubmitResult reject -> m (LocalTxClientStIdle tx reject m a))
-> LocalTxClientStIdle tx reject m a
TxSubmission.SendMsgSubmitTx
                   Tx BabbageEra
header
                   (IO (LocalTxClientStIdle (Tx BabbageEra) FilePath IO ())
-> SubmitResult FilePath
-> IO (LocalTxClientStIdle (Tx BabbageEra) FilePath IO ())
forall a b. a -> b -> a
const IO (LocalTxClientStIdle (Tx BabbageEra) FilePath IO ())
pushTxs) -- ignore rejects for now