-- | 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 (
  withIOManager,
  module Hydra.Network,
  module Hydra.Network.Ouroboros,
  module Hydra.Network.Ouroboros.VersionedProtocol,
) where

import Control.Monad.Class.MonadAsync (wait)
import Hydra.Network.Ouroboros.VersionedProtocol (
  HydraNetworkConfig (..),
  HydraVersionedProtocolData (..),
  hydraVersionedProtocolCodec,
  hydraVersionedProtocolDataCodec,
 )
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 Data.Text qualified as T
import Hydra.Logging (Tracer (..), nullTracer)
import Hydra.Network (
  Host (..),
  Network (..),
  NetworkCallback (..),
  NetworkComponent,
  PortNumber,
 )
import Hydra.Network.Message (
  HydraHandshakeRefused (..),
  HydraVersionedProtocolNumber (..),
  KnownHydraVersions (..),
 )
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),
  NameInfoFlag (..),
  SockAddr,
  Socket,
  defaultHints,
  getAddrInfo,
  getNameInfo,
  getPeerName,
 )
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 (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 (codecHandshake, noTimeLimitsHandshake)
import Ouroboros.Network.Protocol.Handshake.Type (Handshake, HandshakeProtocolError (..), Message (..), RefuseReason (..))
import Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion, queryVersion, simpleSingletonVersions)
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 inbound outbound.
  (ToCBOR outbound, FromCBOR outbound) =>
  (ToCBOR inbound, FromCBOR inbound) =>
  Tracer IO (WithHost (TraceOuroborosNetwork outbound)) ->
  HydraNetworkConfig ->
  (HydraHandshakeRefused -> IO ()) ->
  NetworkComponent IO inbound outbound ()
withOuroborosNetwork :: forall inbound outbound.
(ToCBOR outbound, FromCBOR outbound, ToCBOR inbound,
 FromCBOR inbound) =>
Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> HydraNetworkConfig
-> (HydraHandshakeRefused -> IO ())
-> NetworkComponent IO inbound outbound ()
withOuroborosNetwork
  Tracer IO (WithHost (TraceOuroborosNetwork outbound))
tracer
  HydraNetworkConfig{HydraVersionedProtocolNumber
protocolVersion :: HydraVersionedProtocolNumber
$sel:protocolVersion:HydraNetworkConfig :: HydraNetworkConfig -> HydraVersionedProtocolNumber
protocolVersion, Host
localHost :: Host
$sel:localHost:HydraNetworkConfig :: HydraNetworkConfig -> Host
localHost, [Host]
remoteHosts :: [Host]
$sel:remoteHosts:HydraNetworkConfig :: HydraNetworkConfig -> [Host]
remoteHosts}
  HydraHandshakeRefused -> IO ()
handshakeCallback
  NetworkCallback{inbound -> IO ()
deliver :: inbound -> IO ()
$sel:deliver:NetworkCallback :: forall msg (m :: * -> *). NetworkCallback msg m -> msg -> m ()
deliver}
  Network IO outbound -> IO ()
between = do
    TChan outbound
bchan <- IO (TChan outbound)
forall a. IO (TChan a)
newBroadcastTChanIO
    let newBroadcastChannel :: IO (TChan outbound)
newBroadcastChannel = STM IO (TChan outbound) -> IO (TChan outbound)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (TChan outbound) -> IO (TChan outbound))
-> STM IO (TChan outbound) -> IO (TChan outbound)
forall a b. (a -> b) -> a -> b
$ TChan outbound -> STM (TChan outbound)
forall a. TChan a -> STM (TChan a)
dupTChan TChan outbound
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 LByteString IO Void ()
-> IO ()
-> IO ()
forall a b.
IOManager
-> OuroborosApplicationWithMinimalCtx
     'ResponderMode SockAddr LByteString IO a b
-> IO b
-> IO ()
withServerListening IOManager
iomgr OuroborosApplicationWithMinimalCtx
  'ResponderMode SockAddr LByteString IO Void ()
forall addr.
OuroborosApplicationWithMinimalCtx
  'ResponderMode addr LByteString 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 outbound)
-> (TChan outbound
    -> OuroborosApplicationWithMinimalCtx
         'InitiatorMode SockAddr LByteString IO () Void)
-> IO Void
forall t.
IOManager
-> IO t
-> (t
    -> OuroborosApplicationWithMinimalCtx
         'InitiatorMode SockAddr LByteString IO () Void)
-> IO Void
connect IOManager
iomgr IO (TChan outbound)
newBroadcastChannel TChan outbound
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode SockAddr LByteString IO () Void
forall addr.
TChan outbound
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode addr LByteString IO () Void
hydraClient) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Network IO outbound -> IO ()
between (Network IO outbound -> IO ()) -> Network IO outbound -> IO ()
forall a b. (a -> b) -> a -> b
$
            Network
              { $sel:broadcast:Network :: outbound -> 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 ()) -> (outbound -> STM ()) -> outbound -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan outbound -> outbound -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan outbound
bchan
              }
   where
    resolveSockAddr :: Host -> IO SockAddr
    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"

    getHost :: SockAddr -> IO Host
    getHost :: SockAddr -> IO Host
getHost SockAddr
sockAddr = do
      (Maybe ServiceName
mHost, Maybe ServiceName
mPort) <- [NameInfoFlag]
-> Bool
-> Bool
-> SockAddr
-> IO (Maybe ServiceName, Maybe ServiceName)
getNameInfo [NameInfoFlag
NI_NUMERICHOST, NameInfoFlag
NI_NUMERICSERV] Bool
True Bool
True SockAddr
sockAddr
      IO Host -> (Host -> IO Host) -> Maybe Host -> IO Host
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> IO Host
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"getNameInfo failed.. do proper error handling") Host -> IO Host
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Host -> IO Host) -> Maybe Host -> IO Host
forall a b. (a -> b) -> a -> b
$ do
        Text
host <- ServiceName -> Text
T.pack (ServiceName -> Text) -> Maybe ServiceName -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ServiceName
mHost
        PortNumber
port <- ServiceName -> Maybe PortNumber
forall a. Read a => ServiceName -> Maybe a
readMaybe (ServiceName -> Maybe PortNumber)
-> Maybe ServiceName -> Maybe PortNumber
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ServiceName
mPort
        Host -> Maybe Host
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Host -> Maybe Host) -> Host -> Maybe Host
forall a b. (a -> b) -> a -> b
$ Text -> PortNumber -> Host
Host Text
host PortNumber
port

    connect ::
      IOManager ->
      IO t ->
      ( t ->
        OuroborosApplicationWithMinimalCtx
          InitiatorMode
          SockAddr
          LByteString
          IO
          ()
          Void
      ) ->
      IO Void
    connect :: forall t.
IOManager
-> IO t
-> (t
    -> OuroborosApplicationWithMinimalCtx
         'InitiatorMode SockAddr LByteString IO () Void)
-> IO Void
connect IOManager
iomgr IO t
newBroadcastChannel t
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode SockAddr LByteString 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 outbound))
-> Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> 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 outbound
-> WithHost (TraceOuroborosNetwork outbound)
forall trace. Host -> trace -> WithHost trace
WithHost Host
localHost (TraceOuroborosNetwork outbound
 -> WithHost (TraceOuroborosNetwork outbound))
-> (WithIPList (SubscriptionTrace SockAddr)
    -> TraceOuroborosNetwork outbound)
-> WithIPList (SubscriptionTrace SockAddr)
-> WithHost (TraceOuroborosNetwork outbound)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithIPList (SubscriptionTrace SockAddr)
-> TraceOuroborosNetwork outbound
forall {k} (msg :: k).
WithIPList (SubscriptionTrace SockAddr)
-> TraceOuroborosNetwork msg
TraceSubscriptions) Tracer IO (WithHost (TraceOuroborosNetwork outbound))
tracer)
        ((WithAddr SockAddr ErrorPolicyTrace
 -> WithHost (TraceOuroborosNetwork outbound))
-> Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> 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 outbound
-> WithHost (TraceOuroborosNetwork outbound)
forall trace. Host -> trace -> WithHost trace
WithHost Host
localHost (TraceOuroborosNetwork outbound
 -> WithHost (TraceOuroborosNetwork outbound))
-> (WithAddr SockAddr ErrorPolicyTrace
    -> TraceOuroborosNetwork outbound)
-> WithAddr SockAddr ErrorPolicyTrace
-> WithHost (TraceOuroborosNetwork outbound)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithAddr SockAddr ErrorPolicyTrace
-> TraceOuroborosNetwork outbound
forall {k} (msg :: k).
WithAddr SockAddr ErrorPolicyTrace -> TraceOuroborosNetwork msg
TraceErrorPolicy) Tracer IO (WithHost (TraceOuroborosNetwork outbound))
tracer)
        NetworkMutableState SockAddr
networkState
        (SockAddr -> [SockAddr] -> IPSubscriptionParams ()
forall a.
SockAddr -> [SockAddr] -> SubscriptionParams a IPSubscriptionTarget
subscriptionParams SockAddr
localAddr [SockAddr]
remoteAddrs)
        ( \Socket
sock ->
            IOManager
-> IO t
-> (t
    -> OuroborosApplicationWithMinimalCtx
         'InitiatorMode SockAddr LByteString IO () Void)
-> Socket
-> IO ()
forall t.
IOManager
-> IO t
-> (t
    -> OuroborosApplicationWithMinimalCtx
         'InitiatorMode SockAddr LByteString IO () Void)
-> Socket
-> IO ()
actualConnect IOManager
iomgr IO t
newBroadcastChannel t
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode SockAddr LByteString IO () Void
app Socket
sock IO ()
-> (HandshakeProtocolError HydraVersionedProtocolNumber -> IO ())
-> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \HandshakeProtocolError HydraVersionedProtocolNumber
e -> do
              Host
host <- SockAddr -> IO Host
getHost (SockAddr -> IO Host) -> IO SockAddr -> IO Host
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Socket -> IO SockAddr
getPeerName Socket
sock
              Host
-> HandshakeProtocolError HydraVersionedProtocolNumber -> IO ()
onHandshakeError Host
host HandshakeProtocolError HydraVersionedProtocolNumber
e
        )

    onHandshakeError :: Host -> HandshakeProtocolError HydraVersionedProtocolNumber -> IO ()
    onHandshakeError :: Host
-> HandshakeProtocolError HydraVersionedProtocolNumber -> IO ()
onHandshakeError Host
remoteHost = \case
      HandshakeError (VersionMismatch [HydraVersionedProtocolNumber]
theirVersions [Int]
_) -> do
        HydraHandshakeRefused -> IO ()
handshakeCallback
          HydraHandshakeRefused
            { $sel:ourVersion:HydraHandshakeRefused :: HydraVersionedProtocolNumber
ourVersion = HydraVersionedProtocolNumber
protocolVersion
            , $sel:theirVersions:HydraHandshakeRefused :: KnownHydraVersions
theirVersions = [HydraVersionedProtocolNumber] -> KnownHydraVersions
KnownHydraVersions [HydraVersionedProtocolNumber]
theirVersions
            , Host
remoteHost :: Host
$sel:remoteHost:HydraHandshakeRefused :: Host
remoteHost
            }
      HandshakeProtocolError HydraVersionedProtocolNumber
_ ->
        HydraHandshakeRefused -> IO ()
handshakeCallback
          HydraHandshakeRefused
            { $sel:ourVersion:HydraHandshakeRefused :: HydraVersionedProtocolNumber
ourVersion = HydraVersionedProtocolNumber
protocolVersion
            , $sel:theirVersions:HydraHandshakeRefused :: KnownHydraVersions
theirVersions = KnownHydraVersions
NoKnownHydraVersions
            , Host
remoteHost :: Host
$sel:remoteHost:HydraHandshakeRefused :: Host
remoteHost
            }

    subscriptionParams ::
      SockAddr ->
      [SockAddr] ->
      SubscriptionParams a IPSubscriptionTarget
    subscriptionParams :: forall a.
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 'InitiatorMode SockAddr LByteString IO () Void) ->
      Socket ->
      IO ()
    actualConnect :: forall t.
IOManager
-> IO t
-> (t
    -> OuroborosApplicationWithMinimalCtx
         'InitiatorMode SockAddr LByteString IO () Void)
-> Socket
-> IO ()
actualConnect IOManager
iomgr IO t
newBroadcastChannel t
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode SockAddr LByteString IO () Void
app Socket
sn = do
      t
chan <- IO t
newBroadcastChannel
      IOManager
-> Codec
     (Handshake HydraVersionedProtocolNumber Term)
     DeserialiseFailure
     IO
     LByteString
-> ProtocolTimeLimits (Handshake HydraVersionedProtocolNumber Term)
-> VersionDataCodec
     Term HydraVersionedProtocolNumber HydraVersionedProtocolData
-> NetworkConnectTracers SockAddr HydraVersionedProtocolNumber
-> HandshakeCallbacks HydraVersionedProtocolData
-> Versions
     HydraVersionedProtocolNumber
     HydraVersionedProtocolData
     (OuroborosApplicationWithMinimalCtx
        'InitiatorMode SockAddr LByteString IO () Void)
-> 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 LByteString
-> ProtocolTimeLimits (Handshake vNumber Term)
-> VersionDataCodec Term vNumber vData
-> NetworkConnectTracers SockAddr vNumber
-> HandshakeCallbacks vData
-> Versions
     vNumber
     vData
     (OuroborosApplicationWithMinimalCtx
        appType SockAddr LByteString IO a b)
-> Socket
-> IO ()
connectToNodeSocket
        IOManager
iomgr
        (CodecCBORTerm (ServiceName, Maybe Int) HydraVersionedProtocolNumber
-> Codec
     (Handshake HydraVersionedProtocolNumber Term)
     DeserialiseFailure
     IO
     LByteString
forall vNumber (m :: * -> *) failure.
(MonadST m, Ord vNumber, Show failure) =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m LByteString
codecHandshake CodecCBORTerm (ServiceName, Maybe Int) HydraVersionedProtocolNumber
hydraVersionedProtocolCodec)
        ProtocolTimeLimits (Handshake HydraVersionedProtocolNumber Term)
forall {k} (vNumber :: k).
ProtocolTimeLimits (Handshake vNumber Term)
noTimeLimitsHandshake
        VersionDataCodec
  Term HydraVersionedProtocolNumber HydraVersionedProtocolData
hydraVersionedProtocolDataCodec
        NetworkConnectTracers SockAddr HydraVersionedProtocolNumber
networkConnectTracers
        ((HydraVersionedProtocolData
 -> HydraVersionedProtocolData -> Accept HydraVersionedProtocolData)
-> (HydraVersionedProtocolData -> Bool)
-> HandshakeCallbacks HydraVersionedProtocolData
forall vData.
(vData -> vData -> Accept vData)
-> (vData -> Bool) -> HandshakeCallbacks vData
HandshakeCallbacks HydraVersionedProtocolData
-> HydraVersionedProtocolData -> Accept HydraVersionedProtocolData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion HydraVersionedProtocolData -> Bool
forall v. Queryable v => v -> Bool
queryVersion)
        (HydraVersionedProtocolNumber
-> HydraVersionedProtocolData
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode SockAddr LByteString IO () Void
-> Versions
     HydraVersionedProtocolNumber
     HydraVersionedProtocolData
     (OuroborosApplicationWithMinimalCtx
        'InitiatorMode SockAddr LByteString IO () Void)
forall vNum vData r. vNum -> vData -> r -> Versions vNum vData r
simpleSingletonVersions HydraVersionedProtocolNumber
protocolVersion HydraVersionedProtocolData
MkHydraVersionedProtocolData (t
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode SockAddr LByteString IO () Void
app t
chan))
        Socket
sn
     where
      networkConnectTracers :: NetworkConnectTracers SockAddr HydraVersionedProtocolNumber
      networkConnectTracers :: NetworkConnectTracers SockAddr HydraVersionedProtocolNumber
networkConnectTracers =
        NetworkConnectTracers
          { nctMuxTracer :: Tracer IO (WithMuxBearer (ConnectionId SockAddr) MuxTrace)
nctMuxTracer = Tracer IO (WithMuxBearer (ConnectionId SockAddr) MuxTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
          , nctHandshakeTracer :: Tracer
  IO
  (WithMuxBearer
     (ConnectionId SockAddr)
     (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term)))
nctHandshakeTracer = (WithMuxBearer
   (ConnectionId SockAddr)
   (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term))
 -> WithHost (TraceOuroborosNetwork outbound))
-> Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> Tracer
     IO
     (WithMuxBearer
        (ConnectionId SockAddr)
        (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term)))
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 outbound
-> WithHost (TraceOuroborosNetwork outbound)
forall trace. Host -> trace -> WithHost trace
WithHost Host
localHost (TraceOuroborosNetwork outbound
 -> WithHost (TraceOuroborosNetwork outbound))
-> (WithMuxBearer
      (ConnectionId SockAddr)
      (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term))
    -> TraceOuroborosNetwork outbound)
-> WithMuxBearer
     (ConnectionId SockAddr)
     (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term))
-> WithHost (TraceOuroborosNetwork outbound)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithMuxBearer
  (ConnectionId SockAddr)
  (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term))
-> TraceOuroborosNetwork outbound
forall {k} (msg :: k).
WithMuxBearer
  (ConnectionId SockAddr)
  (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term))
-> TraceOuroborosNetwork msg
TraceHandshake) Tracer IO (WithHost (TraceOuroborosNetwork outbound))
tracer
          }

    withServerListening ::
      IOManager ->
      OuroborosApplicationWithMinimalCtx 'ResponderMode SockAddr LByteString IO a b ->
      IO b ->
      IO ()
    withServerListening :: forall a b.
IOManager
-> OuroborosApplicationWithMinimalCtx
     'ResponderMode SockAddr LByteString IO a b
-> IO b
-> IO ()
withServerListening IOManager
iomgr OuroborosApplicationWithMinimalCtx
  'ResponderMode SockAddr LByteString IO a b
app IO b
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 HydraVersionedProtocolNumber
-> NetworkMutableState SockAddr
-> AcceptedConnectionsLimit
-> SockAddr
-> Codec
     (Handshake HydraVersionedProtocolNumber Term)
     DeserialiseFailure
     IO
     LByteString
-> ProtocolTimeLimits (Handshake HydraVersionedProtocolNumber Term)
-> VersionDataCodec
     Term HydraVersionedProtocolNumber HydraVersionedProtocolData
-> HandshakeCallbacks HydraVersionedProtocolData
-> Versions
     HydraVersionedProtocolNumber
     HydraVersionedProtocolData
     (SomeResponderApplication SockAddr LByteString IO b)
-> 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 LByteString
-> ProtocolTimeLimits (Handshake vNumber Term)
-> VersionDataCodec Term vNumber vData
-> HandshakeCallbacks vData
-> Versions
     vNumber vData (SomeResponderApplication addr LByteString IO b)
-> ErrorPolicies
-> (addr -> Async Void -> IO t)
-> IO t
withServerNode
          (IOManager -> SocketSnocket
socketSnocket IOManager
iomgr)
          MakeBearer IO Socket
makeSocketBearer
          Socket -> SockAddr -> IO ()
forall a b. a -> b -> IO ()
notConfigureSocket
          NetworkServerTracers SockAddr HydraVersionedProtocolNumber
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
          (CodecCBORTerm (ServiceName, Maybe Int) HydraVersionedProtocolNumber
-> Codec
     (Handshake HydraVersionedProtocolNumber Term)
     DeserialiseFailure
     IO
     LByteString
forall vNumber (m :: * -> *) failure.
(MonadST m, Ord vNumber, Show failure) =>
CodecCBORTerm (failure, Maybe Int) vNumber
-> Codec (Handshake vNumber Term) DeserialiseFailure m LByteString
codecHandshake CodecCBORTerm (ServiceName, Maybe Int) HydraVersionedProtocolNumber
hydraVersionedProtocolCodec)
          ProtocolTimeLimits (Handshake HydraVersionedProtocolNumber Term)
forall {k} (vNumber :: k).
ProtocolTimeLimits (Handshake vNumber Term)
noTimeLimitsHandshake
          VersionDataCodec
  Term HydraVersionedProtocolNumber HydraVersionedProtocolData
hydraVersionedProtocolDataCodec
          ((HydraVersionedProtocolData
 -> HydraVersionedProtocolData -> Accept HydraVersionedProtocolData)
-> (HydraVersionedProtocolData -> Bool)
-> HandshakeCallbacks HydraVersionedProtocolData
forall vData.
(vData -> vData -> Accept vData)
-> (vData -> Bool) -> HandshakeCallbacks vData
HandshakeCallbacks HydraVersionedProtocolData
-> HydraVersionedProtocolData -> Accept HydraVersionedProtocolData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion HydraVersionedProtocolData -> Bool
forall v. Queryable v => v -> Bool
queryVersion)
          (HydraVersionedProtocolNumber
-> HydraVersionedProtocolData
-> SomeResponderApplication SockAddr LByteString IO b
-> Versions
     HydraVersionedProtocolNumber
     HydraVersionedProtocolData
     (SomeResponderApplication SockAddr LByteString IO b)
forall vNum vData r. vNum -> vData -> r -> Versions vNum vData r
simpleSingletonVersions HydraVersionedProtocolNumber
protocolVersion HydraVersionedProtocolData
MkHydraVersionedProtocolData (OuroborosApplicationWithMinimalCtx
  'ResponderMode SockAddr LByteString IO a b
-> SomeResponderApplication SockAddr LByteString IO b
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 LByteString IO a b
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 b -> 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 b
continuation
     where
      notConfigureSocket :: a -> b -> IO ()
      notConfigureSocket :: forall a b. a -> b -> IO ()
notConfigureSocket a
_ b
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      networkServerTracers :: NetworkServerTracers SockAddr HydraVersionedProtocolNumber
      networkServerTracers :: NetworkServerTracers SockAddr HydraVersionedProtocolNumber
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 HydraVersionedProtocolNumber Term)))
nstHandshakeTracer = (WithMuxBearer
   (ConnectionId SockAddr)
   (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term))
 -> WithHost (TraceOuroborosNetwork outbound))
-> Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> Tracer
     IO
     (WithMuxBearer
        (ConnectionId SockAddr)
        (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term)))
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 outbound
-> WithHost (TraceOuroborosNetwork outbound)
forall trace. Host -> trace -> WithHost trace
WithHost Host
localHost (TraceOuroborosNetwork outbound
 -> WithHost (TraceOuroborosNetwork outbound))
-> (WithMuxBearer
      (ConnectionId SockAddr)
      (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term))
    -> TraceOuroborosNetwork outbound)
-> WithMuxBearer
     (ConnectionId SockAddr)
     (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term))
-> WithHost (TraceOuroborosNetwork outbound)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithMuxBearer
  (ConnectionId SockAddr)
  (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term))
-> TraceOuroborosNetwork outbound
forall {k} (msg :: k).
WithMuxBearer
  (ConnectionId SockAddr)
  (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term))
-> TraceOuroborosNetwork msg
TraceHandshake) Tracer IO (WithHost (TraceOuroborosNetwork outbound))
tracer
          , nstErrorPolicyTracer :: Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
nstErrorPolicyTracer = (WithAddr SockAddr ErrorPolicyTrace
 -> WithHost (TraceOuroborosNetwork outbound))
-> Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> 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 outbound
-> WithHost (TraceOuroborosNetwork outbound)
forall trace. Host -> trace -> WithHost trace
WithHost Host
localHost (TraceOuroborosNetwork outbound
 -> WithHost (TraceOuroborosNetwork outbound))
-> (WithAddr SockAddr ErrorPolicyTrace
    -> TraceOuroborosNetwork outbound)
-> WithAddr SockAddr ErrorPolicyTrace
-> WithHost (TraceOuroborosNetwork outbound)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithAddr SockAddr ErrorPolicyTrace
-> TraceOuroborosNetwork outbound
forall {k} (msg :: k).
WithAddr SockAddr ErrorPolicyTrace -> TraceOuroborosNetwork msg
TraceErrorPolicy) Tracer IO (WithHost (TraceOuroborosNetwork outbound))
tracer
          , nstAcceptPolicyTracer :: Tracer IO AcceptConnectionsPolicyTrace
nstAcceptPolicyTracer = (AcceptConnectionsPolicyTrace
 -> WithHost (TraceOuroborosNetwork outbound))
-> Tracer IO (WithHost (TraceOuroborosNetwork outbound))
-> 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 outbound
-> WithHost (TraceOuroborosNetwork outbound)
forall trace. Host -> trace -> WithHost trace
WithHost Host
localHost (TraceOuroborosNetwork outbound
 -> WithHost (TraceOuroborosNetwork outbound))
-> (AcceptConnectionsPolicyTrace -> TraceOuroborosNetwork outbound)
-> AcceptConnectionsPolicyTrace
-> WithHost (TraceOuroborosNetwork outbound)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcceptConnectionsPolicyTrace -> TraceOuroborosNetwork outbound
forall {k} (msg :: k).
AcceptConnectionsPolicyTrace -> TraceOuroborosNetwork msg
TraceAcceptPolicy) Tracer IO (WithHost (TraceOuroborosNetwork outbound))
tracer
          }

      onIOException :: IOException -> IO ()
      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 outbound ->
      OuroborosApplicationWithMinimalCtx 'InitiatorMode addr LByteString IO () Void
    hydraClient :: forall addr.
TChan outbound
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode addr LByteString IO () Void
hydraClient TChan outbound
chan =
      [MiniProtocol
   'InitiatorMode
   (MinimalInitiatorContext addr)
   (ResponderContext addr)
   LByteString
   IO
   ()
   Void]
-> OuroborosApplication
     'InitiatorMode
     (MinimalInitiatorContext addr)
     (ResponderContext addr)
     LByteString
     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)
  LByteString
  IO
  ()
  Void
miniProtocolRun = MiniProtocolCb (MinimalInitiatorContext addr) LByteString IO ()
-> RunMiniProtocol
     'InitiatorMode
     (MinimalInitiatorContext addr)
     (ResponderContext addr)
     LByteString
     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) LByteString IO ()
forall ctx. MiniProtocolCb ctx LByteString IO ()
initiator
            }
        ]
     where
      initiator :: MiniProtocolCb ctx LByteString IO ()
      initiator :: forall ctx. MiniProtocolCb ctx LByteString IO ()
initiator =
        (ctx
 -> (Tracer IO (TraceSendRecv (FireForget outbound)),
     Codec (FireForget outbound) DeserialiseFailure IO LByteString,
     Peer (FireForget outbound) 'AsClient 'StIdle IO ()))
-> MiniProtocolCb ctx LByteString 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 outbound)),
 Codec (FireForget outbound) DeserialiseFailure IO LByteString,
 Peer (FireForget outbound) 'AsClient 'StIdle IO ())
-> ctx
-> (Tracer IO (TraceSendRecv (FireForget outbound)),
    Codec (FireForget outbound) DeserialiseFailure IO LByteString,
    Peer (FireForget outbound) 'AsClient 'StIdle IO ())
forall a b. a -> b -> a
const
              (Tracer IO (TraceSendRecv (FireForget outbound))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer, Codec (FireForget outbound) DeserialiseFailure IO LByteString
forall a (m :: * -> *).
(MonadST m, ToCBOR a, FromCBOR a) =>
Codec (FireForget a) DeserialiseFailure m LByteString
codecFireForget, FireForgetClient outbound IO ()
-> Peer (FireForget outbound) 'AsClient 'StIdle IO ()
forall (m :: * -> *) msg a.
Monad m =>
FireForgetClient msg m a
-> Peer (FireForget msg) 'AsClient 'StIdle m a
fireForgetClientPeer (FireForgetClient outbound IO ()
 -> Peer (FireForget outbound) 'AsClient 'StIdle IO ())
-> FireForgetClient outbound IO ()
-> Peer (FireForget outbound) 'AsClient 'StIdle IO ()
forall a b. (a -> b) -> a -> b
$ TChan outbound -> FireForgetClient outbound IO ()
client TChan outbound
chan)
          )

    hydraServer ::
      OuroborosApplicationWithMinimalCtx 'ResponderMode addr LByteString IO Void ()
    hydraServer :: forall addr.
OuroborosApplicationWithMinimalCtx
  'ResponderMode addr LByteString IO Void ()
hydraServer =
      [MiniProtocol
   'ResponderMode
   (MinimalInitiatorContext addr)
   (ResponderContext addr)
   LByteString
   IO
   Void
   ()]
-> OuroborosApplication
     'ResponderMode
     (MinimalInitiatorContext addr)
     (ResponderContext addr)
     LByteString
     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)
  LByteString
  IO
  Void
  ()
miniProtocolRun = MiniProtocolCb (ResponderContext addr) LByteString IO ()
-> RunMiniProtocol
     'ResponderMode
     (MinimalInitiatorContext addr)
     (ResponderContext addr)
     LByteString
     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) LByteString IO ()
forall ctx. MiniProtocolCb ctx LByteString IO ()
responder
            }
        ]
     where
      responder :: MiniProtocolCb ctx LByteString IO ()
      responder :: forall ctx. MiniProtocolCb ctx LByteString IO ()
responder = (ctx
 -> (Tracer IO (TraceSendRecv (FireForget inbound)),
     Codec (FireForget inbound) DeserialiseFailure IO LByteString,
     Peer (FireForget inbound) 'AsServer 'StIdle IO ()))
-> MiniProtocolCb ctx LByteString 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 inbound)),
 Codec (FireForget inbound) DeserialiseFailure IO LByteString,
 Peer (FireForget inbound) 'AsServer 'StIdle IO ())
-> ctx
-> (Tracer IO (TraceSendRecv (FireForget inbound)),
    Codec (FireForget inbound) DeserialiseFailure IO LByteString,
    Peer (FireForget inbound) 'AsServer 'StIdle IO ())
forall a b. a -> b -> a
const (Tracer IO (TraceSendRecv (FireForget inbound))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer, Codec (FireForget inbound) DeserialiseFailure IO LByteString
forall a (m :: * -> *).
(MonadST m, ToCBOR a, FromCBOR a) =>
Codec (FireForget a) DeserialiseFailure m LByteString
codecFireForget, FireForgetServer inbound IO ()
-> Peer (FireForget inbound) 'AsServer 'StIdle IO ()
forall (m :: * -> *) msg a.
Monad m =>
FireForgetServer msg m a
-> Peer (FireForget msg) 'AsServer 'StIdle m a
fireForgetServerPeer FireForgetServer inbound 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 outbound ->
      FireForgetClient outbound IO ()
    client :: TChan outbound -> FireForgetClient outbound IO ()
client TChan outbound
chan =
      IO (FireForgetClient outbound IO ())
-> FireForgetClient outbound IO ()
forall (m :: * -> *) msg a.
m (FireForgetClient msg m a) -> FireForgetClient msg m a
Idle (IO (FireForgetClient outbound IO ())
 -> FireForgetClient outbound IO ())
-> IO (FireForgetClient outbound IO ())
-> FireForgetClient outbound IO ()
forall a b. (a -> b) -> a -> b
$ do
        STM IO outbound -> IO outbound
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TChan outbound -> STM outbound
forall a. TChan a -> STM a
readTChan TChan outbound
chan) IO outbound
-> (outbound -> FireForgetClient outbound IO ())
-> IO (FireForgetClient outbound IO ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \outbound
msg ->
          outbound
-> IO (FireForgetClient outbound IO ())
-> FireForgetClient outbound IO ()
forall msg (m :: * -> *) a.
msg -> m (FireForgetClient msg m a) -> FireForgetClient msg m a
SendMsg outbound
msg (FireForgetClient outbound IO ()
-> IO (FireForgetClient outbound IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FireForgetClient outbound IO ()
 -> IO (FireForgetClient outbound IO ()))
-> FireForgetClient outbound IO ()
-> IO (FireForgetClient outbound IO ())
forall a b. (a -> b) -> a -> b
$ TChan outbound -> FireForgetClient outbound IO ()
client TChan outbound
chan)

    server :: FireForgetServer inbound IO ()
    server :: FireForgetServer inbound IO ()
server =
      FireForgetServer
        { $sel:recvMsg:FireForgetServer :: inbound -> IO (FireForgetServer inbound IO ())
recvMsg = \inbound
msg -> inbound -> IO ()
deliver inbound
msg IO ()
-> FireForgetServer inbound IO ()
-> IO (FireForgetServer inbound IO ())
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> FireForgetServer inbound 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 HydraVersionedProtocolNumber 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 HydraVersionedProtocolNumber 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 HydraVersionedProtocolNumber Term))
-> [Pair]
encodeTraceSendRecvHandshake WithMuxBearer
  (ConnectionId SockAddr)
  (TraceSendRecv (Handshake HydraVersionedProtocolNumber 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 HydraVersionedProtocolNumber CBOR.Term)) ->
  [Aeson.Pair]
encodeTraceSendRecvHandshake :: WithMuxBearer
  (ConnectionId SockAddr)
  (TraceSendRecv (Handshake HydraVersionedProtocolNumber Term))
-> [Pair]
encodeTraceSendRecvHandshake = \case
  WithMuxBearer ConnectionId SockAddr
peerId (TraceSendMsg (AnyMessageAndAgency PeerHasAgency pr st
agency Message (Handshake HydraVersionedProtocolNumber 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 HydraVersionedProtocolNumber Term) st st'
-> [Pair]
forall (from :: Handshake HydraVersionedProtocolNumber Term)
       (to :: Handshake HydraVersionedProtocolNumber Term).
Message (Handshake HydraVersionedProtocolNumber Term) from to
-> [Pair]
encodeMsg Message (Handshake HydraVersionedProtocolNumber Term) st st'
msg
  WithMuxBearer ConnectionId SockAddr
peerId (TraceRecvMsg (AnyMessageAndAgency PeerHasAgency pr st
agency Message (Handshake HydraVersionedProtocolNumber 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 HydraVersionedProtocolNumber Term) st st'
-> [Pair]
forall (from :: Handshake HydraVersionedProtocolNumber Term)
       (to :: Handshake HydraVersionedProtocolNumber Term).
Message (Handshake HydraVersionedProtocolNumber Term) from to
-> [Pair]
encodeMsg Message (Handshake HydraVersionedProtocolNumber Term) st st'
msg
 where
  encodeMsg ::
    Message (Handshake HydraVersionedProtocolNumber Term) from to ->
    [Aeson.Pair]
  encodeMsg :: forall (from :: Handshake HydraVersionedProtocolNumber Term)
       (to :: Handshake HydraVersionedProtocolNumber Term).
Message (Handshake HydraVersionedProtocolNumber 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
.= ()
      ]