View on GitHub
File Changes
import           Data.Proxy (Proxy (..))
import           Data.Time.Clock (secondsToDiffTime)
import           Network.Socket as Socket
+
import qualified Codec.CBOR.Term as CBOR
+
import qualified Codec.CBOR.Read as CBOR

                      
import           Control.Monad.Class.MonadAsync

                      
  { rnaIpSubscriptionTracer  :: Tracer IO (WithIPList (SubscriptionTrace Socket.SockAddr))
    -- ^ IP subscription tracer
  , rnaDnsSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace Socket.SockAddr))
+
  , rnaHandshakeTracer       :: Tracer IO (TraceSendRecv
+
                                            (Handshake NodeToNodeVersion CBOR.Term)
+
                                            peer
+
                                            (DecoderFailureOrTooMuchInput CBOR.DeserialiseFailure))
+
    -- ^ Handshake protocol tracer
+
  , rnaHandshakeLocalTracer  :: Tracer IO (TraceSendRecv
+
                                            (Handshake NodeToClientVersion CBOR.Term)
+
                                            peer
+
                                            (DecoderFailureOrTooMuchInput CBOR.DeserialiseFailure))
    -- ^ DNS subscription tracer
  , rnaDnsResolverTracer     :: Tracer IO (WithDomainName DnsTrace)
    -- ^ DNS resolver tracer
    runLocalServer = do
      (connTable :: ConnectionTable IO Socket.SockAddr) <- newConnectionTable
      NodeToClient.withServer_V1
+
        rnaHandshakeLocalTracer
        connTable
        rnaMyLocalAddr
        rnaMkPeer
    runPeerServer :: ConnectionTable IO Socket.SockAddr -> IO ()
    runPeerServer connTable =
      NodeToNode.withServer_V1
+
        rnaHandshakeTracer
        connTable
        rnaMyAddr
        rnaMkPeer
    runIpSubscriptionWorker :: ConnectionTable IO Socket.SockAddr -> IO ()
    runIpSubscriptionWorker connTable = ipSubscriptionWorker_V1
      rnaIpSubscriptionTracer
-
      nullTracer -- TODO add hanshake protocol tracer to 'ProtocolTracers'
+
      rnaHandshakeTracer
      rnaMkPeer
      connTable
      -- the comments in dnsSbuscriptionWorker call apply
        , ispValency = length rnaIpProducers
        }
      nodeToNodeVersionData
-
      (initiatorNetworkApplication networkApps) 
+
      (initiatorNetworkApplication networkApps)

                      
    runDnsSubscriptionWorker :: ConnectionTable IO Socket.SockAddr
                             -> DnsSubscriptionTarget
                             -> IO ()
    runDnsSubscriptionWorker connTable dnsProducer = dnsSubscriptionWorker_V1
      rnaDnsSubscriptionTracer
      rnaDnsResolverTracer
-
      nullTracer -- TODO add hanshake protocol tracer to 'ProtocolTracers'
+
      rnaHandshakeTracer
      rnaMkPeer
      connTable
      -- IPv4 address
serverPingPong = do
    tbl <- newConnectionTable
    withServerNode
+
      nullTracer
      tbl
      defaultLocalSocketAddrInfo
      (\(DictVersion codec)-> encodeTerm codec)
serverPingPong2 = do
    tbl <- newConnectionTable
    withServerNode
+
      nullTracer
      tbl
      defaultLocalSocketAddrInfo
      (\(DictVersion codec)-> encodeTerm codec)
serverChainSync sockAddr = do
    tbl <- newConnectionTable
    withServerNode
+
      nullTracer
      tbl
      (mkLocalSocketAddrInfo sockAddr)
      (\(DictVersion codec)-> encodeTerm codec)
serverBlockFetch sockAddr = do
    tbl <- newConnectionTable
    withServerNode
+
      nullTracer
      tbl
      (mkLocalSocketAddrInfo sockAddr)
      (\(DictVersion codec)-> encodeTerm codec)
  -- * Re-exported clients
  , chainSyncClientNull
  , localTxSubmissionClientNull
+
  , TraceSendRecv (..)
+
  , DecoderFailureOrTooMuchInput
+
  , Handshake
  ) where

                      
import           Control.Concurrent.Async (Async)
import           Ouroboros.Network.Protocol.Handshake.Version
import           Ouroboros.Network.Socket
import           Network.TypedProtocol.Driver.ByteLimit (DecoderFailureOrTooMuchInput)
-
import           Network.TypedProtocol.Driver (TraceSendRecv)
+
import           Network.TypedProtocol.Driver (TraceSendRecv (..))
import           Control.Tracer (Tracer)

                      

                      
--
withServer
  :: HasResponder appType ~ True
-
  => ConnectionTable IO Socket.SockAddr
+
  => Tracer IO (TraceSendRecv (Handshake NodeToClientVersion CBOR.Term) peerid (DecoderFailureOrTooMuchInput DeserialiseFailure))
+
  -> ConnectionTable IO Socket.SockAddr
  -> Socket.AddrInfo
  -> (Socket.SockAddr -> Socket.SockAddr -> peerid)
  -- ^ create peerid from local address and remote address
              (OuroborosApplication appType peerid NodeToClientProtocols IO BL.ByteString a b)
  -> (Async () -> IO t)
  -> IO t
-
withServer tbl addr peeridFn acceptVersion versions k =
+
withServer tracer tbl addr peeridFn acceptVersion versions k =
  withServerNode
+
    tracer
    tbl
    addr
    (\(DictVersion codec) -> encodeTerm codec)
--
withServer_V1
  :: (HasResponder appType ~ True)
-
  => ConnectionTable IO Socket.SockAddr
+
  => Tracer IO (TraceSendRecv (Handshake NodeToClientVersion CBOR.Term) peerid (DecoderFailureOrTooMuchInput DeserialiseFailure))
+
  -> ConnectionTable IO Socket.SockAddr
  -> Socket.AddrInfo
  -> (Socket.SockAddr -> Socket.SockAddr -> peerid)
  -- ^ create peerid from local address and remote address
  -- 'OuroborosInitiatorAndResponderApplication'.
  -> (Async () -> IO t)
  -> IO t
-
withServer_V1 tbl addr peeridFn versionData application =
+
withServer_V1 tracer tbl addr peeridFn versionData application =
    withServer
-
      tbl addr peeridFn 
+
      tracer tbl addr peeridFn 
      (\(DictVersion _) -> acceptEq)
      (simpleSingletonVersions
        NodeToClientV_1
  -- * Re-exports
  , ConnectionTable
  , newConnectionTable
+
  , TraceSendRecv (..)
+
  , DecoderFailureOrTooMuchInput
+
  , Handshake
  ) where

                      
import           Control.Concurrent.Async (Async)
                                                    , WithDomainName (..)
                                                    )
import           Network.TypedProtocol.Driver.ByteLimit (DecoderFailureOrTooMuchInput)
-
import           Network.TypedProtocol.Driver (TraceSendRecv)
+
import           Network.TypedProtocol.Driver (TraceSendRecv (..))
import           Control.Tracer (Tracer)

                      

                      
  -> Maybe Socket.AddrInfo
  -> Socket.AddrInfo
  -> IO ()
-
connectTo_V1 tracer peeridFn versionData application localAddr remoteAddr =
+
connectTo_V1 handshakeTracer peeridFn versionData application localAddr remoteAddr =
    connectTo
-
      tracer peeridFn
+
      handshakeTracer peeridFn
      (simpleSingletonVersions
          NodeToNodeV_1
          versionData
--
withServer
  :: HasResponder appType ~ True
-
  => ConnectionTable IO Socket.SockAddr
+
  => Tracer IO (TraceSendRecv (Handshake NodeToNodeVersion CBOR.Term) peerid (DecoderFailureOrTooMuchInput DeserialiseFailure))
+
  -> ConnectionTable IO Socket.SockAddr
  -> Socket.AddrInfo
  -> (Socket.SockAddr -> Socket.SockAddr -> peerid)
  -- ^ create peerid from local address and remote address
  -> (forall vData. DictVersion vData -> vData -> vData -> Accept)
  -> Versions NodeToNodeVersion DictVersion (OuroborosApplication appType peerid NodeToNodeProtocols IO BL.ByteString a b)
  -> (Async () -> IO t)
  -> IO t
-
withServer tbl addr peeridFn acceptVersion versions k =
+
withServer handshakeTracer tbl addr peeridFn acceptVersion versions k =
  withServerNode
+
    handshakeTracer
    tbl
    addr
    (\(DictVersion codec) -> encodeTerm codec)
--
withServer_V1
  :: HasResponder appType ~ True
-
  => ConnectionTable IO Socket.SockAddr
+
  => Tracer IO (TraceSendRecv (Handshake NodeToNodeVersion CBOR.Term) peerid (DecoderFailureOrTooMuchInput DeserialiseFailure))
+
  -> ConnectionTable IO Socket.SockAddr
  -> Socket.AddrInfo
  -> (Socket.SockAddr -> Socket.SockAddr -> peerid)
  -- ^ create peerid from local address and remote address
  -> NodeToNodeVersionData
  -> (OuroborosApplication appType peerid NodeToNodeProtocols IO BL.ByteString x y)
  -> (Async () -> IO t)
  -> IO t
-
withServer_V1 tbl addr peeridFn versionData application k =
+
withServer_V1 handshakeTracer tbl addr peeridFn versionData application k =
    withServer
-
      tbl addr peeridFn
+
      handshakeTracer tbl addr peeridFn
      (\(DictVersion _) -> acceptEq)
      (simpleSingletonVersions
          NodeToNodeV_1

                      
import qualified Network.Socket as Socket hiding (recv)

                      
-
import           Control.Tracer (nullTracer, Tracer)
+
import           Control.Tracer (Tracer)

                      
import           Network.TypedProtocol.Driver.ByteLimit
import           Network.TypedProtocol.Driver (TraceSendRecv)
  -> Socket.AddrInfo
  -- ^ remote address
  -> IO ()
-
connectToNode encodeData decodeData tracer peeridFn versions localAddr remoteAddr =
+
connectToNode encodeData decodeData handshakeTracer peeridFn versions localAddr remoteAddr =
    bracket
      (Socket.socket (Socket.addrFamily remoteAddr) Socket.Stream Socket.defaultProtocol)
      Socket.close
            Just addr -> Socket.bind sd (Socket.addrAddress addr)
            Nothing   -> return ()
          Socket.connect sd (Socket.addrAddress remoteAddr)
-
          connectToNode' encodeData decodeData tracer peeridFn versions sd
+
          connectToNode' encodeData decodeData handshakeTracer peeridFn versions sd
      )

                      
-- |
  -- ^ application to run over the connection
  -> Socket.Socket
  -> IO ()
-
connectToNode' encodeData decodeData tracer peeridFn versions sd = do
+
connectToNode' encodeData decodeData handshakeTracer peeridFn versions sd = do
    peerid <- peeridFn <$> Socket.getSocketName sd <*> Socket.getPeerName sd
    bearer <- Mx.socketAsMuxBearer sd
    Mx.muxBearerSetState bearer Mx.Connected
    mapp <- runPeerWithByteLimit
              maxTransmissionUnit
              BL.length
-
              tracer
+
              handshakeTracer
              codecHandshake
              peerid
              (Mx.muxBearerAsControlChannel bearer Mx.ModeInitiator)
       , Typeable vNumber
       , Show vNumber
       )
-
    => (forall vData. extra vData -> vData -> CBOR.Term)
+
    => Tracer IO (TraceSendRecv (Handshake vNumber CBOR.Term) peerid (DecoderFailureOrTooMuchInput DeserialiseFailure))
+
    -> (forall vData. extra vData -> vData -> CBOR.Term)
    -> (forall vData. extra vData -> CBOR.Term -> Either Text vData)
    -> (forall vData. extra vData -> vData -> vData -> Accept)
    -> (addr -> st -> STM.STM (AcceptConnection st vNumber extra peerid ptcl IO BL.ByteString))
    -- ^ either accept or reject a connection.
    -> Server.BeginConnection addr Socket.Socket st ()
-
beginConnection encodeData decodeData acceptVersion fn addr st = do
+
beginConnection handshakeTracer encodeData decodeData acceptVersion fn addr st = do
    accept <- fn addr st
    case accept of
      AcceptConnection st' peerid versions -> pure $ Server.Accept st' $ \sd -> do
        mapp <- runPeerWithByteLimit
                maxTransmissionUnit
                BL.length
-
                nullTracer
+
                handshakeTracer
                codecHandshake
                peerid
                (Mx.muxBearerAsControlChannel bearer Mx.ModeResponder)
       , Typeable vNumber
       , Show vNumber
       )
-
    => ConnectionTable IO Socket.SockAddr
+
    => Tracer IO (TraceSendRecv (Handshake vNumber CBOR.Term) peerid (DecoderFailureOrTooMuchInput DeserialiseFailure))
+
    -> ConnectionTable IO Socket.SockAddr
    -> Socket.Socket
    -> (forall vData. extra vData -> vData -> CBOR.Term)
    -> (forall vData. extra vData -> CBOR.Term -> Either Text vData)
    -> Server.Main st t
    -> st
    -> IO t
-
runNetworkNode' tbl sd encodeData decodeData acceptVersion acceptException acceptConn complete
-
    main st = Server.run (fromSocket tbl sd) acceptException (beginConnection encodeData decodeData
+
runNetworkNode' handshakeTracer tbl sd encodeData decodeData acceptVersion acceptException acceptConn complete
+
    main st = Server.run (fromSocket tbl sd) acceptException (beginConnection handshakeTracer encodeData decodeData
        acceptVersion acceptConn) complete main st

                      

                      
       , Typeable vNumber
       , Show vNumber
       )
-
    => ConnectionTable IO Socket.SockAddr
+
    => Tracer IO (TraceSendRecv (Handshake vNumber CBOR.Term) peerid (DecoderFailureOrTooMuchInput DeserialiseFailure))
+
    -> ConnectionTable IO Socket.SockAddr
    -> Socket.AddrInfo
    -> (forall vData. extra vData -> vData -> CBOR.Term)
    -> (forall vData. extra vData -> CBOR.Term -> Either Text vData)
    -- Note: the server thread will terminate when the callback returns or
    -- throws an exception.
    -> IO t
-
withServerNode tbl addr encodeData decodeData peeridFn acceptVersion versions k =
+
withServerNode handshakeTracer tbl addr encodeData decodeData peeridFn acceptVersion versions k =
    bracket (mkListeningSocket (Socket.addrFamily addr) (Just $ Socket.addrAddress addr)) Socket.close $ \sd -> do
      addr' <- Socket.getSocketName sd
      withAsync
        (runNetworkNode'
+
          handshakeTracer
          tbl
          sd
          encodeData

                      
    res <-
      withServerNode
+
        nullTracer
        tbl
        responderAddr
        (\(DictVersion codec) -> encodeTerm codec)
                                                  encode             decode

                      
    withServerNode
+
      nullTracer
      tbl
      producerAddress
      (\(DictVersion codec)-> encodeTerm codec)

                      
    withDummyServer faultyAddress $
      withServerNode
+
        nullTracer
        tbl
        responderAddr
        (\(DictVersion codec) -> encodeTerm codec)
            )

                      
    startPassiveServer tbl responderAddr localAddrVar rrcfg = withServerNode
+
        nullTracer
        tbl
        responderAddr
        (\(DictVersion codec) -> encodeTerm codec)
          return r

                      
    startActiveServer tbl responderAddr localAddrVar remoteAddrVar rrcfg = withServerNode
+
        nullTracer
        tbl
        responderAddr
        (\(DictVersion codec) -> encodeTerm codec)

                      
    spawnServer tbl addr delay =
        void $ async $ withServerNode
+
            nullTracer
            tbl
            addr
            (\(DictVersion codec) -> encodeTerm codec)