-- | Ouroboros-based implementation of 'Hydra.Network' interface.
-- This implements a dumb 'FireForget' protocol and maintains one connection to each peer.
-- Contrary to other protocols implemented in Ouroboros, this is a push-based protocol.
module Hydra.Network.Ouroboros (
  withOuroborosNetwork,
  withIOManager,
  TraceOuroborosNetwork,
  WithHost,
  module Hydra.Network,
  encodeTraceSendRecvFireForget,
) where

import Control.Monad.Class.MonadAsync (wait)
import Hydra.Prelude

import Codec.CBOR.Term (Term)
import Codec.CBOR.Term qualified as CBOR
import Control.Concurrent.STM (
  TChan,
  dupTChan,
  newBroadcastTChanIO,
  readTChan,
  writeTChan,
 )
import Control.Exception (IOException)
import Data.Aeson (object, withObject, (.:), (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Types qualified as Aeson
import Data.Map.Strict as Map
import Hydra.Logging (Tracer, nullTracer)
import Hydra.Network (
  Host (..),
  Network (..),
  NetworkCallback,
  NetworkComponent,
  PortNumber,
 )
import Hydra.Network.Ouroboros.Client as FireForget (
  FireForgetClient (..),
  fireForgetClientPeer,
 )
import Hydra.Network.Ouroboros.Server as FireForget (
  FireForgetServer (..),
  fireForgetServerPeer,
 )
import Hydra.Network.Ouroboros.Type (
  FireForget (..),
  Message (..),
  codecFireForget,
 )
import Network.Mux.Compat (
  WithMuxBearer (..),
 )
import Network.Socket (
  AddrInfo (addrAddress),
  SockAddr,
  defaultHints,
  getAddrInfo,
 )
import Network.TypedProtocol.Codec (
  AnyMessageAndAgency (..),
 )
import Network.TypedProtocol.Pipelined ()
import Ouroboros.Network.Driver.Simple (
  TraceSendRecv (..),
 )
import Ouroboros.Network.ErrorPolicy (
  ErrorPolicyTrace,
  WithAddr (WithAddr),
  nullErrorPolicies,
 )
import Ouroboros.Network.IOManager (withIOManager)
import Ouroboros.Network.Mux (
  MiniProtocol (
    MiniProtocol,
    miniProtocolLimits,
    miniProtocolNum,
    miniProtocolRun
  ),
  MiniProtocolCb,
  MiniProtocolLimits (..),
  MiniProtocolNum (MiniProtocolNum),
  MuxMode (..),
  OuroborosApplication (..),
  OuroborosApplicationWithMinimalCtx,
  RunMiniProtocol (..),
  mkMiniProtocolCbFromPeer,
 )
import Ouroboros.Network.Protocol.Handshake.Codec (noTimeLimitsHandshake)
import Ouroboros.Network.Protocol.Handshake.Type (Handshake, Message (..), RefuseReason (..))
import Ouroboros.Network.Protocol.Handshake.Unversioned (
  UnversionedProtocol,
  unversionedHandshakeCodec,
  unversionedProtocol,
  unversionedProtocolDataCodec,
 )
import Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion, queryVersion)
import Ouroboros.Network.Server.Socket (AcceptedConnectionsLimit (AcceptedConnectionsLimit))
import Ouroboros.Network.Snocket (makeSocketBearer, socketSnocket)
import Ouroboros.Network.Socket (
  AcceptConnectionsPolicyTrace,
  ConnectionId (..),
  HandshakeCallbacks (..),
  NetworkConnectTracers (..),
  NetworkServerTracers (..),
  SomeResponderApplication (..),
  connectToNodeSocket,
  newNetworkMutableState,
  withServerNode,
 )
import Ouroboros.Network.Subscription (
  IPSubscriptionTarget (IPSubscriptionTarget),
  SubscriptionTrace,
  WithIPList,
 )
import Ouroboros.Network.Subscription qualified as Subscription
import Ouroboros.Network.Subscription.Ip (SubscriptionParams (..), WithIPList (WithIPList))
import Ouroboros.Network.Subscription.Worker (LocalAddresses (LocalAddresses))

withOuroborosNetwork ::
  forall msg.
  (ToCBOR msg, FromCBOR msg) =>
  Tracer IO (WithHost (TraceOuroborosNetwork msg)) ->
  Host ->
  [Host] ->
  NetworkComponent IO msg msg ()
withOuroborosNetwork :: forall msg.
(ToCBOR msg, FromCBOR msg) =>
Tracer IO (WithHost (TraceOuroborosNetwork msg))
-> Host -> [Host] -> NetworkComponent IO msg msg ()
withOuroborosNetwork Tracer IO (WithHost (TraceOuroborosNetwork msg))
tracer Host
localHost [Host]
remoteHosts NetworkCallback msg IO
networkCallback Network IO msg -> IO ()
between = do
  TChan msg
bchan <- IO (TChan msg)
forall a. IO (TChan a)
newBroadcastTChanIO
  let newBroadcastChannel :: IO (TChan msg)
newBroadcastChannel = STM IO (TChan msg) -> IO (TChan msg)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (TChan msg) -> IO (TChan msg))
-> STM IO (TChan msg) -> IO (TChan msg)
forall a b. (a -> b) -> a -> b
$ TChan msg -> STM (TChan msg)
forall a. TChan a -> STM (TChan a)
dupTChan TChan msg
bchan
  -- NOTE: There should only be one `IOManager` instance per process. Should we
  -- want to use ouroboros network framework in other places, we must factor out
  -- this instantiation
  (IOManager -> IO ()) -> IO ()
WithIOManager
withIOManager ((IOManager -> IO ()) -> IO ()) -> (IOManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOManager
iomgr -> do
    IOManager
-> OuroborosApplicationWithMinimalCtx
     'ResponderMode SockAddr ByteString IO Void ()
-> IO ()
-> IO ()
withServerListening IOManager
iomgr OuroborosApplicationWithMinimalCtx
  'ResponderMode SockAddr ByteString IO Void ()
forall addr.
OuroborosApplicationWithMinimalCtx
  'ResponderMode addr ByteString IO Void ()
hydraServer (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      IO Void -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m ()
race_ (IOManager
-> IO (TChan msg)
-> (TChan msg
    -> OuroborosApplicationWithMinimalCtx
         'InitiatorMode SockAddr ByteString IO () Void)
-> IO Void
connect IOManager
iomgr IO (TChan msg)
newBroadcastChannel TChan msg
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode SockAddr ByteString IO () Void
forall addr.
TChan msg
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode addr ByteString IO () Void
hydraClient) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Network IO msg -> IO ()
between (Network IO msg -> IO ()) -> Network IO msg -> IO ()
forall a b. (a -> b) -> a -> b
$
          Network
            { $sel:broadcast:Network :: NetworkCallback msg IO
broadcast = STM () -> IO ()
STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM () -> IO ()) -> (msg -> STM ()) -> NetworkCallback msg IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan msg -> msg -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan msg
bchan
            }
 where
  resolveSockAddr :: Host -> IO SockAddr
resolveSockAddr Host{Text
hostname :: Text
$sel:hostname:Host :: Host -> Text
hostname, PortNumber
port :: PortNumber
$sel:port:Host :: Host -> PortNumber
port} = do
    [AddrInfo]
is <- Maybe AddrInfo
-> Maybe ServiceName -> Maybe ServiceName -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
defaultHints) (ServiceName -> Maybe ServiceName
forall a. a -> Maybe a
Just (ServiceName -> Maybe ServiceName)
-> ServiceName -> Maybe ServiceName
forall a b. (a -> b) -> a -> b
$ Text -> ServiceName
forall a. ToString a => a -> ServiceName
toString Text
hostname) (ServiceName -> Maybe ServiceName
forall a. a -> Maybe a
Just (ServiceName -> Maybe ServiceName)
-> ServiceName -> Maybe ServiceName
forall a b. (a -> b) -> a -> b
$ PortNumber -> ServiceName
forall b a. (Show a, IsString b) => a -> b
show PortNumber
port)
    case [AddrInfo]
is of
      (AddrInfo
info : [AddrInfo]
_) -> SockAddr -> IO SockAddr
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SockAddr -> IO SockAddr) -> SockAddr -> IO SockAddr
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
addrAddress AddrInfo
info
      [AddrInfo]
_ -> Text -> IO SockAddr
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"getAdrrInfo failed.. do proper error handling"

  connect :: IOManager
-> IO (TChan msg)
-> (TChan msg
    -> OuroborosApplicationWithMinimalCtx
         'InitiatorMode SockAddr ByteString IO () Void)
-> IO Void
connect IOManager
iomgr IO (TChan msg)
newBroadcastChannel TChan msg
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode SockAddr ByteString IO () Void
app = do
    -- REVIEW(SN): move outside to have this information available?
    NetworkMutableState SockAddr
networkState <- IO (NetworkMutableState SockAddr)
forall addr. IO (NetworkMutableState addr)
newNetworkMutableState
    -- Using port number 0 to let the operating system pick a random port
    SockAddr
localAddr <- Host -> IO SockAddr
resolveSockAddr Host
localHost{port = 0}
    [SockAddr]
remoteAddrs <- [Host] -> (Host -> IO SockAddr) -> IO [SockAddr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Host]
remoteHosts Host -> IO SockAddr
resolveSockAddr
    let sn :: SocketSnocket
sn = IOManager -> SocketSnocket
socketSnocket IOManager
iomgr
    SocketSnocket
-> Tracer IO (WithIPList (SubscriptionTrace SockAddr))
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
-> NetworkMutableState SockAddr
-> IPSubscriptionParams ()
-> (Socket -> IO ())
-> IO Void
forall a.
SocketSnocket
-> Tracer IO (WithIPList (SubscriptionTrace SockAddr))
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
-> NetworkMutableState SockAddr
-> IPSubscriptionParams a
-> (Socket -> IO a)
-> IO Void
Subscription.ipSubscriptionWorker
      SocketSnocket
sn
      ((WithIPList (SubscriptionTrace SockAddr)
 -> WithHost (TraceOuroborosNetwork msg))
-> Tracer IO (WithHost (TraceOuroborosNetwork msg))
-> Tracer IO (WithIPList (SubscriptionTrace SockAddr))
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Host
-> TraceOuroborosNetwork msg
-> WithHost (TraceOuroborosNetwork msg)
forall trace. Host -> trace -> WithHost trace
WithHost Host
localHost (TraceOuroborosNetwork msg -> WithHost (TraceOuroborosNetwork msg))
-> (WithIPList (SubscriptionTrace SockAddr)
    -> TraceOuroborosNetwork msg)
-> WithIPList (SubscriptionTrace SockAddr)
-> WithHost (TraceOuroborosNetwork msg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithIPList (SubscriptionTrace SockAddr)
-> TraceOuroborosNetwork msg
forall {k} (msg :: k).
WithIPList (SubscriptionTrace SockAddr)
-> TraceOuroborosNetwork msg
TraceSubscriptions) Tracer IO (WithHost (TraceOuroborosNetwork msg))
tracer)
      ((WithAddr SockAddr ErrorPolicyTrace
 -> WithHost (TraceOuroborosNetwork msg))
-> Tracer IO (WithHost (TraceOuroborosNetwork msg))
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Host
-> TraceOuroborosNetwork msg
-> WithHost (TraceOuroborosNetwork msg)
forall trace. Host -> trace -> WithHost trace
WithHost Host
localHost (TraceOuroborosNetwork msg -> WithHost (TraceOuroborosNetwork msg))
-> (WithAddr SockAddr ErrorPolicyTrace
    -> TraceOuroborosNetwork msg)
-> WithAddr SockAddr ErrorPolicyTrace
-> WithHost (TraceOuroborosNetwork msg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithAddr SockAddr ErrorPolicyTrace -> TraceOuroborosNetwork msg
forall {k} (msg :: k).
WithAddr SockAddr ErrorPolicyTrace -> TraceOuroborosNetwork msg
TraceErrorPolicy) Tracer IO (WithHost (TraceOuroborosNetwork msg))
tracer)
      NetworkMutableState SockAddr
networkState
      (SockAddr -> [SockAddr] -> IPSubscriptionParams ()
forall {a}.
SockAddr -> [SockAddr] -> SubscriptionParams a IPSubscriptionTarget
subscriptionParams SockAddr
localAddr [SockAddr]
remoteAddrs)
      (IOManager
-> IO (TChan msg)
-> (TChan msg
    -> OuroborosApplicationWithMinimalCtx
         'InitiatorMode SockAddr ByteString IO () Void)
-> Socket
-> IO ()
forall {appType :: MuxMode} {t} {a} {b}.
(HasInitiator appType ~ 'True) =>
IOManager
-> IO t
-> (t
    -> OuroborosApplicationWithMinimalCtx
         appType SockAddr ByteString IO a b)
-> Socket
-> IO ()
actualConnect IOManager
iomgr IO (TChan msg)
newBroadcastChannel TChan msg
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode SockAddr ByteString IO () Void
app)

  subscriptionParams :: SockAddr -> [SockAddr] -> SubscriptionParams a IPSubscriptionTarget
subscriptionParams SockAddr
localAddr [SockAddr]
remoteAddrs =
    SubscriptionParams
      { spLocalAddresses :: LocalAddresses SockAddr
spLocalAddresses = Maybe SockAddr
-> Maybe SockAddr -> Maybe SockAddr -> LocalAddresses SockAddr
forall addr.
Maybe addr -> Maybe addr -> Maybe addr -> LocalAddresses addr
LocalAddresses (SockAddr -> Maybe SockAddr
forall a. a -> Maybe a
Just SockAddr
localAddr) Maybe SockAddr
forall a. Maybe a
Nothing Maybe SockAddr
forall a. Maybe a
Nothing
      , spConnectionAttemptDelay :: SockAddr -> Maybe DiffTime
spConnectionAttemptDelay = Maybe DiffTime -> SockAddr -> Maybe DiffTime
forall a b. a -> b -> a
const Maybe DiffTime
forall a. Maybe a
Nothing
      , spErrorPolicies :: ErrorPolicies
spErrorPolicies = ErrorPolicies
nullErrorPolicies
      , spSubscriptionTarget :: IPSubscriptionTarget
spSubscriptionTarget = [SockAddr] -> Int -> IPSubscriptionTarget
IPSubscriptionTarget [SockAddr]
remoteAddrs ([SockAddr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SockAddr]
remoteAddrs)
      }

  actualConnect :: IOManager
-> IO t
-> (t
    -> OuroborosApplicationWithMinimalCtx
         appType SockAddr ByteString IO a b)
-> Socket
-> IO ()
actualConnect IOManager
iomgr IO t
newBroadcastChannel t
-> OuroborosApplicationWithMinimalCtx
     appType SockAddr ByteString IO a b
app Socket
sn = do
    t
chan <- IO t
newBroadcastChannel
    IOManager
-> Codec
     (Handshake UnversionedProtocol Term)
     DeserialiseFailure
     IO
     ByteString
-> ProtocolTimeLimits (Handshake UnversionedProtocol Term)
-> VersionDataCodec
     Term UnversionedProtocol UnversionedProtocolData
-> NetworkConnectTracers SockAddr UnversionedProtocol
-> HandshakeCallbacks UnversionedProtocolData
-> Versions
     UnversionedProtocol
     UnversionedProtocolData
     (OuroborosApplicationWithMinimalCtx
        appType SockAddr ByteString IO a b)
-> Socket
-> IO ()
forall (appType :: MuxMode) vNumber vData a b.
(Ord vNumber, Typeable vNumber, Show vNumber,
 HasInitiator appType ~ 'True) =>
IOManager
-> Codec (Handshake vNumber Term) DeserialiseFailure IO ByteString
-> ProtocolTimeLimits (Handshake vNumber Term)
-> VersionDataCodec Term vNumber vData
-> NetworkConnectTracers SockAddr vNumber
-> HandshakeCallbacks vData
-> Versions
     vNumber
     vData
     (OuroborosApplicationWithMinimalCtx
        appType SockAddr ByteString IO a b)
-> Socket
-> IO ()
connectToNodeSocket
      IOManager
iomgr
      Codec
  (Handshake UnversionedProtocol Term)
  DeserialiseFailure
  IO
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake UnversionedProtocol Term)
  DeserialiseFailure
  m
  ByteString
unversionedHandshakeCodec
      ProtocolTimeLimits (Handshake UnversionedProtocol Term)
forall {k} (vNumber :: k).
ProtocolTimeLimits (Handshake vNumber Term)
noTimeLimitsHandshake
      VersionDataCodec Term UnversionedProtocol UnversionedProtocolData
unversionedProtocolDataCodec
      NetworkConnectTracers SockAddr UnversionedProtocol
forall {addr} {vNumber}. NetworkConnectTracers addr vNumber
networkConnectTracers
      ((UnversionedProtocolData
 -> UnversionedProtocolData -> Accept UnversionedProtocolData)
-> (UnversionedProtocolData -> Bool)
-> HandshakeCallbacks UnversionedProtocolData
forall vData.
(vData -> vData -> Accept vData)
-> (vData -> Bool) -> HandshakeCallbacks vData
HandshakeCallbacks UnversionedProtocolData
-> UnversionedProtocolData -> Accept UnversionedProtocolData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion UnversionedProtocolData -> Bool
forall v. Queryable v => v -> Bool
queryVersion)
      (OuroborosApplicationWithMinimalCtx
  appType SockAddr ByteString IO a b
-> Versions
     UnversionedProtocol
     UnversionedProtocolData
     (OuroborosApplicationWithMinimalCtx
        appType SockAddr ByteString IO a b)
forall app.
app -> Versions UnversionedProtocol UnversionedProtocolData app
unversionedProtocol (t
-> OuroborosApplicationWithMinimalCtx
     appType SockAddr ByteString IO a b
app t
chan))
      Socket
sn
   where
    networkConnectTracers :: NetworkConnectTracers addr vNumber
networkConnectTracers =
      NetworkConnectTracers
        { nctMuxTracer :: Tracer IO (WithMuxBearer (ConnectionId addr) MuxTrace)
nctMuxTracer = Tracer IO (WithMuxBearer (ConnectionId addr) MuxTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
        , nctHandshakeTracer :: Tracer
  IO
  (WithMuxBearer
     (ConnectionId addr) (TraceSendRecv (Handshake vNumber Term)))
nctHandshakeTracer = Tracer
  IO
  (WithMuxBearer
     (ConnectionId addr) (TraceSendRecv (Handshake vNumber Term)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
        }

  withServerListening :: IOManager
-> OuroborosApplicationWithMinimalCtx
     'ResponderMode SockAddr ByteString IO Void ()
-> IO ()
-> IO ()
withServerListening IOManager
iomgr OuroborosApplicationWithMinimalCtx
  'ResponderMode SockAddr ByteString IO Void ()
app IO ()
continuation = do
    NetworkMutableState SockAddr
networkState <- IO (NetworkMutableState SockAddr)
forall addr. IO (NetworkMutableState addr)
newNetworkMutableState
    SockAddr
localAddr <- Host -> IO SockAddr
resolveSockAddr Host
localHost
    -- TODO(SN): whats this? _ <- async $ cleanNetworkMutableState networkState
    (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle IOException -> IO ()
onIOException
      (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SocketSnocket
-> MakeBearer IO Socket
-> (Socket -> SockAddr -> IO ())
-> NetworkServerTracers SockAddr UnversionedProtocol
-> NetworkMutableState SockAddr
-> AcceptedConnectionsLimit
-> SockAddr
-> Codec
     (Handshake UnversionedProtocol Term)
     DeserialiseFailure
     IO
     ByteString
-> ProtocolTimeLimits (Handshake UnversionedProtocol Term)
-> VersionDataCodec
     Term UnversionedProtocol UnversionedProtocolData
-> HandshakeCallbacks UnversionedProtocolData
-> Versions
     UnversionedProtocol
     UnversionedProtocolData
     (SomeResponderApplication SockAddr ByteString IO ())
-> ErrorPolicies
-> (SockAddr -> Async Void -> IO ())
-> IO ()
forall vNumber vData t fd addr b.
(Ord vNumber, Typeable vNumber, Show vNumber, Ord addr) =>
Snocket IO fd addr
-> MakeBearer IO fd
-> (fd -> addr -> IO ())
-> NetworkServerTracers addr vNumber
-> NetworkMutableState addr
-> AcceptedConnectionsLimit
-> addr
-> Codec (Handshake vNumber Term) DeserialiseFailure IO ByteString
-> ProtocolTimeLimits (Handshake vNumber Term)
-> VersionDataCodec Term vNumber vData
-> HandshakeCallbacks vData
-> Versions
     vNumber vData (SomeResponderApplication addr ByteString IO b)
-> ErrorPolicies
-> (addr -> Async Void -> IO t)
-> IO t
withServerNode
        (IOManager -> SocketSnocket
socketSnocket IOManager
iomgr)
        MakeBearer IO Socket
makeSocketBearer
        Socket -> SockAddr -> IO ()
forall {f :: * -> *} {p} {p}. Applicative f => p -> p -> f ()
notConfigureSocket
        NetworkServerTracers SockAddr UnversionedProtocol
networkServerTracers
        NetworkMutableState SockAddr
networkState
        (Word32 -> Word32 -> DiffTime -> AcceptedConnectionsLimit
AcceptedConnectionsLimit Word32
forall a. Bounded a => a
maxBound Word32
forall a. Bounded a => a
maxBound DiffTime
0)
        SockAddr
localAddr
        Codec
  (Handshake UnversionedProtocol Term)
  DeserialiseFailure
  IO
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake UnversionedProtocol Term)
  DeserialiseFailure
  m
  ByteString
unversionedHandshakeCodec
        ProtocolTimeLimits (Handshake UnversionedProtocol Term)
forall {k} (vNumber :: k).
ProtocolTimeLimits (Handshake vNumber Term)
noTimeLimitsHandshake
        VersionDataCodec Term UnversionedProtocol UnversionedProtocolData
unversionedProtocolDataCodec
        ((UnversionedProtocolData
 -> UnversionedProtocolData -> Accept UnversionedProtocolData)
-> (UnversionedProtocolData -> Bool)
-> HandshakeCallbacks UnversionedProtocolData
forall vData.
(vData -> vData -> Accept vData)
-> (vData -> Bool) -> HandshakeCallbacks vData
HandshakeCallbacks UnversionedProtocolData
-> UnversionedProtocolData -> Accept UnversionedProtocolData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion UnversionedProtocolData -> Bool
forall v. Queryable v => v -> Bool
queryVersion)
        (SomeResponderApplication SockAddr ByteString IO ()
-> Versions
     UnversionedProtocol
     UnversionedProtocolData
     (SomeResponderApplication SockAddr ByteString IO ())
forall app.
app -> Versions UnversionedProtocol UnversionedProtocolData app
unversionedProtocol (OuroborosApplicationWithMinimalCtx
  'ResponderMode SockAddr ByteString IO Void ()
-> SomeResponderApplication SockAddr ByteString IO ()
forall (appType :: MuxMode) addr bytes (m :: * -> *) a b.
(HasResponder appType ~ 'True) =>
OuroborosApplicationWithMinimalCtx appType addr bytes m a b
-> SomeResponderApplication addr bytes m b
SomeResponderApplication OuroborosApplicationWithMinimalCtx
  'ResponderMode SockAddr ByteString IO Void ()
app))
        ErrorPolicies
nullErrorPolicies
      ((SockAddr -> Async Void -> IO ()) -> IO ())
-> (SockAddr -> Async Void -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SockAddr
_addr Async Void
serverAsync -> do
        IO Void -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m ()
race_ (Async IO Void -> IO Void
forall a. Async IO a -> IO a
forall (m :: * -> *) a. MonadAsync m => Async m a -> m a
wait Async Void
Async IO Void
serverAsync) IO ()
continuation
   where
    notConfigureSocket :: p -> p -> f ()
notConfigureSocket p
_ p
_ = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    networkServerTracers :: NetworkServerTracers SockAddr UnversionedProtocol
networkServerTracers =
      NetworkServerTracers
        { nstMuxTracer :: Tracer IO (WithMuxBearer (ConnectionId SockAddr) MuxTrace)
nstMuxTracer = Tracer IO (WithMuxBearer (ConnectionId SockAddr) MuxTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
        , nstHandshakeTracer :: Tracer
  IO
  (WithMuxBearer
     (ConnectionId SockAddr)
     (TraceSendRecv (Handshake UnversionedProtocol Term)))
nstHandshakeTracer = Tracer
  IO
  (WithMuxBearer
     (ConnectionId SockAddr)
     (TraceSendRecv (Handshake UnversionedProtocol Term)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
        , nstErrorPolicyTracer :: Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
nstErrorPolicyTracer = (WithAddr SockAddr ErrorPolicyTrace
 -> WithHost (TraceOuroborosNetwork msg))
-> Tracer IO (WithHost (TraceOuroborosNetwork msg))
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Host
-> TraceOuroborosNetwork msg
-> WithHost (TraceOuroborosNetwork msg)
forall trace. Host -> trace -> WithHost trace
WithHost Host
localHost (TraceOuroborosNetwork msg -> WithHost (TraceOuroborosNetwork msg))
-> (WithAddr SockAddr ErrorPolicyTrace
    -> TraceOuroborosNetwork msg)
-> WithAddr SockAddr ErrorPolicyTrace
-> WithHost (TraceOuroborosNetwork msg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithAddr SockAddr ErrorPolicyTrace -> TraceOuroborosNetwork msg
forall {k} (msg :: k).
WithAddr SockAddr ErrorPolicyTrace -> TraceOuroborosNetwork msg
TraceErrorPolicy) Tracer IO (WithHost (TraceOuroborosNetwork msg))
tracer
        , nstAcceptPolicyTracer :: Tracer IO AcceptConnectionsPolicyTrace
nstAcceptPolicyTracer = (AcceptConnectionsPolicyTrace
 -> WithHost (TraceOuroborosNetwork msg))
-> Tracer IO (WithHost (TraceOuroborosNetwork msg))
-> Tracer IO AcceptConnectionsPolicyTrace
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Host
-> TraceOuroborosNetwork msg
-> WithHost (TraceOuroborosNetwork msg)
forall trace. Host -> trace -> WithHost trace
WithHost Host
localHost (TraceOuroborosNetwork msg -> WithHost (TraceOuroborosNetwork msg))
-> (AcceptConnectionsPolicyTrace -> TraceOuroborosNetwork msg)
-> AcceptConnectionsPolicyTrace
-> WithHost (TraceOuroborosNetwork msg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcceptConnectionsPolicyTrace -> TraceOuroborosNetwork msg
forall {k} (msg :: k).
AcceptConnectionsPolicyTrace -> TraceOuroborosNetwork msg
TraceAcceptPolicy) Tracer IO (WithHost (TraceOuroborosNetwork msg))
tracer
        }

    onIOException :: IOException -> IO ()
onIOException IOException
ioException =
      NetworkServerListenException -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (NetworkServerListenException -> IO ())
-> NetworkServerListenException -> IO ()
forall a b. (a -> b) -> a -> b
$
        NetworkServerListenException
          { IOException
ioException :: IOException
$sel:ioException:NetworkServerListenException :: IOException
ioException
          , Host
localHost :: Host
$sel:localHost:NetworkServerListenException :: Host
localHost
          }

  hydraClient ::
    TChan msg ->
    OuroborosApplicationWithMinimalCtx 'InitiatorMode addr LByteString IO () Void
  hydraClient :: forall addr.
TChan msg
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode addr ByteString IO () Void
hydraClient TChan msg
chan =
    [MiniProtocol
   'InitiatorMode
   (MinimalInitiatorContext addr)
   (ResponderContext addr)
   ByteString
   IO
   ()
   Void]
-> OuroborosApplication
     'InitiatorMode
     (MinimalInitiatorContext addr)
     (ResponderContext addr)
     ByteString
     IO
     ()
     Void
forall (mode :: MuxMode) initiatorCtx responderCtx bytes
       (m :: * -> *) a b.
[MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> OuroborosApplication mode initiatorCtx responderCtx bytes m a b
OuroborosApplication
      [ MiniProtocol
          { miniProtocolNum :: MiniProtocolNum
miniProtocolNum = Word16 -> MiniProtocolNum
MiniProtocolNum Word16
42
          , miniProtocolLimits :: MiniProtocolLimits
miniProtocolLimits = MiniProtocolLimits
maximumMiniProtocolLimits
          , miniProtocolRun :: RunMiniProtocol
  'InitiatorMode
  (MinimalInitiatorContext addr)
  (ResponderContext addr)
  ByteString
  IO
  ()
  Void
miniProtocolRun = MiniProtocolCb (MinimalInitiatorContext addr) ByteString IO ()
-> RunMiniProtocol
     'InitiatorMode
     (MinimalInitiatorContext addr)
     (ResponderContext addr)
     ByteString
     IO
     ()
     Void
forall initiatorCtx bytes (m :: * -> *) a responderCtx.
MiniProtocolCb initiatorCtx bytes m a
-> RunMiniProtocol
     'InitiatorMode initiatorCtx responderCtx bytes m a Void
InitiatorProtocolOnly MiniProtocolCb (MinimalInitiatorContext addr) ByteString IO ()
forall ctx. MiniProtocolCb ctx ByteString IO ()
initiator
          }
      ]
   where
    initiator :: MiniProtocolCb ctx LByteString IO ()
    initiator :: forall ctx. MiniProtocolCb ctx ByteString IO ()
initiator =
      (ctx
 -> (Tracer IO (TraceSendRecv (FireForget msg)),
     Codec (FireForget msg) DeserialiseFailure IO ByteString,
     Peer (FireForget msg) 'AsClient 'StIdle IO ()))
-> MiniProtocolCb ctx ByteString IO ()
forall (pr :: PeerRole) ps (st :: ps) failure bytes ctx
       (m :: * -> *) a.
(MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
(ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     Peer ps pr st m a))
-> MiniProtocolCb ctx bytes m a
mkMiniProtocolCbFromPeer
        ( (Tracer IO (TraceSendRecv (FireForget msg)),
 Codec (FireForget msg) DeserialiseFailure IO ByteString,
 Peer (FireForget msg) 'AsClient 'StIdle IO ())
-> ctx
-> (Tracer IO (TraceSendRecv (FireForget msg)),
    Codec (FireForget msg) DeserialiseFailure IO ByteString,
    Peer (FireForget msg) 'AsClient 'StIdle IO ())
forall a b. a -> b -> a
const
            (Tracer IO (TraceSendRecv (FireForget msg))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer, Codec (FireForget msg) DeserialiseFailure IO ByteString
forall a (m :: * -> *).
(MonadST m, ToCBOR a, FromCBOR a) =>
Codec (FireForget a) DeserialiseFailure m ByteString
codecFireForget, FireForgetClient msg IO ()
-> Peer (FireForget msg) 'AsClient 'StIdle IO ()
forall (m :: * -> *) msg a.
Monad m =>
FireForgetClient msg m a
-> Peer (FireForget msg) 'AsClient 'StIdle m a
fireForgetClientPeer (FireForgetClient msg IO ()
 -> Peer (FireForget msg) 'AsClient 'StIdle IO ())
-> FireForgetClient msg IO ()
-> Peer (FireForget msg) 'AsClient 'StIdle IO ()
forall a b. (a -> b) -> a -> b
$ TChan msg -> FireForgetClient msg IO ()
client TChan msg
chan)
        )

  hydraServer ::
    OuroborosApplicationWithMinimalCtx 'ResponderMode addr LByteString IO Void ()
  hydraServer :: forall addr.
OuroborosApplicationWithMinimalCtx
  'ResponderMode addr ByteString IO Void ()
hydraServer =
    [MiniProtocol
   'ResponderMode
   (MinimalInitiatorContext addr)
   (ResponderContext addr)
   ByteString
   IO
   Void
   ()]
-> OuroborosApplication
     'ResponderMode
     (MinimalInitiatorContext addr)
     (ResponderContext addr)
     ByteString
     IO
     Void
     ()
forall (mode :: MuxMode) initiatorCtx responderCtx bytes
       (m :: * -> *) a b.
[MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> OuroborosApplication mode initiatorCtx responderCtx bytes m a b
OuroborosApplication
      [ MiniProtocol
          { miniProtocolNum :: MiniProtocolNum
miniProtocolNum = Word16 -> MiniProtocolNum
MiniProtocolNum Word16
42
          , miniProtocolLimits :: MiniProtocolLimits
miniProtocolLimits = MiniProtocolLimits
maximumMiniProtocolLimits
          , miniProtocolRun :: RunMiniProtocol
  'ResponderMode
  (MinimalInitiatorContext addr)
  (ResponderContext addr)
  ByteString
  IO
  Void
  ()
miniProtocolRun = MiniProtocolCb (ResponderContext addr) ByteString IO ()
-> RunMiniProtocol
     'ResponderMode
     (MinimalInitiatorContext addr)
     (ResponderContext addr)
     ByteString
     IO
     Void
     ()
forall responderCtx bytes (m :: * -> *) b initiatorCtx.
MiniProtocolCb responderCtx bytes m b
-> RunMiniProtocol
     'ResponderMode initiatorCtx responderCtx bytes m Void b
ResponderProtocolOnly MiniProtocolCb (ResponderContext addr) ByteString IO ()
forall ctx. MiniProtocolCb ctx ByteString IO ()
responder
          }
      ]
   where
    responder :: MiniProtocolCb ctx LByteString IO ()
    responder :: forall ctx. MiniProtocolCb ctx ByteString IO ()
responder = (ctx
 -> (Tracer IO (TraceSendRecv (FireForget msg)),
     Codec (FireForget msg) DeserialiseFailure IO ByteString,
     Peer (FireForget msg) 'AsServer 'StIdle IO ()))
-> MiniProtocolCb ctx ByteString IO ()
forall (pr :: PeerRole) ps (st :: ps) failure bytes ctx
       (m :: * -> *) a.
(MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
(ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     Peer ps pr st m a))
-> MiniProtocolCb ctx bytes m a
mkMiniProtocolCbFromPeer ((Tracer IO (TraceSendRecv (FireForget msg)),
 Codec (FireForget msg) DeserialiseFailure IO ByteString,
 Peer (FireForget msg) 'AsServer 'StIdle IO ())
-> ctx
-> (Tracer IO (TraceSendRecv (FireForget msg)),
    Codec (FireForget msg) DeserialiseFailure IO ByteString,
    Peer (FireForget msg) 'AsServer 'StIdle IO ())
forall a b. a -> b -> a
const (Tracer IO (TraceSendRecv (FireForget msg))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer, Codec (FireForget msg) DeserialiseFailure IO ByteString
forall a (m :: * -> *).
(MonadST m, ToCBOR a, FromCBOR a) =>
Codec (FireForget a) DeserialiseFailure m ByteString
codecFireForget, FireForgetServer msg IO ()
-> Peer (FireForget msg) 'AsServer 'StIdle IO ()
forall (m :: * -> *) msg a.
Monad m =>
FireForgetServer msg m a
-> Peer (FireForget msg) 'AsServer 'StIdle m a
fireForgetServerPeer FireForgetServer msg IO ()
server))

  -- TODO: provide sensible limits
  -- https://github.com/input-output-hk/ouroboros-network/issues/575
  maximumMiniProtocolLimits :: MiniProtocolLimits
  maximumMiniProtocolLimits :: MiniProtocolLimits
maximumMiniProtocolLimits =
    MiniProtocolLimits{maximumIngressQueue :: Int
maximumIngressQueue = Int
forall a. Bounded a => a
maxBound}

  client ::
    TChan msg ->
    FireForgetClient msg IO ()
  client :: TChan msg -> FireForgetClient msg IO ()
client TChan msg
chan =
    IO (FireForgetClient msg IO ()) -> FireForgetClient msg IO ()
forall (m :: * -> *) msg a.
m (FireForgetClient msg m a) -> FireForgetClient msg m a
Idle (IO (FireForgetClient msg IO ()) -> FireForgetClient msg IO ())
-> IO (FireForgetClient msg IO ()) -> FireForgetClient msg IO ()
forall a b. (a -> b) -> a -> b
$ do
      STM IO msg -> IO msg
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TChan msg -> STM msg
forall a. TChan a -> STM a
readTChan TChan msg
chan) IO msg
-> (msg -> FireForgetClient msg IO ())
-> IO (FireForgetClient msg IO ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \msg
msg ->
        msg
-> IO (FireForgetClient msg IO ()) -> FireForgetClient msg IO ()
forall msg (m :: * -> *) a.
msg -> m (FireForgetClient msg m a) -> FireForgetClient msg m a
SendMsg msg
msg (FireForgetClient msg IO () -> IO (FireForgetClient msg IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FireForgetClient msg IO () -> IO (FireForgetClient msg IO ()))
-> FireForgetClient msg IO () -> IO (FireForgetClient msg IO ())
forall a b. (a -> b) -> a -> b
$ TChan msg -> FireForgetClient msg IO ()
client TChan msg
chan)

  server :: FireForgetServer msg IO ()
  server :: FireForgetServer msg IO ()
server =
    FireForgetServer
      { $sel:recvMsg:FireForgetServer :: msg -> IO (FireForgetServer msg IO ())
recvMsg = \msg
msg -> NetworkCallback msg IO
networkCallback msg
msg IO ()
-> FireForgetServer msg IO () -> IO (FireForgetServer msg IO ())
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> FireForgetServer msg IO ()
server
      , $sel:recvMsgDone:FireForgetServer :: IO ()
recvMsgDone = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      }

data NetworkServerListenException = NetworkServerListenException
  { NetworkServerListenException -> IOException
ioException :: IOException
  , NetworkServerListenException -> Host
localHost :: Host
  }
  deriving stock (Int -> NetworkServerListenException -> ShowS
[NetworkServerListenException] -> ShowS
NetworkServerListenException -> ServiceName
(Int -> NetworkServerListenException -> ShowS)
-> (NetworkServerListenException -> ServiceName)
-> ([NetworkServerListenException] -> ShowS)
-> Show NetworkServerListenException
forall a.
(Int -> a -> ShowS)
-> (a -> ServiceName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NetworkServerListenException -> ShowS
showsPrec :: Int -> NetworkServerListenException -> ShowS
$cshow :: NetworkServerListenException -> ServiceName
show :: NetworkServerListenException -> ServiceName
$cshowList :: [NetworkServerListenException] -> ShowS
showList :: [NetworkServerListenException] -> ShowS
Show)

instance Exception NetworkServerListenException

data WithHost trace = WithHost Host trace
  deriving stock (Int -> WithHost trace -> ShowS
[WithHost trace] -> ShowS
WithHost trace -> ServiceName
(Int -> WithHost trace -> ShowS)
-> (WithHost trace -> ServiceName)
-> ([WithHost trace] -> ShowS)
-> Show (WithHost trace)
forall trace. Show trace => Int -> WithHost trace -> ShowS
forall trace. Show trace => [WithHost trace] -> ShowS
forall trace. Show trace => WithHost trace -> ServiceName
forall a.
(Int -> a -> ShowS)
-> (a -> ServiceName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall trace. Show trace => Int -> WithHost trace -> ShowS
showsPrec :: Int -> WithHost trace -> ShowS
$cshow :: forall trace. Show trace => WithHost trace -> ServiceName
show :: WithHost trace -> ServiceName
$cshowList :: forall trace. Show trace => [WithHost trace] -> ShowS
showList :: [WithHost trace] -> ShowS
Show)

instance ToJSON trace => ToJSON (WithHost trace) where
  toJSON :: WithHost trace -> Value
toJSON (WithHost Host
h trace
tr) =
    [Pair] -> Value
object
      [ Key
"host" Key -> Host -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Host
h
      , Key
"data" Key -> trace -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= trace
tr
      ]

instance FromJSON trace => FromJSON (WithHost trace) where
  parseJSON :: Value -> Parser (WithHost trace)
parseJSON = ServiceName
-> (Object -> Parser (WithHost trace))
-> Value
-> Parser (WithHost trace)
forall a. ServiceName -> (Object -> Parser a) -> Value -> Parser a
withObject ServiceName
"WithHost" ((Object -> Parser (WithHost trace))
 -> Value -> Parser (WithHost trace))
-> (Object -> Parser (WithHost trace))
-> Value
-> Parser (WithHost trace)
forall a b. (a -> b) -> a -> b
$ \Object
obj ->
    Host -> trace -> WithHost trace
forall trace. Host -> trace -> WithHost trace
WithHost
      (Host -> trace -> WithHost trace)
-> Parser Host -> Parser (trace -> WithHost trace)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
obj Object -> Key -> Parser Host
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"host")
      Parser (trace -> WithHost trace)
-> Parser trace -> Parser (WithHost trace)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
obj Object -> Key -> Parser trace
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"data")

data TraceOuroborosNetwork msg
  = TraceSubscriptions (WithIPList (SubscriptionTrace SockAddr))
  | TraceErrorPolicy (WithAddr SockAddr ErrorPolicyTrace)
  | TraceAcceptPolicy AcceptConnectionsPolicyTrace
  | TraceHandshake (WithMuxBearer (ConnectionId SockAddr) (TraceSendRecv (Handshake UnversionedProtocol CBOR.Term)))
  | TraceSendRecv (TraceSendRecv (FireForget msg))

-- NOTE: cardano-node would have orphan ToObject instances for most of these
-- types, but we want to avoid that dependency.
instance ToJSON msg => ToJSON (TraceOuroborosNetwork msg) where
  toJSON :: TraceOuroborosNetwork msg -> Value
toJSON = \case
    TraceSubscriptions WithIPList (SubscriptionTrace SockAddr)
withIpList ->
      Text -> [Pair] -> Value
tagged Text
"TraceSubscriptions" [Key
"subscriptions" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= WithIPList (SubscriptionTrace SockAddr) -> Value
encodeWithIPList WithIPList (SubscriptionTrace SockAddr)
withIpList]
    TraceErrorPolicy WithAddr SockAddr ErrorPolicyTrace
withAddr ->
      Text -> [Pair] -> Value
tagged Text
"TraceErrorPolicy" [Key
"errors" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= WithAddr SockAddr ErrorPolicyTrace -> Value
encodeWithAddr WithAddr SockAddr ErrorPolicyTrace
withAddr]
    TraceAcceptPolicy AcceptConnectionsPolicyTrace
accept ->
      Text -> [Pair] -> Value
tagged Text
"TraceAcceptPolicy" [Key
"accept" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall b a. (Show a, IsString b) => a -> b
show @Text AcceptConnectionsPolicyTrace
accept]
    TraceHandshake WithMuxBearer
  (ConnectionId SockAddr)
  (TraceSendRecv (Handshake UnversionedProtocol Term))
handshake ->
      Text -> [Pair] -> Value
tagged Text
"TraceHandshake" [Key
"handshake" Key -> [Pair] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= WithMuxBearer
  (ConnectionId SockAddr)
  (TraceSendRecv (Handshake UnversionedProtocol Term))
-> [Pair]
encodeTraceSendRecvHandshake WithMuxBearer
  (ConnectionId SockAddr)
  (TraceSendRecv (Handshake UnversionedProtocol Term))
handshake]
    TraceSendRecv TraceSendRecv (FireForget msg)
sndRcv ->
      Text -> [Pair] -> Value
tagged Text
"TraceSendRecv" [Key
"trace" Key -> [Pair] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TraceSendRecv (FireForget msg) -> [Pair]
forall msg. ToJSON msg => TraceSendRecv (FireForget msg) -> [Pair]
encodeTraceSendRecvFireForget TraceSendRecv (FireForget msg)
sndRcv]

tagged :: Text -> [Aeson.Pair] -> Aeson.Value
tagged :: Text -> [Pair] -> Value
tagged Text
tag [Pair]
pairs = [Pair] -> Value
object ((Key
"tag" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
tag) Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [Pair]
pairs)

encodeWithIPList :: WithIPList (SubscriptionTrace SockAddr) -> Aeson.Value
encodeWithIPList :: WithIPList (SubscriptionTrace SockAddr) -> Value
encodeWithIPList (WithIPList LocalAddresses SockAddr
src [SockAddr]
dsts SubscriptionTrace SockAddr
ev) =
  Text -> [Pair] -> Value
tagged
    Text
"WithIPList"
    [ Key
"src" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall b a. (Show a, IsString b) => a -> b
show @Text LocalAddresses SockAddr
src
    , Key
"dsts" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall b a. (Show a, IsString b) => a -> b
show @Text [SockAddr]
dsts
    , Key
"event" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall b a. (Show a, IsString b) => a -> b
show @Text SubscriptionTrace SockAddr
ev
    ]

encodeWithAddr :: WithAddr SockAddr ErrorPolicyTrace -> Aeson.Value
encodeWithAddr :: WithAddr SockAddr ErrorPolicyTrace -> Value
encodeWithAddr (WithAddr SockAddr
addr ErrorPolicyTrace
ev) =
  Text -> [Pair] -> Value
tagged
    Text
"WithAddr"
    [ Key
"addr" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall b a. (Show a, IsString b) => a -> b
show @Text SockAddr
addr
    , Key
"event" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall b a. (Show a, IsString b) => a -> b
show @Text ErrorPolicyTrace
ev
    ]

encodeTraceSendRecvHandshake ::
  WithMuxBearer (ConnectionId SockAddr) (TraceSendRecv (Handshake UnversionedProtocol CBOR.Term)) ->
  [Aeson.Pair]
encodeTraceSendRecvHandshake :: WithMuxBearer
  (ConnectionId SockAddr)
  (TraceSendRecv (Handshake UnversionedProtocol Term))
-> [Pair]
encodeTraceSendRecvHandshake = \case
  WithMuxBearer ConnectionId SockAddr
peerId (TraceSendMsg (AnyMessageAndAgency PeerHasAgency pr st
agency Message (Handshake UnversionedProtocol Term) st st'
msg)) ->
    [ Key
"event" Key -> ServiceName -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ServiceName
"send" :: String)
    , Key
"agency" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (PeerHasAgency pr st -> Text
forall b a. (Show a, IsString b) => a -> b
show PeerHasAgency pr st
agency :: Text)
    , Key
"peer" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ConnectionId SockAddr -> Text
forall b a. (Show a, IsString b) => a -> b
show ConnectionId SockAddr
peerId :: Text)
    ]
      [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ Message (Handshake UnversionedProtocol Term) st st' -> [Pair]
forall (from :: Handshake UnversionedProtocol Term)
       (to :: Handshake UnversionedProtocol Term).
Message (Handshake UnversionedProtocol Term) from to -> [Pair]
encodeMsg Message (Handshake UnversionedProtocol Term) st st'
msg
  WithMuxBearer ConnectionId SockAddr
peerId (TraceRecvMsg (AnyMessageAndAgency PeerHasAgency pr st
agency Message (Handshake UnversionedProtocol Term) st st'
msg)) ->
    [ Key
"event" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"receive" :: Text)
    , Key
"agency" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (PeerHasAgency pr st -> Text
forall b a. (Show a, IsString b) => a -> b
show PeerHasAgency pr st
agency :: Text)
    , Key
"peer" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ConnectionId SockAddr -> Text
forall b a. (Show a, IsString b) => a -> b
show ConnectionId SockAddr
peerId :: Text)
    ]
      [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ Message (Handshake UnversionedProtocol Term) st st' -> [Pair]
forall (from :: Handshake UnversionedProtocol Term)
       (to :: Handshake UnversionedProtocol Term).
Message (Handshake UnversionedProtocol Term) from to -> [Pair]
encodeMsg Message (Handshake UnversionedProtocol Term) st st'
msg
 where
  encodeMsg ::
    Message (Handshake UnversionedProtocol Term) from to ->
    [Aeson.Pair]
  encodeMsg :: forall (from :: Handshake UnversionedProtocol Term)
       (to :: Handshake UnversionedProtocol Term).
Message (Handshake UnversionedProtocol Term) from to -> [Pair]
encodeMsg = \case
    MsgProposeVersions Map vNumber1 vParams1
versions ->
      [ Key
"tag" Key -> ServiceName -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ServiceName
"ProposeVersions" :: String)
      , Key
"versions" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (vNumber1 -> Text
forall b a. (Show a, IsString b) => a -> b
show (vNumber1 -> Text) -> [vNumber1] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map vNumber1 vParams1 -> [vNumber1]
forall k a. Map k a -> [k]
Map.keys Map vNumber1 vParams1
versions :: [Text])
      ]
    MsgAcceptVersion vNumber1
v vParams1
_ ->
      [ Key
"tag" Key -> ServiceName -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ServiceName
"AcceptVersion" :: String)
      , Key
"version" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (vNumber1 -> Text
forall b a. (Show a, IsString b) => a -> b
show vNumber1
v :: Text)
      ]
    MsgRefuse RefuseReason vNumber1
reason ->
      [ Key
"tag" Key -> ServiceName -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ServiceName
"RefuseVersions" :: String)
      , Key
"reason" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RefuseReason vNumber1 -> Value
forall vNumber. RefuseReason vNumber -> Value
encodeRefuseReason RefuseReason vNumber1
reason
      ]
    MsgReplyVersions Map vNumber1 vParams1
versions ->
      [ Key
"tag" Key -> ServiceName -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ServiceName
"ReplyVersions" :: String)
      , Key
"versions" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (vNumber1 -> Text
forall b a. (Show a, IsString b) => a -> b
show (vNumber1 -> Text) -> [vNumber1] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map vNumber1 vParams1 -> [vNumber1]
forall k a. Map k a -> [k]
Map.keys Map vNumber1 vParams1
versions :: [Text])
      ]
    MsgQueryReply Map vNumber1 vParams1
versions ->
      [ Key
"tag" Key -> ServiceName -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ServiceName
"MsgQueryReply" :: String)
      , Key
"versions" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (vNumber1 -> Text
forall b a. (Show a, IsString b) => a -> b
show (vNumber1 -> Text) -> [vNumber1] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map vNumber1 vParams1 -> [vNumber1]
forall k a. Map k a -> [k]
Map.keys Map vNumber1 vParams1
versions :: [Text])
      ]

  encodeRefuseReason ::
    RefuseReason vNumber ->
    Aeson.Value
  encodeRefuseReason :: forall vNumber. RefuseReason vNumber -> Value
encodeRefuseReason = \case
    VersionMismatch{} -> Text -> Value
Aeson.String Text
"VersionMismatchOrUnknown"
    HandshakeDecodeError{} -> Text -> Value
Aeson.String Text
"HandshakeDecodeError"
    Refused{} -> Text -> Value
Aeson.String Text
"ServerRejected"

encodeTraceSendRecvFireForget ::
  forall msg.
  ToJSON msg =>
  TraceSendRecv (FireForget msg) ->
  [Aeson.Pair]
encodeTraceSendRecvFireForget :: forall msg. ToJSON msg => TraceSendRecv (FireForget msg) -> [Pair]
encodeTraceSendRecvFireForget = \case
  TraceSendMsg (AnyMessageAndAgency PeerHasAgency pr st
agency Message (FireForget msg) st st'
msg) ->
    [ Key
"event" Key -> ServiceName -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ServiceName
"send" :: String)
    , Key
"agency" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (PeerHasAgency pr st -> Text
forall b a. (Show a, IsString b) => a -> b
show PeerHasAgency pr st
agency :: Text)
    ]
      [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ Message (FireForget msg) st st' -> [Pair]
forall (from :: FireForget msg) (to :: FireForget msg).
Message (FireForget msg) from to -> [Pair]
encodeMsg Message (FireForget msg) st st'
msg
  TraceRecvMsg (AnyMessageAndAgency PeerHasAgency pr st
agency Message (FireForget msg) st st'
msg) ->
    [ Key
"event" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"receive" :: Text)
    , Key
"agency" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (PeerHasAgency pr st -> Text
forall b a. (Show a, IsString b) => a -> b
show PeerHasAgency pr st
agency :: Text)
    ]
      [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ Message (FireForget msg) st st' -> [Pair]
forall (from :: FireForget msg) (to :: FireForget msg).
Message (FireForget msg) from to -> [Pair]
encodeMsg Message (FireForget msg) st st'
msg
 where
  encodeMsg ::
    Message (FireForget msg) from to ->
    [Aeson.Pair]
  encodeMsg :: forall (from :: FireForget msg) (to :: FireForget msg).
Message (FireForget msg) from to -> [Pair]
encodeMsg = \case
    MsgSend msg1
msg ->
      [ Key
"send" Key -> msg1 -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= msg1
msg
      ]
    Message (FireForget msg) from to
R:MessageFireForgetfromto (*) msg from to
MsgDone ->
      [ Key
"done" Key -> () -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ()
      ]